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 #24380] : assigning to a hash in list
[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;
a0d0e21e 1826 return;
6be89cf9 1827 }
3280af22
NIS		 1828 PL_main_root = scope(sawparens(scalarvoid(o)));
1829 PL_curcop = &PL_compiling;
1830 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 1831 PL_main_root->op_private |= OPpREFCOUNTED;
1832 OpREFCNT_set(PL_main_root, 1);
3280af22 1833 PL_main_root->op_next = 0;
a2efc822 1834 CALL_PEEP(PL_main_start);
3280af22 1835 PL_compcv = 0;
3841441e 1836
4fdae800 1837 /* Register with debugger */
84902520 1838 if (PERLDB_INTER) {
864dbfa3 1839 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 1840 if (cv) {
1841 dSP;
924508f0 1842 PUSHMARK(SP);
cc49e20b 1843 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1844 PUTBACK;
864dbfa3 1845 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 1846 }
1847 }
79072805 1848 }
79072805
LW		 1849}
1850
1851OP *
864dbfa3 1852Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW		 1853{
1854 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 1855/* [perl #17376]: this appears to be premature, and results in code such as
1856 C< our(%x); > executing in list mode rather than void mode */
1857#if 0
79072805 1858 list(o);
d2be0de5
YST		 1859#else
1860 ;
1861#endif
8990e307 1862 else {
64420d0d
JH		 1863 if (ckWARN(WARN_PARENTHESIS)
1864 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1865 {
1866 char *s = PL_bufptr;
8473848f 1867 int sigil = 0;
64420d0d 1868
8473848f
RGS		 1869 /* some heuristics to detect a potential error */
1870 while (*s && (strchr(", \t\n", *s)
1871 || (strchr("@$%*", *s) && ++sigil) ))
64420d0d 1872 s++;
8473848f
RGS		 1873 if (sigil) {
1874 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1875 || strchr("@$%*, \t\n", *s)))
1876 s++;
1877
1878 if (*s == ';' || *s == '=')
1879 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1880 "Parentheses missing around \"%s\" list",
1881 lex ? (PL_in_my == KEY_our ? "our" : "my")
1882 : "local");
1883 }
8990e307
LW		 1884 }
1885 }
93a17b20 1886 if (lex)
eb64745e 1887 o = my(o);
93a17b20 1888 else
eb64745e
GS		 1889 o = mod(o, OP_NULL); /* a bit kludgey */
1890 PL_in_my = FALSE;
1891 PL_in_my_stash = Nullhv;
1892 return o;
79072805
LW		 1893}
1894
1895OP *
864dbfa3 1896Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 1897{
1898 if (o->op_type == OP_LIST) {
554b3eca 1899 OP *o2;
554b3eca 1900 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
554b3eca 1901 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 1902 }
1903 return o;
1904}
1905
1906OP *
864dbfa3 1907Perl_fold_constants(pTHX_ register OP *o)
79072805
LW		 1908{
1909 register OP *curop;
1910 I32 type = o->op_type;
748a9306 1911 SV *sv;
79072805 1912
22c35a8c 1913 if (PL_opargs[type] & OA_RETSCALAR)
79072805 1914 scalar(o);
b162f9ea 1915 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 1916 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 1917
eac055e9
GS		 1918 /* integerize op, unless it happens to be C<-foo>.
1919 * XXX should pp_i_negate() do magic string negation instead? */
1920 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1921 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1922 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1923 {
22c35a8c 1924 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 1925 }
85e6fe83 1926
22c35a8c 1927 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 1928 goto nope;
1929
de939608 1930 switch (type) {
7a52d87a
GS		 1931 case OP_NEGATE:
1932 /* XXX might want a ck_negate() for this */
1933 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1934 break;
de939608
CS		 1935 case OP_SPRINTF:
1936 case OP_UCFIRST:
1937 case OP_LCFIRST:
1938 case OP_UC:
1939 case OP_LC:
69dcf70c
MB		 1940 case OP_SLT:
1941 case OP_SGT:
1942 case OP_SLE:
1943 case OP_SGE:
1944 case OP_SCMP:
2de3dbcc
JH		 1945 /* XXX what about the numeric ops? */
1946 if (PL_hints & HINT_LOCALE)
de939608
CS		 1947 goto nope;
1948 }
1949
3280af22 1950 if (PL_error_count)
a0d0e21e
LW		 1951 goto nope; /* Don't try to run w/ errors */
1952
79072805 1953 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 1954 if ((curop->op_type != OP_CONST ||
1955 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 1956 curop->op_type != OP_LIST &&
1957 curop->op_type != OP_SCALAR &&
1958 curop->op_type != OP_NULL &&
1959 curop->op_type != OP_PUSHMARK)
1960 {
79072805
LW		 1961 goto nope;
1962 }
1963 }
1964
1965 curop = LINKLIST(o);
1966 o->op_next = 0;
533c011a 1967 PL_op = curop;
cea2e8a9 1968 CALLRUNOPS(aTHX);
3280af22 1969 sv = *(PL_stack_sp--);
748a9306 1970 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 1971 pad_swipe(o->op_targ, FALSE);
748a9306
LW		 1972 else if (SvTEMP(sv)) { /* grab mortal temp? */
1973 (void)SvREFCNT_inc(sv);
1974 SvTEMP_off(sv);
85e6fe83 1975 }
79072805
LW		 1976 op_free(o);
1977 if (type == OP_RV2GV)
b1cb66bf 1978 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 1979 return newSVOP(OP_CONST, 0, sv);
aeea060c 1980
79072805 1981 nope:
79072805
LW		 1982 return o;
1983}
1984
1985OP *
864dbfa3 1986Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW		 1987{
1988 register OP *curop;
3280af22 1989 I32 oldtmps_floor = PL_tmps_floor;
79072805 1990
a0d0e21e 1991 list(o);
3280af22 1992 if (PL_error_count)
a0d0e21e
LW		 1993 return o; /* Don't attempt to run with errors */
1994
533c011a 1995 PL_op = curop = LINKLIST(o);
a0d0e21e 1996 o->op_next = 0;
a2efc822 1997 CALL_PEEP(curop);
cea2e8a9
GS		 1998 pp_pushmark();
1999 CALLRUNOPS(aTHX);
533c011a 2000 PL_op = curop;
cea2e8a9 2001 pp_anonlist();
3280af22 2002 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2003
2004 o->op_type = OP_RV2AV;
22c35a8c 2005 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2006 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2007 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
c13f253a 2008 o->op_seq = 0; /* needs to be revisited in peep() */
79072805 2009 curop = ((UNOP*)o)->op_first;
3280af22 2010 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2011 op_free(curop);
79072805
LW		 2012 linklist(o);
2013 return list(o);
2014}
2015
2016OP *
864dbfa3 2017Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2018{
11343788
MB		 2019 if (!o || o->op_type != OP_LIST)
2020 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2021 else
5dc0d613 2022 o->op_flags &= ~OPf_WANT;
79072805 2023
22c35a8c 2024 if (!(PL_opargs[type] & OA_MARK))
93c66552 2025 op_null(cLISTOPo->op_first);
8990e307 2026
eb160463 2027 o->op_type = (OPCODE)type;
22c35a8c 2028 o->op_ppaddr = PL_ppaddr[type];
11343788 2029 o->op_flags |= flags;
79072805 2030
11343788
MB		 2031 o = CHECKOP(type, o);
2032 if (o->op_type != type)
2033 return o;
79072805 2034
11343788 2035 return fold_constants(o);
79072805
LW		 2036}
2037
2038/* List constructors */
2039
2040OP *
864dbfa3 2041Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2042{
2043 if (!first)
2044 return last;
8990e307
LW		 2045
2046 if (!last)
79072805 2047 return first;
8990e307 2048
155aba94
GS		 2049 if (first->op_type != type
2050 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2051 {
2052 return newLISTOP(type, 0, first, last);
2053 }
79072805 2054
a0d0e21e
LW		 2055 if (first->op_flags & OPf_KIDS)
2056 ((LISTOP*)first)->op_last->op_sibling = last;
2057 else {
2058 first->op_flags |= OPf_KIDS;
2059 ((LISTOP*)first)->op_first = last;
2060 }
2061 ((LISTOP*)first)->op_last = last;
a0d0e21e 2062 return first;
79072805
LW		 2063}
2064
2065OP *
864dbfa3 2066Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2067{
2068 if (!first)
2069 return (OP*)last;
8990e307
LW		 2070
2071 if (!last)
79072805 2072 return (OP*)first;
8990e307
LW		 2073
2074 if (first->op_type != type)
79072805 2075 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW		 2076
2077 if (last->op_type != type)
79072805
LW		 2078 return append_elem(type, (OP*)first, (OP*)last);
2079
2080 first->op_last->op_sibling = last->op_first;
2081 first->op_last = last->op_last;
117dada2 2082 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2083
238a4c30
NIS		 2084 FreeOp(last);
2085
79072805
LW		 2086 return (OP*)first;
2087}
2088
2089OP *
864dbfa3 2090Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2091{
2092 if (!first)
2093 return last;
8990e307
LW		 2094
2095 if (!last)
79072805 2096 return first;
8990e307
LW		 2097
2098 if (last->op_type == type) {
2099 if (type == OP_LIST) { /* already a PUSHMARK there */
2100 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2101 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2102 if (!(first->op_flags & OPf_PARENS))
2103 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2104 }
2105 else {
2106 if (!(last->op_flags & OPf_KIDS)) {
2107 ((LISTOP*)last)->op_last = first;
2108 last->op_flags |= OPf_KIDS;
2109 }
2110 first->op_sibling = ((LISTOP*)last)->op_first;
2111 ((LISTOP*)last)->op_first = first;
79072805 2112 }
117dada2 2113 last->op_flags |= OPf_KIDS;
79072805
LW		 2114 return last;
2115 }
2116
2117 return newLISTOP(type, 0, first, last);
2118}
2119
2120/* Constructors */
2121
2122OP *
864dbfa3 2123Perl_newNULLLIST(pTHX)
79072805 2124{
8990e307
LW		 2125 return newOP(OP_STUB, 0);
2126}
2127
2128OP *
864dbfa3 2129Perl_force_list(pTHX_ OP *o)
8990e307 2130{
11343788
MB		 2131 if (!o || o->op_type != OP_LIST)
2132 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2133 op_null(o);
11343788 2134 return o;
79072805
LW		 2135}
2136
2137OP *
864dbfa3 2138Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2139{
2140 LISTOP *listop;
2141
b7dc083c 2142 NewOp(1101, listop, 1, LISTOP);
79072805 2143
eb160463 2144 listop->op_type = (OPCODE)type;
22c35a8c 2145 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2146 if (first || last)
2147 flags |= OPf_KIDS;
eb160463 2148 listop->op_flags = (U8)flags;
79072805
LW		 2149
2150 if (!last && first)
2151 last = first;
2152 else if (!first && last)
2153 first = last;
8990e307
LW		 2154 else if (first)
2155 first->op_sibling = last;
79072805
LW		 2156 listop->op_first = first;
2157 listop->op_last = last;
8990e307
LW		 2158 if (type == OP_LIST) {
2159 OP* pushop;
2160 pushop = newOP(OP_PUSHMARK, 0);
2161 pushop->op_sibling = first;
2162 listop->op_first = pushop;
2163 listop->op_flags |= OPf_KIDS;
2164 if (!last)
2165 listop->op_last = pushop;
2166 }
79072805 2167
463d09e6 2168 return CHECKOP(type, listop);
79072805
LW		 2169}
2170
2171OP *
864dbfa3 2172Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2173{
11343788 2174 OP *o;
b7dc083c 2175 NewOp(1101, o, 1, OP);
eb160463 2176 o->op_type = (OPCODE)type;
22c35a8c 2177 o->op_ppaddr = PL_ppaddr[type];
eb160463 2178 o->op_flags = (U8)flags;
79072805 2179
11343788 2180 o->op_next = o;
eb160463 2181 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2182 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2183 scalar(o);
22c35a8c 2184 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2185 o->op_targ = pad_alloc(type, SVs_PADTMP);
2186 return CHECKOP(type, o);
79072805
LW		 2187}
2188
2189OP *
864dbfa3 2190Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW		 2191{
2192 UNOP *unop;
2193
93a17b20 2194 if (!first)
aeea060c 2195 first = newOP(OP_STUB, 0);
22c35a8c 2196 if (PL_opargs[type] & OA_MARK)
8990e307 2197 first = force_list(first);
93a17b20 2198
b7dc083c 2199 NewOp(1101, unop, 1, UNOP);
eb160463 2200 unop->op_type = (OPCODE)type;
22c35a8c 2201 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2202 unop->op_first = first;
2203 unop->op_flags = flags | OPf_KIDS;
eb160463 2204 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2205 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2206 if (unop->op_next)
2207 return (OP*)unop;
2208
a0d0e21e 2209 return fold_constants((OP *) unop);
79072805
LW		 2210}
2211
2212OP *
864dbfa3 2213Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2214{
2215 BINOP *binop;
b7dc083c 2216 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2217
2218 if (!first)
2219 first = newOP(OP_NULL, 0);
2220
eb160463 2221 binop->op_type = (OPCODE)type;
22c35a8c 2222 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2223 binop->op_first = first;
2224 binop->op_flags = flags | OPf_KIDS;
2225 if (!last) {
2226 last = first;
eb160463 2227 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2228 }
2229 else {
eb160463 2230 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2231 first->op_sibling = last;
2232 }
2233
e50aee73 2234 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2235 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2236 return (OP*)binop;
2237
7284ab6f 2238 binop->op_last = binop->op_first->op_sibling;
79072805 2239
a0d0e21e 2240 return fold_constants((OP *)binop);
79072805
LW		 2241}
2242
a0ed51b3 2243static int
2b9d42f0
NIS		 2244uvcompare(const void *a, const void *b)
2245{
2246 if (*((UV *)a) < (*(UV *)b))
2247 return -1;
2248 if (*((UV *)a) > (*(UV *)b))
2249 return 1;
2250 if (*((UV *)a+1) < (*(UV *)b+1))
2251 return -1;
2252 if (*((UV *)a+1) > (*(UV *)b+1))
2253 return 1;
a0ed51b3
LW		 2254 return 0;
2255}
2256
79072805 2257OP *
864dbfa3 2258Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2259{
79072805
LW		 2260 SV *tstr = ((SVOP*)expr)->op_sv;
2261 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2262 STRLEN tlen;
2263 STRLEN rlen;
9b877dbb
IH		 2264 U8 *t = (U8*)SvPV(tstr, tlen);
2265 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW		 2266 register I32 i;
2267 register I32 j;
a0ed51b3 2268 I32 del;
79072805 2269 I32 complement;
5d06d08e 2270 I32 squash;
9b877dbb 2271 I32 grows = 0;
79072805
LW		 2272 register short *tbl;
2273
800b4dc4 2274 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2275 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2276 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2277 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2278
036b4402
GS		 2279 if (SvUTF8(tstr))
2280 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2281
2282 if (SvUTF8(rstr))
036b4402 2283 o->op_private |= OPpTRANS_TO_UTF;
79072805 2284
a0ed51b3 2285 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2286 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW		 2287 SV* transv = 0;
2288 U8* tend = t + tlen;
2289 U8* rend = r + rlen;
ba210ebe 2290 STRLEN ulen;
84c133a0
RB		 2291 UV tfirst = 1;
2292 UV tlast = 0;
2293 IV tdiff;
2294 UV rfirst = 1;
2295 UV rlast = 0;
2296 IV rdiff;
2297 IV diff;
a0ed51b3
LW		 2298 I32 none = 0;
2299 U32 max = 0;
2300 I32 bits;
a0ed51b3 2301 I32 havefinal = 0;
9c5ffd7c 2302 U32 final = 0;
a0ed51b3
LW		 2303 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2304 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2305 U8* tsave = NULL;
2306 U8* rsave = NULL;
2307
2308 if (!from_utf) {
2309 STRLEN len = tlen;
2310 tsave = t = bytes_to_utf8(t, &len);
2311 tend = t + len;
2312 }
2313 if (!to_utf && rlen) {
2314 STRLEN len = rlen;
2315 rsave = r = bytes_to_utf8(r, &len);
2316 rend = r + len;
2317 }
a0ed51b3 2318
2b9d42f0
NIS		 2319/* There are several snags with this code on EBCDIC:
2320 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2321 2. scan_const() in toke.c has encoded chars in native encoding which makes
2322 ranges at least in EBCDIC 0..255 range the bottom odd.
2323*/
2324
a0ed51b3 2325 if (complement) {
ad391ad9 2326 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2327 UV *cp;
a0ed51b3 2328 UV nextmin = 0;
2b9d42f0 2329 New(1109, cp, 2*tlen, UV);
a0ed51b3 2330 i = 0;
79cb57f6 2331 transv = newSVpvn("",0);
a0ed51b3 2332 while (t < tend) {
2b9d42f0
NIS		 2333 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2334 t += ulen;
2335 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2336 t++;
2b9d42f0
NIS		 2337 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2338 t += ulen;
a0ed51b3 2339 }
2b9d42f0
NIS		 2340 else {
2341 cp[2*i+1] = cp[2*i];
2342 }
2343 i++;
a0ed51b3 2344 }
2b9d42f0 2345 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2346 for (j = 0; j < i; j++) {
2b9d42f0 2347 UV val = cp[2*j];
a0ed51b3
LW		 2348 diff = val - nextmin;
2349 if (diff > 0) {
9041c2e3 2350 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2351 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2352 if (diff > 1) {
2b9d42f0 2353 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2354 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2355 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2356 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2357 }
2358 }
2b9d42f0 2359 val = cp[2*j+1];
a0ed51b3
LW		 2360 if (val >= nextmin)
2361 nextmin = val + 1;
2362 }
9041c2e3 2363 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2364 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2365 {
2366 U8 range_mark = UTF_TO_NATIVE(0xff);
2367 sv_catpvn(transv, (char *)&range_mark, 1);
2368 }
b851fbc1
JH		 2369 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2370 UNICODE_ALLOW_SUPER);
dfe13c55
GS		 2371 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2372 t = (U8*)SvPVX(transv);
a0ed51b3
LW		 2373 tlen = SvCUR(transv);
2374 tend = t + tlen;
455d824a 2375 Safefree(cp);
a0ed51b3
LW		 2376 }
2377 else if (!rlen && !del) {
2378 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2379 }
2380 if (!squash) {
05d340b8 2381 if ((!rlen && !del) || t == r ||
12ae5dfc 2382 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2383 {
4757a243 2384 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2385 }
a0ed51b3
LW		 2386 }
2387
2388 while (t < tend || tfirst <= tlast) {
2389 /* see if we need more "t" chars */
2390 if (tfirst > tlast) {
9041c2e3 2391 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2392 t += ulen;
2b9d42f0 2393 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2394 t++;
9041c2e3 2395 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2396 t += ulen;
2397 }
2398 else
2399 tlast = tfirst;
2400 }
2401
2402 /* now see if we need more "r" chars */
2403 if (rfirst > rlast) {
2404 if (r < rend) {
9041c2e3 2405 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2406 r += ulen;
2b9d42f0 2407 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2408 r++;
9041c2e3 2409 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2410 r += ulen;
2411 }
2412 else
2413 rlast = rfirst;
2414 }
2415 else {
2416 if (!havefinal++)
2417 final = rlast;
2418 rfirst = rlast = 0xffffffff;
2419 }
2420 }
2421
2422 /* now see which range will peter our first, if either. */
2423 tdiff = tlast - tfirst;
2424 rdiff = rlast - rfirst;
2425
2426 if (tdiff <= rdiff)
2427 diff = tdiff;
2428 else
2429 diff = rdiff;
2430
2431 if (rfirst == 0xffffffff) {
2432 diff = tdiff; /* oops, pretend rdiff is infinite */
2433 if (diff > 0)
894356b3
GS		 2434 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2435 (long)tfirst, (long)tlast);
a0ed51b3 2436 else
894356b3 2437 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2438 }
2439 else {
2440 if (diff > 0)
894356b3
GS		 2441 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2442 (long)tfirst, (long)(tfirst + diff),
2443 (long)rfirst);
a0ed51b3 2444 else
894356b3
GS		 2445 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2446 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2447
2448 if (rfirst + diff > max)
2449 max = rfirst + diff;
9b877dbb 2450 if (!grows)
45005bfb
JH		 2451 grows = (tfirst < rfirst &&
2452 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2453 rfirst += diff + 1;
a0ed51b3
LW		 2454 }
2455 tfirst += diff + 1;
2456 }
2457
2458 none = ++max;
2459 if (del)
2460 del = ++max;
2461
2462 if (max > 0xffff)
2463 bits = 32;
2464 else if (max > 0xff)
2465 bits = 16;
2466 else
2467 bits = 8;
2468
455d824a 2469 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2470 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2471 SvREFCNT_dec(listsv);
2472 if (transv)
2473 SvREFCNT_dec(transv);
2474
45005bfb 2475 if (!del && havefinal && rlen)
b448e4fe
JH		 2476 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2477 newSVuv((UV)final), 0);
a0ed51b3 2478
9b877dbb 2479 if (grows)
a0ed51b3
LW		 2480 o->op_private |= OPpTRANS_GROWS;
2481
9b877dbb
IH		 2482 if (tsave)
2483 Safefree(tsave);
2484 if (rsave)
2485 Safefree(rsave);
2486
a0ed51b3
LW		 2487 op_free(expr);
2488 op_free(repl);
2489 return o;
2490 }
2491
2492 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2493 if (complement) {
2494 Zero(tbl, 256, short);
eb160463 2495 for (i = 0; i < (I32)tlen; i++)
ec49126f 2496 tbl[t[i]] = -1;
79072805
LW		 2497 for (i = 0, j = 0; i < 256; i++) {
2498 if (!tbl[i]) {
eb160463 2499 if (j >= (I32)rlen) {
a0ed51b3 2500 if (del)
79072805
LW		 2501 tbl[i] = -2;
2502 else if (rlen)
ec49126f 2503 tbl[i] = r[j-1];
79072805 2504 else
eb160463 2505 tbl[i] = (short)i;
79072805 2506 }
9b877dbb
IH		 2507 else {
2508 if (i < 128 && r[j] >= 128)
2509 grows = 1;
ec49126f 2510 tbl[i] = r[j++];
9b877dbb 2511 }
79072805
LW		 2512 }
2513 }
05d340b8
JH		 2514 if (!del) {
2515 if (!rlen) {
2516 j = rlen;
2517 if (!squash)
2518 o->op_private |= OPpTRANS_IDENTICAL;
2519 }
eb160463 2520 else if (j >= (I32)rlen)
05d340b8
JH		 2521 j = rlen - 1;
2522 else
2523 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79 2524 tbl[0x100] = rlen - j;
eb160463 2525 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 2526 tbl[0x101+i] = r[j+i];
2527 }
79072805
LW		 2528 }
2529 else {
a0ed51b3 2530 if (!rlen && !del) {
79072805 2531 r = t; rlen = tlen;
5d06d08e 2532 if (!squash)
4757a243 2533 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2534 }
94bfe852
RGS		 2535 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2536 o->op_private |= OPpTRANS_IDENTICAL;
2537 }
79072805
LW		 2538 for (i = 0; i < 256; i++)
2539 tbl[i] = -1;
eb160463
GS		 2540 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2541 if (j >= (I32)rlen) {
a0ed51b3 2542 if (del) {
ec49126f 2543 if (tbl[t[i]] == -1)
2544 tbl[t[i]] = -2;
79072805
LW		 2545 continue;
2546 }
2547 --j;
2548 }
9b877dbb
IH		 2549 if (tbl[t[i]] == -1) {
2550 if (t[i] < 128 && r[j] >= 128)
2551 grows = 1;
ec49126f 2552 tbl[t[i]] = r[j];
9b877dbb 2553 }
79072805
LW		 2554 }
2555 }
9b877dbb
IH		 2556 if (grows)
2557 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 2558 op_free(expr);
2559 op_free(repl);
2560
11343788 2561 return o;
79072805
LW		 2562}
2563
2564OP *
864dbfa3 2565Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 2566{
2567 PMOP *pmop;
2568
b7dc083c 2569 NewOp(1101, pmop, 1, PMOP);
eb160463 2570 pmop->op_type = (OPCODE)type;
22c35a8c 2571 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 2572 pmop->op_flags = (U8)flags;
2573 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2574
3280af22 2575 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2576 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2577 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 2578 pmop->op_pmpermflags |= PMf_LOCALE;
2579 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2580
debc9467 2581#ifdef USE_ITHREADS
13137afc
AB		 2582 {
2583 SV* repointer;
2584 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2585 repointer = av_pop((AV*)PL_regex_pad[0]);
2586 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2587 SvREPADTMP_off(repointer);
13137afc 2588 sv_setiv(repointer,0);
1eb1540c 2589 } else {
13137afc
AB		 2590 repointer = newSViv(0);
2591 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2592 pmop->op_pmoffset = av_len(PL_regex_padav);
2593 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2594 }
13137afc 2595 }
debc9467 2596#endif
1eb1540c 2597
1fcf4c12 2598 /* link into pm list */
3280af22
NIS		 2599 if (type != OP_TRANS && PL_curstash) {
2600 pmop->op_pmnext = HvPMROOT(PL_curstash);
2601 HvPMROOT(PL_curstash) = pmop;
cb55de95 2602 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 2603 }
2604
463d09e6 2605 return CHECKOP(type, pmop);
79072805
LW		 2606}
2607
2608OP *
864dbfa3 2609Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 2610{
2611 PMOP *pm;
2612 LOGOP *rcop;
ce862d02 2613 I32 repl_has_vars = 0;
79072805 2614
11343788
MB		 2615 if (o->op_type == OP_TRANS)
2616 return pmtrans(o, expr, repl);
79072805 2617
3280af22 2618 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2619 pm = (PMOP*)o;
79072805
LW		 2620
2621 if (expr->op_type == OP_CONST) {
463ee0b2 2622 STRLEN plen;
79072805 2623 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2624 char *p = SvPV(pat, plen);
11343788 2625 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 2626 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2627 p = SvPV(pat, plen);
79072805
LW		 2628 pm->op_pmflags |= PMf_SKIPWHITE;
2629 }
5b71a6a7 2630 if (DO_UTF8(pat))
a5961de5 2631 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS		 2632 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2633 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2634 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 2635 op_free(expr);
2636 }
2637 else {
3280af22 2638 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2639 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2640 ? OP_REGCRESET
2641 : OP_REGCMAYBE),0,expr);
463ee0b2 2642
b7dc083c 2643 NewOp(1101, rcop, 1, LOGOP);
79072805 2644 rcop->op_type = OP_REGCOMP;
22c35a8c 2645 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2646 rcop->op_first = scalar(expr);
1c846c1f 2647 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2648 ? (OPf_SPECIAL | OPf_KIDS)
2649 : OPf_KIDS);
79072805 2650 rcop->op_private = 1;
11343788 2651 rcop->op_other = o;
b5c19bd7
DM		 2652 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2653 PL_cv_has_eval = 1;
79072805
LW		 2654
2655 /* establish postfix order */
3280af22 2656 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 2657 LINKLIST(expr);
2658 rcop->op_next = expr;
2659 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2660 }
2661 else {
2662 rcop->op_next = LINKLIST(expr);
2663 expr->op_next = (OP*)rcop;
2664 }
79072805 2665
11343788 2666 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 2667 }
2668
2669 if (repl) {
748a9306 2670 OP *curop;
0244c3a4 2671 if (pm->op_pmflags & PMf_EVAL) {
748a9306 2672 curop = 0;
8bafa735 2673 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 2674 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2675 }
748a9306
LW		 2676 else if (repl->op_type == OP_CONST)
2677 curop = repl;
79072805 2678 else {
79072805
LW		 2679 OP *lastop = 0;
2680 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 2681 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 2682 if (curop->op_type == OP_GV) {
638eceb6 2683 GV *gv = cGVOPx_gv(curop);
ce862d02 2684 repl_has_vars = 1;
f702bf4a 2685 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 2686 break;
2687 }
2688 else if (curop->op_type == OP_RV2CV)
2689 break;
2690 else if (curop->op_type == OP_RV2SV ||
2691 curop->op_type == OP_RV2AV ||
2692 curop->op_type == OP_RV2HV ||
2693 curop->op_type == OP_RV2GV) {
2694 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2695 break;
2696 }
748a9306
LW		 2697 else if (curop->op_type == OP_PADSV ||
2698 curop->op_type == OP_PADAV ||
2699 curop->op_type == OP_PADHV ||
554b3eca 2700 curop->op_type == OP_PADANY) {
ce862d02 2701 repl_has_vars = 1;
748a9306 2702 }
1167e5da
SM		 2703 else if (curop->op_type == OP_PUSHRE)
2704 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 2705 else
2706 break;
2707 }
2708 lastop = curop;
2709 }
748a9306 2710 }
ce862d02 2711 if (curop == repl
1c846c1f 2712 && !(repl_has_vars
aaa362c4
RS		 2713 && (!PM_GETRE(pm)
2714 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2715 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2716 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2717 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 2718 }
2719 else {
aaa362c4 2720 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 2721 pm->op_pmflags |= PMf_MAYBE_CONST;
2722 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2723 }
b7dc083c 2724 NewOp(1101, rcop, 1, LOGOP);
748a9306 2725 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2726 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 2727 rcop->op_first = scalar(repl);
2728 rcop->op_flags |= OPf_KIDS;
2729 rcop->op_private = 1;
11343788 2730 rcop->op_other = o;
748a9306
LW		 2731
2732 /* establish postfix order */
2733 rcop->op_next = LINKLIST(repl);
2734 repl->op_next = (OP*)rcop;
2735
2736 pm->op_pmreplroot = scalar((OP*)rcop);
2737 pm->op_pmreplstart = LINKLIST(rcop);
2738 rcop->op_next = 0;
79072805
LW		 2739 }
2740 }
2741
2742 return (OP*)pm;
2743}
2744
2745OP *
864dbfa3 2746Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 2747{
2748 SVOP *svop;
b7dc083c 2749 NewOp(1101, svop, 1, SVOP);
eb160463 2750 svop->op_type = (OPCODE)type;
22c35a8c 2751 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2752 svop->op_sv = sv;
2753 svop->op_next = (OP*)svop;
eb160463 2754 svop->op_flags = (U8)flags;
22c35a8c 2755 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2756 scalar((OP*)svop);
22c35a8c 2757 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2758 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2759 return CHECKOP(type, svop);
79072805
LW		 2760}
2761
2762OP *
350de78d
GS		 2763Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2764{
2765 PADOP *padop;
2766 NewOp(1101, padop, 1, PADOP);
eb160463 2767 padop->op_type = (OPCODE)type;
350de78d
GS		 2768 padop->op_ppaddr = PL_ppaddr[type];
2769 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 2770 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2771 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS		 2772 if (sv)
2773 SvPADTMP_on(sv);
350de78d 2774 padop->op_next = (OP*)padop;
eb160463 2775 padop->op_flags = (U8)flags;
350de78d
GS		 2776 if (PL_opargs[type] & OA_RETSCALAR)
2777 scalar((OP*)padop);
2778 if (PL_opargs[type] & OA_TARGET)
2779 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2780 return CHECKOP(type, padop);
2781}
2782
2783OP *
864dbfa3 2784Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 2785{
350de78d 2786#ifdef USE_ITHREADS
ce50c033
AMS		 2787 if (gv)
2788 GvIN_PAD_on(gv);
350de78d
GS		 2789 return newPADOP(type, flags, SvREFCNT_inc(gv));
2790#else
7934575e 2791 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 2792#endif
79072805
LW		 2793}
2794
2795OP *
864dbfa3 2796Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 2797{
2798 PVOP *pvop;
b7dc083c 2799 NewOp(1101, pvop, 1, PVOP);
eb160463 2800 pvop->op_type = (OPCODE)type;
22c35a8c 2801 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2802 pvop->op_pv = pv;
2803 pvop->op_next = (OP*)pvop;
eb160463 2804 pvop->op_flags = (U8)flags;
22c35a8c 2805 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2806 scalar((OP*)pvop);
22c35a8c 2807 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2808 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2809 return CHECKOP(type, pvop);
79072805
LW		 2810}
2811
79072805 2812void
864dbfa3 2813Perl_package(pTHX_ OP *o)
79072805 2814{
de11ba31
AMS		 2815 char *name;
2816 STRLEN len;
79072805 2817
3280af22
NIS		 2818 save_hptr(&PL_curstash);
2819 save_item(PL_curstname);
de11ba31
AMS		 2820
2821 name = SvPV(cSVOPo->op_sv, len);
2822 PL_curstash = gv_stashpvn(name, len, TRUE);
2823 sv_setpvn(PL_curstname, name, len);
2824 op_free(o);
2825
7ad382f4 2826 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 2827 PL_copline = NOLINE;
2828 PL_expect = XSTATE;
79072805
LW		 2829}
2830
85e6fe83 2831void
88d95a4d 2832Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 2833{
a0d0e21e 2834 OP *pack;
a0d0e21e 2835 OP *imop;
b1cb66bf 2836 OP *veop;
85e6fe83 2837
88d95a4d 2838 if (idop->op_type != OP_CONST)
cea2e8a9 2839 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 2840
b1cb66bf 2841 veop = Nullop;
2842
0f79a09d 2843 if (version != Nullop) {
b1cb66bf 2844 SV *vesv = ((SVOP*)version)->op_sv;
2845
44dcb63b 2846 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 2847 arg = version;
2848 }
2849 else {
2850 OP *pack;
0f79a09d 2851 SV *meth;
b1cb66bf 2852
44dcb63b 2853 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 2854 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 2855
88d95a4d
JH		 2856 /* Make copy of idop so we don't free it twice */
2857 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 2858
2859 /* Fake up a method call to VERSION */
0f79a09d
GS		 2860 meth = newSVpvn("VERSION",7);
2861 sv_upgrade(meth, SVt_PVIV);
155aba94 2862 (void)SvIOK_on(meth);
5afd6d42 2863 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 2864 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2865 append_elem(OP_LIST,
0f79a09d
GS		 2866 prepend_elem(OP_LIST, pack, list(version)),
2867 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 2868 }
2869 }
aeea060c 2870
a0d0e21e 2871 /* Fake up an import/unimport */
4633a7c4
LW		 2872 if (arg && arg->op_type == OP_STUB)
2873 imop = arg; /* no import on explicit () */
88d95a4d 2874 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
b1cb66bf 2875 imop = Nullop; /* use 5.0; */
2876 }
4633a7c4 2877 else {
0f79a09d
GS		 2878 SV *meth;
2879
88d95a4d
JH		 2880 /* Make copy of idop so we don't free it twice */
2881 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 2882
2883 /* Fake up a method call to import/unimport */
b47cad08 2884 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
ad4c42df 2885 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 2886 (void)SvIOK_on(meth);
5afd6d42 2887 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 2888 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 2889 append_elem(OP_LIST,
2890 prepend_elem(OP_LIST, pack, list(arg)),
2891 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 2892 }
2893
a0d0e21e 2894 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 2895 newATTRSUB(floor,
79cb57f6 2896 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 2897 Nullop,
09bef843 2898 Nullop,
a0d0e21e 2899 append_elem(OP_LINESEQ,
b1cb66bf 2900 append_elem(OP_LINESEQ,
88d95a4d 2901 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
b1cb66bf 2902 newSTATEOP(0, Nullch, veop)),
a0d0e21e 2903 newSTATEOP(0, Nullch, imop) ));
85e6fe83 2904
70f5e4ed
JH		 2905 /* The "did you use incorrect case?" warning used to be here.
2906 * The problem is that on case-insensitive filesystems one
2907 * might get false positives for "use" (and "require"):
2908 * "use Strict" or "require CARP" will work. This causes
2909 * portability problems for the script: in case-strict
2910 * filesystems the script will stop working.
2911 *
2912 * The "incorrect case" warning checked whether "use Foo"
2913 * imported "Foo" to your namespace, but that is wrong, too:
2914 * there is no requirement nor promise in the language that
2915 * a Foo.pm should or would contain anything in package "Foo".
2916 *
2917 * There is very little Configure-wise that can be done, either:
2918 * the case-sensitivity of the build filesystem of Perl does not
2919 * help in guessing the case-sensitivity of the runtime environment.
2920 */
18fc9488 2921
c305c6a0 2922 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 2923 PL_copline = NOLINE;
2924 PL_expect = XSTATE;
8ec8fbef 2925 PL_cop_seqmax++; /* Purely for B::*'s benefit */
85e6fe83
LW		 2926}
2927
7d3fb230 2928/*
ccfc67b7
JH		 2929=head1 Embedding Functions
2930
7d3fb230
BS		 2931=for apidoc load_module
2932
2933Loads the module whose name is pointed to by the string part of name.
2934Note that the actual module name, not its filename, should be given.
2935Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2936PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2937(or 0 for no flags). ver, if specified, provides version semantics
2938similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2939arguments can be used to specify arguments to the module's import()
2940method, similar to C<use Foo::Bar VERSION LIST>.
2941
2942=cut */
2943
e4783991
GS		 2944void
2945Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2946{
2947 va_list args;
2948 va_start(args, ver);
2949 vload_module(flags, name, ver, &args);
2950 va_end(args);
2951}
2952
2953#ifdef PERL_IMPLICIT_CONTEXT
2954void
2955Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2956{
2957 dTHX;
2958 va_list args;
2959 va_start(args, ver);
2960 vload_module(flags, name, ver, &args);
2961 va_end(args);
2962}
2963#endif
2964
2965void
2966Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2967{
2968 OP *modname, *veop, *imop;
2969
2970 modname = newSVOP(OP_CONST, 0, name);
2971 modname->op_private |= OPpCONST_BARE;
2972 if (ver) {
2973 veop = newSVOP(OP_CONST, 0, ver);
2974 }
2975 else
2976 veop = Nullop;
2977 if (flags & PERL_LOADMOD_NOIMPORT) {
2978 imop = sawparens(newNULLLIST());
2979 }
2980 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2981 imop = va_arg(*args, OP*);
2982 }
2983 else {
2984 SV *sv;
2985 imop = Nullop;
2986 sv = va_arg(*args, SV*);
2987 while (sv) {
2988 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2989 sv = va_arg(*args, SV*);
2990 }
2991 }
81885997
GS		 2992 {
2993 line_t ocopline = PL_copline;
834a3ffa 2994 COP *ocurcop = PL_curcop;
81885997
GS		 2995 int oexpect = PL_expect;
2996
2997 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2998 veop, modname, imop);
2999 PL_expect = oexpect;
3000 PL_copline = ocopline;
834a3ffa 3001 PL_curcop = ocurcop;
81885997 3002 }
e4783991
GS		 3003}
3004
79072805 3005OP *
864dbfa3 3006Perl_dofile(pTHX_ OP *term)
78ca652e
GS		 3007{
3008 OP *doop;
3009 GV *gv;
3010
3011 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3012 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS		 3013 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3014
b9f751c0 3015 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3016 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3017 append_elem(OP_LIST, term,
3018 scalar(newUNOP(OP_RV2CV, 0,
3019 newGVOP(OP_GV, 0,
3020 gv))))));
3021 }
3022 else {
3023 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3024 }
3025 return doop;
3026}
3027
3028OP *
864dbfa3 3029Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3030{
3031 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3032 list(force_list(subscript)),
3033 list(force_list(listval)) );
79072805
LW		 3034}
3035
76e3520e 3036STATIC I32
cea2e8a9 3037S_list_assignment(pTHX_ register OP *o)
79072805 3038{
11343788 3039 if (!o)
79072805
LW		 3040 return TRUE;
3041
11343788
MB		 3042 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3043 o = cUNOPo->op_first;
79072805 3044
11343788 3045 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM		 3046 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3047 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3048
3049 if (t && f)
3050 return TRUE;
3051 if (t || f)
3052 yyerror("Assignment to both a list and a scalar");
3053 return FALSE;
3054 }
3055
95f0a2f1
SB		 3056 if (o->op_type == OP_LIST &&
3057 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3058 o->op_private & OPpLVAL_INTRO)
3059 return FALSE;
3060
11343788
MB		 3061 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3062 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3063 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3064 return TRUE;
3065
11343788 3066 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3067 return TRUE;
3068
11343788 3069 if (o->op_type == OP_RV2SV)
79072805
LW		 3070 return FALSE;
3071
3072 return FALSE;
3073}
3074
3075OP *
864dbfa3 3076Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3077{
11343788 3078 OP *o;
79072805 3079
a0d0e21e 3080 if (optype) {
c963b151 3081 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 3082 return newLOGOP(optype, 0,
3083 mod(scalar(left), optype),
3084 newUNOP(OP_SASSIGN, 0, scalar(right)));
3085 }
3086 else {
3087 return newBINOP(optype, OPf_STACKED,
3088 mod(scalar(left), optype), scalar(right));
3089 }
3090 }
3091
79072805 3092 if (list_assignment(left)) {
10c8fecd
GS		 3093 OP *curop;
3094
3280af22
NIS		 3095 PL_modcount = 0;
3096 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3097 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3098 if (PL_eval_start)
3099 PL_eval_start = 0;
748a9306 3100 else {
a0d0e21e
LW		 3101 op_free(left);
3102 op_free(right);
3103 return Nullop;
3104 }
10c8fecd
GS		 3105 curop = list(force_list(left));
3106 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3107 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM		 3108
3109 /* PL_generation sorcery:
3110 * an assignment like ($a,$b) = ($c,$d) is easier than
3111 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3112 * To detect whether there are common vars, the global var
3113 * PL_generation is incremented for each assign op we compile.
3114 * Then, while compiling the assign op, we run through all the
3115 * variables on both sides of the assignment, setting a spare slot
3116 * in each of them to PL_generation. If any of them already have
3117 * that value, we know we've got commonality. We could use a
3118 * single bit marker, but then we'd have to make 2 passes, first
3119 * to clear the flag, then to test and set it. To find somewhere
3120 * to store these values, evil chicanery is done with SvCUR().
3121 */
3122
a0d0e21e 3123 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3124 OP *lastop = o;
3280af22 3125 PL_generation++;
11343788 3126 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3127 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3128 if (curop->op_type == OP_GV) {
638eceb6 3129 GV *gv = cGVOPx_gv(curop);
eb160463 3130 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
79072805 3131 break;
3280af22 3132 SvCUR(gv) = PL_generation;
79072805 3133 }
748a9306
LW		 3134 else if (curop->op_type == OP_PADSV ||
3135 curop->op_type == OP_PADAV ||
3136 curop->op_type == OP_PADHV ||
dd2155a4
DM		 3137 curop->op_type == OP_PADANY)
3138 {
3139 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3140 == (STRLEN)PL_generation)
748a9306 3141 break;
dd2155a4
DM		 3142 PAD_COMPNAME_GEN(curop->op_targ)
3143 = PL_generation;
3144
748a9306 3145 }
79072805
LW		 3146 else if (curop->op_type == OP_RV2CV)
3147 break;
3148 else if (curop->op_type == OP_RV2SV ||
3149 curop->op_type == OP_RV2AV ||
3150 curop->op_type == OP_RV2HV ||
3151 curop->op_type == OP_RV2GV) {
3152 if (lastop->op_type != OP_GV) /* funny deref? */
3153 break;
3154 }
1167e5da
SM		 3155 else if (curop->op_type == OP_PUSHRE) {
3156 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3157#ifdef USE_ITHREADS
dd2155a4
DM		 3158 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3159 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3160#else
1167e5da 3161 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3162#endif
eb160463 3163 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
1167e5da 3164 break;
3280af22 3165 SvCUR(gv) = PL_generation;
b2ffa427 3166 }
1167e5da 3167 }
79072805
LW		 3168 else
3169 break;
3170 }
3171 lastop = curop;
3172 }
11343788 3173 if (curop != o)
10c8fecd 3174 o->op_private |= OPpASSIGN_COMMON;
79072805 3175 }
c07a80fd 3176 if (right && right->op_type == OP_SPLIT) {
3177 OP* tmpop;
3178 if ((tmpop = ((LISTOP*)right)->op_first) &&
3179 tmpop->op_type == OP_PUSHRE)
3180 {
3181 PMOP *pm = (PMOP*)tmpop;
3182 if (left->op_type == OP_RV2AV &&
3183 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3184 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3185 {
3186 tmpop = ((UNOP*)left)->op_first;
3187 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3188#ifdef USE_ITHREADS
ba89bb6e 3189 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3190 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3191#else
3192 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3193 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3194#endif
c07a80fd 3195 pm->op_pmflags |= PMf_ONCE;
11343788 3196 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3197 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3198 tmpop->op_sibling = Nullop; /* don't free split */
3199 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3200 op_free(o); /* blow off assign */
54310121 3201 right->op_flags &= ~OPf_WANT;
a5f75d66 3202 /* "I don't know and I don't care." */
c07a80fd 3203 return right;
3204 }
3205 }
3206 else {
e6438c1a 3207 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3208 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3209 {
3210 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3211 if (SvIVX(sv) == 0)
3280af22 3212 sv_setiv(sv, PL_modcount+1);
c07a80fd 3213 }
3214 }
3215 }
3216 }
11343788 3217 return o;
79072805
LW		 3218 }
3219 if (!right)
3220 right = newOP(OP_UNDEF, 0);
3221 if (right->op_type == OP_READLINE) {
3222 right->op_flags |= OPf_STACKED;
463ee0b2 3223 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3224 }
a0d0e21e 3225 else {
3280af22 3226 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3227 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3228 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3229 if (PL_eval_start)
3230 PL_eval_start = 0;
748a9306 3231 else {
11343788 3232 op_free(o);
a0d0e21e
LW		 3233 return Nullop;
3234 }
3235 }
11343788 3236 return o;
79072805
LW		 3237}
3238
3239OP *
864dbfa3 3240Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3241{
bbce6d69 3242 U32 seq = intro_my();
79072805
LW		 3243 register COP *cop;
3244
b7dc083c 3245 NewOp(1101, cop, 1, COP);
57843af0 3246 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3247 cop->op_type = OP_DBSTATE;
22c35a8c 3248 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3249 }
3250 else {
3251 cop->op_type = OP_NEXTSTATE;
22c35a8c 3252 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3253 }
eb160463
GS		 3254 cop->op_flags = (U8)flags;
3255 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3256#ifdef NATIVE_HINTS
3257 cop->op_private |= NATIVE_HINTS;
3258#endif
e24b16f9 3259 PL_compiling.op_private = cop->op_private;
79072805
LW		 3260 cop->op_next = (OP*)cop;
3261
463ee0b2
LW		 3262 if (label) {
3263 cop->cop_label = label;
3280af22 3264 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3265 }
bbce6d69 3266 cop->cop_seq = seq;
3280af22 3267 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3268 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3269 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3270 else
599cee73 3271 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3272 if (specialCopIO(PL_curcop->cop_io))
3273 cop->cop_io = PL_curcop->cop_io;
3274 else
3275 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3276
79072805 3277
3280af22 3278 if (PL_copline == NOLINE)
57843af0 3279 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3280 else {
57843af0 3281 CopLINE_set(cop, PL_copline);
3280af22 3282 PL_copline = NOLINE;
79072805 3283 }
57843af0 3284#ifdef USE_ITHREADS
f4dd75d9 3285 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3286#else
f4dd75d9 3287 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3288#endif
11faa288 3289 CopSTASH_set(cop, PL_curstash);
79072805 3290
3280af22 3291 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3292 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3293 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3294 (void)SvIOK_on(*svp);
57b2e452 3295 SvIVX(*svp) = PTR2IV(cop);
1eb1540c 3296 }
93a17b20
LW		 3297 }
3298
11343788 3299 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3300}
3301
bbce6d69 3302
79072805 3303OP *
864dbfa3 3304Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3305{
883ffac3
CS		 3306 return new_logop(type, flags, &first, &other);
3307}
3308
3bd495df 3309STATIC OP *
cea2e8a9 3310S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3311{
79072805 3312 LOGOP *logop;
11343788 3313 OP *o;
883ffac3
CS		 3314 OP *first = *firstp;
3315 OP *other = *otherp;
79072805 3316
a0d0e21e
LW		 3317 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3318 return newBINOP(type, flags, scalar(first), scalar(other));
3319
8990e307 3320 scalarboolean(first);
79072805
LW		 3321 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3322 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3323 if (type == OP_AND || type == OP_OR) {
3324 if (type == OP_AND)
3325 type = OP_OR;
3326 else
3327 type = OP_AND;
11343788 3328 o = first;
883ffac3 3329 first = *firstp = cUNOPo->op_first;
11343788
MB		 3330 if (o->op_next)
3331 first->op_next = o->op_next;
3332 cUNOPo->op_first = Nullop;
3333 op_free(o);
79072805
LW		 3334 }
3335 }
3336 if (first->op_type == OP_CONST) {
989dfb19 3337 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
6d5637c3 3338 if (first->op_private & OPpCONST_STRICT)
989dfb19
K		 3339 no_bareword_allowed(first);
3340 else
3341 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3342 }
79072805
LW		 3343 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3344 op_free(first);
883ffac3 3345 *firstp = Nullop;
79072805
LW		 3346 return other;
3347 }
3348 else {
3349 op_free(other);
883ffac3 3350 *otherp = Nullop;
79072805
LW		 3351 return first;
3352 }
3353 }
59e10468
RGS		 3354 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3355 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3356 {
a6006777 3357 OP *k1 = ((UNOP*)first)->op_first;
3358 OP *k2 = k1->op_sibling;
3359 OPCODE warnop = 0;
3360 switch (first->op_type)
3361 {
3362 case OP_NULL:
3363 if (k2 && k2->op_type == OP_READLINE
3364 && (k2->op_flags & OPf_STACKED)
1c846c1f 3365 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3366 {
a6006777 3367 warnop = k2->op_type;
72b16652 3368 }
a6006777 3369 break;
3370
3371 case OP_SASSIGN:
68dc0745 3372 if (k1->op_type == OP_READDIR
3373 || k1->op_type == OP_GLOB
72b16652 3374 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3375 || k1->op_type == OP_EACH)
72b16652
GS		 3376 {
3377 warnop = ((k1->op_type == OP_NULL)
eb160463 3378 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 3379 }
a6006777 3380 break;
3381 }
8ebc5c01 3382 if (warnop) {
57843af0
GS		 3383 line_t oldline = CopLINE(PL_curcop);
3384 CopLINE_set(PL_curcop, PL_copline);
9014280d 3385 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 3386 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3387 PL_op_desc[warnop],
68dc0745 3388 ((warnop == OP_READLINE || warnop == OP_GLOB)
3389 ? " construct" : "() operator"));
57843af0 3390 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3391 }
a6006777 3392 }
79072805
LW		 3393
3394 if (!other)
3395 return first;
3396
c963b151 3397 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 3398 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3399
b7dc083c 3400 NewOp(1101, logop, 1, LOGOP);
79072805 3401
eb160463 3402 logop->op_type = (OPCODE)type;
22c35a8c 3403 logop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3404 logop->op_first = first;
3405 logop->op_flags = flags | OPf_KIDS;
3406 logop->op_other = LINKLIST(other);
eb160463 3407 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3408
3409 /* establish postfix order */
3410 logop->op_next = LINKLIST(first);
3411 first->op_next = (OP*)logop;
3412 first->op_sibling = other;
3413
463d09e6
RGS		 3414 CHECKOP(type,logop);
3415
11343788
MB		 3416 o = newUNOP(OP_NULL, 0, (OP*)logop);
3417 other->op_next = o;
79072805 3418
11343788 3419 return o;
79072805
LW		 3420}
3421
3422OP *
864dbfa3 3423Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3424{
1a67a97c
SM		 3425 LOGOP *logop;
3426 OP *start;
11343788 3427 OP *o;
79072805 3428
b1cb66bf 3429 if (!falseop)
3430 return newLOGOP(OP_AND, 0, first, trueop);
3431 if (!trueop)
3432 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3433
8990e307 3434 scalarboolean(first);
79072805 3435 if (first->op_type == OP_CONST) {
2bc6235c
K		 3436 if (first->op_private & OPpCONST_BARE &&
3437 first->op_private & OPpCONST_STRICT) {
3438 no_bareword_allowed(first);
3439 }
79072805
LW		 3440 if (SvTRUE(((SVOP*)first)->op_sv)) {
3441 op_free(first);
b1cb66bf 3442 op_free(falseop);
3443 return trueop;
79072805
LW		 3444 }
3445 else {
3446 op_free(first);
b1cb66bf 3447 op_free(trueop);
3448 return falseop;
79072805
LW		 3449 }
3450 }
1a67a97c
SM		 3451 NewOp(1101, logop, 1, LOGOP);
3452 logop->op_type = OP_COND_EXPR;
3453 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3454 logop->op_first = first;
3455 logop->op_flags = flags | OPf_KIDS;
eb160463 3456 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 3457 logop->op_other = LINKLIST(trueop);
3458 logop->op_next = LINKLIST(falseop);
79072805 3459
463d09e6
RGS		 3460 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3461 logop);
79072805
LW		 3462
3463 /* establish postfix order */
1a67a97c
SM		 3464 start = LINKLIST(first);
3465 first->op_next = (OP*)logop;
79072805 3466
b1cb66bf 3467 first->op_sibling = trueop;
3468 trueop->op_sibling = falseop;
1a67a97c 3469 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 3470
1a67a97c 3471 trueop->op_next = falseop->op_next = o;
79072805 3472
1a67a97c 3473 o->op_next = start;
11343788 3474 return o;
79072805
LW		 3475}
3476
3477OP *
864dbfa3 3478Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 3479{
1a67a97c 3480 LOGOP *range;
79072805
LW		 3481 OP *flip;
3482 OP *flop;
1a67a97c 3483 OP *leftstart;
11343788 3484 OP *o;
79072805 3485
1a67a97c 3486 NewOp(1101, range, 1, LOGOP);
79072805 3487
1a67a97c
SM		 3488 range->op_type = OP_RANGE;
3489 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3490 range->op_first = left;
3491 range->op_flags = OPf_KIDS;
3492 leftstart = LINKLIST(left);
3493 range->op_other = LINKLIST(right);
eb160463 3494 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3495
3496 left->op_sibling = right;
3497
1a67a97c
SM		 3498 range->op_next = (OP*)range;
3499 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 3500 flop = newUNOP(OP_FLOP, 0, flip);
11343788 3501 o = newUNOP(OP_NULL, 0, flop);
79072805 3502 linklist(flop);
1a67a97c 3503 range->op_next = leftstart;
79072805
LW		 3504
3505 left->op_next = flip;
3506 right->op_next = flop;
3507
1a67a97c
SM		 3508 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3509 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 3510 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 3511 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3512
3513 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3514 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3515
11343788 3516 flip->op_next = o;
79072805 3517 if (!flip->op_private || !flop->op_private)
11343788 3518 linklist(o); /* blow off optimizer unless constant */
79072805 3519
11343788 3520 return o;
79072805
LW		 3521}
3522
3523OP *
864dbfa3 3524Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 3525{
463ee0b2 3526 OP* listop;
11343788 3527 OP* o;
463ee0b2 3528 int once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 3529 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
93a17b20 3530
463ee0b2
LW		 3531 if (expr) {
3532 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3533 return block; /* do {} while 0 does once */
fb73857a 3534 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3535 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 3536 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3537 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3538 } else if (expr->op_flags & OPf_KIDS) {
3539 OP *k1 = ((UNOP*)expr)->op_first;
3540 OP *k2 = (k1) ? k1->op_sibling : NULL;
3541 switch (expr->op_type) {
1c846c1f 3542 case OP_NULL:
55d729e4
GS		 3543 if (k2 && k2->op_type == OP_READLINE
3544 && (k2->op_flags & OPf_STACKED)
1c846c1f 3545 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3546 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3547 break;
55d729e4
GS		 3548
3549 case OP_SASSIGN:
3550 if (k1->op_type == OP_READDIR
3551 || k1->op_type == OP_GLOB
6531c3e6 3552 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3553 || k1->op_type == OP_EACH)
3554 expr = newUNOP(OP_DEFINED, 0, expr);
3555 break;
3556 }
774d564b 3557 }
463ee0b2 3558 }
93a17b20 3559
8990e307 3560 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 3561 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 3562
883ffac3
CS		 3563 if (listop)
3564 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 3565
11343788
MB		 3566 if (once && o != listop)
3567 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 3568
11343788
MB		 3569 if (o == listop)
3570 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 3571
11343788
MB		 3572 o->op_flags |= flags;
3573 o = scope(o);
3574 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3575 return o;
79072805
LW		 3576}
3577
3578OP *
864dbfa3 3579Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
79072805
LW		 3580{
3581 OP *redo;
3582 OP *next = 0;
3583 OP *listop;
11343788 3584 OP *o;
1ba6ee2b 3585 U8 loopflags = 0;
79072805 3586
fb73857a 3587 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3588 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
748a9306 3589 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3590 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3591 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3592 OP *k1 = ((UNOP*)expr)->op_first;
3593 OP *k2 = (k1) ? k1->op_sibling : NULL;
3594 switch (expr->op_type) {
1c846c1f 3595 case OP_NULL:
55d729e4
GS		 3596 if (k2 && k2->op_type == OP_READLINE
3597 && (k2->op_flags & OPf_STACKED)
1c846c1f 3598 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3599 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3600 break;
55d729e4
GS		 3601
3602 case OP_SASSIGN:
3603 if (k1->op_type == OP_READDIR
3604 || k1->op_type == OP_GLOB
72b16652 3605 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3606 || k1->op_type == OP_EACH)
3607 expr = newUNOP(OP_DEFINED, 0, expr);
3608 break;
3609 }
748a9306 3610 }
79072805
LW		 3611
3612 if (!block)
3613 block = newOP(OP_NULL, 0);
87246558
GS		 3614 else if (cont) {
3615 block = scope(block);
3616 }
79072805 3617
1ba6ee2b 3618 if (cont) {
79072805 3619 next = LINKLIST(cont);
1ba6ee2b 3620 }
fb73857a 3621 if (expr) {
85538317
GS		 3622 OP *unstack = newOP(OP_UNSTACK, 0);
3623 if (!next)
3624 next = unstack;
3625 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 3626 }
79072805 3627
463ee0b2 3628 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 3629 redo = LINKLIST(listop);
3630
3631 if (expr) {
eb160463 3632 PL_copline = (line_t)whileline;
883ffac3
CS		 3633 scalar(listop);
3634 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 3635 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 3636 op_free(expr); /* oops, it's a while (0) */
463ee0b2 3637 op_free((OP*)loop);
883ffac3 3638 return Nullop; /* listop already freed by new_logop */
463ee0b2 3639 }
883ffac3 3640 if (listop)
497b47a8 3641 ((LISTOP*)listop)->op_last->op_next =
883ffac3 3642 (o == listop ? redo : LINKLIST(o));
79072805
LW		 3643 }
3644 else
11343788 3645 o = listop;
79072805
LW		 3646
3647 if (!loop) {
b7dc083c 3648 NewOp(1101,loop,1,LOOP);
79072805 3649 loop->op_type = OP_ENTERLOOP;
22c35a8c 3650 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 3651 loop->op_private = 0;
3652 loop->op_next = (OP*)loop;
3653 }
3654
11343788 3655 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 3656
3657 loop->op_redoop = redo;
11343788 3658 loop->op_lastop = o;
1ba6ee2b 3659 o->op_private |= loopflags;
79072805
LW		 3660
3661 if (next)
3662 loop->op_nextop = next;
3663 else
11343788 3664 loop->op_nextop = o;
79072805 3665
11343788
MB		 3666 o->op_flags |= flags;
3667 o->op_private |= (flags >> 8);
3668 return o;
79072805
LW		 3669}
3670
3671OP *
864dbfa3 3672Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
79072805
LW		 3673{
3674 LOOP *loop;
fb73857a 3675 OP *wop;
4bbc6d12 3676 PADOFFSET padoff = 0;
4633a7c4 3677 I32 iterflags = 0;
241416b8 3678 I32 iterpflags = 0;
79072805 3679
79072805 3680 if (sv) {
85e6fe83 3681 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 3682 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 3683 sv->op_type = OP_RV2GV;
22c35a8c 3684 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
79072805 3685 }
85e6fe83 3686 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 3687 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 3688 padoff = sv->op_targ;
743e66e6 3689 sv->op_targ = 0;
85e6fe83
LW		 3690 op_free(sv);
3691 sv = Nullop;
3692 }
54b9620d
MB		 3693 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3694 padoff = sv->op_targ;
743e66e6 3695 sv->op_targ = 0;
54b9620d
MB		 3696 iterflags |= OPf_SPECIAL;
3697 op_free(sv);
3698 sv = Nullop;
3699 }
79072805 3700 else
cea2e8a9 3701 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
79072805
LW		 3702 }
3703 else {
3280af22 3704 sv = newGVOP(OP_GV, 0, PL_defgv);
79072805 3705 }
5f05dabc 3706 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 3707 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 3708 iterflags |= OPf_STACKED;
3709 }
89ea2908
GA		 3710 else if (expr->op_type == OP_NULL &&
3711 (expr->op_flags & OPf_KIDS) &&
3712 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3713 {
3714 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3715 * set the STACKED flag to indicate that these values are to be
3716 * treated as min/max values by 'pp_iterinit'.
3717 */
3718 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
1a67a97c 3719 LOGOP* range = (LOGOP*) flip->op_first;
89ea2908
GA		 3720 OP* left = range->op_first;
3721 OP* right = left->op_sibling;
5152d7c7 3722 LISTOP* listop;
89ea2908
GA		 3723
3724 range->op_flags &= ~OPf_KIDS;
3725 range->op_first = Nullop;
3726
5152d7c7 3727 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 3728 listop->op_first->op_next = range->op_next;
3729 left->op_next = range->op_other;
5152d7c7
GS		 3730 right->op_next = (OP*)listop;
3731 listop->op_next = listop->op_first;
89ea2908
GA		 3732
3733 op_free(expr);
5152d7c7 3734 expr = (OP*)(listop);
93c66552 3735 op_null(expr);
89ea2908
GA		 3736 iterflags |= OPf_STACKED;
3737 }
3738 else {
3739 expr = mod(force_list(expr), OP_GREPSTART);
3740 }
3741
3742
4633a7c4 3743 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 3744 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 3745 assert(!loop->op_next);
241416b8 3746 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 3747 * for our $x () sets OPpOUR_INTRO */
c5661c80 3748 loop->op_private = (U8)iterpflags;
b7dc083c 3749#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 3750 {
3751 LOOP *tmp;
3752 NewOp(1234,tmp,1,LOOP);
3753 Copy(loop,tmp,1,LOOP);
238a4c30 3754 FreeOp(loop);
155aba94
GS		 3755 loop = tmp;
3756 }
b7dc083c 3757#else
85e6fe83 3758 Renew(loop, 1, LOOP);
1c846c1f 3759#endif
85e6fe83 3760 loop->op_targ = padoff;
fb73857a 3761 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3280af22 3762 PL_copline = forline;
fb73857a 3763 return newSTATEOP(0, label, wop);
79072805
LW		 3764}
3765
8990e307 3766OP*
864dbfa3 3767Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 3768{
11343788 3769 OP *o;
2d8e6c8d
GS		 3770 STRLEN n_a;
3771
8990e307 3772 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 3773 /* "last()" means "last" */
3774 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3775 o = newOP(type, OPf_SPECIAL);
3776 else {
3777 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
2d8e6c8d 3778 ? SvPVx(((SVOP*)label)->op_sv, n_a)
cdaebead
MB		 3779 : ""));
3780 }
8990e307
LW		 3781 op_free(label);
3782 }
3783 else {
e3aba57a
RGS		 3784 /* Check whether it's going to be a goto &function */
3785 if (label->op_type == OP_ENTERSUB
3786 && !(label->op_flags & OPf_STACKED))
a0d0e21e 3787 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 3788 o = newUNOP(type, OPf_STACKED, label);
8990e307 3789 }
3280af22 3790 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3791 return o;
8990e307
LW		 3792}
3793
7dafbf52
DM		 3794/*
3795=for apidoc cv_undef
3796
3797Clear out all the active components of a CV. This can happen either
3798by an explicit C<undef &foo>, or by the reference count going to zero.
3799In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3800children can still follow the full lexical scope chain.
3801
3802=cut
3803*/
3804
79072805 3805void
864dbfa3 3806Perl_cv_undef(pTHX_ CV *cv)
79072805 3807{
a636914a 3808#ifdef USE_ITHREADS
35f1c1c7
SB		 3809 if (CvFILE(cv) && !CvXSUB(cv)) {
3810 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 3811 Safefree(CvFILE(cv));
a636914a 3812 }
f3e31eb5 3813 CvFILE(cv) = 0;
a636914a
RH		 3814#endif
3815
a0d0e21e
LW		 3816 if (!CvXSUB(cv) && CvROOT(cv)) {
3817 if (CvDEPTH(cv))
cea2e8a9 3818 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 3819 ENTER;
a0d0e21e 3820
f3548bdc 3821 PAD_SAVE_SETNULLPAD();
a0d0e21e 3822
282f25c9 3823 op_free(CvROOT(cv));
79072805 3824 CvROOT(cv) = Nullop;
8990e307 3825 LEAVE;
79072805 3826 }
1d5db326 3827 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 3828 CvGV(cv) = Nullgv;
a3985cdc
DM		 3829
3830 pad_undef(cv);
3831
7dafbf52
DM		 3832 /* remove CvOUTSIDE unless this is an undef rather than a free */
3833 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3834 if (!CvWEAKOUTSIDE(cv))
3835 SvREFCNT_dec(CvOUTSIDE(cv));
3836 CvOUTSIDE(cv) = Nullcv;
3837 }
beab0874
JT		 3838 if (CvCONST(cv)) {
3839 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3840 CvCONST_off(cv);
3841 }
50762d59
DM		 3842 if (CvXSUB(cv)) {
3843 CvXSUB(cv) = 0;
3844 }
7dafbf52
DM		 3845 /* delete all flags except WEAKOUTSIDE */
3846 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 3847}
3848
3fe9a6f1 3849void
864dbfa3 3850Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 3851{
e476b1b5 3852 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 3853 SV* msg = sv_newmortal();
3fe9a6f1 3854 SV* name = Nullsv;
3855
3856 if (gv)
46fc3d4c 3857 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3858 sv_setpv(msg, "Prototype mismatch:");
3859 if (name)
894356b3 3860 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 3861 if (SvPOK(cv))
35c1215d 3862 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
46fc3d4c 3863 sv_catpv(msg, " vs ");
3864 if (p)
cea2e8a9 3865 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 3866 else
3867 sv_catpv(msg, "none");
9014280d 3868 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3fe9a6f1 3869 }
3870}
3871
35f1c1c7
SB		 3872static void const_sv_xsub(pTHX_ CV* cv);
3873
beab0874 3874/*
ccfc67b7
JH		 3875
3876=head1 Optree Manipulation Functions
3877
beab0874
JT		 3878=for apidoc cv_const_sv
3879
3880If C<cv> is a constant sub eligible for inlining. returns the constant
3881value returned by the sub. Otherwise, returns NULL.
3882
3883Constant subs can be created with C<newCONSTSUB> or as described in
3884L<perlsub/"Constant Functions">.
3885
3886=cut
3887*/
760ac839 3888SV *
864dbfa3 3889Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 3890{
beab0874 3891 if (!cv || !CvCONST(cv))
54310121 3892 return Nullsv;
beab0874 3893 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 3894}
760ac839 3895
b5c19bd7
DM		 3896/* op_const_sv: examine an optree to determine whether it's in-lineable.
3897 * Can be called in 3 ways:
3898 *
3899 * !cv
3900 * look for a single OP_CONST with attached value: return the value
3901 *
3902 * cv && CvCLONE(cv) && !CvCONST(cv)
3903 *
3904 * examine the clone prototype, and if contains only a single
3905 * OP_CONST referencing a pad const, or a single PADSV referencing
3906 * an outer lexical, return a non-zero value to indicate the CV is
3907 * a candidate for "constizing" at clone time
3908 *
3909 * cv && CvCONST(cv)
3910 *
3911 * We have just cloned an anon prototype that was marked as a const
3912 * candidiate. Try to grab the current value, and in the case of
3913 * PADSV, ignore it if it has multiple references. Return the value.
3914 */
3915
fe5e78ed 3916SV *
864dbfa3 3917Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 3918{
3919 SV *sv = Nullsv;
3920
0f79a09d 3921 if (!o)
fe5e78ed 3922 return Nullsv;
1c846c1f
NIS		 3923
3924 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 3925 o = cLISTOPo->op_first->op_sibling;
3926
3927 for (; o; o = o->op_next) {
54310121 3928 OPCODE type = o->op_type;
fe5e78ed 3929
1c846c1f 3930 if (sv && o->op_next == o)
fe5e78ed 3931 return sv;
e576b457
JT		 3932 if (o->op_next != o) {
3933 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3934 continue;
3935 if (type == OP_DBSTATE)
3936 continue;
3937 }
54310121 3938 if (type == OP_LEAVESUB || type == OP_RETURN)
3939 break;
3940 if (sv)
3941 return Nullsv;
7766f137 3942 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 3943 sv = cSVOPo->op_sv;
b5c19bd7 3944 else if (cv && type == OP_CONST) {
dd2155a4 3945 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874
JT		 3946 if (!sv)
3947 return Nullsv;
b5c19bd7
DM		 3948 }
3949 else if (cv && type == OP_PADSV) {
3950 if (CvCONST(cv)) { /* newly cloned anon */
3951 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3952 /* the candidate should have 1 ref from this pad and 1 ref
3953 * from the parent */
3954 if (!sv || SvREFCNT(sv) != 2)
3955 return Nullsv;
beab0874 3956 sv = newSVsv(sv);
b5c19bd7
DM		 3957 SvREADONLY_on(sv);
3958 return sv;
3959 }
3960 else {
3961 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3962 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 3963 }
760ac839 3964 }
b5c19bd7 3965 else {
54310121 3966 return Nullsv;
b5c19bd7 3967 }
760ac839
LW		 3968 }
3969 return sv;
3970}
3971
09bef843
SB		 3972void
3973Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3974{
3975 if (o)
3976 SAVEFREEOP(o);
3977 if (proto)
3978 SAVEFREEOP(proto);
3979 if (attrs)
3980 SAVEFREEOP(attrs);
3981 if (block)
3982 SAVEFREEOP(block);
3983 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3984}
3985
748a9306 3986CV *
864dbfa3 3987Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 3988{
09bef843
SB		 3989 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3990}
3991
3992CV *
3993Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3994{
2d8e6c8d 3995 STRLEN n_a;
83ee9e09
GS		 3996 char *name;
3997 char *aname;
3998 GV *gv;
2d8e6c8d 3999 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 4000 register CV *cv=0;
beab0874 4001 SV *const_sv;
79072805 4002
83ee9e09
GS		 4003 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4004 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4005 SV *sv = sv_newmortal();
c99da370
JH		 4006 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4007 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09
GS		 4008 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4009 aname = SvPVX(sv);
4010 }
4011 else
4012 aname = Nullch;
c99da370
JH		 4013 gv = gv_fetchpv(name ? name : (aname ? aname :
4014 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
83ee9e09
GS		 4015 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4016 SVt_PVCV);
4017
11343788 4018 if (o)
5dc0d613 4019 SAVEFREEOP(o);
3fe9a6f1 4020 if (proto)
4021 SAVEFREEOP(proto);
09bef843
SB		 4022 if (attrs)
4023 SAVEFREEOP(attrs);
3fe9a6f1 4024
09bef843 4025 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4026 maximum a prototype before. */
4027 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4028 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4029 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4030 {
9014280d 4031 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 4032 }
55d729e4
GS		 4033 cv_ckproto((CV*)gv, NULL, ps);
4034 }
4035 if (ps)
4036 sv_setpv((SV*)gv, ps);
4037 else
4038 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4039 SvREFCNT_dec(PL_compcv);
4040 cv = PL_compcv = NULL;
4041 PL_sub_generation++;
beab0874 4042 goto done;
55d729e4
GS		 4043 }
4044
beab0874
JT		 4045 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4046
7fb37951
AMS		 4047#ifdef GV_UNIQUE_CHECK
4048 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4049 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4050 }
4051#endif
4052
beab0874
JT		 4053 if (!block || !ps || *ps || attrs)
4054 const_sv = Nullsv;
4055 else
4056 const_sv = op_const_sv(block, Nullcv);
4057
4058 if (cv) {
60ed1d8c 4059 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4060
7fb37951
AMS		 4061#ifdef GV_UNIQUE_CHECK
4062 if (exists && GvUNIQUE(gv)) {
4063 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4064 }
4065#endif
4066
60ed1d8c
GS		 4067 /* if the subroutine doesn't exist and wasn't pre-declared
4068 * with a prototype, assume it will be AUTOLOADed,
4069 * skipping the prototype check
4070 */
4071 if (exists || SvPOK(cv))
01ec43d0 4072 cv_ckproto(cv, gv, ps);
68dc0745 4073 /* already defined (or promised)? */
60ed1d8c 4074 if (exists || GvASSUMECV(gv)) {
09bef843 4075 if (!block && !attrs) {
d3cea301
SB		 4076 if (CvFLAGS(PL_compcv)) {
4077 /* might have had built-in attrs applied */
4078 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4079 }
aa689395 4080 /* just a "sub foo;" when &foo is already defined */
3280af22 4081 SAVEFREESV(PL_compcv);
aa689395 4082 goto done;
4083 }
7bac28a0 4084 /* ahem, death to those who redefine active sort subs */
3280af22 4085 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4086 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4087 if (block) {
4088 if (ckWARN(WARN_REDEFINE)
4089 || (CvCONST(cv)
4090 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4091 {
4092 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4093 if (PL_copline != NOLINE)
4094 CopLINE_set(PL_curcop, PL_copline);
9014280d 4095 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4096 CvCONST(cv) ? "Constant subroutine %s redefined"
4097 : "Subroutine %s redefined", name);
4098 CopLINE_set(PL_curcop, oldline);
4099 }
4100 SvREFCNT_dec(cv);
4101 cv = Nullcv;
79072805 4102 }
79072805
LW		 4103 }
4104 }
beab0874
JT		 4105 if (const_sv) {
4106 SvREFCNT_inc(const_sv);
4107 if (cv) {
0768512c 4108 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4109 sv_setpv((SV*)cv, ""); /* prototype is "" */
4110 CvXSUBANY(cv).any_ptr = const_sv;
4111 CvXSUB(cv) = const_sv_xsub;
4112 CvCONST_on(cv);
beab0874
JT		 4113 }
4114 else {
4115 GvCV(gv) = Nullcv;
4116 cv = newCONSTSUB(NULL, name, const_sv);
4117 }
4118 op_free(block);
4119 SvREFCNT_dec(PL_compcv);
4120 PL_compcv = NULL;
4121 PL_sub_generation++;
4122 goto done;
4123 }
09bef843
SB		 4124 if (attrs) {
4125 HV *stash;
4126 SV *rcv;
4127
4128 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4129 * before we clobber PL_compcv.
4130 */
4131 if (cv && !block) {
4132 rcv = (SV*)cv;
020f0e03
SB		 4133 /* Might have had built-in attributes applied -- propagate them. */
4134 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4135 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4136 stash = GvSTASH(CvGV(cv));
a9164de8 4137 else if (CvSTASH(cv))
09bef843
SB		 4138 stash = CvSTASH(cv);
4139 else
4140 stash = PL_curstash;
4141 }
4142 else {
4143 /* possibly about to re-define existing subr -- ignore old cv */
4144 rcv = (SV*)PL_compcv;
a9164de8 4145 if (name && GvSTASH(gv))
09bef843
SB		 4146 stash = GvSTASH(gv);
4147 else
4148 stash = PL_curstash;
4149 }
95f0a2f1 4150 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4151 }
a0d0e21e 4152 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4153 if (!block) {
4154 /* got here with just attrs -- work done, so bug out */
4155 SAVEFREESV(PL_compcv);
4156 goto done;
4157 }
a3985cdc 4158 /* transfer PL_compcv to cv */
4633a7c4 4159 cv_undef(cv);
3280af22
NIS		 4160 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4161 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 4162 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 4163 CvOUTSIDE(PL_compcv) = 0;
4164 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4165 CvPADLIST(PL_compcv) = 0;
282f25c9 4166 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 4167 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 4168 /* ... before we throw it away */
3280af22 4169 SvREFCNT_dec(PL_compcv);
b5c19bd7 4170 PL_compcv = cv;
a933f601
IZ		 4171 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4172 ++PL_sub_generation;
a0d0e21e
LW		 4173 }
4174 else {
3280af22 4175 cv = PL_compcv;
44a8e56a 4176 if (name) {
4177 GvCV(gv) = cv;
4178 GvCVGEN(gv) = 0;
3280af22 4179 PL_sub_generation++;
44a8e56a 4180 }
a0d0e21e 4181 }
65c50114 4182 CvGV(cv) = gv;
a636914a 4183 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4184 CvSTASH(cv) = PL_curstash;
8990e307 4185
3fe9a6f1 4186 if (ps)
4187 sv_setpv((SV*)cv, ps);
4633a7c4 4188
3280af22 4189 if (PL_error_count) {
c07a80fd 4190 op_free(block);
4191 block = Nullop;
68dc0745 4192 if (name) {
4193 char *s = strrchr(name, ':');
4194 s = s ? s+1 : name;
6d4c2119
CS		 4195 if (strEQ(s, "BEGIN")) {
4196 char *not_safe =
4197 "BEGIN not safe after errors--compilation aborted";
faef0170 4198 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4199 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4200 else {
4201 /* force display of errors found but not reported */
38a03e6e 4202 sv_catpv(ERRSV, not_safe);
35c1215d 4203 Perl_croak(aTHX_ "%"SVf, ERRSV);
6d4c2119
CS		 4204 }
4205 }
68dc0745 4206 }
c07a80fd 4207 }
beab0874
JT		 4208 if (!block)
4209 goto done;
a0d0e21e 4210
7766f137 4211 if (CvLVALUE(cv)) {
78f9721b
SM		 4212 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4213 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4214 }
4215 else {
4216 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4217 }
4218 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4219 OpREFCNT_set(CvROOT(cv), 1);
4220 CvSTART(cv) = LINKLIST(CvROOT(cv));
4221 CvROOT(cv)->op_next = 0;
a2efc822 4222 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4223
4224 /* now that optimizer has done its work, adjust pad values */
54310121 4225
dd2155a4
DM		 4226 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4227
4228 if (CvCLONE(cv)) {
beab0874
JT		 4229 assert(!CvCONST(cv));
4230 if (ps && !*ps && op_const_sv(block, cv))
4231 CvCONST_on(cv);
a0d0e21e 4232 }
79072805 4233
83ee9e09 4234 if (name || aname) {
44a8e56a 4235 char *s;
83ee9e09 4236 char *tname = (name ? name : aname);
44a8e56a 4237
3280af22 4238 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 4239 SV *sv = NEWSV(0,0);
44a8e56a 4240 SV *tmpstr = sv_newmortal();
549bb64a 4241 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 4242 CV *pcv;
44a8e56a 4243 HV *hv;
4244
ed094faf
GS		 4245 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4246 CopFILE(PL_curcop),
cc49e20b 4247 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4248 gv_efullname3(tmpstr, gv, Nullch);
3280af22 4249 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4250 hv = GvHVn(db_postponed);
9607fc9c 4251 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 4252 && (pcv = GvCV(db_postponed)))
4253 {
44a8e56a 4254 dSP;
924508f0 4255 PUSHMARK(SP);
44a8e56a 4256 XPUSHs(tmpstr);
4257 PUTBACK;
83ee9e09 4258 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 4259 }
4260 }
79072805 4261
83ee9e09 4262 if ((s = strrchr(tname,':')))
28757baa 4263 s++;
4264 else
83ee9e09 4265 s = tname;
ed094faf 4266
7d30b5c4 4267 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4268 goto done;
4269
7678c486 4270 if (strEQ(s, "BEGIN") && !PL_error_count) {
3280af22 4271 I32 oldscope = PL_scopestack_ix;
28757baa 4272 ENTER;
57843af0
GS		 4273 SAVECOPFILE(&PL_compiling);
4274 SAVECOPLINE(&PL_compiling);
28757baa 4275
3280af22
NIS		 4276 if (!PL_beginav)
4277 PL_beginav = newAV();
28757baa 4278 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4279 av_push(PL_beginav, (SV*)cv);
4280 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4281 call_list(oldscope, PL_beginav);
a6006777 4282
3280af22 4283 PL_curcop = &PL_compiling;
eb160463 4284 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
28757baa 4285 LEAVE;
4286 }
3280af22
NIS		 4287 else if (strEQ(s, "END") && !PL_error_count) {
4288 if (!PL_endav)
4289 PL_endav = newAV();
ed094faf 4290 DEBUG_x( dump_sub(gv) );
3280af22 4291 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4292 av_store(PL_endav, 0, (SV*)cv);
4293 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4294 }
7d30b5c4
GS		 4295 else if (strEQ(s, "CHECK") && !PL_error_count) {
4296 if (!PL_checkav)
4297 PL_checkav = newAV();
ed094faf 4298 DEBUG_x( dump_sub(gv) );
ddda08b7 4299 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4300 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4301 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4302 av_store(PL_checkav, 0, (SV*)cv);
4303 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4304 }
3280af22
NIS		 4305 else if (strEQ(s, "INIT") && !PL_error_count) {
4306 if (!PL_initav)
4307 PL_initav = newAV();
ed094faf 4308 DEBUG_x( dump_sub(gv) );
ddda08b7 4309 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4310 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4311 av_push(PL_initav, (SV*)cv);
4312 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4313 }
79072805 4314 }
a6006777 4315
aa689395 4316 done:
3280af22 4317 PL_copline = NOLINE;
8990e307 4318 LEAVE_SCOPE(floor);
a0d0e21e 4319 return cv;
79072805
LW		 4320}
4321
b099ddc0 4322/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4323/*
4324=for apidoc newCONSTSUB
4325
4326Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4327eligible for inlining at compile-time.
4328
4329=cut
4330*/
4331
beab0874 4332CV *
864dbfa3 4333Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 4334{
beab0874 4335 CV* cv;
5476c433 4336
11faa288 4337 ENTER;
11faa288 4338
f4dd75d9 4339 SAVECOPLINE(PL_curcop);
11faa288 4340 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4341
4342 SAVEHINTS();
3280af22 4343 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4344
4345 if (stash) {
4346 SAVESPTR(PL_curstash);
4347 SAVECOPSTASH(PL_curcop);
4348 PL_curstash = stash;
05ec9bb3 4349 CopSTASH_set(PL_curcop,stash);
11faa288 4350 }
5476c433 4351
91a15d0d 4352 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
beab0874
JT		 4353 CvXSUBANY(cv).any_ptr = sv;
4354 CvCONST_on(cv);
4355 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 4356
02f28d44
MHM		 4357 if (stash)
4358 CopSTASH_free(PL_curcop);
4359
11faa288 4360 LEAVE;
beab0874
JT		 4361
4362 return cv;
5476c433
JD		 4363}
4364
954c1994
GS		 4365/*
4366=for apidoc U||newXS
4367
4368Used by C<xsubpp> to hook up XSUBs as Perl subs.
4369
4370=cut
4371*/
4372
57d3b86d 4373CV *
864dbfa3 4374Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 4375{
c99da370
JH		 4376 GV *gv = gv_fetchpv(name ? name :
4377 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4378 GV_ADDMULTI, SVt_PVCV);
79072805 4379 register CV *cv;
44a8e56a 4380
1ecdd9a8
HS		 4381 if (!subaddr)
4382 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4383
155aba94 4384 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4385 if (GvCVGEN(gv)) {
4386 /* just a cached method */
4387 SvREFCNT_dec(cv);
4388 cv = 0;
4389 }
4390 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4391 /* already defined (or promised) */
599cee73 4392 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4 4393 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 4394 line_t oldline = CopLINE(PL_curcop);
51f6edd3 4395 if (PL_copline != NOLINE)
57843af0 4396 CopLINE_set(PL_curcop, PL_copline);
9014280d 4397 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4398 CvCONST(cv) ? "Constant subroutine %s redefined"
4399 : "Subroutine %s redefined"
4400 ,name);
57843af0 4401 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 4402 }
4403 SvREFCNT_dec(cv);
4404 cv = 0;
79072805 4405 }
79072805 4406 }
44a8e56a 4407
4408 if (cv) /* must reuse cv if autoloaded */
4409 cv_undef(cv);
a0d0e21e
LW		 4410 else {
4411 cv = (CV*)NEWSV(1105,0);
4412 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 4413 if (name) {
4414 GvCV(gv) = cv;
4415 GvCVGEN(gv) = 0;
3280af22 4416 PL_sub_generation++;
44a8e56a 4417 }
a0d0e21e 4418 }
65c50114 4419 CvGV(cv) = gv;
b195d487 4420 (void)gv_fetchfile(filename);
57843af0
GS		 4421 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4422 an external constant string */
a0d0e21e 4423 CvXSUB(cv) = subaddr;
44a8e56a 4424
28757baa 4425 if (name) {
4426 char *s = strrchr(name,':');
4427 if (s)
4428 s++;
4429 else
4430 s = name;
ed094faf 4431
7d30b5c4 4432 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4433 goto done;
4434
28757baa 4435 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 4436 if (!PL_beginav)
4437 PL_beginav = newAV();
ea2f84a3
GS		 4438 av_push(PL_beginav, (SV*)cv);
4439 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4440 }
4441 else if (strEQ(s, "END")) {
3280af22
NIS		 4442 if (!PL_endav)
4443 PL_endav = newAV();
4444 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4445 av_store(PL_endav, 0, (SV*)cv);
4446 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4447 }
7d30b5c4
GS		 4448 else if (strEQ(s, "CHECK")) {
4449 if (!PL_checkav)
4450 PL_checkav = newAV();
ddda08b7 4451 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4452 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4453 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4454 av_store(PL_checkav, 0, (SV*)cv);
4455 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4456 }
7d07dbc2 4457 else if (strEQ(s, "INIT")) {
3280af22
NIS		 4458 if (!PL_initav)
4459 PL_initav = newAV();
ddda08b7 4460 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4461 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4462 av_push(PL_initav, (SV*)cv);
4463 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4464 }
28757baa 4465 }
8990e307 4466 else
a5f75d66 4467 CvANON_on(cv);
44a8e56a 4468
ed094faf 4469done:
a0d0e21e 4470 return cv;
79072805
LW		 4471}
4472
4473void
864dbfa3 4474Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 4475{
4476 register CV *cv;
4477 char *name;
4478 GV *gv;
2d8e6c8d 4479 STRLEN n_a;
79072805 4480
11343788 4481 if (o)
2d8e6c8d 4482 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 4483 else
4484 name = "STDOUT";
85e6fe83 4485 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
7fb37951
AMS		 4486#ifdef GV_UNIQUE_CHECK
4487 if (GvUNIQUE(gv)) {
4488 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 4489 }
4490#endif
a5f75d66 4491 GvMULTI_on(gv);
155aba94 4492 if ((cv = GvFORM(gv))) {
599cee73 4493 if (ckWARN(WARN_REDEFINE)) {
57843af0 4494 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4495 if (PL_copline != NOLINE)
4496 CopLINE_set(PL_curcop, PL_copline);
9014280d 4497 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
57843af0 4498 CopLINE_set(PL_curcop, oldline);
79072805 4499 }
8990e307 4500 SvREFCNT_dec(cv);
79072805 4501 }
3280af22 4502 cv = PL_compcv;
79072805 4503 GvFORM(gv) = cv;
65c50114 4504 CvGV(cv) = gv;
a636914a 4505 CvFILE_set_from_cop(cv, PL_curcop);
79072805 4506
a0d0e21e 4507
dd2155a4 4508 pad_tidy(padtidy_FORMAT);
79072805 4509 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 4510 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4511 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 4512 CvSTART(cv) = LINKLIST(CvROOT(cv));
4513 CvROOT(cv)->op_next = 0;
a2efc822 4514 CALL_PEEP(CvSTART(cv));
11343788 4515 op_free(o);
3280af22 4516 PL_copline = NOLINE;
8990e307 4517 LEAVE_SCOPE(floor);
79072805
LW		 4518}
4519
4520OP *
864dbfa3 4521Perl_newANONLIST(pTHX_ OP *o)
79072805 4522{
93a17b20 4523 return newUNOP(OP_REFGEN, 0,
11343788 4524 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 4525}
4526
4527OP *
864dbfa3 4528Perl_newANONHASH(pTHX_ OP *o)
79072805 4529{
93a17b20 4530 return newUNOP(OP_REFGEN, 0,
11343788 4531 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 4532}
4533
4534OP *
864dbfa3 4535Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 4536{
09bef843
SB		 4537 return newANONATTRSUB(floor, proto, Nullop, block);
4538}
4539
4540OP *
4541Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4542{
a0d0e21e 4543 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 4544 newSVOP(OP_ANONCODE, 0,
4545 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 4546}
4547
4548OP *
864dbfa3 4549Perl_oopsAV(pTHX_ OP *o)
79072805 4550{
ed6116ce
LW		 4551 switch (o->op_type) {
4552 case OP_PADSV:
4553 o->op_type = OP_PADAV;
22c35a8c 4554 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 4555 return ref(o, OP_RV2AV);
b2ffa427 4556
ed6116ce 4557 case OP_RV2SV:
79072805 4558 o->op_type = OP_RV2AV;
22c35a8c 4559 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 4560 ref(o, OP_RV2AV);
ed6116ce
LW		 4561 break;
4562
4563 default:
0453d815 4564 if (ckWARN_d(WARN_INTERNAL))
9014280d 4565 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 4566 break;
4567 }
79072805
LW		 4568 return o;
4569}
4570
4571OP *
864dbfa3 4572Perl_oopsHV(pTHX_ OP *o)
79072805 4573{
ed6116ce
LW		 4574 switch (o->op_type) {
4575 case OP_PADSV:
4576 case OP_PADAV:
4577 o->op_type = OP_PADHV;
22c35a8c 4578 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 4579 return ref(o, OP_RV2HV);
ed6116ce
LW		 4580
4581 case OP_RV2SV:
4582 case OP_RV2AV:
79072805 4583 o->op_type = OP_RV2HV;
22c35a8c 4584 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 4585 ref(o, OP_RV2HV);
ed6116ce
LW		 4586 break;
4587
4588 default:
0453d815 4589 if (ckWARN_d(WARN_INTERNAL))
9014280d 4590 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 4591 break;
4592 }
79072805
LW		 4593 return o;
4594}
4595
4596OP *
864dbfa3 4597Perl_newAVREF(pTHX_ OP *o)
79072805 4598{
ed6116ce
LW		 4599 if (o->op_type == OP_PADANY) {
4600 o->op_type = OP_PADAV;
22c35a8c 4601 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 4602 return o;
ed6116ce 4603 }
a1063b2d 4604 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 4605 && ckWARN(WARN_DEPRECATED)) {
4606 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4607 "Using an array as a reference is deprecated");
4608 }
79072805
LW		 4609 return newUNOP(OP_RV2AV, 0, scalar(o));
4610}
4611
4612OP *
864dbfa3 4613Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 4614{
82092f1d 4615 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 4616 return newUNOP(OP_NULL, 0, o);
748a9306 4617 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 4618}
4619
4620OP *
864dbfa3 4621Perl_newHVREF(pTHX_ OP *o)
79072805 4622{
ed6116ce
LW		 4623 if (o->op_type == OP_PADANY) {
4624 o->op_type = OP_PADHV;
22c35a8c 4625 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 4626 return o;
ed6116ce 4627 }
a1063b2d 4628 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 4629 && ckWARN(WARN_DEPRECATED)) {
4630 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4631 "Using a hash as a reference is deprecated");
4632 }
79072805
LW		 4633 return newUNOP(OP_RV2HV, 0, scalar(o));
4634}
4635
4636OP *
864dbfa3 4637Perl_oopsCV(pTHX_ OP *o)
79072805 4638{
cea2e8a9 4639 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 4640 /* STUB */
4641 return o;
4642}
4643
4644OP *
864dbfa3 4645Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 4646{
c07a80fd 4647 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 4648}
4649
4650OP *
864dbfa3 4651Perl_newSVREF(pTHX_ OP *o)
79072805 4652{
ed6116ce
LW		 4653 if (o->op_type == OP_PADANY) {
4654 o->op_type = OP_PADSV;
22c35a8c 4655 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 4656 return o;
ed6116ce 4657 }
224a4551
MB		 4658 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4659 o->op_flags |= OPpDONE_SVREF;
a863c7d1 4660 return o;
224a4551 4661 }
79072805
LW		 4662 return newUNOP(OP_RV2SV, 0, scalar(o));
4663}
4664
4665/* Check routines. */
4666
4667OP *
cea2e8a9 4668Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 4669{
dd2155a4 4670 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5dc0d613 4671 cSVOPo->op_sv = Nullsv;
5dc0d613 4672 return o;
5f05dabc 4673}
4674
4675OP *
cea2e8a9 4676Perl_ck_bitop(pTHX_ OP *o)
55497cff 4677{
276b2a0c
RGS		 4678#define OP_IS_NUMCOMPARE(op) \
4679 ((op) == OP_LT || (op) == OP_I_LT || \
4680 (op) == OP_GT || (op) == OP_I_GT || \
4681 (op) == OP_LE || (op) == OP_I_LE || \
4682 (op) == OP_GE || (op) == OP_I_GE || \
4683 (op) == OP_EQ || (op) == OP_I_EQ || \
4684 (op) == OP_NE || (op) == OP_I_NE || \
4685 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 4686 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2b84528b
RGS		 4687 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4688 && (o->op_type == OP_BIT_OR
4689 || o->op_type == OP_BIT_AND
4690 || o->op_type == OP_BIT_XOR))
276b2a0c 4691 {
96a925ab
YST		 4692 OP * left = cBINOPo->op_first;
4693 OP * right = left->op_sibling;
4694 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4695 (left->op_flags & OPf_PARENS) == 0) ||
4696 (OP_IS_NUMCOMPARE(right->op_type) &&
4697 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 4698 if (ckWARN(WARN_PRECEDENCE))
4699 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4700 "Possible precedence problem on bitwise %c operator",
4701 o->op_type == OP_BIT_OR ? '|'
4702 : o->op_type == OP_BIT_AND ? '&' : '^'
4703 );
4704 }
5dc0d613 4705 return o;
55497cff 4706}
4707
4708OP *
cea2e8a9 4709Perl_ck_concat(pTHX_ OP *o)
79072805 4710{
0165acc7
AE		 4711 OP *kid = cUNOPo->op_first;
4712 if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
4713 o->op_flags |= OPf_STACKED;
11343788 4714 return o;
79072805
LW		 4715}
4716
4717OP *
cea2e8a9 4718Perl_ck_spair(pTHX_ OP *o)
79072805 4719{
11343788 4720 if (o->op_flags & OPf_KIDS) {
79072805 4721 OP* newop;
a0d0e21e 4722 OP* kid;
5dc0d613
MB		 4723 OPCODE type = o->op_type;
4724 o = modkids(ck_fun(o), type);
11343788 4725 kid = cUNOPo->op_first;
a0d0e21e
LW		 4726 newop = kUNOP->op_first->op_sibling;
4727 if (newop &&
4728 (newop->op_sibling ||
22c35a8c 4729 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 4730 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4731 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 4732
11343788 4733 return o;
a0d0e21e
LW		 4734 }
4735 op_free(kUNOP->op_first);
4736 kUNOP->op_first = newop;
4737 }
22c35a8c 4738 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 4739 return ck_fun(o);
a0d0e21e
LW		 4740}
4741
4742OP *
cea2e8a9 4743Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 4744{
11343788 4745 o = ck_fun(o);
5dc0d613 4746 o->op_private = 0;
11343788
MB		 4747 if (o->op_flags & OPf_KIDS) {
4748 OP *kid = cUNOPo->op_first;
01020589
GS		 4749 switch (kid->op_type) {
4750 case OP_ASLICE:
4751 o->op_flags |= OPf_SPECIAL;
4752 /* FALL THROUGH */
4753 case OP_HSLICE:
5dc0d613 4754 o->op_private |= OPpSLICE;
01020589
GS		 4755 break;
4756 case OP_AELEM:
4757 o->op_flags |= OPf_SPECIAL;
4758 /* FALL THROUGH */
4759 case OP_HELEM:
4760 break;
4761 default:
4762 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 4763 OP_DESC(o));
01020589 4764 }
93c66552 4765 op_null(kid);
79072805 4766 }
11343788 4767 return o;
79072805
LW		 4768}
4769
4770OP *
96e176bf
CL		 4771Perl_ck_die(pTHX_ OP *o)
4772{
4773#ifdef VMS
4774 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4775#endif
4776 return ck_fun(o);
4777}
4778
4779OP *
cea2e8a9 4780Perl_ck_eof(pTHX_ OP *o)
79072805 4781{
11343788 4782 I32 type = o->op_type;
79072805 4783
11343788
MB		 4784 if (o->op_flags & OPf_KIDS) {
4785 if (cLISTOPo->op_first->op_type == OP_STUB) {
4786 op_free(o);
8fde6460 4787 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8990e307 4788 }
11343788 4789 return ck_fun(o);
79072805 4790 }
11343788 4791 return o;
79072805
LW		 4792}
4793
4794OP *
cea2e8a9 4795Perl_ck_eval(pTHX_ OP *o)
79072805 4796{
3280af22 4797 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 4798 if (o->op_flags & OPf_KIDS) {
4799 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 4800
93a17b20 4801 if (!kid) {
11343788 4802 o->op_flags &= ~OPf_KIDS;
93c66552 4803 op_null(o);
79072805 4804 }
b14574b4 4805 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 4806 LOGOP *enter;
4807
11343788
MB		 4808 cUNOPo->op_first = 0;
4809 op_free(o);
79072805 4810
b7dc083c 4811 NewOp(1101, enter, 1, LOGOP);
79072805 4812 enter->op_type = OP_ENTERTRY;
22c35a8c 4813 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 4814 enter->op_private = 0;
4815
4816 /* establish postfix order */
4817 enter->op_next = (OP*)enter;
4818
11343788
MB		 4819 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4820 o->op_type = OP_LEAVETRY;
22c35a8c 4821 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 4822 enter->op_other = o;
4823 return o;
79072805 4824 }
b5c19bd7 4825 else {
473986ff 4826 scalar((OP*)kid);
b5c19bd7
DM		 4827 PL_cv_has_eval = 1;
4828 }
79072805
LW		 4829 }
4830 else {
11343788 4831 op_free(o);
54b9620d 4832 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 4833 }
3280af22 4834 o->op_targ = (PADOFFSET)PL_hints;
11343788 4835 return o;
79072805
LW		 4836}
4837
4838OP *
d98f61e7
GS		 4839Perl_ck_exit(pTHX_ OP *o)
4840{
4841#ifdef VMS
4842 HV *table = GvHV(PL_hintgv);
4843 if (table) {
4844 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4845 if (svp && *svp && SvTRUE(*svp))
4846 o->op_private |= OPpEXIT_VMSISH;
4847 }
96e176bf 4848 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 4849#endif
4850 return ck_fun(o);
4851}
4852
4853OP *
cea2e8a9 4854Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 4855{
4856 OP *kid;
11343788
MB		 4857 if (o->op_flags & OPf_STACKED) {
4858 o = ck_fun(o);
4859 kid = cUNOPo->op_first->op_sibling;
8990e307 4860 if (kid->op_type == OP_RV2GV)
93c66552 4861 op_null(kid);
79072805 4862 }
463ee0b2 4863 else
11343788
MB		 4864 o = listkids(o);
4865 return o;
79072805
LW		 4866}
4867
4868OP *
cea2e8a9 4869Perl_ck_exists(pTHX_ OP *o)
5f05dabc 4870{
5196be3e
MB		 4871 o = ck_fun(o);
4872 if (o->op_flags & OPf_KIDS) {
4873 OP *kid = cUNOPo->op_first;
afebc493
GS		 4874 if (kid->op_type == OP_ENTERSUB) {
4875 (void) ref(kid, o->op_type);
4876 if (kid->op_type != OP_RV2CV && !PL_error_count)
4877 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 4878 OP_DESC(o));
afebc493
GS		 4879 o->op_private |= OPpEXISTS_SUB;
4880 }
4881 else if (kid->op_type == OP_AELEM)
01020589
GS		 4882 o->op_flags |= OPf_SPECIAL;
4883 else if (kid->op_type != OP_HELEM)
4884 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 4885 OP_DESC(o));
93c66552 4886 op_null(kid);
5f05dabc 4887 }
5196be3e 4888 return o;
5f05dabc 4889}
4890
22c35a8c 4891#if 0
5f05dabc 4892OP *
cea2e8a9 4893Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 4894{
4895 o = fold_constants(o);
4896 if (o->op_type == OP_CONST)
4897 o->op_type = OP_GV;
4898 return o;
4899}
22c35a8c 4900#endif
79072805
LW		 4901
4902OP *
cea2e8a9 4903Perl_ck_rvconst(pTHX_ register OP *o)
79072805 4904{
11343788 4905 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 4906
3280af22 4907 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 4908 if (kid->op_type == OP_CONST) {
44a8e56a 4909 char *name;
4910 int iscv;
4911 GV *gv;
779c5bc9 4912 SV *kidsv = kid->op_sv;
2d8e6c8d 4913 STRLEN n_a;
44a8e56a 4914
779c5bc9
GS		 4915 /* Is it a constant from cv_const_sv()? */
4916 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4917 SV *rsv = SvRV(kidsv);
4918 int svtype = SvTYPE(rsv);
4919 char *badtype = Nullch;
4920
4921 switch (o->op_type) {
4922 case OP_RV2SV:
4923 if (svtype > SVt_PVMG)
4924 badtype = "a SCALAR";
4925 break;
4926 case OP_RV2AV:
4927 if (svtype != SVt_PVAV)
4928 badtype = "an ARRAY";
4929 break;
4930 case OP_RV2HV:
6d822dc4 4931 if (svtype != SVt_PVHV)
779c5bc9 4932 badtype = "a HASH";
779c5bc9
GS		 4933 break;
4934 case OP_RV2CV:
4935 if (svtype != SVt_PVCV)
4936 badtype = "a CODE";
4937 break;
4938 }
4939 if (badtype)
cea2e8a9 4940 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 4941 return o;
4942 }
2d8e6c8d 4943 name = SvPV(kidsv, n_a);
3280af22 4944 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 4945 char *badthing = Nullch;
5dc0d613 4946 switch (o->op_type) {
44a8e56a 4947 case OP_RV2SV:
4948 badthing = "a SCALAR";
4949 break;
4950 case OP_RV2AV:
4951 badthing = "an ARRAY";
4952 break;
4953 case OP_RV2HV:
4954 badthing = "a HASH";
4955 break;
4956 }
4957 if (badthing)
1c846c1f 4958 Perl_croak(aTHX_
44a8e56a 4959 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4960 name, badthing);
4961 }
93233ece
CS		 4962 /*
4963 * This is a little tricky. We only want to add the symbol if we
4964 * didn't add it in the lexer. Otherwise we get duplicate strict
4965 * warnings. But if we didn't add it in the lexer, we must at
4966 * least pretend like we wanted to add it even if it existed before,
4967 * or we get possible typo warnings. OPpCONST_ENTERED says
4968 * whether the lexer already added THIS instance of this symbol.
4969 */
5196be3e 4970 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 4971 do {
44a8e56a 4972 gv = gv_fetchpv(name,
748a9306 4973 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 4974 iscv
4975 ? SVt_PVCV
11343788 4976 : o->op_type == OP_RV2SV
a0d0e21e 4977 ? SVt_PV
11343788 4978 : o->op_type == OP_RV2AV
a0d0e21e 4979 ? SVt_PVAV
11343788 4980 : o->op_type == OP_RV2HV
a0d0e21e
LW		 4981 ? SVt_PVHV
4982 : SVt_PVGV);
93233ece
CS		 4983 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4984 if (gv) {
4985 kid->op_type = OP_GV;
4986 SvREFCNT_dec(kid->op_sv);
350de78d 4987#ifdef USE_ITHREADS
638eceb6 4988 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 4989 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 4990 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 4991 GvIN_PAD_on(gv);
dd2155a4 4992 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
350de78d 4993#else
93233ece 4994 kid->op_sv = SvREFCNT_inc(gv);
350de78d 4995#endif
23f1ca44 4996 kid->op_private = 0;
76cd736e 4997 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 4998 }
79072805 4999 }
11343788 5000 return o;
79072805
LW		 5001}
5002
5003OP *
cea2e8a9 5004Perl_ck_ftst(pTHX_ OP *o)
79072805 5005{
11343788 5006 I32 type = o->op_type;
79072805 5007
d0dca557
JD		 5008 if (o->op_flags & OPf_REF) {
5009 /* nothing */
5010 }
5011 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5012 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5013
5014 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5015 STRLEN n_a;
a0d0e21e 5016 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5017 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5018 op_free(o);
d0dca557 5019 o = newop;
79072805 5020 }
1af34c76
JH		 5021 else {
5022 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5023 OP_IS_FILETEST_ACCESS(o))
5024 o->op_private |= OPpFT_ACCESS;
5025 }
79072805
LW		 5026 }
5027 else {
11343788 5028 op_free(o);
79072805 5029 if (type == OP_FTTTY)
8fde6460 5030 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5031 else
d0dca557 5032 o = newUNOP(type, 0, newDEFSVOP());
79072805 5033 }
11343788 5034 return o;
79072805
LW		 5035}
5036
5037OP *
cea2e8a9 5038Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5039{
5040 register OP *kid;
5041 OP **tokid;
5042 OP *sibl;
5043 I32 numargs = 0;
11343788 5044 int type = o->op_type;
22c35a8c 5045 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5046
11343788 5047 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5048 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5049 oa &= ~OA_OPTIONAL;
5050 else
11343788 5051 return no_fh_allowed(o);
79072805
LW		 5052 }
5053
11343788 5054 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5055 STRLEN n_a;
11343788
MB		 5056 tokid = &cLISTOPo->op_first;
5057 kid = cLISTOPo->op_first;
8990e307 5058 if (kid->op_type == OP_PUSHMARK ||
155aba94 5059 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5060 {
79072805
LW		 5061 tokid = &kid->op_sibling;
5062 kid = kid->op_sibling;
5063 }
22c35a8c 5064 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5065 *tokid = kid = newDEFSVOP();
79072805
LW		 5066
5067 while (oa && kid) {
5068 numargs++;
5069 sibl = kid->op_sibling;
5070 switch (oa & 7) {
5071 case OA_SCALAR:
62c18ce2
GS		 5072 /* list seen where single (scalar) arg expected? */
5073 if (numargs == 1 && !(oa >> 4)
5074 && kid->op_type == OP_LIST && type != OP_SCALAR)
5075 {
5076 return too_many_arguments(o,PL_op_desc[type]);
5077 }
79072805
LW		 5078 scalar(kid);
5079 break;
5080 case OA_LIST:
5081 if (oa < 16) {
5082 kid = 0;
5083 continue;
5084 }
5085 else
5086 list(kid);
5087 break;
5088 case OA_AVREF:
936edb8b 5089 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5090 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5091 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5092 "Useless use of %s with no values",
936edb8b 5093 PL_op_desc[type]);
b2ffa427 5094
79072805 5095 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5096 (kid->op_private & OPpCONST_BARE))
5097 {
2d8e6c8d 5098 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5099 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5100 gv_fetchpv(name, TRUE, SVt_PVAV) ));
12bcd1a6
PM		 5101 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5102 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5103 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5104 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5105 op_free(kid);
5106 kid = newop;
5107 kid->op_sibling = sibl;
5108 *tokid = kid;
5109 }
8990e307 5110 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5111 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5112 mod(kid, type);
79072805
LW		 5113 break;
5114 case OA_HVREF:
5115 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5116 (kid->op_private & OPpCONST_BARE))
5117 {
2d8e6c8d 5118 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5119 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5120 gv_fetchpv(name, TRUE, SVt_PVHV) ));
12bcd1a6
PM		 5121 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5122 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5123 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5124 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5125 op_free(kid);
5126 kid = newop;
5127 kid->op_sibling = sibl;
5128 *tokid = kid;
5129 }
8990e307 5130 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5131 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5132 mod(kid, type);
79072805
LW		 5133 break;
5134 case OA_CVREF:
5135 {
a0d0e21e 5136 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5137 kid->op_sibling = 0;
5138 linklist(kid);
5139 newop->op_next = newop;
5140 kid = newop;
5141 kid->op_sibling = sibl;
5142 *tokid = kid;
5143 }
5144 break;
5145 case OA_FILEREF:
c340be78 5146 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5147 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5148 (kid->op_private & OPpCONST_BARE))
5149 {
79072805 5150 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5151 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5152 SVt_PVIO) );
afbdacea 5153 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5154 kid == cLISTOPo->op_last)
364daeac 5155 cLISTOPo->op_last = newop;
79072805
LW		 5156 op_free(kid);
5157 kid = newop;
5158 }
1ea32a52
GS		 5159 else if (kid->op_type == OP_READLINE) {
5160 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5161 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5162 }
79072805 5163 else {
35cd451c 5164 I32 flags = OPf_SPECIAL;
a6c40364 5165 I32 priv = 0;
2c8ac474
GS		 5166 PADOFFSET targ = 0;
5167
35cd451c 5168 /* is this op a FH constructor? */
853846ea 5169 if (is_handle_constructor(o,numargs)) {
2c8ac474 5170 char *name = Nullch;
dd2155a4 5171 STRLEN len = 0;
2c8ac474
GS		 5172
5173 flags = 0;
5174 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5175 * need to "prove" flag does not mean something
5176 * else already - NI-S 1999/05/07
2c8ac474
GS		 5177 */
5178 priv = OPpDEREF;
5179 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 5180 name = PAD_COMPNAME_PV(kid->op_targ);
5181 /* SvCUR of a pad namesv can't be trusted
5182 * (see PL_generation), so calc its length
5183 * manually */
5184 if (name)
5185 len = strlen(name);
5186
2c8ac474
GS		 5187 }
5188 else if (kid->op_type == OP_RV2SV
5189 && kUNOP->op_first->op_type == OP_GV)
5190 {
5191 GV *gv = cGVOPx_gv(kUNOP->op_first);
5192 name = GvNAME(gv);
5193 len = GvNAMELEN(gv);
5194 }
afd1915d
GS		 5195 else if (kid->op_type == OP_AELEM
5196 || kid->op_type == OP_HELEM)
5197 {
0c4b0a3f
JH		 5198 OP *op;
5199
5200 name = 0;
5201 if ((op = ((BINOP*)kid)->op_first)) {
5202 SV *tmpstr = Nullsv;
5203 char *a =
5204 kid->op_type == OP_AELEM ?
5205 "[]" : "{}";
5206 if (((op->op_type == OP_RV2AV) ||
5207 (op->op_type == OP_RV2HV)) &&
5208 (op = ((UNOP*)op)->op_first) &&
5209 (op->op_type == OP_GV)) {
5210 /* packagevar $a[] or $h{} */
5211 GV *gv = cGVOPx_gv(op);
5212 if (gv)
5213 tmpstr =
5214 Perl_newSVpvf(aTHX_
5215 "%s%c...%c",
5216 GvNAME(gv),
5217 a[0], a[1]);
5218 }
5219 else if (op->op_type == OP_PADAV
5220 || op->op_type == OP_PADHV) {
5221 /* lexicalvar $a[] or $h{} */
5222 char *padname =
5223 PAD_COMPNAME_PV(op->op_targ);
5224 if (padname)
5225 tmpstr =
5226 Perl_newSVpvf(aTHX_
5227 "%s%c...%c",
5228 padname + 1,
5229 a[0], a[1]);
5230
5231 }
5232 if (tmpstr) {
5233 name = savepv(SvPVX(tmpstr));
5234 len = strlen(name);
5235 sv_2mortal(tmpstr);
5236 }
5237 }
5238 if (!name) {
5239 name = "__ANONIO__";
5240 len = 10;
5241 }
5242 mod(kid, type);
afd1915d 5243 }
2c8ac474
GS		 5244 if (name) {
5245 SV *namesv;
5246 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 5247 namesv = PAD_SVl(targ);
155aba94 5248 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5249 if (*name != '$')
5250 sv_setpvn(namesv, "$", 1);
5251 sv_catpvn(namesv, name, len);
5252 }
853846ea 5253 }
79072805 5254 kid->op_sibling = 0;
35cd451c 5255 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5256 kid->op_targ = targ;
5257 kid->op_private |= priv;
79072805
LW		 5258 }
5259 kid->op_sibling = sibl;
5260 *tokid = kid;
5261 }
5262 scalar(kid);
5263 break;
5264 case OA_SCALARREF:
a0d0e21e 5265 mod(scalar(kid), type);
79072805
LW		 5266 break;
5267 }
5268 oa >>= 4;
5269 tokid = &kid->op_sibling;
5270 kid = kid->op_sibling;
5271 }
11343788 5272 o->op_private |= numargs;
79072805 5273 if (kid)
53e06cf0 5274 return too_many_arguments(o,OP_DESC(o));
11343788 5275 listkids(o);
79072805 5276 }
22c35a8c 5277 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5278 op_free(o);
54b9620d 5279 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5280 }
5281
79072805
LW		 5282 if (oa) {
5283 while (oa & OA_OPTIONAL)
5284 oa >>= 4;
5285 if (oa && oa != OA_LIST)
53e06cf0 5286 return too_few_arguments(o,OP_DESC(o));
79072805 5287 }
11343788 5288 return o;
79072805
LW		 5289}
5290
5291OP *
cea2e8a9 5292Perl_ck_glob(pTHX_ OP *o)
79072805 5293{
fb73857a 5294 GV *gv;
5295
649da076 5296 o = ck_fun(o);
1f2bfc8a 5297 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5298 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5299
b9f751c0
GS		 5300 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5301 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5302 {
fb73857a 5303 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b9f751c0 5304 }
b1cb66bf 5305
52bb0670 5306#if !defined(PERL_EXTERNAL_GLOB)
72b16652 5307 /* XXX this can be tightened up and made more failsafe. */
f444d496 5308 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 5309 GV *glob_gv;
72b16652 5310 ENTER;
00ca71c1
NIS		 5311 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5312 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
72b16652 5313 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5314 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5315 GvCV(gv) = GvCV(glob_gv);
445266f0 5316 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5317 GvIMPORTED_CV_on(gv);
72b16652
GS		 5318 LEAVE;
5319 }
52bb0670 5320#endif /* PERL_EXTERNAL_GLOB */
72b16652 5321
b9f751c0 5322 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5323 append_elem(OP_GLOB, o,
80252599 5324 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5325 o->op_type = OP_LIST;
22c35a8c 5326 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5327 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5328 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
1f2bfc8a 5329 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5330 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5331 scalar(newUNOP(OP_RV2CV, 0,
5332 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5333 o = newUNOP(OP_NULL, 0, ck_subr(o));
5334 o->op_targ = OP_GLOB; /* hint at what it used to be */
5335 return o;
b1cb66bf 5336 }
5337 gv = newGVgen("main");
a0d0e21e 5338 gv_IOadd(gv);
11343788
MB		 5339 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5340 scalarkids(o);
649da076 5341 return o;
79072805
LW		 5342}
5343
5344OP *
cea2e8a9 5345Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 5346{
5347 LOGOP *gwop;
5348 OP *kid;
11343788 5349 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 5350
22c35a8c 5351 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5352 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5353
11343788 5354 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5355 OP* k;
11343788
MB		 5356 o = ck_sort(o);
5357 kid = cLISTOPo->op_first->op_sibling;
5358 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 5359 kid = k;
5360 }
5361 kid->op_next = (OP*)gwop;
11343788 5362 o->op_flags &= ~OPf_STACKED;
93a17b20 5363 }
11343788 5364 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5365 if (type == OP_MAPWHILE)
5366 list(kid);
5367 else
5368 scalar(kid);
11343788 5369 o = ck_fun(o);
3280af22 5370 if (PL_error_count)
11343788 5371 return o;
aeea060c 5372 kid = cLISTOPo->op_first->op_sibling;
79072805 5373 if (kid->op_type != OP_NULL)
cea2e8a9 5374 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5375 kid = kUNOP->op_first;
5376
a0d0e21e 5377 gwop->op_type = type;
22c35a8c 5378 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5379 gwop->op_first = listkids(o);
79072805
LW		 5380 gwop->op_flags |= OPf_KIDS;
5381 gwop->op_private = 1;
5382 gwop->op_other = LINKLIST(kid);
a0d0e21e 5383 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 5384 kid->op_next = (OP*)gwop;
5385
11343788 5386 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5387 if (!kid || !kid->op_sibling)
53e06cf0 5388 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5389 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5390 mod(kid, OP_GREPSTART);
5391
79072805
LW		 5392 return (OP*)gwop;
5393}
5394
5395OP *
cea2e8a9 5396Perl_ck_index(pTHX_ OP *o)
79072805 5397{
11343788
MB		 5398 if (o->op_flags & OPf_KIDS) {
5399 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5400 if (kid)
5401 kid = kid->op_sibling; /* get past "big" */
79072805 5402 if (kid && kid->op_type == OP_CONST)
2779dcf1 5403 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5404 }
11343788 5405 return ck_fun(o);
79072805
LW		 5406}
5407
5408OP *
cea2e8a9 5409Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5410{
5411 /* XXX length optimization goes here */
11343788 5412 return ck_fun(o);
79072805
LW		 5413}
5414
5415OP *
cea2e8a9 5416Perl_ck_lfun(pTHX_ OP *o)
79072805 5417{
5dc0d613
MB		 5418 OPCODE type = o->op_type;
5419 return modkids(ck_fun(o), type);
79072805
LW		 5420}
5421
5422OP *
cea2e8a9 5423Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5424{
12bcd1a6 5425 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5426 switch (cUNOPo->op_first->op_type) {
5427 case OP_RV2AV:
a8739d98
JH		 5428 /* This is needed for
5429 if (defined %stash::)
5430 to work. Do not break Tk.
5431 */
1c846c1f 5432 break; /* Globals via GV can be undef */
d0334bed
GS		 5433 case OP_PADAV:
5434 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5435 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5436 "defined(@array) is deprecated");
12bcd1a6 5437 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5438 "\t(Maybe you should just omit the defined()?)\n");
69794302 5439 break;
d0334bed 5440 case OP_RV2HV:
a8739d98
JH		 5441 /* This is needed for
5442 if (defined %stash::)
5443 to work. Do not break Tk.
5444 */
1c846c1f 5445 break; /* Globals via GV can be undef */
d0334bed 5446 case OP_PADHV:
12bcd1a6 5447 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5448 "defined(%%hash) is deprecated");
12bcd1a6 5449 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5450 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5451 break;
5452 default:
5453 /* no warning */
5454 break;
5455 }
69794302
MJD		 5456 }
5457 return ck_rfun(o);
5458}
5459
5460OP *
cea2e8a9 5461Perl_ck_rfun(pTHX_ OP *o)
8990e307 5462{
5dc0d613
MB		 5463 OPCODE type = o->op_type;
5464 return refkids(ck_fun(o), type);
8990e307
LW		 5465}
5466
5467OP *
cea2e8a9 5468Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5469{
5470 register OP *kid;
aeea060c 5471
11343788 5472 kid = cLISTOPo->op_first;
79072805 5473 if (!kid) {
11343788
MB		 5474 o = force_list(o);
5475 kid = cLISTOPo->op_first;
79072805
LW		 5476 }
5477 if (kid->op_type == OP_PUSHMARK)
5478 kid = kid->op_sibling;
11343788 5479 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 5480 kid = kid->op_sibling;
5481 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5482 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 5483 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 5484 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 5485 cLISTOPo->op_first->op_sibling = kid;
5486 cLISTOPo->op_last = kid;
79072805
LW		 5487 kid = kid->op_sibling;
5488 }
5489 }
b2ffa427 5490
79072805 5491 if (!kid)
54b9620d 5492 append_elem(o->op_type, o, newDEFSVOP());
79072805 5493
2de3dbcc 5494 return listkids(o);
bbce6d69 5495}
5496
5497OP *
b162f9ea
IZ		 5498Perl_ck_sassign(pTHX_ OP *o)
5499{
5500 OP *kid = cLISTOPo->op_first;
5501 /* has a disposable target? */
5502 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 5503 && !(kid->op_flags & OPf_STACKED)
5504 /* Cannot steal the second time! */
5505 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 5506 {
5507 OP *kkid = kid->op_sibling;
5508
5509 /* Can just relocate the target. */
2c2d71f5
JH		 5510 if (kkid && kkid->op_type == OP_PADSV
5511 && !(kkid->op_private & OPpLVAL_INTRO))
5512 {
b162f9ea 5513 kid->op_targ = kkid->op_targ;
743e66e6 5514 kkid->op_targ = 0;
b162f9ea
IZ		 5515 /* Now we do not need PADSV and SASSIGN. */
5516 kid->op_sibling = o->op_sibling; /* NULL */
5517 cLISTOPo->op_first = NULL;
5518 op_free(o);
5519 op_free(kkid);
5520 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5521 return kid;
5522 }
5523 }
5524 return o;
5525}
5526
5527OP *
cea2e8a9 5528Perl_ck_match(pTHX_ OP *o)
79072805 5529{
5dc0d613 5530 o->op_private |= OPpRUNTIME;
11343788 5531 return o;
79072805
LW		 5532}
5533
5534OP *
f5d5a27c
CS		 5535Perl_ck_method(pTHX_ OP *o)
5536{
5537 OP *kid = cUNOPo->op_first;
5538 if (kid->op_type == OP_CONST) {
5539 SV* sv = kSVOP->op_sv;
5540 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5541 OP *cmop;
1c846c1f
NIS		 5542 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5543 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5544 }
5545 else {
5546 kSVOP->op_sv = Nullsv;
5547 }
f5d5a27c 5548 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 5549 op_free(o);
5550 return cmop;
5551 }
5552 }
5553 return o;
5554}
5555
5556OP *
cea2e8a9 5557Perl_ck_null(pTHX_ OP *o)
79072805 5558{
11343788 5559 return o;
79072805
LW		 5560}
5561
5562OP *
16fe6d59
GS		 5563Perl_ck_open(pTHX_ OP *o)
5564{
5565 HV *table = GvHV(PL_hintgv);
5566 if (table) {
5567 SV **svp;
5568 I32 mode;
5569 svp = hv_fetch(table, "open_IN", 7, FALSE);
5570 if (svp && *svp) {
5571 mode = mode_from_discipline(*svp);
5572 if (mode & O_BINARY)
5573 o->op_private |= OPpOPEN_IN_RAW;
5574 else if (mode & O_TEXT)
5575 o->op_private |= OPpOPEN_IN_CRLF;
5576 }
5577
5578 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5579 if (svp && *svp) {
5580 mode = mode_from_discipline(*svp);
5581 if (mode & O_BINARY)
5582 o->op_private |= OPpOPEN_OUT_RAW;
5583 else if (mode & O_TEXT)
5584 o->op_private |= OPpOPEN_OUT_CRLF;
5585 }
5586 }
5587 if (o->op_type == OP_BACKTICK)
5588 return o;
3b82e551
JH		 5589 {
5590 /* In case of three-arg dup open remove strictness
5591 * from the last arg if it is a bareword. */
5592 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5593 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5594 OP *oa;
5595 char *mode;
5596
5597 if ((last->op_type == OP_CONST) && /* The bareword. */
5598 (last->op_private & OPpCONST_BARE) &&
5599 (last->op_private & OPpCONST_STRICT) &&
5600 (oa = first->op_sibling) && /* The fh. */
5601 (oa = oa->op_sibling) && /* The mode. */
5602 SvPOK(((SVOP*)oa)->op_sv) &&
5603 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5604 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5605 (last == oa->op_sibling)) /* The bareword. */
5606 last->op_private &= ~OPpCONST_STRICT;
5607 }
16fe6d59
GS		 5608 return ck_fun(o);
5609}
5610
5611OP *
cea2e8a9 5612Perl_ck_repeat(pTHX_ OP *o)
79072805 5613{
11343788
MB		 5614 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5615 o->op_private |= OPpREPEAT_DOLIST;
5616 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 5617 }
5618 else
11343788
MB		 5619 scalar(o);
5620 return o;
79072805
LW		 5621}
5622
5623OP *
cea2e8a9 5624Perl_ck_require(pTHX_ OP *o)
8990e307 5625{
ec4ab249
GA		 5626 GV* gv;
5627
11343788
MB		 5628 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5629 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 5630
5631 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 5632 char *s;
a0d0e21e
LW		 5633 for (s = SvPVX(kid->op_sv); *s; s++) {
5634 if (*s == ':' && s[1] == ':') {
5635 *s = '/';
1aef975c 5636 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 5637 --SvCUR(kid->op_sv);
5638 }
8990e307 5639 }
ce3b816e
GS		 5640 if (SvREADONLY(kid->op_sv)) {
5641 SvREADONLY_off(kid->op_sv);
5642 sv_catpvn(kid->op_sv, ".pm", 3);
5643 SvREADONLY_on(kid->op_sv);
5644 }
5645 else
5646 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 5647 }
5648 }
ec4ab249
GA		 5649
5650 /* handle override, if any */
5651 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
b9f751c0 5652 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
ec4ab249
GA		 5653 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5654
b9f751c0 5655 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
ec4ab249
GA		 5656 OP *kid = cUNOPo->op_first;
5657 cUNOPo->op_first = 0;
5658 op_free(o);
5659 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5660 append_elem(OP_LIST, kid,
5661 scalar(newUNOP(OP_RV2CV, 0,
5662 newGVOP(OP_GV, 0,
5663 gv))))));
5664 }
5665
11343788 5666 return ck_fun(o);
8990e307
LW		 5667}
5668
78f9721b
SM		 5669OP *
5670Perl_ck_return(pTHX_ OP *o)
5671{
5672 OP *kid;
5673 if (CvLVALUE(PL_compcv)) {
5674 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5675 mod(kid, OP_LEAVESUBLV);
5676 }
5677 return o;
5678}
5679
22c35a8c 5680#if 0
8990e307 5681OP *
cea2e8a9 5682Perl_ck_retarget(pTHX_ OP *o)
79072805 5683{
cea2e8a9 5684 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 5685 /* STUB */
11343788 5686 return o;
79072805 5687}
22c35a8c 5688#endif
79072805
LW		 5689
5690OP *
cea2e8a9 5691Perl_ck_select(pTHX_ OP *o)
79072805 5692{
c07a80fd 5693 OP* kid;
11343788
MB		 5694 if (o->op_flags & OPf_KIDS) {
5695 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 5696 if (kid && kid->op_sibling) {
11343788 5697 o->op_type = OP_SSELECT;
22c35a8c 5698 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 5699 o = ck_fun(o);
5700 return fold_constants(o);
79072805
LW		 5701 }
5702 }
11343788
MB		 5703 o = ck_fun(o);
5704 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 5705 if (kid && kid->op_type == OP_RV2GV)
5706 kid->op_private &= ~HINT_STRICT_REFS;
11343788 5707 return o;
79072805
LW		 5708}
5709
5710OP *
cea2e8a9 5711Perl_ck_shift(pTHX_ OP *o)
79072805 5712{
11343788 5713 I32 type = o->op_type;
79072805 5714
11343788 5715 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 5716 OP *argop;
b2ffa427 5717
11343788 5718 op_free(o);
6d4ff0d2 5719 argop = newUNOP(OP_RV2AV, 0,
8fde6460 5720 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6d4ff0d2 5721 return newUNOP(type, 0, scalar(argop));
79072805 5722 }
11343788 5723 return scalar(modkids(ck_fun(o), type));
79072805
LW		 5724}
5725
5726OP *
cea2e8a9 5727Perl_ck_sort(pTHX_ OP *o)
79072805 5728{
8e3f9bdf 5729 OP *firstkid;
bbce6d69 5730
9ea6e965 5731 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 5732 simplify_sort(o);
8e3f9bdf
GS		 5733 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5734 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 5735 OP *k = NULL;
8e3f9bdf 5736 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 5737
463ee0b2 5738 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 5739 linklist(kid);
463ee0b2
LW		 5740 if (kid->op_type == OP_SCOPE) {
5741 k = kid->op_next;
5742 kid->op_next = 0;
79072805 5743 }
463ee0b2 5744 else if (kid->op_type == OP_LEAVE) {
11343788 5745 if (o->op_type == OP_SORT) {
93c66552 5746 op_null(kid); /* wipe out leave */
748a9306 5747 kid->op_next = kid;
463ee0b2 5748
748a9306
LW		 5749 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5750 if (k->op_next == kid)
5751 k->op_next = 0;
71a29c3c
GS		 5752 /* don't descend into loops */
5753 else if (k->op_type == OP_ENTERLOOP
5754 || k->op_type == OP_ENTERITER)
5755 {
5756 k = cLOOPx(k)->op_lastop;
5757 }
748a9306 5758 }
463ee0b2 5759 }
748a9306
LW		 5760 else
5761 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 5762 k = kLISTOP->op_first;
463ee0b2 5763 }
a2efc822 5764 CALL_PEEP(k);
a0d0e21e 5765
8e3f9bdf
GS		 5766 kid = firstkid;
5767 if (o->op_type == OP_SORT) {
5768 /* provide scalar context for comparison function/block */
5769 kid = scalar(kid);
a0d0e21e 5770 kid->op_next = kid;
8e3f9bdf 5771 }
a0d0e21e
LW		 5772 else
5773 kid->op_next = k;
11343788 5774 o->op_flags |= OPf_SPECIAL;
79072805 5775 }
c6e96bcb 5776 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 5777 op_null(firstkid);
8e3f9bdf
GS		 5778
5779 firstkid = firstkid->op_sibling;
79072805 5780 }
bbce6d69 5781
8e3f9bdf
GS		 5782 /* provide list context for arguments */
5783 if (o->op_type == OP_SORT)
5784 list(firstkid);
5785
11343788 5786 return o;
79072805 5787}
bda4119b
GS		 5788
5789STATIC void
cea2e8a9 5790S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 5791{
5792 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5793 OP *k;
5794 int reversed;
350de78d 5795 GV *gv;
9c007264
JH		 5796 if (!(o->op_flags & OPf_STACKED))
5797 return;
1c846c1f
NIS		 5798 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5799 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 5800 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 5801 if (kid->op_type != OP_SCOPE)
5802 return;
5803 kid = kLISTOP->op_last; /* get past scope */
5804 switch(kid->op_type) {
5805 case OP_NCMP:
5806 case OP_I_NCMP:
5807 case OP_SCMP:
5808 break;
5809 default:
5810 return;
5811 }
5812 k = kid; /* remember this node*/
5813 if (kBINOP->op_first->op_type != OP_RV2SV)
5814 return;
5815 kid = kBINOP->op_first; /* get past cmp */
5816 if (kUNOP->op_first->op_type != OP_GV)
5817 return;
5818 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5819 gv = kGVOP_gv;
350de78d 5820 if (GvSTASH(gv) != PL_curstash)
9c007264 5821 return;
350de78d 5822 if (strEQ(GvNAME(gv), "a"))
9c007264 5823 reversed = 0;
0f79a09d 5824 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 5825 reversed = 1;
5826 else
5827 return;
5828 kid = k; /* back to cmp */
5829 if (kBINOP->op_last->op_type != OP_RV2SV)
5830 return;
5831 kid = kBINOP->op_last; /* down to 2nd arg */
5832 if (kUNOP->op_first->op_type != OP_GV)
5833 return;
5834 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5835 gv = kGVOP_gv;
350de78d 5836 if (GvSTASH(gv) != PL_curstash
9c007264 5837 || ( reversed
350de78d
GS		 5838 ? strNE(GvNAME(gv), "a")
5839 : strNE(GvNAME(gv), "b")))
9c007264
JH		 5840 return;
5841 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5842 if (reversed)
5843 o->op_private |= OPpSORT_REVERSE;
5844 if (k->op_type == OP_NCMP)
5845 o->op_private |= OPpSORT_NUMERIC;
5846 if (k->op_type == OP_I_NCMP)
5847 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 5848 kid = cLISTOPo->op_first->op_sibling;
5849 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5850 op_free(kid); /* then delete it */
9c007264 5851}
79072805
LW		 5852
5853OP *
cea2e8a9 5854Perl_ck_split(pTHX_ OP *o)
79072805
LW		 5855{
5856 register OP *kid;
aeea060c 5857
11343788
MB		 5858 if (o->op_flags & OPf_STACKED)
5859 return no_fh_allowed(o);
79072805 5860
11343788 5861 kid = cLISTOPo->op_first;
8990e307 5862 if (kid->op_type != OP_NULL)
cea2e8a9 5863 Perl_croak(aTHX_ "panic: ck_split");
8990e307 5864 kid = kid->op_sibling;
11343788
MB		 5865 op_free(cLISTOPo->op_first);
5866 cLISTOPo->op_first = kid;
85e6fe83 5867 if (!kid) {
79cb57f6 5868 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 5869 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 5870 }
79072805 5871
de4bf5b3 5872 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 5873 OP *sibl = kid->op_sibling;
463ee0b2 5874 kid->op_sibling = 0;
79072805 5875 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 5876 if (cLISTOPo->op_first == cLISTOPo->op_last)
5877 cLISTOPo->op_last = kid;
5878 cLISTOPo->op_first = kid;
79072805
LW		 5879 kid->op_sibling = sibl;
5880 }
5881
5882 kid->op_type = OP_PUSHRE;
22c35a8c 5883 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 5884 scalar(kid);
f34840d8
MJD		 5885 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5886 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5887 "Use of /g modifier is meaningless in split");
5888 }
79072805
LW		 5889
5890 if (!kid->op_sibling)
54b9620d 5891 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 5892
5893 kid = kid->op_sibling;
5894 scalar(kid);
5895
5896 if (!kid->op_sibling)
11343788 5897 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 5898
5899 kid = kid->op_sibling;
5900 scalar(kid);
5901
5902 if (kid->op_sibling)
53e06cf0 5903 return too_many_arguments(o,OP_DESC(o));
79072805 5904
11343788 5905 return o;
79072805
LW		 5906}
5907
5908OP *
1c846c1f 5909Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 5910{
5911 if (ckWARN(WARN_SYNTAX)) {
5912 OP *kid = cLISTOPo->op_first->op_sibling;
5913 if (kid && kid->op_type == OP_MATCH) {
5914 char *pmstr = "STRING";
aaa362c4
RS		 5915 if (PM_GETRE(kPMOP))
5916 pmstr = PM_GETRE(kPMOP)->precomp;
9014280d 5917 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 5918 "/%s/ should probably be written as \"%s\"",
5919 pmstr, pmstr);
5920 }
5921 }
5922 return ck_fun(o);
5923}
5924
5925OP *
cea2e8a9 5926Perl_ck_subr(pTHX_ OP *o)
79072805 5927{
11343788
MB		 5928 OP *prev = ((cUNOPo->op_first->op_sibling)
5929 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5930 OP *o2 = prev->op_sibling;
4633a7c4
LW		 5931 OP *cvop;
5932 char *proto = 0;
5933 CV *cv = 0;
46fc3d4c 5934 GV *namegv = 0;
4633a7c4
LW		 5935 int optional = 0;
5936 I32 arg = 0;
5b794e05 5937 I32 contextclass = 0;
90b7f708 5938 char *e = 0;
2d8e6c8d 5939 STRLEN n_a;
06492da6 5940 bool delete=0;
4633a7c4 5941
d3011074 5942 o->op_private |= OPpENTERSUB_HASTARG;
11343788 5943 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 5944 if (cvop->op_type == OP_RV2CV) {
5945 SVOP* tmpop;
11343788 5946 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 5947 op_null(cvop); /* disable rv2cv */
4633a7c4 5948 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 5949 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 5950 GV *gv = cGVOPx_gv(tmpop);
350de78d 5951 cv = GvCVu(gv);
76cd736e
GS		 5952 if (!cv)
5953 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 5954 else {
5955 if (SvPOK(cv)) {
5956 namegv = CvANON(cv) ? gv : CvGV(cv);
5957 proto = SvPV((SV*)cv, n_a);
5958 }
5959 if (CvASSERTION(cv)) {
5960 if (PL_hints & HINT_ASSERTING) {
5961 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5962 o->op_private |= OPpENTERSUB_DB;
5963 }
8fa7688f
SF		 5964 else {
5965 delete=1;
5966 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5967 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5968 "Impossible to activate assertion call");
5969 }
5970 }
06492da6 5971 }
46fc3d4c 5972 }
4633a7c4
LW		 5973 }
5974 }
f5d5a27c 5975 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 5976 if (o2->op_type == OP_CONST)
5977 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 5978 else if (o2->op_type == OP_LIST) {
5979 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5980 if (o && o->op_type == OP_CONST)
5981 o->op_private &= ~OPpCONST_STRICT;
5982 }
7a52d87a 5983 }
3280af22
NIS		 5984 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5985 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 5986 o->op_private |= OPpENTERSUB_DB;
5987 while (o2 != cvop) {
4633a7c4
LW		 5988 if (proto) {
5989 switch (*proto) {
5990 case '\0':
5dc0d613 5991 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 5992 case ';':
5993 optional = 1;
5994 proto++;
5995 continue;
5996 case '$':
5997 proto++;
5998 arg++;
11343788 5999 scalar(o2);
4633a7c4
LW		 6000 break;
6001 case '%':
6002 case '@':
11343788 6003 list(o2);
4633a7c4
LW		 6004 arg++;
6005 break;
6006 case '&':
6007 proto++;
6008 arg++;
11343788 6009 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6010 bad_type(arg,
6011 arg == 1 ? "block or sub {}" : "sub {}",
6012 gv_ename(namegv), o2);
4633a7c4
LW		 6013 break;
6014 case '*':
2ba6ecf4 6015 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6016 proto++;
6017 arg++;
11343788 6018 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6019 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6020 else if (o2->op_type == OP_CONST)
6021 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6022 else if (o2->op_type == OP_ENTERSUB) {
6023 /* accidental subroutine, revert to bareword */
6024 OP *gvop = ((UNOP*)o2)->op_first;
6025 if (gvop && gvop->op_type == OP_NULL) {
6026 gvop = ((UNOP*)gvop)->op_first;
6027 if (gvop) {
6028 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6029 ;
6030 if (gvop &&
6031 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6032 (gvop = ((UNOP*)gvop)->op_first) &&
6033 gvop->op_type == OP_GV)
6034 {
638eceb6 6035 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6036 OP *sibling = o2->op_sibling;
2692f720 6037 SV *n = newSVpvn("",0);
9675f7ac 6038 op_free(o2);
2692f720
GS		 6039 gv_fullname3(n, gv, "");
6040 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6041 sv_chop(n, SvPVX(n)+6);
6042 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6043 prev->op_sibling = o2;
6044 o2->op_sibling = sibling;
6045 }
6046 }
6047 }
6048 }
2ba6ecf4
GS		 6049 scalar(o2);
6050 break;
5b794e05
JH		 6051 case '[': case ']':
6052 goto oops;
6053 break;
4633a7c4
LW		 6054 case '\\':
6055 proto++;
6056 arg++;
5b794e05 6057 again:
4633a7c4 6058 switch (*proto++) {
5b794e05
JH		 6059 case '[':
6060 if (contextclass++ == 0) {
841d93c8 6061 e = strchr(proto, ']');
5b794e05
JH		 6062 if (!e || e == proto)
6063 goto oops;
6064 }
6065 else
6066 goto oops;
6067 goto again;
6068 break;
6069 case ']':
466bafcd
RGS		 6070 if (contextclass) {
6071 char *p = proto;
6072 char s = *p;
6073 contextclass = 0;
6074 *p = '\0';
6075 while (*--p != '[');
1eb1540c 6076 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6077 gv_ename(namegv), o2);
6078 *proto = s;
6079 } else
5b794e05
JH		 6080 goto oops;
6081 break;
4633a7c4 6082 case '*':
5b794e05
JH		 6083 if (o2->op_type == OP_RV2GV)
6084 goto wrapref;
6085 if (!contextclass)
6086 bad_type(arg, "symbol", gv_ename(namegv), o2);
6087 break;
4633a7c4 6088 case '&':
5b794e05
JH		 6089 if (o2->op_type == OP_ENTERSUB)
6090 goto wrapref;
6091 if (!contextclass)
6092 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6093 break;
4633a7c4 6094 case '$':
5b794e05
JH		 6095 if (o2->op_type == OP_RV2SV ||
6096 o2->op_type == OP_PADSV ||
6097 o2->op_type == OP_HELEM ||
6098 o2->op_type == OP_AELEM ||
6099 o2->op_type == OP_THREADSV)
6100 goto wrapref;
6101 if (!contextclass)
5dc0d613 6102 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6103 break;
4633a7c4 6104 case '@':
5b794e05
JH		 6105 if (o2->op_type == OP_RV2AV ||
6106 o2->op_type == OP_PADAV)
6107 goto wrapref;
6108 if (!contextclass)
5dc0d613 6109 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6110 break;
4633a7c4 6111 case '%':
5b794e05
JH		 6112 if (o2->op_type == OP_RV2HV ||
6113 o2->op_type == OP_PADHV)
6114 goto wrapref;
6115 if (!contextclass)
6116 bad_type(arg, "hash", gv_ename(namegv), o2);
6117 break;
6118 wrapref:
4633a7c4 6119 {
11343788 6120 OP* kid = o2;
6fa846a0 6121 OP* sib = kid->op_sibling;
4633a7c4 6122 kid->op_sibling = 0;
6fa846a0
GS		 6123 o2 = newUNOP(OP_REFGEN, 0, kid);
6124 o2->op_sibling = sib;
e858de61 6125 prev->op_sibling = o2;
4633a7c4 6126 }
841d93c8 6127 if (contextclass && e) {
5b794e05
JH		 6128 proto = e + 1;
6129 contextclass = 0;
6130 }
4633a7c4
LW		 6131 break;
6132 default: goto oops;
6133 }
5b794e05
JH		 6134 if (contextclass)
6135 goto again;
4633a7c4 6136 break;
b1cb66bf 6137 case ' ':
6138 proto++;
6139 continue;
4633a7c4
LW		 6140 default:
6141 oops:
35c1215d
NC		 6142 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6143 gv_ename(namegv), cv);
4633a7c4
LW		 6144 }
6145 }
6146 else
11343788
MB		 6147 list(o2);
6148 mod(o2, OP_ENTERSUB);
6149 prev = o2;
6150 o2 = o2->op_sibling;
4633a7c4 6151 }
fb73857a 6152 if (proto && !optional &&
6153 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6154 return too_few_arguments(o, gv_ename(namegv));
06492da6
SF		 6155 if(delete) {
6156 op_free(o);
6157 o=newSVOP(OP_CONST, 0, newSViv(0));
6158 }
11343788 6159 return o;
79072805
LW		 6160}
6161
6162OP *
cea2e8a9 6163Perl_ck_svconst(pTHX_ OP *o)
8990e307 6164{
11343788
MB		 6165 SvREADONLY_on(cSVOPo->op_sv);
6166 return o;
8990e307
LW		 6167}
6168
6169OP *
cea2e8a9 6170Perl_ck_trunc(pTHX_ OP *o)
79072805 6171{
11343788
MB		 6172 if (o->op_flags & OPf_KIDS) {
6173 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6174
a0d0e21e
LW		 6175 if (kid->op_type == OP_NULL)
6176 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6177 if (kid && kid->op_type == OP_CONST &&
6178 (kid->op_private & OPpCONST_BARE))
6179 {
11343788 6180 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6181 kid->op_private &= ~OPpCONST_STRICT;
6182 }
79072805 6183 }
11343788 6184 return ck_fun(o);
79072805
LW		 6185}
6186
35fba0d9
RG		 6187OP *
6188Perl_ck_substr(pTHX_ OP *o)
6189{
6190 o = ck_fun(o);
6191 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6192 OP *kid = cLISTOPo->op_first;
6193
6194 if (kid->op_type == OP_NULL)
6195 kid = kid->op_sibling;
6196 if (kid)
6197 kid->op_flags |= OPf_MOD;
6198
6199 }
6200 return o;
6201}
6202
463ee0b2
LW		 6203/* A peephole optimizer. We visit the ops in the order they're to execute. */
6204
79072805 6205void
864dbfa3 6206Perl_peep(pTHX_ register OP *o)
79072805
LW		 6207{
6208 register OP* oldop = 0;
2d8e6c8d 6209
a0d0e21e 6210 if (!o || o->op_seq)
79072805 6211 return;
a0d0e21e 6212 ENTER;
462e5cf6 6213 SAVEOP();
7766f137 6214 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6215 for (; o; o = o->op_next) {
6216 if (o->op_seq)
6217 break;
cfa2c302
PJ		 6218 /* The special value -1 is used by the B::C compiler backend to indicate
6219 * that an op is statically defined and should not be freed */
6220 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6221 PL_op_seqmax = 1;
533c011a 6222 PL_op = o;
a0d0e21e 6223 switch (o->op_type) {
acb36ea4 6224 case OP_SETSTATE:
a0d0e21e
LW		 6225 case OP_NEXTSTATE:
6226 case OP_DBSTATE:
3280af22
NIS		 6227 PL_curcop = ((COP*)o); /* for warnings */
6228 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6229 break;
6230
a0d0e21e 6231 case OP_CONST:
7a52d87a
GS		 6232 if (cSVOPo->op_private & OPpCONST_STRICT)
6233 no_bareword_allowed(o);
7766f137 6234#ifdef USE_ITHREADS
3848b962 6235 case OP_METHOD_NAMED:
7766f137
GS		 6236 /* Relocate sv to the pad for thread safety.
6237 * Despite being a "constant", the SV is written to,
6238 * for reference counts, sv_upgrade() etc. */
6239 if (cSVOP->op_sv) {
6240 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 6241 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6242 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6243 * some pad, so make a copy. */
dd2155a4
DM		 6244 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6245 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6246 SvREFCNT_dec(cSVOPo->op_sv);
6247 }
6248 else {
dd2155a4 6249 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6250 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 6251 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6252 /* XXX I don't know how this isn't readonly already. */
dd2155a4 6253 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6254 }
7766f137
GS		 6255 cSVOPo->op_sv = Nullsv;
6256 o->op_targ = ix;
6257 }
6258#endif
07447971
GS		 6259 o->op_seq = PL_op_seqmax++;
6260 break;
6261
ed7ab888 6262 case OP_CONCAT:
b162f9ea
IZ		 6263 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6264 if (o->op_next->op_private & OPpTARGET_MY) {
69b47968 6265 if (o->op_flags & OPf_STACKED) /* chained concats */
b162f9ea 6266 goto ignore_optimization;
cd06dffe 6267 else {
07447971 6268 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
b162f9ea 6269 o->op_targ = o->op_next->op_targ;
743e66e6 6270 o->op_next->op_targ = 0;
2c2d71f5 6271 o->op_private |= OPpTARGET_MY;
b162f9ea
IZ		 6272 }
6273 }
93c66552 6274 op_null(o->op_next);
b162f9ea
IZ		 6275 }
6276 ignore_optimization:
3280af22 6277 o->op_seq = PL_op_seqmax++;
a0d0e21e 6278 break;
8990e307 6279 case OP_STUB:
838efab4
NC		 6280 /* XXX This makes sub {}; work as expected.
6281 ie {return;} not {return @_;}
6282 When optimiser is properly split into fixups and
6283 optimisations, this needs to stay in the fixups. */
2d981f27
AB		 6284 if(!oldop &&
6285 o->op_next &&
6286 o->op_next->op_type == OP_LEAVESUB) {
6287 OP* newop = newSTATEOP(0, Nullch, 0);
6288 newop->op_next = o->op_next;
6289 o->op_next = 0;
6290 op_free(o);
6291 o = newop;
6292 ((UNOP*)o->op_next)->op_first = newop;
6293 CvSTART(PL_compcv) = newop;
6294 }
54310121 6295 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 6296 o->op_seq = PL_op_seqmax++;
54310121 6297 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6298 }
748a9306 6299 goto nothin;
79072805 6300 case OP_NULL:
acb36ea4
GS		 6301 if (o->op_targ == OP_NEXTSTATE
6302 || o->op_targ == OP_DBSTATE
6303 || o->op_targ == OP_SETSTATE)
6304 {
3280af22 6305 PL_curcop = ((COP*)o);
acb36ea4 6306 }
dad75012
AMS		 6307 /* XXX: We avoid setting op_seq here to prevent later calls
6308 to peep() from mistakenly concluding that optimisation
6309 has already occurred. This doesn't fix the real problem,
6310 though (See 20010220.007). AMS 20010719 */
6311 if (oldop && o->op_next) {
6312 oldop->op_next = o->op_next;
6313 continue;
6314 }
6315 break;
79072805 6316 case OP_SCALAR:
93a17b20 6317 case OP_LINESEQ:
463ee0b2 6318 case OP_SCOPE:
748a9306 6319 nothin:
a0d0e21e
LW		 6320 if (oldop && o->op_next) {
6321 oldop->op_next = o->op_next;
79072805
LW		 6322 continue;
6323 }
3280af22 6324 o->op_seq = PL_op_seqmax++;
79072805
LW		 6325 break;
6326
6327 case OP_GV:
a0d0e21e 6328 if (o->op_next->op_type == OP_RV2SV) {
64aac5a9 6329 if (!(o->op_next->op_private & OPpDEREF)) {
93c66552 6330 op_null(o->op_next);
64aac5a9
GS		 6331 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6332 | OPpOUR_INTRO);
a0d0e21e
LW		 6333 o->op_next = o->op_next->op_next;
6334 o->op_type = OP_GVSV;
22c35a8c 6335 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307
LW		 6336 }
6337 }
a0d0e21e
LW		 6338 else if (o->op_next->op_type == OP_RV2AV) {
6339 OP* pop = o->op_next->op_next;
6340 IV i;
f9dc862f 6341 if (pop && pop->op_type == OP_CONST &&
533c011a 6342 (PL_op = pop->op_next) &&
8990e307 6343 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6344 !(pop->op_next->op_private &
78f9721b 6345 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6346 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6347 <= 255 &&
8990e307
LW		 6348 i >= 0)
6349 {
350de78d 6350 GV *gv;
93c66552
DM		 6351 op_null(o->op_next);
6352 op_null(pop->op_next);
6353 op_null(pop);
a0d0e21e
LW		 6354 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6355 o->op_next = pop->op_next->op_next;
6356 o->op_type = OP_AELEMFAST;
22c35a8c 6357 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6358 o->op_private = (U8)i;
638eceb6 6359 gv = cGVOPo_gv;
350de78d 6360 GvAVn(gv);
8990e307 6361 }
79072805 6362 }
e476b1b5 6363 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 6364 GV *gv = cGVOPo_gv;
76cd736e
GS		 6365 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6366 /* XXX could check prototype here instead of just carping */
6367 SV *sv = sv_newmortal();
6368 gv_efullname3(sv, gv, Nullch);
9014280d 6369 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d
NC		 6370 "%"SVf"() called too early to check prototype",
6371 sv);
76cd736e
GS		 6372 }
6373 }
89de2904
AMS		 6374 else if (o->op_next->op_type == OP_READLINE
6375 && o->op_next->op_next->op_type == OP_CONCAT
6376 && (o->op_next->op_next->op_flags & OPf_STACKED))
6377 {
d2c45030
AMS		 6378 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6379 o->op_type = OP_RCATLINE;
6380 o->op_flags |= OPf_STACKED;
6381 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6382 op_null(o->op_next->op_next);
d2c45030 6383 op_null(o->op_next);
89de2904 6384 }
76cd736e 6385
3280af22 6386 o->op_seq = PL_op_seqmax++;
79072805
LW		 6387 break;
6388
a0d0e21e 6389 case OP_MAPWHILE:
79072805
LW		 6390 case OP_GREPWHILE:
6391 case OP_AND:
6392 case OP_OR:
c963b151 6393 case OP_DOR:
2c2d71f5
JH		 6394 case OP_ANDASSIGN:
6395 case OP_ORASSIGN:
c963b151 6396 case OP_DORASSIGN:
1a67a97c
SM		 6397 case OP_COND_EXPR:
6398 case OP_RANGE:
3280af22 6399 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 6400 while (cLOGOP->op_other->op_type == OP_NULL)
6401 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 6402 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 6403 break;
6404
79072805 6405 case OP_ENTERLOOP:
9c2ca71a 6406 case OP_ENTERITER:
3280af22 6407 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 6408 while (cLOOP->op_redoop->op_type == OP_NULL)
6409 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6410 peep(cLOOP->op_redoop);
58cccf98
SM		 6411 while (cLOOP->op_nextop->op_type == OP_NULL)
6412 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6413 peep(cLOOP->op_nextop);
58cccf98
SM		 6414 while (cLOOP->op_lastop->op_type == OP_NULL)
6415 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6416 peep(cLOOP->op_lastop);
6417 break;
6418
8782bef2 6419 case OP_QR:
79072805
LW		 6420 case OP_MATCH:
6421 case OP_SUBST:
3280af22 6422 o->op_seq = PL_op_seqmax++;
9041c2e3 6423 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6424 cPMOP->op_pmreplstart->op_type == OP_NULL)
6425 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6426 peep(cPMOP->op_pmreplstart);
79072805
LW		 6427 break;
6428
a0d0e21e 6429 case OP_EXEC:
3280af22 6430 o->op_seq = PL_op_seqmax++;
1c846c1f 6431 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 6432 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 6433 if (o->op_next->op_sibling &&
20408e3c
GS		 6434 o->op_next->op_sibling->op_type != OP_EXIT &&
6435 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6436 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 6437 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 6438
57843af0 6439 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 6440 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 6441 "Statement unlikely to be reached");
9014280d 6442 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 6443 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 6444 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 6445 }
6446 }
6447 break;
b2ffa427 6448
c750a3ec 6449 case OP_HELEM: {
6d822dc4
MS		 6450 SV *lexname;
6451 SV **svp, *sv;
1c846c1f 6452 char *key = NULL;
c750a3ec 6453 STRLEN keylen;
b2ffa427 6454
9615e741 6455 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 6456
6457 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6458 break;
1c846c1f
NIS		 6459
6460 /* Make the CONST have a shared SV */
6461 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6462 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 6463 key = SvPV(sv, keylen);
25716404
GS		 6464 lexname = newSVpvn_share(key,
6465 SvUTF8(sv) ? -(I32)keylen : keylen,
6466 0);
1c846c1f
NIS		 6467 SvREFCNT_dec(sv);
6468 *svp = lexname;
6469 }
6d822dc4
MS		 6470 break;
6471 }
c750a3ec 6472
79072805 6473 default:
3280af22 6474 o->op_seq = PL_op_seqmax++;
79072805
LW		 6475 break;
6476 }
a0d0e21e 6477 oldop = o;
79072805 6478 }
a0d0e21e 6479 LEAVE;
79072805 6480}
beab0874 6481
19e8ce8e
AB		 6482
6483
6484char* Perl_custom_op_name(pTHX_ OP* o)
53e06cf0
SC		 6485{
6486 IV index = PTR2IV(o->op_ppaddr);
6487 SV* keysv;
6488 HE* he;
6489
6490 if (!PL_custom_op_names) /* This probably shouldn't happen */
6491 return PL_op_name[OP_CUSTOM];
6492
6493 keysv = sv_2mortal(newSViv(index));
6494
6495 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6496 if (!he)
6497 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6498
6499 return SvPV_nolen(HeVAL(he));
6500}
6501
19e8ce8e 6502char* Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0
SC		 6503{
6504 IV index = PTR2IV(o->op_ppaddr);
6505 SV* keysv;
6506 HE* he;
6507
6508 if (!PL_custom_op_descs)
6509 return PL_op_desc[OP_CUSTOM];
6510
6511 keysv = sv_2mortal(newSViv(index));
6512
6513 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6514 if (!he)
6515 return PL_op_desc[OP_CUSTOM];
6516
6517 return SvPV_nolen(HeVAL(he));
6518}
19e8ce8e 6519
53e06cf0 6520
beab0874
JT		 6521#include "XSUB.h"
6522
6523/* Efficient sub that returns a constant scalar value. */
6524static void
acfe0abc 6525const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 6526{
6527 dXSARGS;
9cbac4c7
DM		 6528 if (items != 0) {
6529#if 0
6530 Perl_croak(aTHX_ "usage: %s::%s()",
6531 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6532#endif
6533 }
9a049f1c 6534 EXTEND(sp, 1);
0768512c 6535 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 6536 XSRETURN(1);
6537}
Unnamed repository; edit this file 'description' to name the repository.