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