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