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
On Linux-PPC, using gcc, downgrade to the -O1 optimisation
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
b5f8cc5c 4 * 2000, 2001, 2002, 2003, 2004, 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
2814eb74 219 if (!o || o->op_static)
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:
6a077020
DM		 278 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
279 /* not an OP_PADAV replacement */
350de78d 280#ifdef USE_ITHREADS
6a077020
DM		 281 if (cPADOPo->op_padix > 0) {
282 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
283 * may still exist on the pad */
284 pad_swipe(cPADOPo->op_padix, TRUE);
285 cPADOPo->op_padix = 0;
286 }
350de78d 287#else
6a077020
DM		 288 SvREFCNT_dec(cSVOPo->op_sv);
289 cSVOPo->op_sv = Nullsv;
350de78d 290#endif
6a077020 291 }
79072805 292 break;
a1ae71d2 293 case OP_METHOD_NAMED:
79072805 294 case OP_CONST:
11343788 295 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 296 cSVOPo->op_sv = Nullsv;
3b1c21fa
AB		 297#ifdef USE_ITHREADS
298 /** Bug #15654
299 Even if op_clear does a pad_free for the target of the op,
6a077020 300 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 301 instead it lives on. This results in that it could be reused as
302 a target later on when the pad was reallocated.
303 **/
304 if(o->op_targ) {
305 pad_swipe(o->op_targ,1);
306 o->op_targ = 0;
307 }
308#endif
79072805 309 break;
748a9306
LW		 310 case OP_GOTO:
311 case OP_NEXT:
312 case OP_LAST:
313 case OP_REDO:
11343788 314 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 315 break;
316 /* FALL THROUGH */
a0d0e21e 317 case OP_TRANS:
acb36ea4 318 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 319 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS		 320 cSVOPo->op_sv = Nullsv;
321 }
322 else {
a0ed51b3 323 Safefree(cPVOPo->op_pv);
acb36ea4
GS		 324 cPVOPo->op_pv = Nullch;
325 }
a0d0e21e
LW		 326 break;
327 case OP_SUBST:
11343788 328 op_free(cPMOPo->op_pmreplroot);
971a9dd3 329 goto clear_pmop;
748a9306 330 case OP_PUSHRE:
971a9dd3 331#ifdef USE_ITHREADS
ba89bb6e 332 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
dd2155a4
DM		 333 /* No GvIN_PAD_off here, because other references may still
334 * exist on the pad */
335 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
971a9dd3
GS		 336 }
337#else
338 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
339#endif
340 /* FALL THROUGH */
a0d0e21e 341 case OP_MATCH:
8782bef2 342 case OP_QR:
971a9dd3 343clear_pmop:
cb55de95
JH		 344 {
345 HV *pmstash = PmopSTASH(cPMOPo);
346 if (pmstash && SvREFCNT(pmstash)) {
347 PMOP *pmop = HvPMROOT(pmstash);
348 PMOP *lastpmop = NULL;
349 while (pmop) {
350 if (cPMOPo == pmop) {
351 if (lastpmop)
352 lastpmop->op_pmnext = pmop->op_pmnext;
353 else
354 HvPMROOT(pmstash) = pmop->op_pmnext;
355 break;
356 }
357 lastpmop = pmop;
358 pmop = pmop->op_pmnext;
359 }
83da49e6 360 }
05ec9bb3 361 PmopSTASH_free(cPMOPo);
cb55de95 362 }
971a9dd3 363 cPMOPo->op_pmreplroot = Nullop;
5f8cb046
DM		 364 /* we use the "SAFE" version of the PM_ macros here
365 * since sv_clean_all might release some PMOPs
366 * after PL_regex_padav has been cleared
367 * and the clearing of PL_regex_padav needs to
368 * happen before sv_clean_all
369 */
370 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
371 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
13137afc
AB		 372#ifdef USE_ITHREADS
373 if(PL_regex_pad) { /* We could be in destruction */
374 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 375 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 376 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
377 }
1eb1540c 378#endif
13137afc 379
a0d0e21e 380 break;
79072805
LW		 381 }
382
743e66e6 383 if (o->op_targ > 0) {
11343788 384 pad_free(o->op_targ);
743e66e6
GS		 385 o->op_targ = 0;
386 }
79072805
LW		 387}
388
76e3520e 389STATIC void
3eb57f73
HS		 390S_cop_free(pTHX_ COP* cop)
391{
05ec9bb3
NIS		 392 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
393 CopFILE_free(cop);
394 CopSTASH_free(cop);
0453d815 395 if (! specialWARN(cop->cop_warnings))
3eb57f73 396 SvREFCNT_dec(cop->cop_warnings);
05ec9bb3
NIS		 397 if (! specialCopIO(cop->cop_io)) {
398#ifdef USE_ITHREADS
042f6df8 399#if 0
05ec9bb3
NIS		 400 STRLEN len;
401 char *s = SvPV(cop->cop_io,len);
b178108d
JH		 402 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
403#endif
05ec9bb3 404#else
ac27b0f5 405 SvREFCNT_dec(cop->cop_io);
05ec9bb3
NIS		 406#endif
407 }
3eb57f73
HS		 408}
409
93c66552
DM		 410void
411Perl_op_null(pTHX_ OP *o)
8990e307 412{
acb36ea4
GS		 413 if (o->op_type == OP_NULL)
414 return;
415 op_clear(o);
11343788
MB		 416 o->op_targ = o->op_type;
417 o->op_type = OP_NULL;
22c35a8c 418 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 419}
420
79072805
LW		 421/* Contextualizers */
422
463ee0b2 423#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 424
425OP *
864dbfa3 426Perl_linklist(pTHX_ OP *o)
79072805
LW		 427{
428 register OP *kid;
429
11343788
MB		 430 if (o->op_next)
431 return o->op_next;
79072805
LW		 432
433 /* establish postfix order */
11343788
MB		 434 if (cUNOPo->op_first) {
435 o->op_next = LINKLIST(cUNOPo->op_first);
436 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 437 if (kid->op_sibling)
438 kid->op_next = LINKLIST(kid->op_sibling);
439 else
11343788 440 kid->op_next = o;
79072805
LW		 441 }
442 }
443 else
11343788 444 o->op_next = o;
79072805 445
11343788 446 return o->op_next;
79072805
LW		 447}
448
449OP *
864dbfa3 450Perl_scalarkids(pTHX_ OP *o)
79072805
LW		 451{
452 OP *kid;
11343788
MB		 453 if (o && o->op_flags & OPf_KIDS) {
454 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 455 scalar(kid);
456 }
11343788 457 return o;
79072805
LW		 458}
459
76e3520e 460STATIC OP *
cea2e8a9 461S_scalarboolean(pTHX_ OP *o)
8990e307 462{
d008e5eb 463 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 464 if (ckWARN(WARN_SYNTAX)) {
57843af0 465 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 466
d008e5eb 467 if (PL_copline != NOLINE)
57843af0 468 CopLINE_set(PL_curcop, PL_copline);
9014280d 469 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 470 CopLINE_set(PL_curcop, oldline);
d008e5eb 471 }
a0d0e21e 472 }
11343788 473 return scalar(o);
8990e307
LW		 474}
475
476OP *
864dbfa3 477Perl_scalar(pTHX_ OP *o)
79072805
LW		 478{
479 OP *kid;
480
a0d0e21e 481 /* assumes no premature commitment */
3280af22 482 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 483 || o->op_type == OP_RETURN)
7e363e51 484 {
11343788 485 return o;
7e363e51 486 }
79072805 487
5dc0d613 488 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 489
11343788 490 switch (o->op_type) {
79072805 491 case OP_REPEAT:
11343788 492 scalar(cBINOPo->op_first);
8990e307 493 break;
79072805
LW		 494 case OP_OR:
495 case OP_AND:
496 case OP_COND_EXPR:
11343788 497 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 498 scalar(kid);
79072805 499 break;
a0d0e21e 500 case OP_SPLIT:
11343788 501 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 502 if (!kPMOP->op_pmreplroot)
12bcd1a6 503 deprecate_old("implicit split to @_");
a0d0e21e
LW		 504 }
505 /* FALL THROUGH */
79072805 506 case OP_MATCH:
8782bef2 507 case OP_QR:
79072805
LW		 508 case OP_SUBST:
509 case OP_NULL:
8990e307 510 default:
11343788
MB		 511 if (o->op_flags & OPf_KIDS) {
512 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 513 scalar(kid);
514 }
79072805
LW		 515 break;
516 case OP_LEAVE:
517 case OP_LEAVETRY:
5dc0d613 518 kid = cLISTOPo->op_first;
54310121 519 scalar(kid);
155aba94 520 while ((kid = kid->op_sibling)) {
54310121 521 if (kid->op_sibling)
522 scalarvoid(kid);
523 else
524 scalar(kid);
525 }
3280af22 526 WITH_THR(PL_curcop = &PL_compiling);
54310121 527 break;
748a9306 528 case OP_SCOPE:
79072805 529 case OP_LINESEQ:
8990e307 530 case OP_LIST:
11343788 531 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 532 if (kid->op_sibling)
533 scalarvoid(kid);
534 else
535 scalar(kid);
536 }
3280af22 537 WITH_THR(PL_curcop = &PL_compiling);
79072805 538 break;
a801c63c
RGS		 539 case OP_SORT:
540 if (ckWARN(WARN_VOID))
9014280d 541 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 542 }
11343788 543 return o;
79072805
LW		 544}
545
546OP *
864dbfa3 547Perl_scalarvoid(pTHX_ OP *o)
79072805
LW		 548{
549 OP *kid;
8990e307
LW		 550 char* useless = 0;
551 SV* sv;
2ebea0a1
GS		 552 U8 want;
553
acb36ea4
GS		 554 if (o->op_type == OP_NEXTSTATE
555 || o->op_type == OP_SETSTATE
556 || o->op_type == OP_DBSTATE
557 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
558 || o->op_targ == OP_SETSTATE
559 || o->op_targ == OP_DBSTATE)))
2ebea0a1 560 PL_curcop = (COP*)o; /* for warning below */
79072805 561
54310121 562 /* assumes no premature commitment */
2ebea0a1
GS		 563 want = o->op_flags & OPf_WANT;
564 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 565 || o->op_type == OP_RETURN)
7e363e51 566 {
11343788 567 return o;
7e363e51 568 }
79072805 569
b162f9ea 570 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 571 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
572 {
b162f9ea 573 return scalar(o); /* As if inside SASSIGN */
7e363e51 574 }
1c846c1f 575
5dc0d613 576 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 577
11343788 578 switch (o->op_type) {
79072805 579 default:
22c35a8c 580 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 581 break;
36477c24 582 /* FALL THROUGH */
583 case OP_REPEAT:
11343788 584 if (o->op_flags & OPf_STACKED)
8990e307 585 break;
5d82c453
GA		 586 goto func_ops;
587 case OP_SUBSTR:
588 if (o->op_private == 4)
589 break;
8990e307
LW		 590 /* FALL THROUGH */
591 case OP_GVSV:
592 case OP_WANTARRAY:
593 case OP_GV:
594 case OP_PADSV:
595 case OP_PADAV:
596 case OP_PADHV:
597 case OP_PADANY:
598 case OP_AV2ARYLEN:
8990e307 599 case OP_REF:
a0d0e21e
LW		 600 case OP_REFGEN:
601 case OP_SREFGEN:
8990e307
LW		 602 case OP_DEFINED:
603 case OP_HEX:
604 case OP_OCT:
605 case OP_LENGTH:
8990e307
LW		 606 case OP_VEC:
607 case OP_INDEX:
608 case OP_RINDEX:
609 case OP_SPRINTF:
610 case OP_AELEM:
611 case OP_AELEMFAST:
612 case OP_ASLICE:
8990e307
LW		 613 case OP_HELEM:
614 case OP_HSLICE:
615 case OP_UNPACK:
616 case OP_PACK:
8990e307
LW		 617 case OP_JOIN:
618 case OP_LSLICE:
619 case OP_ANONLIST:
620 case OP_ANONHASH:
621 case OP_SORT:
622 case OP_REVERSE:
623 case OP_RANGE:
624 case OP_FLIP:
625 case OP_FLOP:
626 case OP_CALLER:
627 case OP_FILENO:
628 case OP_EOF:
629 case OP_TELL:
630 case OP_GETSOCKNAME:
631 case OP_GETPEERNAME:
632 case OP_READLINK:
633 case OP_TELLDIR:
634 case OP_GETPPID:
635 case OP_GETPGRP:
636 case OP_GETPRIORITY:
637 case OP_TIME:
638 case OP_TMS:
639 case OP_LOCALTIME:
640 case OP_GMTIME:
641 case OP_GHBYNAME:
642 case OP_GHBYADDR:
643 case OP_GHOSTENT:
644 case OP_GNBYNAME:
645 case OP_GNBYADDR:
646 case OP_GNETENT:
647 case OP_GPBYNAME:
648 case OP_GPBYNUMBER:
649 case OP_GPROTOENT:
650 case OP_GSBYNAME:
651 case OP_GSBYPORT:
652 case OP_GSERVENT:
653 case OP_GPWNAM:
654 case OP_GPWUID:
655 case OP_GGRNAM:
656 case OP_GGRGID:
657 case OP_GETLOGIN:
78e1b766 658 case OP_PROTOTYPE:
5d82c453 659 func_ops:
64aac5a9 660 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 661 useless = OP_DESC(o);
8990e307
LW		 662 break;
663
664 case OP_RV2GV:
665 case OP_RV2SV:
666 case OP_RV2AV:
667 case OP_RV2HV:
192587c2 668 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 669 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 670 useless = "a variable";
671 break;
79072805
LW		 672
673 case OP_CONST:
7766f137 674 sv = cSVOPo_sv;
7a52d87a
GS		 675 if (cSVOPo->op_private & OPpCONST_STRICT)
676 no_bareword_allowed(o);
677 else {
d008e5eb
GS		 678 if (ckWARN(WARN_VOID)) {
679 useless = "a constant";
e7fec78e 680 /* don't warn on optimised away booleans, eg
b5a930ec 681 * use constant Foo, 5; Foo || print; */
e7fec78e
DM		 682 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
683 useless = 0;
960b4253
MG		 684 /* the constants 0 and 1 are permitted as they are
685 conventionally used as dummies in constructs like
686 1 while some_condition_with_side_effects; */
e7fec78e 687 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d008e5eb
GS		 688 useless = 0;
689 else if (SvPOK(sv)) {
a52fe3ac
A		 690 /* perl4's way of mixing documentation and code
691 (before the invention of POD) was based on a
692 trick to mix nroff and perl code. The trick was
693 built upon these three nroff macros being used in
694 void context. The pink camel has the details in
695 the script wrapman near page 319. */
d008e5eb
GS		 696 if (strnEQ(SvPVX(sv), "di", 2) ||
697 strnEQ(SvPVX(sv), "ds", 2) ||
698 strnEQ(SvPVX(sv), "ig", 2))
699 useless = 0;
700 }
8990e307
LW		 701 }
702 }
93c66552 703 op_null(o); /* don't execute or even remember it */
79072805
LW		 704 break;
705
706 case OP_POSTINC:
11343788 707 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 708 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 709 break;
710
711 case OP_POSTDEC:
11343788 712 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 713 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 714 break;
715
79072805
LW		 716 case OP_OR:
717 case OP_AND:
c963b151 718 case OP_DOR:
79072805 719 case OP_COND_EXPR:
11343788 720 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 721 scalarvoid(kid);
722 break;
5aabfad6 723
a0d0e21e 724 case OP_NULL:
11343788 725 if (o->op_flags & OPf_STACKED)
a0d0e21e 726 break;
5aabfad6 727 /* FALL THROUGH */
2ebea0a1
GS		 728 case OP_NEXTSTATE:
729 case OP_DBSTATE:
79072805
LW		 730 case OP_ENTERTRY:
731 case OP_ENTER:
11343788 732 if (!(o->op_flags & OPf_KIDS))
79072805 733 break;
54310121 734 /* FALL THROUGH */
463ee0b2 735 case OP_SCOPE:
79072805
LW		 736 case OP_LEAVE:
737 case OP_LEAVETRY:
a0d0e21e 738 case OP_LEAVELOOP:
79072805 739 case OP_LINESEQ:
79072805 740 case OP_LIST:
11343788 741 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 742 scalarvoid(kid);
743 break;
c90c0ff4 744 case OP_ENTEREVAL:
5196be3e 745 scalarkids(o);
c90c0ff4 746 break;
5aabfad6 747 case OP_REQUIRE:
c90c0ff4 748 /* all requires must return a boolean value */
5196be3e 749 o->op_flags &= ~OPf_WANT;
d6483035
GS		 750 /* FALL THROUGH */
751 case OP_SCALAR:
5196be3e 752 return scalar(o);
a0d0e21e 753 case OP_SPLIT:
11343788 754 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 755 if (!kPMOP->op_pmreplroot)
12bcd1a6 756 deprecate_old("implicit split to @_");
a0d0e21e
LW		 757 }
758 break;
79072805 759 }
411caa50 760 if (useless && ckWARN(WARN_VOID))
9014280d 761 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 762 return o;
79072805
LW		 763}
764
765OP *
864dbfa3 766Perl_listkids(pTHX_ OP *o)
79072805
LW		 767{
768 OP *kid;
11343788
MB		 769 if (o && o->op_flags & OPf_KIDS) {
770 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 771 list(kid);
772 }
11343788 773 return o;
79072805
LW		 774}
775
776OP *
864dbfa3 777Perl_list(pTHX_ OP *o)
79072805
LW		 778{
779 OP *kid;
780
a0d0e21e 781 /* assumes no premature commitment */
3280af22 782 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 783 || o->op_type == OP_RETURN)
7e363e51 784 {
11343788 785 return o;
7e363e51 786 }
79072805 787
b162f9ea 788 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 789 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
790 {
b162f9ea 791 return o; /* As if inside SASSIGN */
7e363e51 792 }
1c846c1f 793
5dc0d613 794 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 795
11343788 796 switch (o->op_type) {
79072805
LW		 797 case OP_FLOP:
798 case OP_REPEAT:
11343788 799 list(cBINOPo->op_first);
79072805
LW		 800 break;
801 case OP_OR:
802 case OP_AND:
803 case OP_COND_EXPR:
11343788 804 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 805 list(kid);
806 break;
807 default:
808 case OP_MATCH:
8782bef2 809 case OP_QR:
79072805
LW		 810 case OP_SUBST:
811 case OP_NULL:
11343788 812 if (!(o->op_flags & OPf_KIDS))
79072805 813 break;
11343788
MB		 814 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
815 list(cBINOPo->op_first);
816 return gen_constant_list(o);
79072805
LW		 817 }
818 case OP_LIST:
11343788 819 listkids(o);
79072805
LW		 820 break;
821 case OP_LEAVE:
822 case OP_LEAVETRY:
5dc0d613 823 kid = cLISTOPo->op_first;
54310121 824 list(kid);
155aba94 825 while ((kid = kid->op_sibling)) {
54310121 826 if (kid->op_sibling)
827 scalarvoid(kid);
828 else
829 list(kid);
830 }
3280af22 831 WITH_THR(PL_curcop = &PL_compiling);
54310121 832 break;
748a9306 833 case OP_SCOPE:
79072805 834 case OP_LINESEQ:
11343788 835 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 836 if (kid->op_sibling)
837 scalarvoid(kid);
838 else
839 list(kid);
840 }
3280af22 841 WITH_THR(PL_curcop = &PL_compiling);
79072805 842 break;
c90c0ff4 843 case OP_REQUIRE:
844 /* all requires must return a boolean value */
5196be3e
MB		 845 o->op_flags &= ~OPf_WANT;
846 return scalar(o);
79072805 847 }
11343788 848 return o;
79072805
LW		 849}
850
851OP *
864dbfa3 852Perl_scalarseq(pTHX_ OP *o)
79072805
LW		 853{
854 OP *kid;
855
11343788
MB		 856 if (o) {
857 if (o->op_type == OP_LINESEQ ||
858 o->op_type == OP_SCOPE ||
859 o->op_type == OP_LEAVE ||
860 o->op_type == OP_LEAVETRY)
463ee0b2 861 {
11343788 862 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 863 if (kid->op_sibling) {
463ee0b2 864 scalarvoid(kid);
ed6116ce 865 }
463ee0b2 866 }
3280af22 867 PL_curcop = &PL_compiling;
79072805 868 }
11343788 869 o->op_flags &= ~OPf_PARENS;
3280af22 870 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 871 o->op_flags |= OPf_PARENS;
79072805 872 }
8990e307 873 else
11343788
MB		 874 o = newOP(OP_STUB, 0);
875 return o;
79072805
LW		 876}
877
76e3520e 878STATIC OP *
cea2e8a9 879S_modkids(pTHX_ OP *o, I32 type)
79072805
LW		 880{
881 OP *kid;
11343788
MB		 882 if (o && o->op_flags & OPf_KIDS) {
883 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 884 mod(kid, type);
79072805 885 }
11343788 886 return o;
79072805
LW		 887}
888
ddeae0f1
DM		 889/* Propagate lvalue ("modifiable") context to an op and it's children.
890 * 'type' represents the context type, roughly based on the type of op that
891 * would do the modifying, although local() is represented by OP_NULL.
892 * It's responsible for detecting things that can't be modified, flag
893 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
894 * might have to vivify a reference in $x), and so on.
895 *
896 * For example, "$a+1 = 2" would cause mod() to be called with o being
897 * OP_ADD and type being OP_SASSIGN, and would output an error.
898 */
899
79072805 900OP *
864dbfa3 901Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW		 902{
903 OP *kid;
ddeae0f1
DM		 904 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
905 int localize = -1;
79072805 906
3280af22 907 if (!o || PL_error_count)
11343788 908 return o;
79072805 909
b162f9ea 910 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 911 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
912 {
b162f9ea 913 return o;
7e363e51 914 }
1c846c1f 915
11343788 916 switch (o->op_type) {
68dc0745 917 case OP_UNDEF:
ddeae0f1 918 localize = 0;
3280af22 919 PL_modcount++;
5dc0d613 920 return o;
a0d0e21e 921 case OP_CONST:
11343788 922 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 923 goto nomod;
3280af22 924 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 925 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 926 PL_eval_start = 0;
a0d0e21e
LW		 927 }
928 else if (!type) {
3280af22
NIS		 929 SAVEI32(PL_compiling.cop_arybase);
930 PL_compiling.cop_arybase = 0;
a0d0e21e
LW		 931 }
932 else if (type == OP_REFGEN)
933 goto nomod;
934 else
cea2e8a9 935 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 936 break;
5f05dabc 937 case OP_STUB:
5196be3e 938 if (o->op_flags & OPf_PARENS)
5f05dabc 939 break;
940 goto nomod;
a0d0e21e
LW		 941 case OP_ENTERSUB:
942 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 943 !(o->op_flags & OPf_STACKED)) {
944 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 945 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 946 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 947 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 948 break;
949 }
95f0a2f1
SB		 950 else if (o->op_private & OPpENTERSUB_NOMOD)
951 return o;
cd06dffe
GS		 952 else { /* lvalue subroutine call */
953 o->op_private |= OPpLVAL_INTRO;
e6438c1a 954 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 955 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 956 /* Backward compatibility mode: */
957 o->op_private |= OPpENTERSUB_INARGS;
958 break;
959 }
960 else { /* Compile-time error message: */
961 OP *kid = cUNOPo->op_first;
962 CV *cv;
963 OP *okid;
964
965 if (kid->op_type == OP_PUSHMARK)
966 goto skip_kids;
967 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
968 Perl_croak(aTHX_
969 "panic: unexpected lvalue entersub "
55140b79 970 "args: type/targ %ld:%"UVuf,
3d811634 971 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 972 kid = kLISTOP->op_first;
973 skip_kids:
974 while (kid->op_sibling)
975 kid = kid->op_sibling;
976 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
977 /* Indirect call */
978 if (kid->op_type == OP_METHOD_NAMED
979 || kid->op_type == OP_METHOD)
980 {
87d7fd28 981 UNOP *newop;
b2ffa427 982
87d7fd28 983 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 984 newop->op_type = OP_RV2CV;
985 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS		 986 newop->op_first = Nullop;
987 newop->op_next = (OP*)newop;
988 kid->op_sibling = (OP*)newop;
349fd7b7 989 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS		 990 break;
991 }
b2ffa427 992
cd06dffe
GS		 993 if (kid->op_type != OP_RV2CV)
994 Perl_croak(aTHX_
995 "panic: unexpected lvalue entersub "
55140b79 996 "entry via type/targ %ld:%"UVuf,
3d811634 997 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 998 kid->op_private |= OPpLVAL_INTRO;
999 break; /* Postpone until runtime */
1000 }
b2ffa427
NIS		 1001
1002 okid = kid;
cd06dffe
GS		 1003 kid = kUNOP->op_first;
1004 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1005 kid = kUNOP->op_first;
b2ffa427 1006 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1007 Perl_croak(aTHX_
1008 "Unexpected constant lvalue entersub "
55140b79 1009 "entry via type/targ %ld:%"UVuf,
3d811634 1010 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1011 if (kid->op_type != OP_GV) {
1012 /* Restore RV2CV to check lvalueness */
1013 restore_2cv:
1014 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1015 okid->op_next = kid->op_next;
1016 kid->op_next = okid;
1017 }
1018 else
1019 okid->op_next = Nullop;
1020 okid->op_type = OP_RV2CV;
1021 okid->op_targ = 0;
1022 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1023 okid->op_private |= OPpLVAL_INTRO;
1024 break;
1025 }
b2ffa427 1026
638eceb6 1027 cv = GvCV(kGVOP_gv);
1c846c1f 1028 if (!cv)
cd06dffe
GS		 1029 goto restore_2cv;
1030 if (CvLVALUE(cv))
1031 break;
1032 }
1033 }
79072805
LW		 1034 /* FALL THROUGH */
1035 default:
a0d0e21e
LW		 1036 nomod:
1037 /* grep, foreach, subcalls, refgen */
1038 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1039 break;
cea2e8a9 1040 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1041 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1042 ? "do block"
1043 : (o->op_type == OP_ENTERSUB
1044 ? "non-lvalue subroutine call"
53e06cf0 1045 : OP_DESC(o))),
22c35a8c 1046 type ? PL_op_desc[type] : "local"));
11343788 1047 return o;
79072805 1048
a0d0e21e
LW		 1049 case OP_PREINC:
1050 case OP_PREDEC:
1051 case OP_POW:
1052 case OP_MULTIPLY:
1053 case OP_DIVIDE:
1054 case OP_MODULO:
1055 case OP_REPEAT:
1056 case OP_ADD:
1057 case OP_SUBTRACT:
1058 case OP_CONCAT:
1059 case OP_LEFT_SHIFT:
1060 case OP_RIGHT_SHIFT:
1061 case OP_BIT_AND:
1062 case OP_BIT_XOR:
1063 case OP_BIT_OR:
1064 case OP_I_MULTIPLY:
1065 case OP_I_DIVIDE:
1066 case OP_I_MODULO:
1067 case OP_I_ADD:
1068 case OP_I_SUBTRACT:
11343788 1069 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1070 goto nomod;
3280af22 1071 PL_modcount++;
a0d0e21e 1072 break;
b2ffa427 1073
79072805 1074 case OP_COND_EXPR:
ddeae0f1 1075 localize = 1;
11343788 1076 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1077 mod(kid, type);
79072805
LW		 1078 break;
1079
1080 case OP_RV2AV:
1081 case OP_RV2HV:
11343788 1082 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1083 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1084 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1085 }
1086 /* FALL THROUGH */
79072805 1087 case OP_RV2GV:
5dc0d613 1088 if (scalar_mod_type(o, type))
3fe9a6f1 1089 goto nomod;
11343788 1090 ref(cUNOPo->op_first, o->op_type);
79072805 1091 /* FALL THROUGH */
79072805
LW		 1092 case OP_ASLICE:
1093 case OP_HSLICE:
78f9721b
SM		 1094 if (type == OP_LEAVESUBLV)
1095 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1096 localize = 1;
78f9721b
SM		 1097 /* FALL THROUGH */
1098 case OP_AASSIGN:
93a17b20
LW		 1099 case OP_NEXTSTATE:
1100 case OP_DBSTATE:
e6438c1a 1101 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1102 break;
463ee0b2 1103 case OP_RV2SV:
aeea060c 1104 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1105 localize = 1;
463ee0b2 1106 /* FALL THROUGH */
79072805 1107 case OP_GV:
463ee0b2 1108 case OP_AV2ARYLEN:
3280af22 1109 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1110 case OP_SASSIGN:
bf4b1e52
GS		 1111 case OP_ANDASSIGN:
1112 case OP_ORASSIGN:
c963b151 1113 case OP_DORASSIGN:
ddeae0f1
DM		 1114 PL_modcount++;
1115 break;
1116
8990e307 1117 case OP_AELEMFAST:
6a077020 1118 localize = -1;
3280af22 1119 PL_modcount++;
8990e307
LW		 1120 break;
1121
748a9306
LW		 1122 case OP_PADAV:
1123 case OP_PADHV:
e6438c1a 1124 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1125 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1126 return o; /* Treat \(@foo) like ordinary list. */
1127 if (scalar_mod_type(o, type))
3fe9a6f1 1128 goto nomod;
78f9721b
SM		 1129 if (type == OP_LEAVESUBLV)
1130 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1131 /* FALL THROUGH */
1132 case OP_PADSV:
3280af22 1133 PL_modcount++;
ddeae0f1 1134 if (!type) /* local() */
cea2e8a9 1135 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1136 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1137 break;
1138
748a9306 1139 case OP_PUSHMARK:
ddeae0f1 1140 localize = 0;
748a9306 1141 break;
b2ffa427 1142
69969c6f
SB		 1143 case OP_KEYS:
1144 if (type != OP_SASSIGN)
1145 goto nomod;
5d82c453
GA		 1146 goto lvalue_func;
1147 case OP_SUBSTR:
1148 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1149 goto nomod;
5f05dabc 1150 /* FALL THROUGH */
a0d0e21e 1151 case OP_POS:
463ee0b2 1152 case OP_VEC:
78f9721b
SM		 1153 if (type == OP_LEAVESUBLV)
1154 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1155 lvalue_func:
11343788
MB		 1156 pad_free(o->op_targ);
1157 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1158 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1159 if (o->op_flags & OPf_KIDS)
1160 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1161 break;
a0d0e21e 1162
463ee0b2
LW		 1163 case OP_AELEM:
1164 case OP_HELEM:
11343788 1165 ref(cBINOPo->op_first, o->op_type);
68dc0745 1166 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1167 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1168 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1169 if (type == OP_LEAVESUBLV)
1170 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1171 localize = 1;
3280af22 1172 PL_modcount++;
463ee0b2
LW		 1173 break;
1174
1175 case OP_SCOPE:
1176 case OP_LEAVE:
1177 case OP_ENTER:
78f9721b 1178 case OP_LINESEQ:
ddeae0f1 1179 localize = 0;
11343788
MB		 1180 if (o->op_flags & OPf_KIDS)
1181 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1182 break;
1183
1184 case OP_NULL:
ddeae0f1 1185 localize = 0;
638bc118
GS		 1186 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1187 goto nomod;
1188 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1189 break;
11343788
MB		 1190 if (o->op_targ != OP_LIST) {
1191 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1192 break;
1193 }
1194 /* FALL THROUGH */
463ee0b2 1195 case OP_LIST:
ddeae0f1 1196 localize = 0;
11343788 1197 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1198 mod(kid, type);
1199 break;
78f9721b
SM		 1200
1201 case OP_RETURN:
1202 if (type != OP_LEAVESUBLV)
1203 goto nomod;
1204 break; /* mod()ing was handled by ck_return() */
463ee0b2 1205 }
58d95175 1206
8be1be90
AMS		 1207 /* [20011101.069] File test operators interpret OPf_REF to mean that
1208 their argument is a filehandle; thus \stat(".") should not set
1209 it. AMS 20011102 */
1210 if (type == OP_REFGEN &&
1211 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1212 return o;
1213
1214 if (type != OP_LEAVESUBLV)
1215 o->op_flags |= OPf_MOD;
1216
1217 if (type == OP_AASSIGN || type == OP_SASSIGN)
1218 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1219 else if (!type) { /* local() */
1220 switch (localize) {
1221 case 1:
1222 o->op_private |= OPpLVAL_INTRO;
1223 o->op_flags &= ~OPf_SPECIAL;
1224 PL_hints |= HINT_BLOCK_SCOPE;
1225 break;
1226 case 0:
1227 break;
1228 case -1:
1229 if (ckWARN(WARN_SYNTAX)) {
1230 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1231 "Useless localization of %s", OP_DESC(o));
1232 }
1233 }
463ee0b2 1234 }
8be1be90
AMS		 1235 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1236 && type != OP_LEAVESUBLV)
1237 o->op_flags |= OPf_REF;
11343788 1238 return o;
463ee0b2
LW		 1239}
1240
864dbfa3 1241STATIC bool
cea2e8a9 1242S_scalar_mod_type(pTHX_ OP *o, I32 type)
3fe9a6f1 1243{
1244 switch (type) {
1245 case OP_SASSIGN:
5196be3e 1246 if (o->op_type == OP_RV2GV)
3fe9a6f1 1247 return FALSE;
1248 /* FALL THROUGH */
1249 case OP_PREINC:
1250 case OP_PREDEC:
1251 case OP_POSTINC:
1252 case OP_POSTDEC:
1253 case OP_I_PREINC:
1254 case OP_I_PREDEC:
1255 case OP_I_POSTINC:
1256 case OP_I_POSTDEC:
1257 case OP_POW:
1258 case OP_MULTIPLY:
1259 case OP_DIVIDE:
1260 case OP_MODULO:
1261 case OP_REPEAT:
1262 case OP_ADD:
1263 case OP_SUBTRACT:
1264 case OP_I_MULTIPLY:
1265 case OP_I_DIVIDE:
1266 case OP_I_MODULO:
1267 case OP_I_ADD:
1268 case OP_I_SUBTRACT:
1269 case OP_LEFT_SHIFT:
1270 case OP_RIGHT_SHIFT:
1271 case OP_BIT_AND:
1272 case OP_BIT_XOR:
1273 case OP_BIT_OR:
1274 case OP_CONCAT:
1275 case OP_SUBST:
1276 case OP_TRANS:
49e9fbe6
GS		 1277 case OP_READ:
1278 case OP_SYSREAD:
1279 case OP_RECV:
bf4b1e52
GS		 1280 case OP_ANDASSIGN:
1281 case OP_ORASSIGN:
3fe9a6f1 1282 return TRUE;
1283 default:
1284 return FALSE;
1285 }
1286}
1287
35cd451c 1288STATIC bool
cea2e8a9 1289S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
35cd451c
GS		 1290{
1291 switch (o->op_type) {
1292 case OP_PIPE_OP:
1293 case OP_SOCKPAIR:
1294 if (argnum == 2)
1295 return TRUE;
1296 /* FALL THROUGH */
1297 case OP_SYSOPEN:
1298 case OP_OPEN:
ded8aa31 1299 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1300 case OP_SOCKET:
1301 case OP_OPEN_DIR:
1302 case OP_ACCEPT:
1303 if (argnum == 1)
1304 return TRUE;
1305 /* FALL THROUGH */
1306 default:
1307 return FALSE;
1308 }
1309}
1310
463ee0b2 1311OP *
864dbfa3 1312Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1313{
1314 OP *kid;
11343788
MB		 1315 if (o && o->op_flags & OPf_KIDS) {
1316 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1317 ref(kid, type);
1318 }
11343788 1319 return o;
463ee0b2
LW		 1320}
1321
1322OP *
864dbfa3 1323Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1324{
1325 OP *kid;
463ee0b2 1326
3280af22 1327 if (!o || PL_error_count)
11343788 1328 return o;
463ee0b2 1329
11343788 1330 switch (o->op_type) {
a0d0e21e 1331 case OP_ENTERSUB:
afebc493 1332 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1333 !(o->op_flags & OPf_STACKED)) {
1334 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1335 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1336 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1337 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1338 o->op_flags |= OPf_SPECIAL;
8990e307
LW		 1339 }
1340 break;
aeea060c 1341
463ee0b2 1342 case OP_COND_EXPR:
11343788 1343 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW		 1344 ref(kid, type);
1345 break;
8990e307 1346 case OP_RV2SV:
35cd451c
GS		 1347 if (type == OP_DEFINED)
1348 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1349 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW		 1350 /* FALL THROUGH */
1351 case OP_PADSV:
5f05dabc 1352 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1353 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1354 : type == OP_RV2HV ? OPpDEREF_HV
1355 : OPpDEREF_SV);
11343788 1356 o->op_flags |= OPf_MOD;
a0d0e21e 1357 }
8990e307 1358 break;
1c846c1f 1359
2faa37cc 1360 case OP_THREADSV:
a863c7d1
MB		 1361 o->op_flags |= OPf_MOD; /* XXX ??? */
1362 break;
1363
463ee0b2
LW		 1364 case OP_RV2AV:
1365 case OP_RV2HV:
aeea060c 1366 o->op_flags |= OPf_REF;
8990e307 1367 /* FALL THROUGH */
463ee0b2 1368 case OP_RV2GV:
35cd451c
GS		 1369 if (type == OP_DEFINED)
1370 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1371 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1372 break;
8990e307 1373
463ee0b2
LW		 1374 case OP_PADAV:
1375 case OP_PADHV:
aeea060c 1376 o->op_flags |= OPf_REF;
79072805 1377 break;
aeea060c 1378
8990e307 1379 case OP_SCALAR:
79072805 1380 case OP_NULL:
11343788 1381 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1382 break;
11343788 1383 ref(cBINOPo->op_first, type);
79072805
LW		 1384 break;
1385 case OP_AELEM:
1386 case OP_HELEM:
11343788 1387 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1388 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1389 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1390 : type == OP_RV2HV ? OPpDEREF_HV
1391 : OPpDEREF_SV);
11343788 1392 o->op_flags |= OPf_MOD;
8990e307 1393 }
79072805
LW		 1394 break;
1395
463ee0b2 1396 case OP_SCOPE:
79072805
LW		 1397 case OP_LEAVE:
1398 case OP_ENTER:
8990e307 1399 case OP_LIST:
11343788 1400 if (!(o->op_flags & OPf_KIDS))
79072805 1401 break;
11343788 1402 ref(cLISTOPo->op_last, type);
79072805 1403 break;
a0d0e21e
LW		 1404 default:
1405 break;
79072805 1406 }
11343788 1407 return scalar(o);
8990e307 1408
79072805
LW		 1409}
1410
09bef843
SB		 1411STATIC OP *
1412S_dup_attrlist(pTHX_ OP *o)
1413{
1414 OP *rop = Nullop;
1415
1416 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1417 * where the first kid is OP_PUSHMARK and the remaining ones
1418 * are OP_CONST. We need to push the OP_CONST values.
1419 */
1420 if (o->op_type == OP_CONST)
1421 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1422 else {
1423 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1424 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1425 if (o->op_type == OP_CONST)
1426 rop = append_elem(OP_LIST, rop,
1427 newSVOP(OP_CONST, o->op_flags,
1428 SvREFCNT_inc(cSVOPo->op_sv)));
1429 }
1430 }
1431 return rop;
1432}
1433
1434STATIC void
95f0a2f1 1435S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1436{
09bef843
SB		 1437 SV *stashsv;
1438
1439 /* fake up C<use attributes $pkg,$rv,@attrs> */
1440 ENTER; /* need to protect against side-effects of 'use' */
1441 SAVEINT(PL_expect);
a9164de8 1442 if (stash)
09bef843
SB		 1443 stashsv = newSVpv(HvNAME(stash), 0);
1444 else
1445 stashsv = &PL_sv_no;
e4783991 1446
09bef843 1447#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1448#define ATTRSMODULE_PM "attributes.pm"
1449
1450 if (for_my) {
1451 SV **svp;
1452 /* Don't force the C<use> if we don't need it. */
1453 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1454 sizeof(ATTRSMODULE_PM)-1, 0);
1455 if (svp && *svp != &PL_sv_undef)
1456 ; /* already in %INC */
1457 else
1458 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1459 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1460 Nullsv);
1461 }
1462 else {
1463 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1464 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1465 Nullsv,
1466 prepend_elem(OP_LIST,
1467 newSVOP(OP_CONST, 0, stashsv),
1468 prepend_elem(OP_LIST,
1469 newSVOP(OP_CONST, 0,
1470 newRV(target)),
1471 dup_attrlist(attrs))));
1472 }
09bef843
SB		 1473 LEAVE;
1474}
1475
95f0a2f1
SB		 1476STATIC void
1477S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1478{
1479 OP *pack, *imop, *arg;
1480 SV *meth, *stashsv;
1481
1482 if (!attrs)
1483 return;
1484
1485 assert(target->op_type == OP_PADSV ||
1486 target->op_type == OP_PADHV ||
1487 target->op_type == OP_PADAV);
1488
1489 /* Ensure that attributes.pm is loaded. */
dd2155a4 1490 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1491
1492 /* Need package name for method call. */
1493 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1494
1495 /* Build up the real arg-list. */
1496 if (stash)
1497 stashsv = newSVpv(HvNAME(stash), 0);
1498 else
1499 stashsv = &PL_sv_no;
1500 arg = newOP(OP_PADSV, 0);
1501 arg->op_targ = target->op_targ;
1502 arg = prepend_elem(OP_LIST,
1503 newSVOP(OP_CONST, 0, stashsv),
1504 prepend_elem(OP_LIST,
1505 newUNOP(OP_REFGEN, 0,
1506 mod(arg, OP_REFGEN)),
1507 dup_attrlist(attrs)));
1508
1509 /* Fake up a method call to import */
1510 meth = newSVpvn("import", 6);
1511 (void)SvUPGRADE(meth, SVt_PVIV);
1512 (void)SvIOK_on(meth);
5afd6d42 1513 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
95f0a2f1
SB		 1514 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1515 append_elem(OP_LIST,
1516 prepend_elem(OP_LIST, pack, list(arg)),
1517 newSVOP(OP_METHOD_NAMED, 0, meth)));
1518 imop->op_private |= OPpENTERSUB_NOMOD;
1519
1520 /* Combine the ops. */
1521 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1522}
1523
1524/*
1525=notfor apidoc apply_attrs_string
1526
1527Attempts to apply a list of attributes specified by the C<attrstr> and
1528C<len> arguments to the subroutine identified by the C<cv> argument which
1529is expected to be associated with the package identified by the C<stashpv>
1530argument (see L<attributes>). It gets this wrong, though, in that it
1531does not correctly identify the boundaries of the individual attribute
1532specifications within C<attrstr>. This is not really intended for the
1533public API, but has to be listed here for systems such as AIX which
1534need an explicit export list for symbols. (It's called from XS code
1535in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1536to respect attribute syntax properly would be welcome.
1537
1538=cut
1539*/
1540
be3174d2
GS		 1541void
1542Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1543 char *attrstr, STRLEN len)
1544{
1545 OP *attrs = Nullop;
1546
1547 if (!len) {
1548 len = strlen(attrstr);
1549 }
1550
1551 while (len) {
1552 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1553 if (len) {
1554 char *sstr = attrstr;
1555 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1556 attrs = append_elem(OP_LIST, attrs,
1557 newSVOP(OP_CONST, 0,
1558 newSVpvn(sstr, attrstr-sstr)));
1559 }
1560 }
1561
1562 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1563 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1564 Nullsv, prepend_elem(OP_LIST,
1565 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1566 prepend_elem(OP_LIST,
1567 newSVOP(OP_CONST, 0,
1568 newRV((SV*)cv)),
1569 attrs)));
1570}
1571
09bef843 1572STATIC OP *
95f0a2f1 1573S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20
LW		 1574{
1575 OP *kid;
93a17b20
LW		 1576 I32 type;
1577
3280af22 1578 if (!o || PL_error_count)
11343788 1579 return o;
93a17b20 1580
11343788 1581 type = o->op_type;
93a17b20 1582 if (type == OP_LIST) {
11343788 1583 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1584 my_kid(kid, attrs, imopsp);
dab48698 1585 } else if (type == OP_UNDEF) {
7766148a 1586 return o;
77ca0c92
LW		 1587 } else if (type == OP_RV2SV || /* "our" declaration */
1588 type == OP_RV2AV ||
1589 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS		 1590 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1591 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1592 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1593 } else if (attrs) {
1594 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1595 PL_in_my = FALSE;
1596 PL_in_my_stash = Nullhv;
1597 apply_attrs(GvSTASH(gv),
1598 (type == OP_RV2SV ? GvSV(gv) :
1599 type == OP_RV2AV ? (SV*)GvAV(gv) :
1600 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1601 attrs, FALSE);
1602 }
192587c2 1603 o->op_private |= OPpOUR_INTRO;
77ca0c92 1604 return o;
95f0a2f1
SB		 1605 }
1606 else if (type != OP_PADSV &&
93a17b20
LW		 1607 type != OP_PADAV &&
1608 type != OP_PADHV &&
1609 type != OP_PUSHMARK)
1610 {
eb64745e 1611 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1612 OP_DESC(o),
eb64745e 1613 PL_in_my == KEY_our ? "our" : "my"));
11343788 1614 return o;
93a17b20 1615 }
09bef843
SB		 1616 else if (attrs && type != OP_PUSHMARK) {
1617 HV *stash;
09bef843 1618
eb64745e
GS		 1619 PL_in_my = FALSE;
1620 PL_in_my_stash = Nullhv;
1621
09bef843 1622 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 1623 stash = PAD_COMPNAME_TYPE(o->op_targ);
1624 if (!stash)
09bef843 1625 stash = PL_curstash;
95f0a2f1 1626 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1627 }
11343788
MB		 1628 o->op_flags |= OPf_MOD;
1629 o->op_private |= OPpLVAL_INTRO;
1630 return o;
93a17b20
LW		 1631}
1632
1633OP *
09bef843
SB		 1634Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1635{
95f0a2f1
SB		 1636 OP *rops = Nullop;
1637 int maybe_scalar = 0;
1638
d2be0de5 1639/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1640 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1641#if 0
09bef843
SB		 1642 if (o->op_flags & OPf_PARENS)
1643 list(o);
95f0a2f1
SB		 1644 else
1645 maybe_scalar = 1;
d2be0de5
YST		 1646#else
1647 maybe_scalar = 1;
1648#endif
09bef843
SB		 1649 if (attrs)
1650 SAVEFREEOP(attrs);
95f0a2f1
SB		 1651 o = my_kid(o, attrs, &rops);
1652 if (rops) {
1653 if (maybe_scalar && o->op_type == OP_PADSV) {
1654 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1655 o->op_private |= OPpLVAL_INTRO;
1656 }
1657 else
1658 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1659 }
eb64745e
GS		 1660 PL_in_my = FALSE;
1661 PL_in_my_stash = Nullhv;
1662 return o;
09bef843
SB		 1663}
1664
1665OP *
1666Perl_my(pTHX_ OP *o)
1667{
95f0a2f1 1668 return my_attrs(o, Nullop);
09bef843
SB		 1669}
1670
1671OP *
864dbfa3 1672Perl_sawparens(pTHX_ OP *o)
79072805
LW		 1673{
1674 if (o)
1675 o->op_flags |= OPf_PARENS;
1676 return o;
1677}
1678
1679OP *
864dbfa3 1680Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1681{
11343788 1682 OP *o;
59f00321 1683 bool ismatchop = 0;
79072805 1684
e476b1b5 1685 if (ckWARN(WARN_MISC) &&
599cee73
PM		 1686 (left->op_type == OP_RV2AV ||
1687 left->op_type == OP_RV2HV ||
1688 left->op_type == OP_PADAV ||
1689 left->op_type == OP_PADHV)) {
22c35a8c 1690 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM		 1691 right->op_type == OP_TRANS)
1692 ? right->op_type : OP_MATCH];
dff6d3cd
GS		 1693 const char *sample = ((left->op_type == OP_RV2AV ||
1694 left->op_type == OP_PADAV)
1695 ? "@array" : "%hash");
9014280d 1696 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1697 "Applying %s to %s will act on scalar(%s)",
599cee73 1698 desc, sample, sample);
2ae324a7 1699 }
1700
5cc9e5c9
RH		 1701 if (right->op_type == OP_CONST &&
1702 cSVOPx(right)->op_private & OPpCONST_BARE &&
1703 cSVOPx(right)->op_private & OPpCONST_STRICT)
1704 {
1705 no_bareword_allowed(right);
1706 }
1707
59f00321
RGS		 1708 ismatchop = right->op_type == OP_MATCH ||
1709 right->op_type == OP_SUBST ||
1710 right->op_type == OP_TRANS;
1711 if (ismatchop && right->op_private & OPpTARGET_MY) {
1712 right->op_targ = 0;
1713 right->op_private &= ~OPpTARGET_MY;
1714 }
1715 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
79072805 1716 right->op_flags |= OPf_STACKED;
18808301
JH		 1717 if (right->op_type != OP_MATCH &&
1718 ! (right->op_type == OP_TRANS &&
1719 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 1720 left = mod(left, right->op_type);
79072805 1721 if (right->op_type == OP_TRANS)
11343788 1722 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1723 else
11343788 1724 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1725 if (type == OP_NOT)
11343788
MB		 1726 return newUNOP(OP_NOT, 0, scalar(o));
1727 return o;
79072805
LW		 1728 }
1729 else
1730 return bind_match(type, left,
1731 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1732}
1733
1734OP *
864dbfa3 1735Perl_invert(pTHX_ OP *o)
79072805 1736{
11343788
MB		 1737 if (!o)
1738 return o;
79072805 1739 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1740 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 1741}
1742
1743OP *
864dbfa3 1744Perl_scope(pTHX_ OP *o)
79072805
LW		 1745{
1746 if (o) {
3280af22 1747 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 1748 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1749 o->op_type = OP_LEAVE;
22c35a8c 1750 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1751 }
fdb22418
HS		 1752 else if (o->op_type == OP_LINESEQ) {
1753 OP *kid;
1754 o->op_type = OP_SCOPE;
1755 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1756 kid = ((LISTOP*)o)->op_first;
1757 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1758 op_null(kid);
463ee0b2 1759 }
fdb22418
HS		 1760 else
1761 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
79072805
LW		 1762 }
1763 return o;
1764}
1765
dfa41748 1766/* XXX kept for BINCOMPAT only */
b3ac6de7 1767void
864dbfa3 1768Perl_save_hints(pTHX)
b3ac6de7 1769{
dfa41748 1770 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
b3ac6de7
IZ		 1771}
1772
a0d0e21e 1773int
864dbfa3 1774Perl_block_start(pTHX_ int full)
79072805 1775{
3280af22 1776 int retval = PL_savestack_ix;
dd2155a4 1777 pad_block_start(full);
b3ac6de7 1778 SAVEHINTS();
3280af22 1779 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1780 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1781 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 1782 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1783 SAVEFREESV(PL_compiling.cop_warnings) ;
1784 }
ac27b0f5
NIS		 1785 SAVESPTR(PL_compiling.cop_io);
1786 if (! specialCopIO(PL_compiling.cop_io)) {
1787 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1788 SAVEFREESV(PL_compiling.cop_io) ;
1789 }
a0d0e21e
LW		 1790 return retval;
1791}
1792
1793OP*
864dbfa3 1794Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1795{
3280af22 1796 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
e9f19e3c 1797 OP* retval = scalarseq(seq);
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) */
2814eb74 2030 o->op_opt = 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 }
b9d46b39
RGS		 3127 /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3128 if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3129 && right->op_type == OP_STUB
3130 && (left->op_private & OPpLVAL_INTRO))
3131 {
3132 op_free(right);
3133 return left;
3134 }
10c8fecd
GS		 3135 curop = list(force_list(left));
3136 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3137 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM		 3138
3139 /* PL_generation sorcery:
3140 * an assignment like ($a,$b) = ($c,$d) is easier than
3141 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3142 * To detect whether there are common vars, the global var
3143 * PL_generation is incremented for each assign op we compile.
3144 * Then, while compiling the assign op, we run through all the
3145 * variables on both sides of the assignment, setting a spare slot
3146 * in each of them to PL_generation. If any of them already have
3147 * that value, we know we've got commonality. We could use a
3148 * single bit marker, but then we'd have to make 2 passes, first
3149 * to clear the flag, then to test and set it. To find somewhere
3150 * to store these values, evil chicanery is done with SvCUR().
3151 */
3152
a0d0e21e 3153 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3154 OP *lastop = o;
3280af22 3155 PL_generation++;
11343788 3156 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3157 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3158 if (curop->op_type == OP_GV) {
638eceb6 3159 GV *gv = cGVOPx_gv(curop);
eb160463 3160 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
79072805 3161 break;
3280af22 3162 SvCUR(gv) = PL_generation;
79072805 3163 }
748a9306
LW		 3164 else if (curop->op_type == OP_PADSV ||
3165 curop->op_type == OP_PADAV ||
3166 curop->op_type == OP_PADHV ||
dd2155a4
DM		 3167 curop->op_type == OP_PADANY)
3168 {
3169 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3170 == (STRLEN)PL_generation)
748a9306 3171 break;
dd2155a4
DM		 3172 PAD_COMPNAME_GEN(curop->op_targ)
3173 = PL_generation;
3174
748a9306 3175 }
79072805
LW		 3176 else if (curop->op_type == OP_RV2CV)
3177 break;
3178 else if (curop->op_type == OP_RV2SV ||
3179 curop->op_type == OP_RV2AV ||
3180 curop->op_type == OP_RV2HV ||
3181 curop->op_type == OP_RV2GV) {
3182 if (lastop->op_type != OP_GV) /* funny deref? */
3183 break;
3184 }
1167e5da
SM		 3185 else if (curop->op_type == OP_PUSHRE) {
3186 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3187#ifdef USE_ITHREADS
dd2155a4
DM		 3188 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3189 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3190#else
1167e5da 3191 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3192#endif
eb160463 3193 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
1167e5da 3194 break;
3280af22 3195 SvCUR(gv) = PL_generation;
b2ffa427 3196 }
1167e5da 3197 }
79072805
LW		 3198 else
3199 break;
3200 }
3201 lastop = curop;
3202 }
11343788 3203 if (curop != o)
10c8fecd 3204 o->op_private |= OPpASSIGN_COMMON;
79072805 3205 }
c07a80fd 3206 if (right && right->op_type == OP_SPLIT) {
3207 OP* tmpop;
3208 if ((tmpop = ((LISTOP*)right)->op_first) &&
3209 tmpop->op_type == OP_PUSHRE)
3210 {
3211 PMOP *pm = (PMOP*)tmpop;
3212 if (left->op_type == OP_RV2AV &&
3213 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3214 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3215 {
3216 tmpop = ((UNOP*)left)->op_first;
3217 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3218#ifdef USE_ITHREADS
ba89bb6e 3219 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3220 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3221#else
3222 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3223 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3224#endif
c07a80fd 3225 pm->op_pmflags |= PMf_ONCE;
11343788 3226 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3227 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3228 tmpop->op_sibling = Nullop; /* don't free split */
3229 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3230 op_free(o); /* blow off assign */
54310121 3231 right->op_flags &= ~OPf_WANT;
a5f75d66 3232 /* "I don't know and I don't care." */
c07a80fd 3233 return right;
3234 }
3235 }
3236 else {
e6438c1a 3237 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3238 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3239 {
3240 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3241 if (SvIVX(sv) == 0)
3280af22 3242 sv_setiv(sv, PL_modcount+1);
c07a80fd 3243 }
3244 }
3245 }
3246 }
11343788 3247 return o;
79072805
LW		 3248 }
3249 if (!right)
3250 right = newOP(OP_UNDEF, 0);
3251 if (right->op_type == OP_READLINE) {
3252 right->op_flags |= OPf_STACKED;
463ee0b2 3253 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3254 }
a0d0e21e 3255 else {
3280af22 3256 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3257 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3258 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3259 if (PL_eval_start)
3260 PL_eval_start = 0;
748a9306 3261 else {
11343788 3262 op_free(o);
a0d0e21e
LW		 3263 return Nullop;
3264 }
3265 }
11343788 3266 return o;
79072805
LW		 3267}
3268
3269OP *
864dbfa3 3270Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3271{
bbce6d69 3272 U32 seq = intro_my();
79072805
LW		 3273 register COP *cop;
3274
b7dc083c 3275 NewOp(1101, cop, 1, COP);
57843af0 3276 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3277 cop->op_type = OP_DBSTATE;
22c35a8c 3278 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3279 }
3280 else {
3281 cop->op_type = OP_NEXTSTATE;
22c35a8c 3282 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3283 }
eb160463
GS		 3284 cop->op_flags = (U8)flags;
3285 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3286#ifdef NATIVE_HINTS
3287 cop->op_private |= NATIVE_HINTS;
3288#endif
e24b16f9 3289 PL_compiling.op_private = cop->op_private;
79072805
LW		 3290 cop->op_next = (OP*)cop;
3291
463ee0b2
LW		 3292 if (label) {
3293 cop->cop_label = label;
3280af22 3294 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3295 }
bbce6d69 3296 cop->cop_seq = seq;
3280af22 3297 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3298 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3299 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3300 else
599cee73 3301 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3302 if (specialCopIO(PL_curcop->cop_io))
3303 cop->cop_io = PL_curcop->cop_io;
3304 else
3305 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3306
79072805 3307
3280af22 3308 if (PL_copline == NOLINE)
57843af0 3309 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3310 else {
57843af0 3311 CopLINE_set(cop, PL_copline);
3280af22 3312 PL_copline = NOLINE;
79072805 3313 }
57843af0 3314#ifdef USE_ITHREADS
f4dd75d9 3315 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3316#else
f4dd75d9 3317 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3318#endif
11faa288 3319 CopSTASH_set(cop, PL_curstash);
79072805 3320
3280af22 3321 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3322 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3323 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3324 (void)SvIOK_on(*svp);
57b2e452 3325 SvIVX(*svp) = PTR2IV(cop);
1eb1540c 3326 }
93a17b20
LW		 3327 }
3328
722969e2 3329 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3330}
3331
bbce6d69 3332
79072805 3333OP *
864dbfa3 3334Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3335{
883ffac3
CS		 3336 return new_logop(type, flags, &first, &other);
3337}
3338
3bd495df 3339STATIC OP *
cea2e8a9 3340S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3341{
79072805 3342 LOGOP *logop;
11343788 3343 OP *o;
883ffac3
CS		 3344 OP *first = *firstp;
3345 OP *other = *otherp;
79072805 3346
a0d0e21e
LW		 3347 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3348 return newBINOP(type, flags, scalar(first), scalar(other));
3349
8990e307 3350 scalarboolean(first);
79072805
LW		 3351 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3352 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3353 if (type == OP_AND || type == OP_OR) {
3354 if (type == OP_AND)
3355 type = OP_OR;
3356 else
3357 type = OP_AND;
11343788 3358 o = first;
883ffac3 3359 first = *firstp = cUNOPo->op_first;
11343788
MB		 3360 if (o->op_next)
3361 first->op_next = o->op_next;
3362 cUNOPo->op_first = Nullop;
3363 op_free(o);
79072805
LW		 3364 }
3365 }
3366 if (first->op_type == OP_CONST) {
39a440a3
DM		 3367 if (first->op_private & OPpCONST_STRICT)
3368 no_bareword_allowed(first);
3369 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
989dfb19 3370 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
75cc09e4
MHM		 3371 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3372 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3373 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
79072805 3374 op_free(first);
883ffac3 3375 *firstp = Nullop;
d6fee5c7
DM		 3376 if (other->op_type == OP_CONST)
3377 other->op_private |= OPpCONST_SHORTCIRCUIT;
79072805
LW		 3378 return other;
3379 }
3380 else {
7921d0f2
DM		 3381 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3382 OP *o2 = other;
3383 if ( ! (o2->op_type == OP_LIST
3384 && (( o2 = cUNOPx(o2)->op_first))
3385 && o2->op_type == OP_PUSHMARK
3386 && (( o2 = o2->op_sibling)) )
3387 )
3388 o2 = other;
3389 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3390 || o2->op_type == OP_PADHV)
3391 && o2->op_private & OPpLVAL_INTRO
3392 && ckWARN(WARN_DEPRECATED))
3393 {
3394 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3395 "Deprecated use of my() in false conditional");
3396 }
3397
79072805 3398 op_free(other);
883ffac3 3399 *otherp = Nullop;
d6fee5c7
DM		 3400 if (first->op_type == OP_CONST)
3401 first->op_private |= OPpCONST_SHORTCIRCUIT;
79072805
LW		 3402 return first;
3403 }
3404 }
59e10468
RGS		 3405 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3406 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3407 {
a6006777 3408 OP *k1 = ((UNOP*)first)->op_first;
3409 OP *k2 = k1->op_sibling;
3410 OPCODE warnop = 0;
3411 switch (first->op_type)
3412 {
3413 case OP_NULL:
3414 if (k2 && k2->op_type == OP_READLINE
3415 && (k2->op_flags & OPf_STACKED)
1c846c1f 3416 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3417 {
a6006777 3418 warnop = k2->op_type;
72b16652 3419 }
a6006777 3420 break;
3421
3422 case OP_SASSIGN:
68dc0745 3423 if (k1->op_type == OP_READDIR
3424 || k1->op_type == OP_GLOB
72b16652 3425 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3426 || k1->op_type == OP_EACH)
72b16652
GS		 3427 {
3428 warnop = ((k1->op_type == OP_NULL)
eb160463 3429 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 3430 }
a6006777 3431 break;
3432 }
8ebc5c01 3433 if (warnop) {
57843af0
GS		 3434 line_t oldline = CopLINE(PL_curcop);
3435 CopLINE_set(PL_curcop, PL_copline);
9014280d 3436 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 3437 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3438 PL_op_desc[warnop],
68dc0745 3439 ((warnop == OP_READLINE || warnop == OP_GLOB)
3440 ? " construct" : "() operator"));
57843af0 3441 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3442 }
a6006777 3443 }
79072805
LW		 3444
3445 if (!other)
3446 return first;
3447
c963b151 3448 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 3449 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3450
b7dc083c 3451 NewOp(1101, logop, 1, LOGOP);
79072805 3452
eb160463 3453 logop->op_type = (OPCODE)type;
22c35a8c 3454 logop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3455 logop->op_first = first;
3456 logop->op_flags = flags | OPf_KIDS;
3457 logop->op_other = LINKLIST(other);
eb160463 3458 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3459
3460 /* establish postfix order */
3461 logop->op_next = LINKLIST(first);
3462 first->op_next = (OP*)logop;
3463 first->op_sibling = other;
3464
463d09e6
RGS		 3465 CHECKOP(type,logop);
3466
11343788
MB		 3467 o = newUNOP(OP_NULL, 0, (OP*)logop);
3468 other->op_next = o;
79072805 3469
11343788 3470 return o;
79072805
LW		 3471}
3472
3473OP *
864dbfa3 3474Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3475{
1a67a97c
SM		 3476 LOGOP *logop;
3477 OP *start;
11343788 3478 OP *o;
79072805 3479
b1cb66bf 3480 if (!falseop)
3481 return newLOGOP(OP_AND, 0, first, trueop);
3482 if (!trueop)
3483 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3484
8990e307 3485 scalarboolean(first);
79072805 3486 if (first->op_type == OP_CONST) {
2bc6235c
K		 3487 if (first->op_private & OPpCONST_BARE &&
3488 first->op_private & OPpCONST_STRICT) {
3489 no_bareword_allowed(first);
3490 }
79072805
LW		 3491 if (SvTRUE(((SVOP*)first)->op_sv)) {
3492 op_free(first);
b1cb66bf 3493 op_free(falseop);
3494 return trueop;
79072805
LW		 3495 }
3496 else {
3497 op_free(first);
b1cb66bf 3498 op_free(trueop);
3499 return falseop;
79072805
LW		 3500 }
3501 }
1a67a97c
SM		 3502 NewOp(1101, logop, 1, LOGOP);
3503 logop->op_type = OP_COND_EXPR;
3504 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3505 logop->op_first = first;
3506 logop->op_flags = flags | OPf_KIDS;
eb160463 3507 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 3508 logop->op_other = LINKLIST(trueop);
3509 logop->op_next = LINKLIST(falseop);
79072805 3510
463d09e6
RGS		 3511 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3512 logop);
79072805
LW		 3513
3514 /* establish postfix order */
1a67a97c
SM		 3515 start = LINKLIST(first);
3516 first->op_next = (OP*)logop;
79072805 3517
b1cb66bf 3518 first->op_sibling = trueop;
3519 trueop->op_sibling = falseop;
1a67a97c 3520 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 3521
1a67a97c 3522 trueop->op_next = falseop->op_next = o;
79072805 3523
1a67a97c 3524 o->op_next = start;
11343788 3525 return o;
79072805
LW		 3526}
3527
3528OP *
864dbfa3 3529Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 3530{
1a67a97c 3531 LOGOP *range;
79072805
LW		 3532 OP *flip;
3533 OP *flop;
1a67a97c 3534 OP *leftstart;
11343788 3535 OP *o;
79072805 3536
1a67a97c 3537 NewOp(1101, range, 1, LOGOP);
79072805 3538
1a67a97c
SM		 3539 range->op_type = OP_RANGE;
3540 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3541 range->op_first = left;
3542 range->op_flags = OPf_KIDS;
3543 leftstart = LINKLIST(left);
3544 range->op_other = LINKLIST(right);
eb160463 3545 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3546
3547 left->op_sibling = right;
3548
1a67a97c
SM		 3549 range->op_next = (OP*)range;
3550 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 3551 flop = newUNOP(OP_FLOP, 0, flip);
11343788 3552 o = newUNOP(OP_NULL, 0, flop);
79072805 3553 linklist(flop);
1a67a97c 3554 range->op_next = leftstart;
79072805
LW		 3555
3556 left->op_next = flip;
3557 right->op_next = flop;
3558
1a67a97c
SM		 3559 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3560 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 3561 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 3562 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3563
3564 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3565 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3566
11343788 3567 flip->op_next = o;
79072805 3568 if (!flip->op_private || !flop->op_private)
11343788 3569 linklist(o); /* blow off optimizer unless constant */
79072805 3570
11343788 3571 return o;
79072805
LW		 3572}
3573
3574OP *
864dbfa3 3575Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 3576{
463ee0b2 3577 OP* listop;
11343788 3578 OP* o;
463ee0b2 3579 int once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 3580 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
93a17b20 3581
463ee0b2
LW		 3582 if (expr) {
3583 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3584 return block; /* do {} while 0 does once */
fb73857a 3585 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3586 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 3587 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3588 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3589 } else if (expr->op_flags & OPf_KIDS) {
3590 OP *k1 = ((UNOP*)expr)->op_first;
3591 OP *k2 = (k1) ? k1->op_sibling : NULL;
3592 switch (expr->op_type) {
1c846c1f 3593 case OP_NULL:
55d729e4
GS		 3594 if (k2 && k2->op_type == OP_READLINE
3595 && (k2->op_flags & OPf_STACKED)
1c846c1f 3596 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3597 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3598 break;
55d729e4
GS		 3599
3600 case OP_SASSIGN:
3601 if (k1->op_type == OP_READDIR
3602 || k1->op_type == OP_GLOB
6531c3e6 3603 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3604 || k1->op_type == OP_EACH)
3605 expr = newUNOP(OP_DEFINED, 0, expr);
3606 break;
3607 }
774d564b 3608 }
463ee0b2 3609 }
93a17b20 3610
e1548254
RGS		 3611 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3612 * op, in listop. This is wrong. [perl #27024] */
3613 if (!block)
3614 block = newOP(OP_NULL, 0);
8990e307 3615 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 3616 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 3617
883ffac3
CS		 3618 if (listop)
3619 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 3620
11343788
MB		 3621 if (once && o != listop)
3622 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 3623
11343788
MB		 3624 if (o == listop)
3625 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 3626
11343788
MB		 3627 o->op_flags |= flags;
3628 o = scope(o);
3629 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3630 return o;
79072805
LW		 3631}
3632
3633OP *
864dbfa3 3634Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
79072805
LW		 3635{
3636 OP *redo;
3637 OP *next = 0;
3638 OP *listop;
11343788 3639 OP *o;
1ba6ee2b 3640 U8 loopflags = 0;
79072805 3641
fb73857a 3642 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3643 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
748a9306 3644 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3645 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3646 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3647 OP *k1 = ((UNOP*)expr)->op_first;
3648 OP *k2 = (k1) ? k1->op_sibling : NULL;
3649 switch (expr->op_type) {
1c846c1f 3650 case OP_NULL:
55d729e4
GS		 3651 if (k2 && k2->op_type == OP_READLINE
3652 && (k2->op_flags & OPf_STACKED)
1c846c1f 3653 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3654 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3655 break;
55d729e4
GS		 3656
3657 case OP_SASSIGN:
3658 if (k1->op_type == OP_READDIR
3659 || k1->op_type == OP_GLOB
72b16652 3660 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3661 || k1->op_type == OP_EACH)
3662 expr = newUNOP(OP_DEFINED, 0, expr);
3663 break;
3664 }
748a9306 3665 }
79072805
LW		 3666
3667 if (!block)
3668 block = newOP(OP_NULL, 0);
87246558
GS		 3669 else if (cont) {
3670 block = scope(block);
3671 }
79072805 3672
1ba6ee2b 3673 if (cont) {
79072805 3674 next = LINKLIST(cont);
1ba6ee2b 3675 }
fb73857a 3676 if (expr) {
85538317
GS		 3677 OP *unstack = newOP(OP_UNSTACK, 0);
3678 if (!next)
3679 next = unstack;
3680 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 3681 }
79072805 3682
463ee0b2 3683 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 3684 redo = LINKLIST(listop);
3685
3686 if (expr) {
eb160463 3687 PL_copline = (line_t)whileline;
883ffac3
CS		 3688 scalar(listop);
3689 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 3690 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 3691 op_free(expr); /* oops, it's a while (0) */
463ee0b2 3692 op_free((OP*)loop);
883ffac3 3693 return Nullop; /* listop already freed by new_logop */
463ee0b2 3694 }
883ffac3 3695 if (listop)
497b47a8 3696 ((LISTOP*)listop)->op_last->op_next =
883ffac3 3697 (o == listop ? redo : LINKLIST(o));
79072805
LW		 3698 }
3699 else
11343788 3700 o = listop;
79072805
LW		 3701
3702 if (!loop) {
b7dc083c 3703 NewOp(1101,loop,1,LOOP);
79072805 3704 loop->op_type = OP_ENTERLOOP;
22c35a8c 3705 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 3706 loop->op_private = 0;
3707 loop->op_next = (OP*)loop;
3708 }
3709
11343788 3710 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 3711
3712 loop->op_redoop = redo;
11343788 3713 loop->op_lastop = o;
1ba6ee2b 3714 o->op_private |= loopflags;
79072805
LW		 3715
3716 if (next)
3717 loop->op_nextop = next;
3718 else
11343788 3719 loop->op_nextop = o;
79072805 3720
11343788
MB		 3721 o->op_flags |= flags;
3722 o->op_private |= (flags >> 8);
3723 return o;
79072805
LW		 3724}
3725
3726OP *
864dbfa3 3727Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
79072805
LW		 3728{
3729 LOOP *loop;
fb73857a 3730 OP *wop;
4bbc6d12 3731 PADOFFSET padoff = 0;
4633a7c4 3732 I32 iterflags = 0;
241416b8 3733 I32 iterpflags = 0;
79072805 3734
79072805 3735 if (sv) {
85e6fe83 3736 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 3737 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 3738 sv->op_type = OP_RV2GV;
22c35a8c 3739 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
79072805 3740 }
85e6fe83 3741 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 3742 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 3743 padoff = sv->op_targ;
743e66e6 3744 sv->op_targ = 0;
85e6fe83
LW		 3745 op_free(sv);
3746 sv = Nullop;
3747 }
54b9620d
MB		 3748 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3749 padoff = sv->op_targ;
743e66e6 3750 sv->op_targ = 0;
54b9620d
MB		 3751 iterflags |= OPf_SPECIAL;
3752 op_free(sv);
3753 sv = Nullop;
3754 }
79072805 3755 else
cea2e8a9 3756 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
79072805
LW		 3757 }
3758 else {
aabe9514
RGS		 3759 I32 offset = pad_findmy("$_");
3760 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3761 sv = newGVOP(OP_GV, 0, PL_defgv);
3762 }
3763 else {
3764 padoff = offset;
aabe9514 3765 }
79072805 3766 }
5f05dabc 3767 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 3768 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 3769 iterflags |= OPf_STACKED;
3770 }
89ea2908
GA		 3771 else if (expr->op_type == OP_NULL &&
3772 (expr->op_flags & OPf_KIDS) &&
3773 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3774 {
3775 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3776 * set the STACKED flag to indicate that these values are to be
3777 * treated as min/max values by 'pp_iterinit'.
3778 */
3779 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
1a67a97c 3780 LOGOP* range = (LOGOP*) flip->op_first;
89ea2908
GA		 3781 OP* left = range->op_first;
3782 OP* right = left->op_sibling;
5152d7c7 3783 LISTOP* listop;
89ea2908
GA		 3784
3785 range->op_flags &= ~OPf_KIDS;
3786 range->op_first = Nullop;
3787
5152d7c7 3788 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 3789 listop->op_first->op_next = range->op_next;
3790 left->op_next = range->op_other;
5152d7c7
GS		 3791 right->op_next = (OP*)listop;
3792 listop->op_next = listop->op_first;
89ea2908
GA		 3793
3794 op_free(expr);
5152d7c7 3795 expr = (OP*)(listop);
93c66552 3796 op_null(expr);
89ea2908
GA		 3797 iterflags |= OPf_STACKED;
3798 }
3799 else {
3800 expr = mod(force_list(expr), OP_GREPSTART);
3801 }
3802
3803
4633a7c4 3804 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 3805 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 3806 assert(!loop->op_next);
241416b8 3807 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 3808 * for our $x () sets OPpOUR_INTRO */
c5661c80 3809 loop->op_private = (U8)iterpflags;
b7dc083c 3810#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 3811 {
3812 LOOP *tmp;
3813 NewOp(1234,tmp,1,LOOP);
3814 Copy(loop,tmp,1,LOOP);
238a4c30 3815 FreeOp(loop);
155aba94
GS		 3816 loop = tmp;
3817 }
b7dc083c 3818#else
85e6fe83 3819 Renew(loop, 1, LOOP);
1c846c1f 3820#endif
85e6fe83 3821 loop->op_targ = padoff;
fb73857a 3822 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3280af22 3823 PL_copline = forline;
fb73857a 3824 return newSTATEOP(0, label, wop);
79072805
LW		 3825}
3826
8990e307 3827OP*
864dbfa3 3828Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 3829{
11343788 3830 OP *o;
2d8e6c8d
GS		 3831 STRLEN n_a;
3832
8990e307 3833 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 3834 /* "last()" means "last" */
3835 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3836 o = newOP(type, OPf_SPECIAL);
3837 else {
3838 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
2d8e6c8d 3839 ? SvPVx(((SVOP*)label)->op_sv, n_a)
cdaebead
MB		 3840 : ""));
3841 }
8990e307
LW		 3842 op_free(label);
3843 }
3844 else {
e3aba57a
RGS		 3845 /* Check whether it's going to be a goto &function */
3846 if (label->op_type == OP_ENTERSUB
3847 && !(label->op_flags & OPf_STACKED))
a0d0e21e 3848 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 3849 o = newUNOP(type, OPf_STACKED, label);
8990e307 3850 }
3280af22 3851 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3852 return o;
8990e307
LW		 3853}
3854
7dafbf52
DM		 3855/*
3856=for apidoc cv_undef
3857
3858Clear out all the active components of a CV. This can happen either
3859by an explicit C<undef &foo>, or by the reference count going to zero.
3860In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3861children can still follow the full lexical scope chain.
3862
3863=cut
3864*/
3865
79072805 3866void
864dbfa3 3867Perl_cv_undef(pTHX_ CV *cv)
79072805 3868{
a636914a 3869#ifdef USE_ITHREADS
35f1c1c7
SB		 3870 if (CvFILE(cv) && !CvXSUB(cv)) {
3871 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 3872 Safefree(CvFILE(cv));
a636914a 3873 }
f3e31eb5 3874 CvFILE(cv) = 0;
a636914a
RH		 3875#endif
3876
a0d0e21e
LW		 3877 if (!CvXSUB(cv) && CvROOT(cv)) {
3878 if (CvDEPTH(cv))
cea2e8a9 3879 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 3880 ENTER;
a0d0e21e 3881
f3548bdc 3882 PAD_SAVE_SETNULLPAD();
a0d0e21e 3883
282f25c9 3884 op_free(CvROOT(cv));
79072805 3885 CvROOT(cv) = Nullop;
8990e307 3886 LEAVE;
79072805 3887 }
1d5db326 3888 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 3889 CvGV(cv) = Nullgv;
a3985cdc
DM		 3890
3891 pad_undef(cv);
3892
7dafbf52
DM		 3893 /* remove CvOUTSIDE unless this is an undef rather than a free */
3894 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3895 if (!CvWEAKOUTSIDE(cv))
3896 SvREFCNT_dec(CvOUTSIDE(cv));
3897 CvOUTSIDE(cv) = Nullcv;
3898 }
beab0874
JT		 3899 if (CvCONST(cv)) {
3900 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3901 CvCONST_off(cv);
3902 }
50762d59
DM		 3903 if (CvXSUB(cv)) {
3904 CvXSUB(cv) = 0;
3905 }
7dafbf52
DM		 3906 /* delete all flags except WEAKOUTSIDE */
3907 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 3908}
3909
3fe9a6f1 3910void
864dbfa3 3911Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 3912{
e476b1b5 3913 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 3914 SV* msg = sv_newmortal();
3fe9a6f1 3915 SV* name = Nullsv;
3916
3917 if (gv)
46fc3d4c 3918 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3919 sv_setpv(msg, "Prototype mismatch:");
3920 if (name)
894356b3 3921 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 3922 if (SvPOK(cv))
35c1215d 3923 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
ebe643b9
RGS		 3924 else
3925 Perl_sv_catpvf(aTHX_ msg, ": none");
46fc3d4c 3926 sv_catpv(msg, " vs ");
3927 if (p)
cea2e8a9 3928 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 3929 else
3930 sv_catpv(msg, "none");
9014280d 3931 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3fe9a6f1 3932 }
3933}
3934
35f1c1c7
SB		 3935static void const_sv_xsub(pTHX_ CV* cv);
3936
beab0874 3937/*
ccfc67b7
JH		 3938
3939=head1 Optree Manipulation Functions
3940
beab0874
JT		 3941=for apidoc cv_const_sv
3942
3943If C<cv> is a constant sub eligible for inlining. returns the constant
3944value returned by the sub. Otherwise, returns NULL.
3945
3946Constant subs can be created with C<newCONSTSUB> or as described in
3947L<perlsub/"Constant Functions">.
3948
3949=cut
3950*/
760ac839 3951SV *
864dbfa3 3952Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 3953{
beab0874 3954 if (!cv || !CvCONST(cv))
54310121 3955 return Nullsv;
beab0874 3956 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 3957}
760ac839 3958
b5c19bd7
DM		 3959/* op_const_sv: examine an optree to determine whether it's in-lineable.
3960 * Can be called in 3 ways:
3961 *
3962 * !cv
3963 * look for a single OP_CONST with attached value: return the value
3964 *
3965 * cv && CvCLONE(cv) && !CvCONST(cv)
3966 *
3967 * examine the clone prototype, and if contains only a single
3968 * OP_CONST referencing a pad const, or a single PADSV referencing
3969 * an outer lexical, return a non-zero value to indicate the CV is
3970 * a candidate for "constizing" at clone time
3971 *
3972 * cv && CvCONST(cv)
3973 *
3974 * We have just cloned an anon prototype that was marked as a const
3975 * candidiate. Try to grab the current value, and in the case of
3976 * PADSV, ignore it if it has multiple references. Return the value.
3977 */
3978
fe5e78ed 3979SV *
864dbfa3 3980Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 3981{
3982 SV *sv = Nullsv;
3983
0f79a09d 3984 if (!o)
fe5e78ed 3985 return Nullsv;
1c846c1f
NIS		 3986
3987 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 3988 o = cLISTOPo->op_first->op_sibling;
3989
3990 for (; o; o = o->op_next) {
54310121 3991 OPCODE type = o->op_type;
fe5e78ed 3992
1c846c1f 3993 if (sv && o->op_next == o)
fe5e78ed 3994 return sv;
e576b457
JT		 3995 if (o->op_next != o) {
3996 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3997 continue;
3998 if (type == OP_DBSTATE)
3999 continue;
4000 }
54310121 4001 if (type == OP_LEAVESUB || type == OP_RETURN)
4002 break;
4003 if (sv)
4004 return Nullsv;
7766f137 4005 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 4006 sv = cSVOPo->op_sv;
b5c19bd7 4007 else if (cv && type == OP_CONST) {
dd2155a4 4008 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874
JT		 4009 if (!sv)
4010 return Nullsv;
b5c19bd7
DM		 4011 }
4012 else if (cv && type == OP_PADSV) {
4013 if (CvCONST(cv)) { /* newly cloned anon */
4014 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4015 /* the candidate should have 1 ref from this pad and 1 ref
4016 * from the parent */
4017 if (!sv || SvREFCNT(sv) != 2)
4018 return Nullsv;
beab0874 4019 sv = newSVsv(sv);
b5c19bd7
DM		 4020 SvREADONLY_on(sv);
4021 return sv;
4022 }
4023 else {
4024 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4025 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 4026 }
760ac839 4027 }
b5c19bd7 4028 else {
54310121 4029 return Nullsv;
b5c19bd7 4030 }
760ac839
LW		 4031 }
4032 return sv;
4033}
4034
09bef843
SB		 4035void
4036Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4037{
4038 if (o)
4039 SAVEFREEOP(o);
4040 if (proto)
4041 SAVEFREEOP(proto);
4042 if (attrs)
4043 SAVEFREEOP(attrs);
4044 if (block)
4045 SAVEFREEOP(block);
4046 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4047}
4048
748a9306 4049CV *
864dbfa3 4050Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 4051{
09bef843
SB		 4052 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4053}
4054
4055CV *
4056Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4057{
2d8e6c8d 4058 STRLEN n_a;
83ee9e09
GS		 4059 char *name;
4060 char *aname;
4061 GV *gv;
2d8e6c8d 4062 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 4063 register CV *cv=0;
beab0874 4064 SV *const_sv;
79072805 4065
83ee9e09
GS		 4066 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4067 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4068 SV *sv = sv_newmortal();
c99da370
JH		 4069 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4070 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09
GS		 4071 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4072 aname = SvPVX(sv);
4073 }
4074 else
4075 aname = Nullch;
c99da370
JH		 4076 gv = gv_fetchpv(name ? name : (aname ? aname :
4077 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
83ee9e09
GS		 4078 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4079 SVt_PVCV);
4080
11343788 4081 if (o)
5dc0d613 4082 SAVEFREEOP(o);
3fe9a6f1 4083 if (proto)
4084 SAVEFREEOP(proto);
09bef843
SB		 4085 if (attrs)
4086 SAVEFREEOP(attrs);
3fe9a6f1 4087
09bef843 4088 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4089 maximum a prototype before. */
4090 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4091 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4092 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4093 {
9014280d 4094 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 4095 }
55d729e4
GS		 4096 cv_ckproto((CV*)gv, NULL, ps);
4097 }
4098 if (ps)
4099 sv_setpv((SV*)gv, ps);
4100 else
4101 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4102 SvREFCNT_dec(PL_compcv);
4103 cv = PL_compcv = NULL;
4104 PL_sub_generation++;
beab0874 4105 goto done;
55d729e4
GS		 4106 }
4107
beab0874
JT		 4108 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4109
7fb37951
AMS		 4110#ifdef GV_UNIQUE_CHECK
4111 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4112 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4113 }
4114#endif
4115
beab0874
JT		 4116 if (!block || !ps || *ps || attrs)
4117 const_sv = Nullsv;
4118 else
4119 const_sv = op_const_sv(block, Nullcv);
4120
4121 if (cv) {
60ed1d8c 4122 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4123
7fb37951
AMS		 4124#ifdef GV_UNIQUE_CHECK
4125 if (exists && GvUNIQUE(gv)) {
4126 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4127 }
4128#endif
4129
60ed1d8c
GS		 4130 /* if the subroutine doesn't exist and wasn't pre-declared
4131 * with a prototype, assume it will be AUTOLOADed,
4132 * skipping the prototype check
4133 */
4134 if (exists || SvPOK(cv))
01ec43d0 4135 cv_ckproto(cv, gv, ps);
68dc0745 4136 /* already defined (or promised)? */
60ed1d8c 4137 if (exists || GvASSUMECV(gv)) {
09bef843 4138 if (!block && !attrs) {
d3cea301
SB		 4139 if (CvFLAGS(PL_compcv)) {
4140 /* might have had built-in attrs applied */
4141 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4142 }
aa689395 4143 /* just a "sub foo;" when &foo is already defined */
3280af22 4144 SAVEFREESV(PL_compcv);
aa689395 4145 goto done;
4146 }
7bac28a0 4147 /* ahem, death to those who redefine active sort subs */
3280af22 4148 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4149 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4150 if (block) {
4151 if (ckWARN(WARN_REDEFINE)
4152 || (CvCONST(cv)
4153 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4154 {
4155 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4156 if (PL_copline != NOLINE)
4157 CopLINE_set(PL_curcop, PL_copline);
9014280d 4158 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4159 CvCONST(cv) ? "Constant subroutine %s redefined"
4160 : "Subroutine %s redefined", name);
4161 CopLINE_set(PL_curcop, oldline);
4162 }
4163 SvREFCNT_dec(cv);
4164 cv = Nullcv;
79072805 4165 }
79072805
LW		 4166 }
4167 }
beab0874
JT		 4168 if (const_sv) {
4169 SvREFCNT_inc(const_sv);
4170 if (cv) {
0768512c 4171 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4172 sv_setpv((SV*)cv, ""); /* prototype is "" */
4173 CvXSUBANY(cv).any_ptr = const_sv;
4174 CvXSUB(cv) = const_sv_xsub;
4175 CvCONST_on(cv);
beab0874
JT		 4176 }
4177 else {
4178 GvCV(gv) = Nullcv;
4179 cv = newCONSTSUB(NULL, name, const_sv);
4180 }
4181 op_free(block);
4182 SvREFCNT_dec(PL_compcv);
4183 PL_compcv = NULL;
4184 PL_sub_generation++;
4185 goto done;
4186 }
09bef843
SB		 4187 if (attrs) {
4188 HV *stash;
4189 SV *rcv;
4190
4191 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4192 * before we clobber PL_compcv.
4193 */
4194 if (cv && !block) {
4195 rcv = (SV*)cv;
020f0e03
SB		 4196 /* Might have had built-in attributes applied -- propagate them. */
4197 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4198 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4199 stash = GvSTASH(CvGV(cv));
a9164de8 4200 else if (CvSTASH(cv))
09bef843
SB		 4201 stash = CvSTASH(cv);
4202 else
4203 stash = PL_curstash;
4204 }
4205 else {
4206 /* possibly about to re-define existing subr -- ignore old cv */
4207 rcv = (SV*)PL_compcv;
a9164de8 4208 if (name && GvSTASH(gv))
09bef843
SB		 4209 stash = GvSTASH(gv);
4210 else
4211 stash = PL_curstash;
4212 }
95f0a2f1 4213 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4214 }
a0d0e21e 4215 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4216 if (!block) {
4217 /* got here with just attrs -- work done, so bug out */
4218 SAVEFREESV(PL_compcv);
4219 goto done;
4220 }
a3985cdc 4221 /* transfer PL_compcv to cv */
4633a7c4 4222 cv_undef(cv);
3280af22 4223 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5c41a5fa
DM		 4224 if (!CvWEAKOUTSIDE(cv))
4225 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 4226 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 4227 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 4228 CvOUTSIDE(PL_compcv) = 0;
4229 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4230 CvPADLIST(PL_compcv) = 0;
282f25c9 4231 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 4232 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 4233 /* ... before we throw it away */
3280af22 4234 SvREFCNT_dec(PL_compcv);
b5c19bd7 4235 PL_compcv = cv;
a933f601
IZ		 4236 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4237 ++PL_sub_generation;
a0d0e21e
LW		 4238 }
4239 else {
3280af22 4240 cv = PL_compcv;
44a8e56a 4241 if (name) {
4242 GvCV(gv) = cv;
4243 GvCVGEN(gv) = 0;
3280af22 4244 PL_sub_generation++;
44a8e56a 4245 }
a0d0e21e 4246 }
65c50114 4247 CvGV(cv) = gv;
a636914a 4248 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4249 CvSTASH(cv) = PL_curstash;
8990e307 4250
3fe9a6f1 4251 if (ps)
4252 sv_setpv((SV*)cv, ps);
4633a7c4 4253
3280af22 4254 if (PL_error_count) {
c07a80fd 4255 op_free(block);
4256 block = Nullop;
68dc0745 4257 if (name) {
4258 char *s = strrchr(name, ':');
4259 s = s ? s+1 : name;
6d4c2119
CS		 4260 if (strEQ(s, "BEGIN")) {
4261 char *not_safe =
4262 "BEGIN not safe after errors--compilation aborted";
faef0170 4263 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4264 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4265 else {
4266 /* force display of errors found but not reported */
38a03e6e 4267 sv_catpv(ERRSV, not_safe);
35c1215d 4268 Perl_croak(aTHX_ "%"SVf, ERRSV);
6d4c2119
CS		 4269 }
4270 }
68dc0745 4271 }
c07a80fd 4272 }
beab0874
JT		 4273 if (!block)
4274 goto done;
a0d0e21e 4275
7766f137 4276 if (CvLVALUE(cv)) {
78f9721b
SM		 4277 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4278 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4279 }
4280 else {
09c2fd24
AE		 4281 /* This makes sub {}; work as expected. */
4282 if (block->op_type == OP_STUB) {
4283 op_free(block);
4284 block = newSTATEOP(0, Nullch, 0);
4285 }
7766f137
GS		 4286 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4287 }
4288 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4289 OpREFCNT_set(CvROOT(cv), 1);
4290 CvSTART(cv) = LINKLIST(CvROOT(cv));
4291 CvROOT(cv)->op_next = 0;
a2efc822 4292 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4293
4294 /* now that optimizer has done its work, adjust pad values */
54310121 4295
dd2155a4
DM		 4296 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4297
4298 if (CvCLONE(cv)) {
beab0874
JT		 4299 assert(!CvCONST(cv));
4300 if (ps && !*ps && op_const_sv(block, cv))
4301 CvCONST_on(cv);
a0d0e21e 4302 }
79072805 4303
83ee9e09 4304 if (name || aname) {
44a8e56a 4305 char *s;
83ee9e09 4306 char *tname = (name ? name : aname);
44a8e56a 4307
3280af22 4308 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 4309 SV *sv = NEWSV(0,0);
44a8e56a 4310 SV *tmpstr = sv_newmortal();
549bb64a 4311 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 4312 CV *pcv;
44a8e56a 4313 HV *hv;
4314
ed094faf
GS		 4315 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4316 CopFILE(PL_curcop),
cc49e20b 4317 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4318 gv_efullname3(tmpstr, gv, Nullch);
3280af22 4319 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4320 hv = GvHVn(db_postponed);
9607fc9c 4321 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 4322 && (pcv = GvCV(db_postponed)))
4323 {
44a8e56a 4324 dSP;
924508f0 4325 PUSHMARK(SP);
44a8e56a 4326 XPUSHs(tmpstr);
4327 PUTBACK;
83ee9e09 4328 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 4329 }
4330 }
79072805 4331
83ee9e09 4332 if ((s = strrchr(tname,':')))
28757baa 4333 s++;
4334 else
83ee9e09 4335 s = tname;
ed094faf 4336
7d30b5c4 4337 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4338 goto done;
4339
7678c486 4340 if (strEQ(s, "BEGIN") && !PL_error_count) {
3280af22 4341 I32 oldscope = PL_scopestack_ix;
28757baa 4342 ENTER;
57843af0
GS		 4343 SAVECOPFILE(&PL_compiling);
4344 SAVECOPLINE(&PL_compiling);
28757baa 4345
3280af22
NIS		 4346 if (!PL_beginav)
4347 PL_beginav = newAV();
28757baa 4348 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4349 av_push(PL_beginav, (SV*)cv);
4350 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4351 call_list(oldscope, PL_beginav);
a6006777 4352
3280af22 4353 PL_curcop = &PL_compiling;
eb160463 4354 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
28757baa 4355 LEAVE;
4356 }
3280af22
NIS		 4357 else if (strEQ(s, "END") && !PL_error_count) {
4358 if (!PL_endav)
4359 PL_endav = newAV();
ed094faf 4360 DEBUG_x( dump_sub(gv) );
3280af22 4361 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4362 av_store(PL_endav, 0, (SV*)cv);
4363 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4364 }
7d30b5c4
GS		 4365 else if (strEQ(s, "CHECK") && !PL_error_count) {
4366 if (!PL_checkav)
4367 PL_checkav = newAV();
ed094faf 4368 DEBUG_x( dump_sub(gv) );
ddda08b7 4369 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4370 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4371 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4372 av_store(PL_checkav, 0, (SV*)cv);
4373 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4374 }
3280af22
NIS		 4375 else if (strEQ(s, "INIT") && !PL_error_count) {
4376 if (!PL_initav)
4377 PL_initav = newAV();
ed094faf 4378 DEBUG_x( dump_sub(gv) );
ddda08b7 4379 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4380 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4381 av_push(PL_initav, (SV*)cv);
4382 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4383 }
79072805 4384 }
a6006777 4385
aa689395 4386 done:
3280af22 4387 PL_copline = NOLINE;
8990e307 4388 LEAVE_SCOPE(floor);
a0d0e21e 4389 return cv;
79072805
LW		 4390}
4391
b099ddc0 4392/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4393/*
4394=for apidoc newCONSTSUB
4395
4396Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4397eligible for inlining at compile-time.
4398
4399=cut
4400*/
4401
beab0874 4402CV *
864dbfa3 4403Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 4404{
beab0874 4405 CV* cv;
5476c433 4406
11faa288 4407 ENTER;
11faa288 4408
f4dd75d9 4409 SAVECOPLINE(PL_curcop);
11faa288 4410 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4411
4412 SAVEHINTS();
3280af22 4413 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4414
4415 if (stash) {
4416 SAVESPTR(PL_curstash);
4417 SAVECOPSTASH(PL_curcop);
4418 PL_curstash = stash;
05ec9bb3 4419 CopSTASH_set(PL_curcop,stash);
11faa288 4420 }
5476c433 4421
91a15d0d 4422 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
beab0874
JT		 4423 CvXSUBANY(cv).any_ptr = sv;
4424 CvCONST_on(cv);
4425 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 4426
02f28d44
MHM		 4427 if (stash)
4428 CopSTASH_free(PL_curcop);
4429
11faa288 4430 LEAVE;
beab0874
JT		 4431
4432 return cv;
5476c433
JD		 4433}
4434
954c1994
GS		 4435/*
4436=for apidoc U||newXS
4437
4438Used by C<xsubpp> to hook up XSUBs as Perl subs.
4439
4440=cut
4441*/
4442
57d3b86d 4443CV *
864dbfa3 4444Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 4445{
c99da370
JH		 4446 GV *gv = gv_fetchpv(name ? name :
4447 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4448 GV_ADDMULTI, SVt_PVCV);
79072805 4449 register CV *cv;
44a8e56a 4450
1ecdd9a8
HS		 4451 if (!subaddr)
4452 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4453
155aba94 4454 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4455 if (GvCVGEN(gv)) {
4456 /* just a cached method */
4457 SvREFCNT_dec(cv);
4458 cv = 0;
4459 }
4460 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4461 /* already defined (or promised) */
599cee73 4462 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4 4463 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 4464 line_t oldline = CopLINE(PL_curcop);
51f6edd3 4465 if (PL_copline != NOLINE)
57843af0 4466 CopLINE_set(PL_curcop, PL_copline);
9014280d 4467 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4468 CvCONST(cv) ? "Constant subroutine %s redefined"
4469 : "Subroutine %s redefined"
4470 ,name);
57843af0 4471 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 4472 }
4473 SvREFCNT_dec(cv);
4474 cv = 0;
79072805 4475 }
79072805 4476 }
44a8e56a 4477
4478 if (cv) /* must reuse cv if autoloaded */
4479 cv_undef(cv);
a0d0e21e
LW		 4480 else {
4481 cv = (CV*)NEWSV(1105,0);
4482 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 4483 if (name) {
4484 GvCV(gv) = cv;
4485 GvCVGEN(gv) = 0;
3280af22 4486 PL_sub_generation++;
44a8e56a 4487 }
a0d0e21e 4488 }
65c50114 4489 CvGV(cv) = gv;
b195d487 4490 (void)gv_fetchfile(filename);
57843af0
GS		 4491 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4492 an external constant string */
a0d0e21e 4493 CvXSUB(cv) = subaddr;
44a8e56a 4494
28757baa 4495 if (name) {
4496 char *s = strrchr(name,':');
4497 if (s)
4498 s++;
4499 else
4500 s = name;
ed094faf 4501
7d30b5c4 4502 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4503 goto done;
4504
28757baa 4505 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 4506 if (!PL_beginav)
4507 PL_beginav = newAV();
ea2f84a3
GS		 4508 av_push(PL_beginav, (SV*)cv);
4509 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4510 }
4511 else if (strEQ(s, "END")) {
3280af22
NIS		 4512 if (!PL_endav)
4513 PL_endav = newAV();
4514 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4515 av_store(PL_endav, 0, (SV*)cv);
4516 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4517 }
7d30b5c4
GS		 4518 else if (strEQ(s, "CHECK")) {
4519 if (!PL_checkav)
4520 PL_checkav = newAV();
ddda08b7 4521 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4522 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4523 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4524 av_store(PL_checkav, 0, (SV*)cv);
4525 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4526 }
7d07dbc2 4527 else if (strEQ(s, "INIT")) {
3280af22
NIS		 4528 if (!PL_initav)
4529 PL_initav = newAV();
ddda08b7 4530 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4531 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4532 av_push(PL_initav, (SV*)cv);
4533 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4534 }
28757baa 4535 }
8990e307 4536 else
a5f75d66 4537 CvANON_on(cv);
44a8e56a 4538
ed094faf 4539done:
a0d0e21e 4540 return cv;
79072805
LW		 4541}
4542
4543void
864dbfa3 4544Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 4545{
4546 register CV *cv;
4547 char *name;
4548 GV *gv;
2d8e6c8d 4549 STRLEN n_a;
79072805 4550
11343788 4551 if (o)
2d8e6c8d 4552 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 4553 else
4554 name = "STDOUT";
85e6fe83 4555 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
7fb37951
AMS		 4556#ifdef GV_UNIQUE_CHECK
4557 if (GvUNIQUE(gv)) {
4558 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 4559 }
4560#endif
a5f75d66 4561 GvMULTI_on(gv);
155aba94 4562 if ((cv = GvFORM(gv))) {
599cee73 4563 if (ckWARN(WARN_REDEFINE)) {
57843af0 4564 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4565 if (PL_copline != NOLINE)
4566 CopLINE_set(PL_curcop, PL_copline);
9014280d 4567 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
57843af0 4568 CopLINE_set(PL_curcop, oldline);
79072805 4569 }
8990e307 4570 SvREFCNT_dec(cv);
79072805 4571 }
3280af22 4572 cv = PL_compcv;
79072805 4573 GvFORM(gv) = cv;
65c50114 4574 CvGV(cv) = gv;
a636914a 4575 CvFILE_set_from_cop(cv, PL_curcop);
79072805 4576
a0d0e21e 4577
dd2155a4 4578 pad_tidy(padtidy_FORMAT);
79072805 4579 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 4580 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4581 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 4582 CvSTART(cv) = LINKLIST(CvROOT(cv));
4583 CvROOT(cv)->op_next = 0;
a2efc822 4584 CALL_PEEP(CvSTART(cv));
11343788 4585 op_free(o);
3280af22 4586 PL_copline = NOLINE;
8990e307 4587 LEAVE_SCOPE(floor);
79072805
LW		 4588}
4589
4590OP *
864dbfa3 4591Perl_newANONLIST(pTHX_ OP *o)
79072805 4592{
93a17b20 4593 return newUNOP(OP_REFGEN, 0,
11343788 4594 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 4595}
4596
4597OP *
864dbfa3 4598Perl_newANONHASH(pTHX_ OP *o)
79072805 4599{
93a17b20 4600 return newUNOP(OP_REFGEN, 0,
11343788 4601 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 4602}
4603
4604OP *
864dbfa3 4605Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 4606{
09bef843
SB		 4607 return newANONATTRSUB(floor, proto, Nullop, block);
4608}
4609
4610OP *
4611Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4612{
a0d0e21e 4613 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 4614 newSVOP(OP_ANONCODE, 0,
4615 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 4616}
4617
4618OP *
864dbfa3 4619Perl_oopsAV(pTHX_ OP *o)
79072805 4620{
ed6116ce
LW		 4621 switch (o->op_type) {
4622 case OP_PADSV:
4623 o->op_type = OP_PADAV;
22c35a8c 4624 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 4625 return ref(o, OP_RV2AV);
b2ffa427 4626
ed6116ce 4627 case OP_RV2SV:
79072805 4628 o->op_type = OP_RV2AV;
22c35a8c 4629 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 4630 ref(o, OP_RV2AV);
ed6116ce
LW		 4631 break;
4632
4633 default:
0453d815 4634 if (ckWARN_d(WARN_INTERNAL))
9014280d 4635 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 4636 break;
4637 }
79072805
LW		 4638 return o;
4639}
4640
4641OP *
864dbfa3 4642Perl_oopsHV(pTHX_ OP *o)
79072805 4643{
ed6116ce
LW		 4644 switch (o->op_type) {
4645 case OP_PADSV:
4646 case OP_PADAV:
4647 o->op_type = OP_PADHV;
22c35a8c 4648 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 4649 return ref(o, OP_RV2HV);
ed6116ce
LW		 4650
4651 case OP_RV2SV:
4652 case OP_RV2AV:
79072805 4653 o->op_type = OP_RV2HV;
22c35a8c 4654 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 4655 ref(o, OP_RV2HV);
ed6116ce
LW		 4656 break;
4657
4658 default:
0453d815 4659 if (ckWARN_d(WARN_INTERNAL))
9014280d 4660 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 4661 break;
4662 }
79072805
LW		 4663 return o;
4664}
4665
4666OP *
864dbfa3 4667Perl_newAVREF(pTHX_ OP *o)
79072805 4668{
ed6116ce
LW		 4669 if (o->op_type == OP_PADANY) {
4670 o->op_type = OP_PADAV;
22c35a8c 4671 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 4672 return o;
ed6116ce 4673 }
a1063b2d 4674 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 4675 && ckWARN(WARN_DEPRECATED)) {
4676 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4677 "Using an array as a reference is deprecated");
4678 }
79072805
LW		 4679 return newUNOP(OP_RV2AV, 0, scalar(o));
4680}
4681
4682OP *
864dbfa3 4683Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 4684{
82092f1d 4685 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 4686 return newUNOP(OP_NULL, 0, o);
748a9306 4687 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 4688}
4689
4690OP *
864dbfa3 4691Perl_newHVREF(pTHX_ OP *o)
79072805 4692{
ed6116ce
LW		 4693 if (o->op_type == OP_PADANY) {
4694 o->op_type = OP_PADHV;
22c35a8c 4695 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 4696 return o;
ed6116ce 4697 }
a1063b2d 4698 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 4699 && ckWARN(WARN_DEPRECATED)) {
4700 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4701 "Using a hash as a reference is deprecated");
4702 }
79072805
LW		 4703 return newUNOP(OP_RV2HV, 0, scalar(o));
4704}
4705
4706OP *
864dbfa3 4707Perl_oopsCV(pTHX_ OP *o)
79072805 4708{
cea2e8a9 4709 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 4710 /* STUB */
4711 return o;
4712}
4713
4714OP *
864dbfa3 4715Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 4716{
c07a80fd 4717 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 4718}
4719
4720OP *
864dbfa3 4721Perl_newSVREF(pTHX_ OP *o)
79072805 4722{
ed6116ce
LW		 4723 if (o->op_type == OP_PADANY) {
4724 o->op_type = OP_PADSV;
22c35a8c 4725 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 4726 return o;
ed6116ce 4727 }
224a4551
MB		 4728 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4729 o->op_flags |= OPpDONE_SVREF;
a863c7d1 4730 return o;
224a4551 4731 }
79072805
LW		 4732 return newUNOP(OP_RV2SV, 0, scalar(o));
4733}
4734
4735/* Check routines. */
4736
4737OP *
cea2e8a9 4738Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 4739{
dd2155a4 4740 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5dc0d613 4741 cSVOPo->op_sv = Nullsv;
5dc0d613 4742 return o;
5f05dabc 4743}
4744
4745OP *
cea2e8a9 4746Perl_ck_bitop(pTHX_ OP *o)
55497cff 4747{
276b2a0c
RGS		 4748#define OP_IS_NUMCOMPARE(op) \
4749 ((op) == OP_LT || (op) == OP_I_LT || \
4750 (op) == OP_GT || (op) == OP_I_GT || \
4751 (op) == OP_LE || (op) == OP_I_LE || \
4752 (op) == OP_GE || (op) == OP_I_GE || \
4753 (op) == OP_EQ || (op) == OP_I_EQ || \
4754 (op) == OP_NE || (op) == OP_I_NE || \
4755 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 4756 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2b84528b
RGS		 4757 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4758 && (o->op_type == OP_BIT_OR
4759 || o->op_type == OP_BIT_AND
4760 || o->op_type == OP_BIT_XOR))
276b2a0c 4761 {
96a925ab
YST		 4762 OP * left = cBINOPo->op_first;
4763 OP * right = left->op_sibling;
4764 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4765 (left->op_flags & OPf_PARENS) == 0) ||
4766 (OP_IS_NUMCOMPARE(right->op_type) &&
4767 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 4768 if (ckWARN(WARN_PRECEDENCE))
4769 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4770 "Possible precedence problem on bitwise %c operator",
4771 o->op_type == OP_BIT_OR ? '|'
4772 : o->op_type == OP_BIT_AND ? '&' : '^'
4773 );
4774 }
5dc0d613 4775 return o;
55497cff 4776}
4777
4778OP *
cea2e8a9 4779Perl_ck_concat(pTHX_ OP *o)
79072805 4780{
0165acc7 4781 OP *kid = cUNOPo->op_first;
df91b2c5
AE		 4782 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4783 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 4784 o->op_flags |= OPf_STACKED;
11343788 4785 return o;
79072805
LW		 4786}
4787
4788OP *
cea2e8a9 4789Perl_ck_spair(pTHX_ OP *o)
79072805 4790{
11343788 4791 if (o->op_flags & OPf_KIDS) {
79072805 4792 OP* newop;
a0d0e21e 4793 OP* kid;
5dc0d613
MB		 4794 OPCODE type = o->op_type;
4795 o = modkids(ck_fun(o), type);
11343788 4796 kid = cUNOPo->op_first;
a0d0e21e
LW		 4797 newop = kUNOP->op_first->op_sibling;
4798 if (newop &&
4799 (newop->op_sibling ||
22c35a8c 4800 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 4801 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4802 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 4803
11343788 4804 return o;
a0d0e21e
LW		 4805 }
4806 op_free(kUNOP->op_first);
4807 kUNOP->op_first = newop;
4808 }
22c35a8c 4809 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 4810 return ck_fun(o);
a0d0e21e
LW		 4811}
4812
4813OP *
cea2e8a9 4814Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 4815{
11343788 4816 o = ck_fun(o);
5dc0d613 4817 o->op_private = 0;
11343788
MB		 4818 if (o->op_flags & OPf_KIDS) {
4819 OP *kid = cUNOPo->op_first;
01020589
GS		 4820 switch (kid->op_type) {
4821 case OP_ASLICE:
4822 o->op_flags |= OPf_SPECIAL;
4823 /* FALL THROUGH */
4824 case OP_HSLICE:
5dc0d613 4825 o->op_private |= OPpSLICE;
01020589
GS		 4826 break;
4827 case OP_AELEM:
4828 o->op_flags |= OPf_SPECIAL;
4829 /* FALL THROUGH */
4830 case OP_HELEM:
4831 break;
4832 default:
4833 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 4834 OP_DESC(o));
01020589 4835 }
93c66552 4836 op_null(kid);
79072805 4837 }
11343788 4838 return o;
79072805
LW		 4839}
4840
4841OP *
96e176bf
CL		 4842Perl_ck_die(pTHX_ OP *o)
4843{
4844#ifdef VMS
4845 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4846#endif
4847 return ck_fun(o);
4848}
4849
4850OP *
cea2e8a9 4851Perl_ck_eof(pTHX_ OP *o)
79072805 4852{
11343788 4853 I32 type = o->op_type;
79072805 4854
11343788
MB		 4855 if (o->op_flags & OPf_KIDS) {
4856 if (cLISTOPo->op_first->op_type == OP_STUB) {
4857 op_free(o);
8fde6460 4858 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8990e307 4859 }
11343788 4860 return ck_fun(o);
79072805 4861 }
11343788 4862 return o;
79072805
LW		 4863}
4864
4865OP *
cea2e8a9 4866Perl_ck_eval(pTHX_ OP *o)
79072805 4867{
3280af22 4868 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 4869 if (o->op_flags & OPf_KIDS) {
4870 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 4871
93a17b20 4872 if (!kid) {
11343788 4873 o->op_flags &= ~OPf_KIDS;
93c66552 4874 op_null(o);
79072805 4875 }
b14574b4 4876 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 4877 LOGOP *enter;
4878
11343788
MB		 4879 cUNOPo->op_first = 0;
4880 op_free(o);
79072805 4881
b7dc083c 4882 NewOp(1101, enter, 1, LOGOP);
79072805 4883 enter->op_type = OP_ENTERTRY;
22c35a8c 4884 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 4885 enter->op_private = 0;
4886
4887 /* establish postfix order */
4888 enter->op_next = (OP*)enter;
4889
11343788
MB		 4890 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4891 o->op_type = OP_LEAVETRY;
22c35a8c 4892 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 4893 enter->op_other = o;
4894 return o;
79072805 4895 }
b5c19bd7 4896 else {
473986ff 4897 scalar((OP*)kid);
b5c19bd7
DM		 4898 PL_cv_has_eval = 1;
4899 }
79072805
LW		 4900 }
4901 else {
11343788 4902 op_free(o);
54b9620d 4903 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 4904 }
3280af22 4905 o->op_targ = (PADOFFSET)PL_hints;
11343788 4906 return o;
79072805
LW		 4907}
4908
4909OP *
d98f61e7
GS		 4910Perl_ck_exit(pTHX_ OP *o)
4911{
4912#ifdef VMS
4913 HV *table = GvHV(PL_hintgv);
4914 if (table) {
4915 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4916 if (svp && *svp && SvTRUE(*svp))
4917 o->op_private |= OPpEXIT_VMSISH;
4918 }
96e176bf 4919 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 4920#endif
4921 return ck_fun(o);
4922}
4923
4924OP *
cea2e8a9 4925Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 4926{
4927 OP *kid;
11343788
MB		 4928 if (o->op_flags & OPf_STACKED) {
4929 o = ck_fun(o);
4930 kid = cUNOPo->op_first->op_sibling;
8990e307 4931 if (kid->op_type == OP_RV2GV)
93c66552 4932 op_null(kid);
79072805 4933 }
463ee0b2 4934 else
11343788
MB		 4935 o = listkids(o);
4936 return o;
79072805
LW		 4937}
4938
4939OP *
cea2e8a9 4940Perl_ck_exists(pTHX_ OP *o)
5f05dabc 4941{
5196be3e
MB		 4942 o = ck_fun(o);
4943 if (o->op_flags & OPf_KIDS) {
4944 OP *kid = cUNOPo->op_first;
afebc493
GS		 4945 if (kid->op_type == OP_ENTERSUB) {
4946 (void) ref(kid, o->op_type);
4947 if (kid->op_type != OP_RV2CV && !PL_error_count)
4948 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 4949 OP_DESC(o));
afebc493
GS		 4950 o->op_private |= OPpEXISTS_SUB;
4951 }
4952 else if (kid->op_type == OP_AELEM)
01020589
GS		 4953 o->op_flags |= OPf_SPECIAL;
4954 else if (kid->op_type != OP_HELEM)
4955 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 4956 OP_DESC(o));
93c66552 4957 op_null(kid);
5f05dabc 4958 }
5196be3e 4959 return o;
5f05dabc 4960}
4961
22c35a8c 4962#if 0
5f05dabc 4963OP *
cea2e8a9 4964Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 4965{
4966 o = fold_constants(o);
4967 if (o->op_type == OP_CONST)
4968 o->op_type = OP_GV;
4969 return o;
4970}
22c35a8c 4971#endif
79072805
LW		 4972
4973OP *
cea2e8a9 4974Perl_ck_rvconst(pTHX_ register OP *o)
79072805 4975{
11343788 4976 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 4977
3280af22 4978 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 4979 if (kid->op_type == OP_CONST) {
44a8e56a 4980 char *name;
4981 int iscv;
4982 GV *gv;
779c5bc9 4983 SV *kidsv = kid->op_sv;
2d8e6c8d 4984 STRLEN n_a;
44a8e56a 4985
779c5bc9
GS		 4986 /* Is it a constant from cv_const_sv()? */
4987 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4988 SV *rsv = SvRV(kidsv);
4989 int svtype = SvTYPE(rsv);
4990 char *badtype = Nullch;
4991
4992 switch (o->op_type) {
4993 case OP_RV2SV:
4994 if (svtype > SVt_PVMG)
4995 badtype = "a SCALAR";
4996 break;
4997 case OP_RV2AV:
4998 if (svtype != SVt_PVAV)
4999 badtype = "an ARRAY";
5000 break;
5001 case OP_RV2HV:
6d822dc4 5002 if (svtype != SVt_PVHV)
779c5bc9 5003 badtype = "a HASH";
779c5bc9
GS		 5004 break;
5005 case OP_RV2CV:
5006 if (svtype != SVt_PVCV)
5007 badtype = "a CODE";
5008 break;
5009 }
5010 if (badtype)
cea2e8a9 5011 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5012 return o;
5013 }
2d8e6c8d 5014 name = SvPV(kidsv, n_a);
3280af22 5015 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 5016 char *badthing = Nullch;
5dc0d613 5017 switch (o->op_type) {
44a8e56a 5018 case OP_RV2SV:
5019 badthing = "a SCALAR";
5020 break;
5021 case OP_RV2AV:
5022 badthing = "an ARRAY";
5023 break;
5024 case OP_RV2HV:
5025 badthing = "a HASH";
5026 break;
5027 }
5028 if (badthing)
1c846c1f 5029 Perl_croak(aTHX_
44a8e56a 5030 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5031 name, badthing);
5032 }
93233ece
CS		 5033 /*
5034 * This is a little tricky. We only want to add the symbol if we
5035 * didn't add it in the lexer. Otherwise we get duplicate strict
5036 * warnings. But if we didn't add it in the lexer, we must at
5037 * least pretend like we wanted to add it even if it existed before,
5038 * or we get possible typo warnings. OPpCONST_ENTERED says
5039 * whether the lexer already added THIS instance of this symbol.
5040 */
5196be3e 5041 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5042 do {
44a8e56a 5043 gv = gv_fetchpv(name,
748a9306 5044 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5045 iscv
5046 ? SVt_PVCV
11343788 5047 : o->op_type == OP_RV2SV
a0d0e21e 5048 ? SVt_PV
11343788 5049 : o->op_type == OP_RV2AV
a0d0e21e 5050 ? SVt_PVAV
11343788 5051 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5052 ? SVt_PVHV
5053 : SVt_PVGV);
93233ece
CS		 5054 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5055 if (gv) {
5056 kid->op_type = OP_GV;
5057 SvREFCNT_dec(kid->op_sv);
350de78d 5058#ifdef USE_ITHREADS
638eceb6 5059 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5060 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 5061 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 5062 GvIN_PAD_on(gv);
dd2155a4 5063 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
350de78d 5064#else
93233ece 5065 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5066#endif
23f1ca44 5067 kid->op_private = 0;
76cd736e 5068 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5069 }
79072805 5070 }
11343788 5071 return o;
79072805
LW		 5072}
5073
5074OP *
cea2e8a9 5075Perl_ck_ftst(pTHX_ OP *o)
79072805 5076{
11343788 5077 I32 type = o->op_type;
79072805 5078
d0dca557
JD		 5079 if (o->op_flags & OPf_REF) {
5080 /* nothing */
5081 }
5082 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5083 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5084
5085 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5086 STRLEN n_a;
a0d0e21e 5087 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5088 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5089 op_free(o);
d0dca557 5090 o = newop;
79072805 5091 }
1af34c76
JH		 5092 else {
5093 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5094 OP_IS_FILETEST_ACCESS(o))
5095 o->op_private |= OPpFT_ACCESS;
5096 }
fbb0b3b3
RGS		 5097 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5098 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5099 o->op_private |= OPpFT_STACKED;
79072805
LW		 5100 }
5101 else {
11343788 5102 op_free(o);
79072805 5103 if (type == OP_FTTTY)
8fde6460 5104 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5105 else
d0dca557 5106 o = newUNOP(type, 0, newDEFSVOP());
79072805 5107 }
11343788 5108 return o;
79072805
LW		 5109}
5110
5111OP *
cea2e8a9 5112Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5113{
5114 register OP *kid;
5115 OP **tokid;
5116 OP *sibl;
5117 I32 numargs = 0;
11343788 5118 int type = o->op_type;
22c35a8c 5119 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5120
11343788 5121 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5122 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5123 oa &= ~OA_OPTIONAL;
5124 else
11343788 5125 return no_fh_allowed(o);
79072805
LW		 5126 }
5127
11343788 5128 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5129 STRLEN n_a;
11343788
MB		 5130 tokid = &cLISTOPo->op_first;
5131 kid = cLISTOPo->op_first;
8990e307 5132 if (kid->op_type == OP_PUSHMARK ||
155aba94 5133 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5134 {
79072805
LW		 5135 tokid = &kid->op_sibling;
5136 kid = kid->op_sibling;
5137 }
22c35a8c 5138 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5139 *tokid = kid = newDEFSVOP();
79072805
LW		 5140
5141 while (oa && kid) {
5142 numargs++;
5143 sibl = kid->op_sibling;
5144 switch (oa & 7) {
5145 case OA_SCALAR:
62c18ce2
GS		 5146 /* list seen where single (scalar) arg expected? */
5147 if (numargs == 1 && !(oa >> 4)
5148 && kid->op_type == OP_LIST && type != OP_SCALAR)
5149 {
5150 return too_many_arguments(o,PL_op_desc[type]);
5151 }
79072805
LW		 5152 scalar(kid);
5153 break;
5154 case OA_LIST:
5155 if (oa < 16) {
5156 kid = 0;
5157 continue;
5158 }
5159 else
5160 list(kid);
5161 break;
5162 case OA_AVREF:
936edb8b 5163 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5164 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5165 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5166 "Useless use of %s with no values",
936edb8b 5167 PL_op_desc[type]);
b2ffa427 5168
79072805 5169 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5170 (kid->op_private & OPpCONST_BARE))
5171 {
2d8e6c8d 5172 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5173 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5174 gv_fetchpv(name, TRUE, SVt_PVAV) ));
12bcd1a6
PM		 5175 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5176 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5177 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5178 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5179 op_free(kid);
5180 kid = newop;
5181 kid->op_sibling = sibl;
5182 *tokid = kid;
5183 }
8990e307 5184 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5185 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5186 mod(kid, type);
79072805
LW		 5187 break;
5188 case OA_HVREF:
5189 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5190 (kid->op_private & OPpCONST_BARE))
5191 {
2d8e6c8d 5192 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5193 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5194 gv_fetchpv(name, TRUE, SVt_PVHV) ));
12bcd1a6
PM		 5195 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5196 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5197 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5198 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5199 op_free(kid);
5200 kid = newop;
5201 kid->op_sibling = sibl;
5202 *tokid = kid;
5203 }
8990e307 5204 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5205 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5206 mod(kid, type);
79072805
LW		 5207 break;
5208 case OA_CVREF:
5209 {
a0d0e21e 5210 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5211 kid->op_sibling = 0;
5212 linklist(kid);
5213 newop->op_next = newop;
5214 kid = newop;
5215 kid->op_sibling = sibl;
5216 *tokid = kid;
5217 }
5218 break;
5219 case OA_FILEREF:
c340be78 5220 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5221 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5222 (kid->op_private & OPpCONST_BARE))
5223 {
79072805 5224 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5225 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5226 SVt_PVIO) );
afbdacea 5227 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5228 kid == cLISTOPo->op_last)
364daeac 5229 cLISTOPo->op_last = newop;
79072805
LW		 5230 op_free(kid);
5231 kid = newop;
5232 }
1ea32a52
GS		 5233 else if (kid->op_type == OP_READLINE) {
5234 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5235 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5236 }
79072805 5237 else {
35cd451c 5238 I32 flags = OPf_SPECIAL;
a6c40364 5239 I32 priv = 0;
2c8ac474
GS		 5240 PADOFFSET targ = 0;
5241
35cd451c 5242 /* is this op a FH constructor? */
853846ea 5243 if (is_handle_constructor(o,numargs)) {
2c8ac474 5244 char *name = Nullch;
dd2155a4 5245 STRLEN len = 0;
2c8ac474
GS		 5246
5247 flags = 0;
5248 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5249 * need to "prove" flag does not mean something
5250 * else already - NI-S 1999/05/07
2c8ac474
GS		 5251 */
5252 priv = OPpDEREF;
5253 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 5254 name = PAD_COMPNAME_PV(kid->op_targ);
5255 /* SvCUR of a pad namesv can't be trusted
5256 * (see PL_generation), so calc its length
5257 * manually */
5258 if (name)
5259 len = strlen(name);
5260
2c8ac474
GS		 5261 }
5262 else if (kid->op_type == OP_RV2SV
5263 && kUNOP->op_first->op_type == OP_GV)
5264 {
5265 GV *gv = cGVOPx_gv(kUNOP->op_first);
5266 name = GvNAME(gv);
5267 len = GvNAMELEN(gv);
5268 }
afd1915d
GS		 5269 else if (kid->op_type == OP_AELEM
5270 || kid->op_type == OP_HELEM)
5271 {
0c4b0a3f
JH		 5272 OP *op;
5273
5274 name = 0;
5275 if ((op = ((BINOP*)kid)->op_first)) {
5276 SV *tmpstr = Nullsv;
5277 char *a =
5278 kid->op_type == OP_AELEM ?
5279 "[]" : "{}";
5280 if (((op->op_type == OP_RV2AV) ||
5281 (op->op_type == OP_RV2HV)) &&
5282 (op = ((UNOP*)op)->op_first) &&
5283 (op->op_type == OP_GV)) {
5284 /* packagevar $a[] or $h{} */
5285 GV *gv = cGVOPx_gv(op);
5286 if (gv)
5287 tmpstr =
5288 Perl_newSVpvf(aTHX_
5289 "%s%c...%c",
5290 GvNAME(gv),
5291 a[0], a[1]);
5292 }
5293 else if (op->op_type == OP_PADAV
5294 || op->op_type == OP_PADHV) {
5295 /* lexicalvar $a[] or $h{} */
5296 char *padname =
5297 PAD_COMPNAME_PV(op->op_targ);
5298 if (padname)
5299 tmpstr =
5300 Perl_newSVpvf(aTHX_
5301 "%s%c...%c",
5302 padname + 1,
5303 a[0], a[1]);
5304
5305 }
5306 if (tmpstr) {
2a4f803a 5307 name = SvPV(tmpstr, len);
0c4b0a3f
JH		 5308 sv_2mortal(tmpstr);
5309 }
5310 }
5311 if (!name) {
5312 name = "__ANONIO__";
5313 len = 10;
5314 }
5315 mod(kid, type);
afd1915d 5316 }
2c8ac474
GS		 5317 if (name) {
5318 SV *namesv;
5319 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 5320 namesv = PAD_SVl(targ);
155aba94 5321 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5322 if (*name != '$')
5323 sv_setpvn(namesv, "$", 1);
5324 sv_catpvn(namesv, name, len);
5325 }
853846ea 5326 }
79072805 5327 kid->op_sibling = 0;
35cd451c 5328 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5329 kid->op_targ = targ;
5330 kid->op_private |= priv;
79072805
LW		 5331 }
5332 kid->op_sibling = sibl;
5333 *tokid = kid;
5334 }
5335 scalar(kid);
5336 break;
5337 case OA_SCALARREF:
a0d0e21e 5338 mod(scalar(kid), type);
79072805
LW		 5339 break;
5340 }
5341 oa >>= 4;
5342 tokid = &kid->op_sibling;
5343 kid = kid->op_sibling;
5344 }
11343788 5345 o->op_private |= numargs;
79072805 5346 if (kid)
53e06cf0 5347 return too_many_arguments(o,OP_DESC(o));
11343788 5348 listkids(o);
79072805 5349 }
22c35a8c 5350 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5351 op_free(o);
54b9620d 5352 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5353 }
5354
79072805
LW		 5355 if (oa) {
5356 while (oa & OA_OPTIONAL)
5357 oa >>= 4;
5358 if (oa && oa != OA_LIST)
53e06cf0 5359 return too_few_arguments(o,OP_DESC(o));
79072805 5360 }
11343788 5361 return o;
79072805
LW		 5362}
5363
5364OP *
cea2e8a9 5365Perl_ck_glob(pTHX_ OP *o)
79072805 5366{
fb73857a 5367 GV *gv;
5368
649da076 5369 o = ck_fun(o);
1f2bfc8a 5370 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5371 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5372
b9f751c0
GS		 5373 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5374 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5375 {
fb73857a 5376 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b9f751c0 5377 }
b1cb66bf 5378
52bb0670 5379#if !defined(PERL_EXTERNAL_GLOB)
72b16652 5380 /* XXX this can be tightened up and made more failsafe. */
f444d496 5381 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 5382 GV *glob_gv;
72b16652 5383 ENTER;
00ca71c1
NIS		 5384 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5385 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
72b16652 5386 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5387 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5388 GvCV(gv) = GvCV(glob_gv);
445266f0 5389 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5390 GvIMPORTED_CV_on(gv);
72b16652
GS		 5391 LEAVE;
5392 }
52bb0670 5393#endif /* PERL_EXTERNAL_GLOB */
72b16652 5394
b9f751c0 5395 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5396 append_elem(OP_GLOB, o,
80252599 5397 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5398 o->op_type = OP_LIST;
22c35a8c 5399 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5400 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5401 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 5402 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 5403 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5404 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5405 scalar(newUNOP(OP_RV2CV, 0,
5406 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5407 o = newUNOP(OP_NULL, 0, ck_subr(o));
5408 o->op_targ = OP_GLOB; /* hint at what it used to be */
5409 return o;
b1cb66bf 5410 }
5411 gv = newGVgen("main");
a0d0e21e 5412 gv_IOadd(gv);
11343788
MB		 5413 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5414 scalarkids(o);
649da076 5415 return o;
79072805
LW		 5416}
5417
5418OP *
cea2e8a9 5419Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 5420{
5421 LOGOP *gwop;
5422 OP *kid;
11343788 5423 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
59f00321 5424 I32 offset;
79072805 5425
22c35a8c 5426 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5427 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5428
11343788 5429 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5430 OP* k;
11343788
MB		 5431 o = ck_sort(o);
5432 kid = cLISTOPo->op_first->op_sibling;
e3c9a8b9 5433 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 5434 kid = k;
5435 }
5436 kid->op_next = (OP*)gwop;
11343788 5437 o->op_flags &= ~OPf_STACKED;
93a17b20 5438 }
11343788 5439 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5440 if (type == OP_MAPWHILE)
5441 list(kid);
5442 else
5443 scalar(kid);
11343788 5444 o = ck_fun(o);
3280af22 5445 if (PL_error_count)
11343788 5446 return o;
aeea060c 5447 kid = cLISTOPo->op_first->op_sibling;
79072805 5448 if (kid->op_type != OP_NULL)
cea2e8a9 5449 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5450 kid = kUNOP->op_first;
5451
a0d0e21e 5452 gwop->op_type = type;
22c35a8c 5453 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5454 gwop->op_first = listkids(o);
79072805 5455 gwop->op_flags |= OPf_KIDS;
79072805 5456 gwop->op_other = LINKLIST(kid);
79072805 5457 kid->op_next = (OP*)gwop;
59f00321
RGS		 5458 offset = pad_findmy("$_");
5459 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5460 o->op_private = gwop->op_private = 0;
5461 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5462 }
5463 else {
5464 o->op_private = gwop->op_private = OPpGREP_LEX;
5465 gwop->op_targ = o->op_targ = offset;
5466 }
79072805 5467
11343788 5468 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5469 if (!kid || !kid->op_sibling)
53e06cf0 5470 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5471 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5472 mod(kid, OP_GREPSTART);
5473
79072805
LW		 5474 return (OP*)gwop;
5475}
5476
5477OP *
cea2e8a9 5478Perl_ck_index(pTHX_ OP *o)
79072805 5479{
11343788
MB		 5480 if (o->op_flags & OPf_KIDS) {
5481 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5482 if (kid)
5483 kid = kid->op_sibling; /* get past "big" */
79072805 5484 if (kid && kid->op_type == OP_CONST)
2779dcf1 5485 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5486 }
11343788 5487 return ck_fun(o);
79072805
LW		 5488}
5489
5490OP *
cea2e8a9 5491Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5492{
5493 /* XXX length optimization goes here */
11343788 5494 return ck_fun(o);
79072805
LW		 5495}
5496
5497OP *
cea2e8a9 5498Perl_ck_lfun(pTHX_ OP *o)
79072805 5499{
5dc0d613
MB		 5500 OPCODE type = o->op_type;
5501 return modkids(ck_fun(o), type);
79072805
LW		 5502}
5503
5504OP *
cea2e8a9 5505Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5506{
12bcd1a6 5507 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5508 switch (cUNOPo->op_first->op_type) {
5509 case OP_RV2AV:
a8739d98
JH		 5510 /* This is needed for
5511 if (defined %stash::)
5512 to work. Do not break Tk.
5513 */
1c846c1f 5514 break; /* Globals via GV can be undef */
d0334bed
GS		 5515 case OP_PADAV:
5516 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5517 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5518 "defined(@array) is deprecated");
12bcd1a6 5519 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5520 "\t(Maybe you should just omit the defined()?)\n");
69794302 5521 break;
d0334bed 5522 case OP_RV2HV:
a8739d98
JH		 5523 /* This is needed for
5524 if (defined %stash::)
5525 to work. Do not break Tk.
5526 */
1c846c1f 5527 break; /* Globals via GV can be undef */
d0334bed 5528 case OP_PADHV:
12bcd1a6 5529 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5530 "defined(%%hash) is deprecated");
12bcd1a6 5531 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5532 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5533 break;
5534 default:
5535 /* no warning */
5536 break;
5537 }
69794302
MJD		 5538 }
5539 return ck_rfun(o);
5540}
5541
5542OP *
cea2e8a9 5543Perl_ck_rfun(pTHX_ OP *o)
8990e307 5544{
5dc0d613
MB		 5545 OPCODE type = o->op_type;
5546 return refkids(ck_fun(o), type);
8990e307
LW		 5547}
5548
5549OP *
cea2e8a9 5550Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5551{
5552 register OP *kid;
aeea060c 5553
11343788 5554 kid = cLISTOPo->op_first;
79072805 5555 if (!kid) {
11343788
MB		 5556 o = force_list(o);
5557 kid = cLISTOPo->op_first;
79072805
LW		 5558 }
5559 if (kid->op_type == OP_PUSHMARK)
5560 kid = kid->op_sibling;
11343788 5561 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 5562 kid = kid->op_sibling;
5563 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5564 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 5565 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 5566 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 5567 cLISTOPo->op_first->op_sibling = kid;
5568 cLISTOPo->op_last = kid;
79072805
LW		 5569 kid = kid->op_sibling;
5570 }
5571 }
b2ffa427 5572
79072805 5573 if (!kid)
54b9620d 5574 append_elem(o->op_type, o, newDEFSVOP());
79072805 5575
2de3dbcc 5576 return listkids(o);
bbce6d69 5577}
5578
5579OP *
b162f9ea
IZ		 5580Perl_ck_sassign(pTHX_ OP *o)
5581{
5582 OP *kid = cLISTOPo->op_first;
5583 /* has a disposable target? */
5584 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 5585 && !(kid->op_flags & OPf_STACKED)
5586 /* Cannot steal the second time! */
5587 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 5588 {
5589 OP *kkid = kid->op_sibling;
5590
5591 /* Can just relocate the target. */
2c2d71f5
JH		 5592 if (kkid && kkid->op_type == OP_PADSV
5593 && !(kkid->op_private & OPpLVAL_INTRO))
5594 {
b162f9ea 5595 kid->op_targ = kkid->op_targ;
743e66e6 5596 kkid->op_targ = 0;
b162f9ea
IZ		 5597 /* Now we do not need PADSV and SASSIGN. */
5598 kid->op_sibling = o->op_sibling; /* NULL */
5599 cLISTOPo->op_first = NULL;
5600 op_free(o);
5601 op_free(kkid);
5602 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5603 return kid;
5604 }
5605 }
b9d46b39
RGS		 5606 /* optimise C<my $x = undef> to C<my $x> */
5607 if (kid->op_type == OP_UNDEF) {
5608 OP *kkid = kid->op_sibling;
5609 if (kkid && kkid->op_type == OP_PADSV
5610 && (kkid->op_private & OPpLVAL_INTRO))
5611 {
5612 cLISTOPo->op_first = NULL;
5613 kid->op_sibling = NULL;
5614 op_free(o);
5615 op_free(kid);
5616 return kkid;
5617 }
5618 }
b162f9ea
IZ		 5619 return o;
5620}
5621
5622OP *
cea2e8a9 5623Perl_ck_match(pTHX_ OP *o)
79072805 5624{
59f00321
RGS		 5625 if (o->op_type != OP_QR) {
5626 I32 offset = pad_findmy("$_");
5627 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5628 o->op_targ = offset;
5629 o->op_private |= OPpTARGET_MY;
5630 }
5631 }
5632 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5633 o->op_private |= OPpRUNTIME;
11343788 5634 return o;
79072805
LW		 5635}
5636
5637OP *
f5d5a27c
CS		 5638Perl_ck_method(pTHX_ OP *o)
5639{
5640 OP *kid = cUNOPo->op_first;
5641 if (kid->op_type == OP_CONST) {
5642 SV* sv = kSVOP->op_sv;
5643 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5644 OP *cmop;
1c846c1f
NIS		 5645 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5646 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5647 }
5648 else {
5649 kSVOP->op_sv = Nullsv;
5650 }
f5d5a27c 5651 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 5652 op_free(o);
5653 return cmop;
5654 }
5655 }
5656 return o;
5657}
5658
5659OP *
cea2e8a9 5660Perl_ck_null(pTHX_ OP *o)
79072805 5661{
11343788 5662 return o;
79072805
LW		 5663}
5664
5665OP *
16fe6d59
GS		 5666Perl_ck_open(pTHX_ OP *o)
5667{
5668 HV *table = GvHV(PL_hintgv);
5669 if (table) {
5670 SV **svp;
5671 I32 mode;
5672 svp = hv_fetch(table, "open_IN", 7, FALSE);
5673 if (svp && *svp) {
5674 mode = mode_from_discipline(*svp);
5675 if (mode & O_BINARY)
5676 o->op_private |= OPpOPEN_IN_RAW;
5677 else if (mode & O_TEXT)
5678 o->op_private |= OPpOPEN_IN_CRLF;
5679 }
5680
5681 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5682 if (svp && *svp) {
5683 mode = mode_from_discipline(*svp);
5684 if (mode & O_BINARY)
5685 o->op_private |= OPpOPEN_OUT_RAW;
5686 else if (mode & O_TEXT)
5687 o->op_private |= OPpOPEN_OUT_CRLF;
5688 }
5689 }
5690 if (o->op_type == OP_BACKTICK)
5691 return o;
3b82e551
JH		 5692 {
5693 /* In case of three-arg dup open remove strictness
5694 * from the last arg if it is a bareword. */
5695 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5696 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5697 OP *oa;
5698 char *mode;
5699
5700 if ((last->op_type == OP_CONST) && /* The bareword. */
5701 (last->op_private & OPpCONST_BARE) &&
5702 (last->op_private & OPpCONST_STRICT) &&
5703 (oa = first->op_sibling) && /* The fh. */
5704 (oa = oa->op_sibling) && /* The mode. */
5705 SvPOK(((SVOP*)oa)->op_sv) &&
5706 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5707 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5708 (last == oa->op_sibling)) /* The bareword. */
5709 last->op_private &= ~OPpCONST_STRICT;
5710 }
16fe6d59
GS		 5711 return ck_fun(o);
5712}
5713
5714OP *
cea2e8a9 5715Perl_ck_repeat(pTHX_ OP *o)
79072805 5716{
11343788
MB		 5717 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5718 o->op_private |= OPpREPEAT_DOLIST;
5719 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 5720 }
5721 else
11343788
MB		 5722 scalar(o);
5723 return o;
79072805
LW		 5724}
5725
5726OP *
cea2e8a9 5727Perl_ck_require(pTHX_ OP *o)
8990e307 5728{
ec4ab249
GA		 5729 GV* gv;
5730
11343788
MB		 5731 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5732 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 5733
5734 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 5735 char *s;
a0d0e21e
LW		 5736 for (s = SvPVX(kid->op_sv); *s; s++) {
5737 if (*s == ':' && s[1] == ':') {
5738 *s = '/';
1aef975c 5739 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 5740 --SvCUR(kid->op_sv);
5741 }
8990e307 5742 }
ce3b816e
GS		 5743 if (SvREADONLY(kid->op_sv)) {
5744 SvREADONLY_off(kid->op_sv);
5745 sv_catpvn(kid->op_sv, ".pm", 3);
5746 SvREADONLY_on(kid->op_sv);
5747 }
5748 else
5749 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 5750 }
5751 }
ec4ab249
GA		 5752
5753 /* handle override, if any */
5754 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
b9f751c0 5755 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
ec4ab249
GA		 5756 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5757
b9f751c0 5758 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
ec4ab249
GA		 5759 OP *kid = cUNOPo->op_first;
5760 cUNOPo->op_first = 0;
5761 op_free(o);
5762 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5763 append_elem(OP_LIST, kid,
5764 scalar(newUNOP(OP_RV2CV, 0,
5765 newGVOP(OP_GV, 0,
5766 gv))))));
5767 }
5768
11343788 5769 return ck_fun(o);
8990e307
LW		 5770}
5771
78f9721b
SM		 5772OP *
5773Perl_ck_return(pTHX_ OP *o)
5774{
5775 OP *kid;
5776 if (CvLVALUE(PL_compcv)) {
5777 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5778 mod(kid, OP_LEAVESUBLV);
5779 }
5780 return o;
5781}
5782
22c35a8c 5783#if 0
8990e307 5784OP *
cea2e8a9 5785Perl_ck_retarget(pTHX_ OP *o)
79072805 5786{
cea2e8a9 5787 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 5788 /* STUB */
11343788 5789 return o;
79072805 5790}
22c35a8c 5791#endif
79072805
LW		 5792
5793OP *
cea2e8a9 5794Perl_ck_select(pTHX_ OP *o)
79072805 5795{
c07a80fd 5796 OP* kid;
11343788
MB		 5797 if (o->op_flags & OPf_KIDS) {
5798 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 5799 if (kid && kid->op_sibling) {
11343788 5800 o->op_type = OP_SSELECT;
22c35a8c 5801 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 5802 o = ck_fun(o);
5803 return fold_constants(o);
79072805
LW		 5804 }
5805 }
11343788
MB		 5806 o = ck_fun(o);
5807 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 5808 if (kid && kid->op_type == OP_RV2GV)
5809 kid->op_private &= ~HINT_STRICT_REFS;
11343788 5810 return o;
79072805
LW		 5811}
5812
5813OP *
cea2e8a9 5814Perl_ck_shift(pTHX_ OP *o)
79072805 5815{
11343788 5816 I32 type = o->op_type;
79072805 5817
11343788 5818 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 5819 OP *argop;
b2ffa427 5820
11343788 5821 op_free(o);
6d4ff0d2 5822 argop = newUNOP(OP_RV2AV, 0,
8fde6460 5823 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6d4ff0d2 5824 return newUNOP(type, 0, scalar(argop));
79072805 5825 }
11343788 5826 return scalar(modkids(ck_fun(o), type));
79072805
LW		 5827}
5828
5829OP *
cea2e8a9 5830Perl_ck_sort(pTHX_ OP *o)
79072805 5831{
8e3f9bdf 5832 OP *firstkid;
bbce6d69 5833
9ea6e965 5834 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 5835 simplify_sort(o);
8e3f9bdf
GS		 5836 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5837 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 5838 OP *k = NULL;
8e3f9bdf 5839 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 5840
463ee0b2 5841 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 5842 linklist(kid);
463ee0b2
LW		 5843 if (kid->op_type == OP_SCOPE) {
5844 k = kid->op_next;
5845 kid->op_next = 0;
79072805 5846 }
463ee0b2 5847 else if (kid->op_type == OP_LEAVE) {
11343788 5848 if (o->op_type == OP_SORT) {
93c66552 5849 op_null(kid); /* wipe out leave */
748a9306 5850 kid->op_next = kid;
463ee0b2 5851
748a9306
LW		 5852 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5853 if (k->op_next == kid)
5854 k->op_next = 0;
71a29c3c
GS		 5855 /* don't descend into loops */
5856 else if (k->op_type == OP_ENTERLOOP
5857 || k->op_type == OP_ENTERITER)
5858 {
5859 k = cLOOPx(k)->op_lastop;
5860 }
748a9306 5861 }
463ee0b2 5862 }
748a9306
LW		 5863 else
5864 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 5865 k = kLISTOP->op_first;
463ee0b2 5866 }
a2efc822 5867 CALL_PEEP(k);
a0d0e21e 5868
8e3f9bdf
GS		 5869 kid = firstkid;
5870 if (o->op_type == OP_SORT) {
5871 /* provide scalar context for comparison function/block */
5872 kid = scalar(kid);
a0d0e21e 5873 kid->op_next = kid;
8e3f9bdf 5874 }
a0d0e21e
LW		 5875 else
5876 kid->op_next = k;
11343788 5877 o->op_flags |= OPf_SPECIAL;
79072805 5878 }
c6e96bcb 5879 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 5880 op_null(firstkid);
8e3f9bdf
GS		 5881
5882 firstkid = firstkid->op_sibling;
79072805 5883 }
bbce6d69 5884
8e3f9bdf
GS		 5885 /* provide list context for arguments */
5886 if (o->op_type == OP_SORT)
5887 list(firstkid);
5888
11343788 5889 return o;
79072805 5890}
bda4119b
GS		 5891
5892STATIC void
cea2e8a9 5893S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 5894{
5895 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5896 OP *k;
5897 int reversed;
350de78d 5898 GV *gv;
9c007264
JH		 5899 if (!(o->op_flags & OPf_STACKED))
5900 return;
1c846c1f
NIS		 5901 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5902 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 5903 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 5904 if (kid->op_type != OP_SCOPE)
5905 return;
5906 kid = kLISTOP->op_last; /* get past scope */
5907 switch(kid->op_type) {
5908 case OP_NCMP:
5909 case OP_I_NCMP:
5910 case OP_SCMP:
5911 break;
5912 default:
5913 return;
5914 }
5915 k = kid; /* remember this node*/
5916 if (kBINOP->op_first->op_type != OP_RV2SV)
5917 return;
5918 kid = kBINOP->op_first; /* get past cmp */
5919 if (kUNOP->op_first->op_type != OP_GV)
5920 return;
5921 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5922 gv = kGVOP_gv;
350de78d 5923 if (GvSTASH(gv) != PL_curstash)
9c007264 5924 return;
350de78d 5925 if (strEQ(GvNAME(gv), "a"))
9c007264 5926 reversed = 0;
0f79a09d 5927 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 5928 reversed = 1;
5929 else
5930 return;
5931 kid = k; /* back to cmp */
5932 if (kBINOP->op_last->op_type != OP_RV2SV)
5933 return;
5934 kid = kBINOP->op_last; /* down to 2nd arg */
5935 if (kUNOP->op_first->op_type != OP_GV)
5936 return;
5937 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5938 gv = kGVOP_gv;
350de78d 5939 if (GvSTASH(gv) != PL_curstash
9c007264 5940 || ( reversed
350de78d
GS		 5941 ? strNE(GvNAME(gv), "a")
5942 : strNE(GvNAME(gv), "b")))
9c007264
JH		 5943 return;
5944 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5945 if (reversed)
5946 o->op_private |= OPpSORT_REVERSE;
5947 if (k->op_type == OP_NCMP)
5948 o->op_private |= OPpSORT_NUMERIC;
5949 if (k->op_type == OP_I_NCMP)
5950 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 5951 kid = cLISTOPo->op_first->op_sibling;
5952 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5953 op_free(kid); /* then delete it */
9c007264 5954}
79072805
LW		 5955
5956OP *
cea2e8a9 5957Perl_ck_split(pTHX_ OP *o)
79072805
LW		 5958{
5959 register OP *kid;
aeea060c 5960
11343788
MB		 5961 if (o->op_flags & OPf_STACKED)
5962 return no_fh_allowed(o);
79072805 5963
11343788 5964 kid = cLISTOPo->op_first;
8990e307 5965 if (kid->op_type != OP_NULL)
cea2e8a9 5966 Perl_croak(aTHX_ "panic: ck_split");
8990e307 5967 kid = kid->op_sibling;
11343788
MB		 5968 op_free(cLISTOPo->op_first);
5969 cLISTOPo->op_first = kid;
85e6fe83 5970 if (!kid) {
79cb57f6 5971 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 5972 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 5973 }
79072805 5974
de4bf5b3 5975 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 5976 OP *sibl = kid->op_sibling;
463ee0b2 5977 kid->op_sibling = 0;
79072805 5978 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 5979 if (cLISTOPo->op_first == cLISTOPo->op_last)
5980 cLISTOPo->op_last = kid;
5981 cLISTOPo->op_first = kid;
79072805
LW		 5982 kid->op_sibling = sibl;
5983 }
5984
5985 kid->op_type = OP_PUSHRE;
22c35a8c 5986 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 5987 scalar(kid);
f34840d8
MJD		 5988 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5989 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5990 "Use of /g modifier is meaningless in split");
5991 }
79072805
LW		 5992
5993 if (!kid->op_sibling)
54b9620d 5994 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 5995
5996 kid = kid->op_sibling;
5997 scalar(kid);
5998
5999 if (!kid->op_sibling)
11343788 6000 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 6001
6002 kid = kid->op_sibling;
6003 scalar(kid);
6004
6005 if (kid->op_sibling)
53e06cf0 6006 return too_many_arguments(o,OP_DESC(o));
79072805 6007
11343788 6008 return o;
79072805
LW		 6009}
6010
6011OP *
1c846c1f 6012Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 6013{
6014 if (ckWARN(WARN_SYNTAX)) {
6015 OP *kid = cLISTOPo->op_first->op_sibling;
6016 if (kid && kid->op_type == OP_MATCH) {
6017 char *pmstr = "STRING";
aaa362c4
RS		 6018 if (PM_GETRE(kPMOP))
6019 pmstr = PM_GETRE(kPMOP)->precomp;
9014280d 6020 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 6021 "/%s/ should probably be written as \"%s\"",
6022 pmstr, pmstr);
6023 }
6024 }
6025 return ck_fun(o);
6026}
6027
6028OP *
cea2e8a9 6029Perl_ck_subr(pTHX_ OP *o)
79072805 6030{
11343788
MB		 6031 OP *prev = ((cUNOPo->op_first->op_sibling)
6032 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6033 OP *o2 = prev->op_sibling;
4633a7c4
LW		 6034 OP *cvop;
6035 char *proto = 0;
6036 CV *cv = 0;
46fc3d4c 6037 GV *namegv = 0;
4633a7c4
LW		 6038 int optional = 0;
6039 I32 arg = 0;
5b794e05 6040 I32 contextclass = 0;
90b7f708 6041 char *e = 0;
2d8e6c8d 6042 STRLEN n_a;
06492da6 6043 bool delete=0;
4633a7c4 6044
d3011074 6045 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6046 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6047 if (cvop->op_type == OP_RV2CV) {
6048 SVOP* tmpop;
11343788 6049 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6050 op_null(cvop); /* disable rv2cv */
4633a7c4 6051 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6052 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6053 GV *gv = cGVOPx_gv(tmpop);
350de78d 6054 cv = GvCVu(gv);
76cd736e
GS		 6055 if (!cv)
6056 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 6057 else {
6058 if (SvPOK(cv)) {
6059 namegv = CvANON(cv) ? gv : CvGV(cv);
6060 proto = SvPV((SV*)cv, n_a);
6061 }
6062 if (CvASSERTION(cv)) {
6063 if (PL_hints & HINT_ASSERTING) {
6064 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6065 o->op_private |= OPpENTERSUB_DB;
6066 }
8fa7688f
SF		 6067 else {
6068 delete=1;
6069 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6070 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6071 "Impossible to activate assertion call");
6072 }
6073 }
06492da6 6074 }
46fc3d4c 6075 }
4633a7c4
LW		 6076 }
6077 }
f5d5a27c 6078 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6079 if (o2->op_type == OP_CONST)
6080 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 6081 else if (o2->op_type == OP_LIST) {
6082 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6083 if (o && o->op_type == OP_CONST)
6084 o->op_private &= ~OPpCONST_STRICT;
6085 }
7a52d87a 6086 }
3280af22
NIS		 6087 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6088 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6089 o->op_private |= OPpENTERSUB_DB;
6090 while (o2 != cvop) {
4633a7c4
LW		 6091 if (proto) {
6092 switch (*proto) {
6093 case '\0':
5dc0d613 6094 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 6095 case ';':
6096 optional = 1;
6097 proto++;
6098 continue;
6099 case '$':
6100 proto++;
6101 arg++;
11343788 6102 scalar(o2);
4633a7c4
LW		 6103 break;
6104 case '%':
6105 case '@':
11343788 6106 list(o2);
4633a7c4
LW		 6107 arg++;
6108 break;
6109 case '&':
6110 proto++;
6111 arg++;
11343788 6112 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6113 bad_type(arg,
6114 arg == 1 ? "block or sub {}" : "sub {}",
6115 gv_ename(namegv), o2);
4633a7c4
LW		 6116 break;
6117 case '*':
2ba6ecf4 6118 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6119 proto++;
6120 arg++;
11343788 6121 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6122 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6123 else if (o2->op_type == OP_CONST)
6124 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6125 else if (o2->op_type == OP_ENTERSUB) {
6126 /* accidental subroutine, revert to bareword */
6127 OP *gvop = ((UNOP*)o2)->op_first;
6128 if (gvop && gvop->op_type == OP_NULL) {
6129 gvop = ((UNOP*)gvop)->op_first;
6130 if (gvop) {
6131 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6132 ;
6133 if (gvop &&
6134 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6135 (gvop = ((UNOP*)gvop)->op_first) &&
6136 gvop->op_type == OP_GV)
6137 {
638eceb6 6138 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6139 OP *sibling = o2->op_sibling;
2692f720 6140 SV *n = newSVpvn("",0);
9675f7ac 6141 op_free(o2);
2692f720
GS		 6142 gv_fullname3(n, gv, "");
6143 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6144 sv_chop(n, SvPVX(n)+6);
6145 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6146 prev->op_sibling = o2;
6147 o2->op_sibling = sibling;
6148 }
6149 }
6150 }
6151 }
2ba6ecf4
GS		 6152 scalar(o2);
6153 break;
5b794e05
JH		 6154 case '[': case ']':
6155 goto oops;
6156 break;
4633a7c4
LW		 6157 case '\\':
6158 proto++;
6159 arg++;
5b794e05 6160 again:
4633a7c4 6161 switch (*proto++) {
5b794e05
JH		 6162 case '[':
6163 if (contextclass++ == 0) {
841d93c8 6164 e = strchr(proto, ']');
5b794e05
JH		 6165 if (!e || e == proto)
6166 goto oops;
6167 }
6168 else
6169 goto oops;
6170 goto again;
6171 break;
6172 case ']':
466bafcd
RGS		 6173 if (contextclass) {
6174 char *p = proto;
6175 char s = *p;
6176 contextclass = 0;
6177 *p = '\0';
6178 while (*--p != '[');
1eb1540c 6179 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6180 gv_ename(namegv), o2);
6181 *proto = s;
6182 } else
5b794e05
JH		 6183 goto oops;
6184 break;
4633a7c4 6185 case '*':
5b794e05
JH		 6186 if (o2->op_type == OP_RV2GV)
6187 goto wrapref;
6188 if (!contextclass)
6189 bad_type(arg, "symbol", gv_ename(namegv), o2);
6190 break;
4633a7c4 6191 case '&':
5b794e05
JH		 6192 if (o2->op_type == OP_ENTERSUB)
6193 goto wrapref;
6194 if (!contextclass)
6195 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6196 break;
4633a7c4 6197 case '$':
5b794e05
JH		 6198 if (o2->op_type == OP_RV2SV ||
6199 o2->op_type == OP_PADSV ||
6200 o2->op_type == OP_HELEM ||
6201 o2->op_type == OP_AELEM ||
6202 o2->op_type == OP_THREADSV)
6203 goto wrapref;
6204 if (!contextclass)
5dc0d613 6205 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6206 break;
4633a7c4 6207 case '@':
5b794e05
JH		 6208 if (o2->op_type == OP_RV2AV ||
6209 o2->op_type == OP_PADAV)
6210 goto wrapref;
6211 if (!contextclass)
5dc0d613 6212 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6213 break;
4633a7c4 6214 case '%':
5b794e05
JH		 6215 if (o2->op_type == OP_RV2HV ||
6216 o2->op_type == OP_PADHV)
6217 goto wrapref;
6218 if (!contextclass)
6219 bad_type(arg, "hash", gv_ename(namegv), o2);
6220 break;
6221 wrapref:
4633a7c4 6222 {
11343788 6223 OP* kid = o2;
6fa846a0 6224 OP* sib = kid->op_sibling;
4633a7c4 6225 kid->op_sibling = 0;
6fa846a0
GS		 6226 o2 = newUNOP(OP_REFGEN, 0, kid);
6227 o2->op_sibling = sib;
e858de61 6228 prev->op_sibling = o2;
4633a7c4 6229 }
841d93c8 6230 if (contextclass && e) {
5b794e05
JH		 6231 proto = e + 1;
6232 contextclass = 0;
6233 }
4633a7c4
LW		 6234 break;
6235 default: goto oops;
6236 }
5b794e05
JH		 6237 if (contextclass)
6238 goto again;
4633a7c4 6239 break;
b1cb66bf 6240 case ' ':
6241 proto++;
6242 continue;
4633a7c4
LW		 6243 default:
6244 oops:
35c1215d
NC		 6245 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6246 gv_ename(namegv), cv);
4633a7c4
LW		 6247 }
6248 }
6249 else
11343788
MB		 6250 list(o2);
6251 mod(o2, OP_ENTERSUB);
6252 prev = o2;
6253 o2 = o2->op_sibling;
4633a7c4 6254 }
fb73857a 6255 if (proto && !optional &&
6256 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6257 return too_few_arguments(o, gv_ename(namegv));
06492da6
SF		 6258 if(delete) {
6259 op_free(o);
6260 o=newSVOP(OP_CONST, 0, newSViv(0));
6261 }
11343788 6262 return o;
79072805
LW		 6263}
6264
6265OP *
cea2e8a9 6266Perl_ck_svconst(pTHX_ OP *o)
8990e307 6267{
11343788
MB		 6268 SvREADONLY_on(cSVOPo->op_sv);
6269 return o;
8990e307
LW		 6270}
6271
6272OP *
cea2e8a9 6273Perl_ck_trunc(pTHX_ OP *o)
79072805 6274{
11343788
MB		 6275 if (o->op_flags & OPf_KIDS) {
6276 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6277
a0d0e21e
LW		 6278 if (kid->op_type == OP_NULL)
6279 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6280 if (kid && kid->op_type == OP_CONST &&
6281 (kid->op_private & OPpCONST_BARE))
6282 {
11343788 6283 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6284 kid->op_private &= ~OPpCONST_STRICT;
6285 }
79072805 6286 }
11343788 6287 return ck_fun(o);
79072805
LW		 6288}
6289
35fba0d9 6290OP *
bab9c0ac
RGS		 6291Perl_ck_unpack(pTHX_ OP *o)
6292{
6293 OP *kid = cLISTOPo->op_first;
6294 if (kid->op_sibling) {
6295 kid = kid->op_sibling;
6296 if (!kid->op_sibling)
6297 kid->op_sibling = newDEFSVOP();
6298 }
6299 return ck_fun(o);
6300}
6301
6302OP *
35fba0d9
RG		 6303Perl_ck_substr(pTHX_ OP *o)
6304{
6305 o = ck_fun(o);
6306 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6307 OP *kid = cLISTOPo->op_first;
6308
6309 if (kid->op_type == OP_NULL)
6310 kid = kid->op_sibling;
6311 if (kid)
6312 kid->op_flags |= OPf_MOD;
6313
6314 }
6315 return o;
6316}
6317
463ee0b2
LW		 6318/* A peephole optimizer. We visit the ops in the order they're to execute. */
6319
79072805 6320void
864dbfa3 6321Perl_peep(pTHX_ register OP *o)
79072805
LW		 6322{
6323 register OP* oldop = 0;
2d8e6c8d 6324
2814eb74 6325 if (!o || o->op_opt)
79072805 6326 return;
a0d0e21e 6327 ENTER;
462e5cf6 6328 SAVEOP();
7766f137 6329 SAVEVPTR(PL_curcop);
a0d0e21e 6330 for (; o; o = o->op_next) {
2814eb74 6331 if (o->op_opt)
a0d0e21e 6332 break;
533c011a 6333 PL_op = o;
a0d0e21e 6334 switch (o->op_type) {
acb36ea4 6335 case OP_SETSTATE:
a0d0e21e
LW		 6336 case OP_NEXTSTATE:
6337 case OP_DBSTATE:
3280af22 6338 PL_curcop = ((COP*)o); /* for warnings */
2814eb74 6339 o->op_opt = 1;
a0d0e21e
LW		 6340 break;
6341
a0d0e21e 6342 case OP_CONST:
7a52d87a
GS		 6343 if (cSVOPo->op_private & OPpCONST_STRICT)
6344 no_bareword_allowed(o);
7766f137 6345#ifdef USE_ITHREADS
3848b962 6346 case OP_METHOD_NAMED:
7766f137
GS		 6347 /* Relocate sv to the pad for thread safety.
6348 * Despite being a "constant", the SV is written to,
6349 * for reference counts, sv_upgrade() etc. */
6350 if (cSVOP->op_sv) {
6351 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 6352 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6353 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6354 * some pad, so make a copy. */
dd2155a4
DM		 6355 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6356 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6357 SvREFCNT_dec(cSVOPo->op_sv);
6358 }
6359 else {
dd2155a4 6360 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6361 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 6362 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6363 /* XXX I don't know how this isn't readonly already. */
dd2155a4 6364 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6365 }
7766f137
GS		 6366 cSVOPo->op_sv = Nullsv;
6367 o->op_targ = ix;
6368 }
6369#endif
2814eb74 6370 o->op_opt = 1;
07447971
GS		 6371 break;
6372
df91b2c5
AE		 6373 case OP_CONCAT:
6374 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6375 if (o->op_next->op_private & OPpTARGET_MY) {
6376 if (o->op_flags & OPf_STACKED) /* chained concats */
6377 goto ignore_optimization;
6378 else {
6379 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6380 o->op_targ = o->op_next->op_targ;
6381 o->op_next->op_targ = 0;
6382 o->op_private |= OPpTARGET_MY;
6383 }
6384 }
6385 op_null(o->op_next);
6386 }
6387 ignore_optimization:
2814eb74 6388 o->op_opt = 1;
df91b2c5 6389 break;
8990e307 6390 case OP_STUB:
54310121 6391 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
2814eb74 6392 o->op_opt = 1;
54310121 6393 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6394 }
748a9306 6395 goto nothin;
79072805 6396 case OP_NULL:
acb36ea4
GS		 6397 if (o->op_targ == OP_NEXTSTATE
6398 || o->op_targ == OP_DBSTATE
6399 || o->op_targ == OP_SETSTATE)
6400 {
3280af22 6401 PL_curcop = ((COP*)o);
acb36ea4 6402 }
dad75012
AMS		 6403 /* XXX: We avoid setting op_seq here to prevent later calls
6404 to peep() from mistakenly concluding that optimisation
6405 has already occurred. This doesn't fix the real problem,
6406 though (See 20010220.007). AMS 20010719 */
2814eb74 6407 /* op_seq functionality is now replaced by op_opt */
dad75012
AMS		 6408 if (oldop && o->op_next) {
6409 oldop->op_next = o->op_next;
6410 continue;
6411 }
6412 break;
79072805 6413 case OP_SCALAR:
93a17b20 6414 case OP_LINESEQ:
463ee0b2 6415 case OP_SCOPE:
748a9306 6416 nothin:
a0d0e21e
LW		 6417 if (oldop && o->op_next) {
6418 oldop->op_next = o->op_next;
79072805
LW		 6419 continue;
6420 }
2814eb74 6421 o->op_opt = 1;
79072805
LW		 6422 break;
6423
6a077020 6424 case OP_PADAV:
79072805 6425 case OP_GV:
6a077020
DM		 6426 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6427 OP* pop = (o->op_type == OP_PADAV) ?
6428 o->op_next : o->op_next->op_next;
a0d0e21e 6429 IV i;
f9dc862f 6430 if (pop && pop->op_type == OP_CONST &&
af5acbb4 6431 ((PL_op = pop->op_next)) &&
8990e307 6432 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6433 !(pop->op_next->op_private &
78f9721b 6434 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6435 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6436 <= 255 &&
8990e307
LW		 6437 i >= 0)
6438 {
350de78d 6439 GV *gv;
af5acbb4
DM		 6440 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6441 no_bareword_allowed(pop);
6a077020
DM		 6442 if (o->op_type == OP_GV)
6443 op_null(o->op_next);
93c66552
DM		 6444 op_null(pop->op_next);
6445 op_null(pop);
a0d0e21e
LW		 6446 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6447 o->op_next = pop->op_next->op_next;
22c35a8c 6448 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6449 o->op_private = (U8)i;
6a077020
DM		 6450 if (o->op_type == OP_GV) {
6451 gv = cGVOPo_gv;
6452 GvAVn(gv);
6453 }
6454 else
6455 o->op_flags |= OPf_SPECIAL;
6456 o->op_type = OP_AELEMFAST;
6457 }
6458 o->op_opt = 1;
6459 break;
6460 }
6461
6462 if (o->op_next->op_type == OP_RV2SV) {
6463 if (!(o->op_next->op_private & OPpDEREF)) {
6464 op_null(o->op_next);
6465 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6466 | OPpOUR_INTRO);
6467 o->op_next = o->op_next->op_next;
6468 o->op_type = OP_GVSV;
6469 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 6470 }
79072805 6471 }
e476b1b5 6472 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 6473 GV *gv = cGVOPo_gv;
76cd736e
GS		 6474 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6475 /* XXX could check prototype here instead of just carping */
6476 SV *sv = sv_newmortal();
6477 gv_efullname3(sv, gv, Nullch);
9014280d 6478 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d
NC		 6479 "%"SVf"() called too early to check prototype",
6480 sv);
76cd736e
GS		 6481 }
6482 }
89de2904
AMS		 6483 else if (o->op_next->op_type == OP_READLINE
6484 && o->op_next->op_next->op_type == OP_CONCAT
6485 && (o->op_next->op_next->op_flags & OPf_STACKED))
6486 {
d2c45030
AMS		 6487 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6488 o->op_type = OP_RCATLINE;
6489 o->op_flags |= OPf_STACKED;
6490 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6491 op_null(o->op_next->op_next);
d2c45030 6492 op_null(o->op_next);
89de2904 6493 }
76cd736e 6494
2814eb74 6495 o->op_opt = 1;
79072805
LW		 6496 break;
6497
a0d0e21e 6498 case OP_MAPWHILE:
79072805
LW		 6499 case OP_GREPWHILE:
6500 case OP_AND:
6501 case OP_OR:
c963b151 6502 case OP_DOR:
2c2d71f5
JH		 6503 case OP_ANDASSIGN:
6504 case OP_ORASSIGN:
c963b151 6505 case OP_DORASSIGN:
1a67a97c
SM		 6506 case OP_COND_EXPR:
6507 case OP_RANGE:
2814eb74 6508 o->op_opt = 1;
fd4d1407
IZ		 6509 while (cLOGOP->op_other->op_type == OP_NULL)
6510 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 6511 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 6512 break;
6513
79072805 6514 case OP_ENTERLOOP:
9c2ca71a 6515 case OP_ENTERITER:
2814eb74 6516 o->op_opt = 1;
58cccf98
SM		 6517 while (cLOOP->op_redoop->op_type == OP_NULL)
6518 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6519 peep(cLOOP->op_redoop);
58cccf98
SM		 6520 while (cLOOP->op_nextop->op_type == OP_NULL)
6521 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6522 peep(cLOOP->op_nextop);
58cccf98
SM		 6523 while (cLOOP->op_lastop->op_type == OP_NULL)
6524 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6525 peep(cLOOP->op_lastop);
6526 break;
6527
8782bef2 6528 case OP_QR:
79072805
LW		 6529 case OP_MATCH:
6530 case OP_SUBST:
2814eb74 6531 o->op_opt = 1;
9041c2e3 6532 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6533 cPMOP->op_pmreplstart->op_type == OP_NULL)
6534 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6535 peep(cPMOP->op_pmreplstart);
79072805
LW		 6536 break;
6537
a0d0e21e 6538 case OP_EXEC:
2814eb74 6539 o->op_opt = 1;
1c846c1f 6540 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 6541 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 6542 if (o->op_next->op_sibling &&
20408e3c
GS		 6543 o->op_next->op_sibling->op_type != OP_EXIT &&
6544 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6545 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 6546 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 6547
57843af0 6548 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 6549 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 6550 "Statement unlikely to be reached");
9014280d 6551 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 6552 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 6553 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 6554 }
6555 }
6556 break;
b2ffa427 6557
c750a3ec 6558 case OP_HELEM: {
6d822dc4
MS		 6559 SV *lexname;
6560 SV **svp, *sv;
1c846c1f 6561 char *key = NULL;
c750a3ec 6562 STRLEN keylen;
b2ffa427 6563
2814eb74 6564 o->op_opt = 1;
1c846c1f
NIS		 6565
6566 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6567 break;
1c846c1f
NIS		 6568
6569 /* Make the CONST have a shared SV */
6570 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6571 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 6572 key = SvPV(sv, keylen);
25716404
GS		 6573 lexname = newSVpvn_share(key,
6574 SvUTF8(sv) ? -(I32)keylen : keylen,
6575 0);
1c846c1f
NIS		 6576 SvREFCNT_dec(sv);
6577 *svp = lexname;
6578 }
6d822dc4
MS		 6579 break;
6580 }
c750a3ec 6581
fe1bc4cf
DM		 6582 case OP_SORT: {
6583 /* make @a = sort @a act in-place */
6584
6585 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6586 OP *oleft, *oright;
6587 OP *o2;
6588
2814eb74 6589 o->op_opt = 1;
fe1bc4cf
DM		 6590
6591 /* check that RHS of sort is a single plain array */
6592 oright = cUNOPo->op_first;
6593 if (!oright || oright->op_type != OP_PUSHMARK)
6594 break;
6595 oright = cUNOPx(oright)->op_sibling;
6596 if (!oright)
6597 break;
6598 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6599 oright = cUNOPx(oright)->op_sibling;
6600 }
6601
6602 if (!oright ||
6603 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6604 || oright->op_next != o
6605 || (oright->op_private & OPpLVAL_INTRO)
6606 )
6607 break;
6608
6609 /* o2 follows the chain of op_nexts through the LHS of the
6610 * assign (if any) to the aassign op itself */
6611 o2 = o->op_next;
6612 if (!o2 || o2->op_type != OP_NULL)
6613 break;
6614 o2 = o2->op_next;
6615 if (!o2 || o2->op_type != OP_PUSHMARK)
6616 break;
6617 o2 = o2->op_next;
6618 if (o2 && o2->op_type == OP_GV)
6619 o2 = o2->op_next;
6620 if (!o2
6621 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6622 || (o2->op_private & OPpLVAL_INTRO)
6623 )
6624 break;
6625 oleft = o2;
6626 o2 = o2->op_next;
6627 if (!o2 || o2->op_type != OP_NULL)
6628 break;
6629 o2 = o2->op_next;
6630 if (!o2 || o2->op_type != OP_AASSIGN
6631 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6632 break;
6633
6634 /* check the array is the same on both sides */
6635 if (oleft->op_type == OP_RV2AV) {
6636 if (oright->op_type != OP_RV2AV
6637 || !cUNOPx(oright)->op_first
6638 || cUNOPx(oright)->op_first->op_type != OP_GV
6639 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6640 cGVOPx_gv(cUNOPx(oright)->op_first)
6641 )
6642 break;
6643 }
6644 else if (oright->op_type != OP_PADAV
6645 || oright->op_targ != oleft->op_targ
6646 )
6647 break;
6648
6649 /* transfer MODishness etc from LHS arg to RHS arg */
6650 oright->op_flags = oleft->op_flags;
6651 o->op_private |= OPpSORT_INPLACE;
6652
6653 /* excise push->gv->rv2av->null->aassign */
6654 o2 = o->op_next->op_next;
6655 op_null(o2); /* PUSHMARK */
6656 o2 = o2->op_next;
6657 if (o2->op_type == OP_GV) {
6658 op_null(o2); /* GV */
6659 o2 = o2->op_next;
6660 }
6661 op_null(o2); /* RV2AV or PADAV */
6662 o2 = o2->op_next->op_next;
6663 op_null(o2); /* AASSIGN */
6664
6665 o->op_next = o2->op_next;
6666
6667 break;
6668 }
6669
6670
6671
79072805 6672 default:
2814eb74 6673 o->op_opt = 1;
79072805
LW		 6674 break;
6675 }
a0d0e21e 6676 oldop = o;
79072805 6677 }
a0d0e21e 6678 LEAVE;
79072805 6679}
beab0874 6680
19e8ce8e
AB		 6681
6682
6683char* Perl_custom_op_name(pTHX_ OP* o)
53e06cf0
SC		 6684{
6685 IV index = PTR2IV(o->op_ppaddr);
6686 SV* keysv;
6687 HE* he;
6688
6689 if (!PL_custom_op_names) /* This probably shouldn't happen */
6690 return PL_op_name[OP_CUSTOM];
6691
6692 keysv = sv_2mortal(newSViv(index));
6693
6694 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6695 if (!he)
6696 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6697
6698 return SvPV_nolen(HeVAL(he));
6699}
6700
19e8ce8e 6701char* Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0
SC		 6702{
6703 IV index = PTR2IV(o->op_ppaddr);
6704 SV* keysv;
6705 HE* he;
6706
6707 if (!PL_custom_op_descs)
6708 return PL_op_desc[OP_CUSTOM];
6709
6710 keysv = sv_2mortal(newSViv(index));
6711
6712 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6713 if (!he)
6714 return PL_op_desc[OP_CUSTOM];
6715
6716 return SvPV_nolen(HeVAL(he));
6717}
19e8ce8e 6718
53e06cf0 6719
beab0874
JT		 6720#include "XSUB.h"
6721
6722/* Efficient sub that returns a constant scalar value. */
6723static void
acfe0abc 6724const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 6725{
6726 dXSARGS;
9cbac4c7
DM		 6727 if (items != 0) {
6728#if 0
6729 Perl_croak(aTHX_ "usage: %s::%s()",
6730 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6731#endif
6732 }
9a049f1c 6733 EXTEND(sp, 1);
0768512c 6734 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 6735 XSRETURN(1);
6736}
Unnamed repository; edit this file 'description' to name the repository.