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