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
Integrate:
[perl5.git] / op.c
CommitLineData
d7559646 1 /* op.c
79072805 2 *
e6906430 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
2c351e65 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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
40d34c0d
SB		 19/* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
21 *
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
28 * stack.
29 *
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
34 *
35 * newBINOP(OP_ADD, flags,
36 * newSVREF($a),
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
38 * )
39 *
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
42 */
ccfc67b7 43
e93457dc
NC		 44/*
45Perl's compiler is essentially a 3-pass compiler with interleaved phases:
46
47 A bottom-up pass
48 A top-down pass
49 An execution-order pass
50
51The bottom-up pass is represented by all the "newOP" routines and
52the ck_ routines. The bottom-upness is actually driven by yacc.
53So at the point that a ck_ routine fires, we have no idea what the
54context is, either upward in the syntax tree, or either forward or
55backward in the execution order. (The bottom-up parser builds that
56part of the execution order it knows about, but if you follow the "next"
57links around, you'll find it's actually a closed loop through the
58top level node.
59
60Whenever the bottom-up parser gets to a node that supplies context to
61its components, it invokes that portion of the top-down pass that applies
62to that part of the subtree (and marks the top node as processed, so
63if a node further up supplies context, it doesn't have to take the
64plunge again). As a particular subcase of this, as the new node is
65built, it takes all the closed execution loops of its subcomponents
66and links them into a new closed loop for the higher level node. But
67it's still not the real execution order.
68
69The actual execution order is not known till we get a grammar reduction
70to a top-level unit like a subroutine or file that will be called by
71"name" rather than via a "next" pointer. At that point, we can call
72into peep() to do that code's portion of the 3rd pass. It has to be
73recursive, but it's recursive on basic blocks, not on tree nodes.
74*/
75
79072805 76#include "EXTERN.h"
864dbfa3 77#define PERL_IN_OP_C
79072805 78#include "perl.h"
77ca0c92 79#include "keywords.h"
79072805 80
a07e034d 81#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 82
238a4c30
NIS		 83#if defined(PL_OP_SLAB_ALLOC)
84
85#ifndef PERL_SLAB_SIZE
86#define PERL_SLAB_SIZE 2048
87#endif
88
aa39c176
JH		 89void *
90Perl_Slab_Alloc(pTHX_ int m, size_t sz)
1c846c1f 91{
5a8e194f
NIS		 92 /*
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
97 */
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 99 if ((PL_OpSpace -= sz) < 0) {
083fcd59
JH		 100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
101 if (!PL_OpPtr) {
238a4c30
NIS		 102 return NULL;
103 }
5a8e194f
NIS		 104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
109 */
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
114 */
5a8e194f 115 PL_OpPtr += PERL_SLAB_SIZE;
238a4c30
NIS		 116 }
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
119 PL_OpPtr -= sz;
5a8e194f 120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
126}
127
aa39c176
JH		 128void
129Perl_Slab_Free(pTHX_ void *op)
238a4c30 130{
78fd745e 131 I32 * const * const ptr = (I32 **) op;
c9dc1ff4 132 I32 * const slab = ptr[-1];
5a8e194f
NIS		 133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30
NIS		 135 assert( *slab > 0 );
136 if (--(*slab) == 0) {
56b65a99
AT		 137# ifdef NETWARE
138# define PerlMemShared PerlMem
139# endif
083fcd59
JH		 140
141 PerlMemShared_free(slab);
238a4c30
NIS		 142 if (slab == PL_OpSlab) {
143 PL_OpSpace = 0;
144 }
145 }
b7dc083c 146}
b7dc083c 147#endif
e50aee73 148/*
5900599a 149 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 150 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 151 */
11343788 152#define CHECKOP(type,o) \
5900599a 153 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 154 ? ( op_free((OP*)o), \
5b7ea690 155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
5900599a 156 (OP*)0 ) \
fc0dc3b3 157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 158
e6438c1a 159#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 160
db1c9db1 161STATIC const char*
cea2e8a9 162S_gv_ename(pTHX_ GV *gv)
4633a7c4 163{
217ef1d7 164 SV* const tmpsv = sv_newmortal();
0e2d6244 165 gv_efullname3(tmpsv, gv, NULL);
db1c9db1 166 return SvPV_nolen_const(tmpsv);
4633a7c4
LW		 167}
168
76e3520e 169STATIC OP *
cea2e8a9 170S_no_fh_allowed(pTHX_ OP *o)
79072805 171{
cea2e8a9 172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 173 OP_DESC(o)));
11343788 174 return o;
79072805
LW		 175}
176
76e3520e 177STATIC OP *
a00f3e00 178S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 179{
cea2e8a9 180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 181 return o;
79072805
LW		 182}
183
76e3520e 184STATIC OP *
a00f3e00 185S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 186{
cea2e8a9 187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 188 return o;
79072805
LW		 189}
190
76e3520e 191STATIC void
c501bbfe 192S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 193{
cea2e8a9 194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
5adb6136 195 (int)n, name, t, OP_DESC((OP *)kid)));
8990e307
LW		 196}
197
7a52d87a 198STATIC void
c501bbfe 199S_no_bareword_allowed(pTHX_ const OP *o)
7a52d87a 200{
5a844595 201 qerror(Perl_mess(aTHX_
c293eb2b 202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
f2139bd3 203 (void*)cSVOPo_sv));
7a52d87a
GS		 204}
205
79072805
LW		 206/* "register" allocation */
207
208PADOFFSET
9755d405 209Perl_allocmy(pTHX_ char *name)
93a17b20 210{
a0d0e21e 211 PADOFFSET off;
8916b559 212 const bool is_our = (PL_in_my == KEY_our);
a0d0e21e 213
9755d405 214 /* complain about "my $_" etc etc */
aae6d3c0 215 if (*name &&
8916b559 216 !(is_our ||
155aba94 217 isALPHA(name[1]) ||
39e02b42 218 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
aae6d3c0 219 (name[1] == '_' && name[2])))
834a4ddd 220 {
aae6d3c0 221 /* name[2] is true if strlen(name) > 2 */
c4d0567e 222 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
86d06bda
AL		 223 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
224 name[0], toCTRL(name[1]), name + 2));
225 } else {
226 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
46fc3d4c 227 }
a0d0e21e 228 }
9755d405 229 /* check for duplicate declaration */
8916b559 230 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
748a9306 231
9755d405
JH		 232 if (PL_in_my_stash && *name != '$') {
233 yyerror(Perl_form(aTHX_
234 "Can't declare class for non-scalar %s in \"%s\"",
8916b559 235 name, is_our ? "our" : "my"));
6b35e009
GS		 236 }
237
9755d405 238 /* allocate a spare slot and store the name in that slot */
93a17b20 239
9755d405
JH		 240 off = pad_add_name(name,
241 PL_in_my_stash,
8916b559 242 (is_our
9755d405 243 ? (PL_curstash ? PL_curstash : PL_defstash)
0e2d6244 244 : NULL
9755d405
JH		 245 ),
246 0 /* not fake */
247 );
248 return off;
79072805
LW		 249}
250
79072805 251
4d1ff10f 252#ifdef USE_5005THREADS
54b9620d 253/* find_threadsv is not reentrant */
a863c7d1 254PADOFFSET
864dbfa3 255Perl_find_threadsv(pTHX_ const char *name)
a863c7d1 256{
a863c7d1
MB		 257 char *p;
258 PADOFFSET key;
554b3eca 259 SV **svp;
54b9620d 260 /* We currently only handle names of a single character */
533c011a 261 p = strchr(PL_threadsv_names, *name);
a863c7d1
MB		 262 if (!p)
263 return NOT_IN_PAD;
533c011a 264 key = p - PL_threadsv_names;
2d8e6c8d 265 MUTEX_LOCK(&thr->mutex);
54b9620d 266 svp = av_fetch(thr->threadsv, key, FALSE);
2d8e6c8d
GS		 267 if (svp)
268 MUTEX_UNLOCK(&thr->mutex);
269 else {
133cdda0 270 SV *sv = newSV(0);
54b9620d 271 av_store(thr->threadsv, key, sv);
940cb80d 272 thr->threadsvp = AvARRAY(thr->threadsv);
2d8e6c8d 273 MUTEX_UNLOCK(&thr->mutex);
554b3eca
MB		 274 /*
275 * Some magic variables used to be automagically initialised
276 * in gv_fetchpv. Those which are now per-thread magicals get
277 * initialised here instead.
278 */
279 switch (*name) {
54b9620d
MB		 280 case '_':
281 break;
554b3eca
MB		 282 case ';':
283 sv_setpv(sv, "\034");
14befaf4 284 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 285 break;
c277df42
IZ		 286 case '&':
287 case '`':
288 case '\'':
533c011a 289 PL_sawampersand = TRUE;
a3f914c5
GS		 290 /* FALL THROUGH */
291 case '1':
292 case '2':
293 case '3':
294 case '4':
295 case '5':
296 case '6':
297 case '7':
298 case '8':
299 case '9':
c277df42 300 SvREADONLY_on(sv);
d8b5173a 301 /* FALL THROUGH */
067391ea
GS		 302
303 /* XXX %! tied to Errno.pm needs to be added here.
304 * See gv_fetchpv(). */
305 /* case '!': */
306
54b9620d 307 default:
14befaf4 308 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 309 }
bf49b057 310 DEBUG_S(PerlIO_printf(Perl_error_log,
54b9620d 311 "find_threadsv: new SV %p for $%s%c\n",
554b3eca
MB		 312 sv, (*name < 32) ? "^" : "",
313 (*name < 32) ? toCTRL(*name) : *name));
a863c7d1
MB		 314 }
315 return key;
316}
4d1ff10f 317#endif /* USE_5005THREADS */
a863c7d1 318
79072805
LW		 319/* Destructor */
320
321void
864dbfa3 322Perl_op_free(pTHX_ OP *o)
79072805 323{
acb36ea4 324 OPCODE type;
79072805 325
5dc0d613 326 if (!o || o->op_seq == (U16)-1)
79072805
LW		 327 return;
328
2ebc12fe 329 type = o->op_type;
7934575e 330 if (o->op_private & OPpREFCOUNTED) {
2ebc12fe 331 switch (type) {
7934575e
GS		 332 case OP_LEAVESUB:
333 case OP_LEAVESUBLV:
334 case OP_LEAVEEVAL:
335 case OP_LEAVE:
336 case OP_SCOPE:
337 case OP_LEAVEWRITE:
2ebc12fe
NC		 338 {
339 PADOFFSET refcnt;
7934575e 340 OP_REFCNT_LOCK;
46330ab1 341 refcnt = OpREFCNT_dec(o);
7934575e 342 OP_REFCNT_UNLOCK;
46330ab1
NC		 343 if (refcnt)
344 return;
2ebc12fe 345 }
7934575e
GS		 346 break;
347 default:
348 break;
349 }
350 }
351
11343788 352 if (o->op_flags & OPf_KIDS) {
c501bbfe 353 register OP *kid, *nextkid;
11343788 354 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 355 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 356 op_free(kid);
85e6fe83 357 }
79072805 358 }
acb36ea4 359 if (type == OP_NULL)
eb160463 360 type = (OPCODE)o->op_targ;
acb36ea4
GS		 361
362 /* COP* is not cleared by op_clear() so that we may track line
363 * numbers etc even after null() */
364 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
365 cop_free((COP*)o);
366
367 op_clear(o);
238a4c30 368 FreeOp(o);
acb36ea4 369}
79072805 370
93c66552
DM		 371void
372Perl_op_clear(pTHX_ OP *o)
acb36ea4 373{
13137afc 374
11343788 375 switch (o->op_type) {
acb36ea4
GS		 376 case OP_NULL: /* Was holding old type, if any. */
377 case OP_ENTEREVAL: /* Was holding hints. */
4d1ff10f 378#ifdef USE_5005THREADS
acb36ea4
GS		 379 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
380#endif
381 o->op_targ = 0;
a0d0e21e 382 break;
4d1ff10f 383#ifdef USE_5005THREADS
8dd3ba40
SM		 384 case OP_ENTERITER:
385 if (!(o->op_flags & OPf_SPECIAL))
386 break;
387 /* FALL THROUGH */
4d1ff10f 388#endif /* USE_5005THREADS */
a6006777 389 default:
ac4c12e7 390 if (!(o->op_flags & OPf_REF)
0b94c7bb 391 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 392 break;
393 /* FALL THROUGH */
463ee0b2 394 case OP_GVSV:
79072805 395 case OP_GV:
a6006777 396 case OP_AELEMFAST:
c9f5579e
TP		 397 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
398 /* not an OP_PADAV replacement */
350de78d 399#ifdef USE_ITHREADS
c9f5579e
TP		 400 if (cPADOPo->op_padix > 0) {
401 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
402 * may still exist on the pad */
403 pad_swipe(cPADOPo->op_padix, TRUE);
404 cPADOPo->op_padix = 0;
405 }
350de78d 406#else
c9f5579e 407 SvREFCNT_dec(cSVOPo->op_sv);
0e2d6244 408 cSVOPo->op_sv = NULL;
350de78d 409#endif
c9f5579e 410 }
79072805 411 break;
a1ae71d2 412 case OP_METHOD_NAMED:
79072805 413 case OP_CONST:
11343788 414 SvREFCNT_dec(cSVOPo->op_sv);
0e2d6244 415 cSVOPo->op_sv = NULL;
251c53ad
AE		 416#ifdef USE_ITHREADS
417 /** Bug #15654
418 Even if op_clear does a pad_free for the target of the op,
c9f5579e 419 pad_free doesn't actually remove the sv that exists in the pad;
251c53ad
AE		 420 instead it lives on. This results in that it could be reused as
421 a target later on when the pad was reallocated.
422 **/
423 if(o->op_targ) {
424 pad_swipe(o->op_targ,1);
425 o->op_targ = 0;
426 }
427#endif
79072805 428 break;
748a9306
LW		 429 case OP_GOTO:
430 case OP_NEXT:
431 case OP_LAST:
432 case OP_REDO:
11343788 433 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 434 break;
435 /* FALL THROUGH */
a0d0e21e 436 case OP_TRANS:
acb36ea4 437 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 438 SvREFCNT_dec(cSVOPo->op_sv);
0e2d6244 439 cSVOPo->op_sv = NULL;
acb36ea4
GS		 440 }
441 else {
a0ed51b3 442 Safefree(cPVOPo->op_pv);
0e2d6244 443 cPVOPo->op_pv = NULL;
acb36ea4 444 }
a0d0e21e
LW		 445 break;
446 case OP_SUBST:
11343788 447 op_free(cPMOPo->op_pmreplroot);
971a9dd3 448 goto clear_pmop;
748a9306 449 case OP_PUSHRE:
971a9dd3 450#ifdef USE_ITHREADS
ba89bb6e 451 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
9755d405
JH		 452 /* No GvIN_PAD_off here, because other references may still
453 * exist on the pad */
454 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
971a9dd3
GS		 455 }
456#else
457 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
458#endif
459 /* FALL THROUGH */
a0d0e21e 460 case OP_MATCH:
8782bef2 461 case OP_QR:
971a9dd3 462clear_pmop:
cb55de95 463 {
78fd745e 464 HV * const pmstash = PmopSTASH(cPMOPo);
546fbbb9 465 if (pmstash && !SvIS_FREED(pmstash)) {
cb55de95
JH		 466 PMOP *pmop = HvPMROOT(pmstash);
467 PMOP *lastpmop = NULL;
468 while (pmop) {
469 if (cPMOPo == pmop) {
470 if (lastpmop)
471 lastpmop->op_pmnext = pmop->op_pmnext;
472 else
473 HvPMROOT(pmstash) = pmop->op_pmnext;
474 break;
475 }
476 lastpmop = pmop;
477 pmop = pmop->op_pmnext;
478 }
83da49e6 479 }
05ec9bb3 480 PmopSTASH_free(cPMOPo);
cb55de95 481 }
5900599a 482 cPMOPo->op_pmreplroot = NULL;
5f8cb046
DM		 483 /* we use the "SAFE" version of the PM_ macros here
484 * since sv_clean_all might release some PMOPs
485 * after PL_regex_padav has been cleared
486 * and the clearing of PL_regex_padav needs to
487 * happen before sv_clean_all
488 */
489 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
5900599a 490 PM_SETRE_SAFE(cPMOPo, NULL);
13137afc
AB		 491#ifdef USE_ITHREADS
492 if(PL_regex_pad) { /* We could be in destruction */
493 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 494 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 495 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
496 }
1eb1540c 497#endif
13137afc 498
a0d0e21e 499 break;
79072805
LW		 500 }
501
743e66e6 502 if (o->op_targ > 0) {
11343788 503 pad_free(o->op_targ);
743e66e6
GS		 504 o->op_targ = 0;
505 }
79072805
LW		 506}
507
76e3520e 508STATIC void
3eb57f73
HS		 509S_cop_free(pTHX_ COP* cop)
510{
05ec9bb3
NIS		 511 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
512 CopFILE_free(cop);
513 CopSTASH_free(cop);
0453d815 514 if (! specialWARN(cop->cop_warnings))
3eb57f73 515 SvREFCNT_dec(cop->cop_warnings);
05ec9bb3
NIS		 516 if (! specialCopIO(cop->cop_io)) {
517#ifdef USE_ITHREADS
c9c8c8e1 518 NOOP;
05ec9bb3 519#else
ac27b0f5 520 SvREFCNT_dec(cop->cop_io);
05ec9bb3
NIS		 521#endif
522 }
2ae05241
NC		 523 if (PL_curcop == cop)
524 PL_curcop = NULL;
3eb57f73
HS		 525}
526
93c66552
DM		 527void
528Perl_op_null(pTHX_ OP *o)
8990e307 529{
acb36ea4
GS		 530 if (o->op_type == OP_NULL)
531 return;
532 op_clear(o);
11343788
MB		 533 o->op_targ = o->op_type;
534 o->op_type = OP_NULL;
22c35a8c 535 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 536}
537
46330ab1
NC		 538void
539Perl_op_refcnt_lock(pTHX)
540{
1e7ed80e 541 PERL_UNUSED_CONTEXT;
46330ab1
NC		 542 OP_REFCNT_LOCK;
543}
544
545void
546Perl_op_refcnt_unlock(pTHX)
547{
1e7ed80e 548 PERL_UNUSED_CONTEXT;
46330ab1
NC		 549 OP_REFCNT_UNLOCK;
550}
551
79072805
LW		 552/* Contextualizers */
553
463ee0b2 554#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 555
556OP *
864dbfa3 557Perl_linklist(pTHX_ OP *o)
79072805 558{
8916b559 559 OP *first;
79072805 560
11343788
MB		 561 if (o->op_next)
562 return o->op_next;
79072805
LW		 563
564 /* establish postfix order */
8916b559
NC		 565 first = cUNOPo->op_first;
566 if (first) {
c501bbfe 567 register OP *kid;
8916b559
NC		 568 o->op_next = LINKLIST(first);
569 kid = first;
570 for (;;) {
571 if (kid->op_sibling) {
79072805 572 kid->op_next = LINKLIST(kid->op_sibling);
8916b559
NC		 573 kid = kid->op_sibling;
574 } else {
11343788 575 kid->op_next = o;
8916b559
NC		 576 break;
577 }
79072805
LW		 578 }
579 }
580 else
11343788 581 o->op_next = o;
79072805 582
11343788 583 return o->op_next;
79072805
LW		 584}
585
586OP *
864dbfa3 587Perl_scalarkids(pTHX_ OP *o)
79072805 588{
11343788 589 if (o && o->op_flags & OPf_KIDS) {
a00f3e00 590 OP *kid;
11343788 591 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 592 scalar(kid);
593 }
11343788 594 return o;
79072805
LW		 595}
596
76e3520e 597STATIC OP *
cea2e8a9 598S_scalarboolean(pTHX_ OP *o)
8990e307 599{
d008e5eb 600 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 601 if (ckWARN(WARN_SYNTAX)) {
c501bbfe 602 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 603
d008e5eb 604 if (PL_copline != NOLINE)
57843af0 605 CopLINE_set(PL_curcop, PL_copline);
9014280d 606 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 607 CopLINE_set(PL_curcop, oldline);
d008e5eb 608 }
a0d0e21e 609 }
11343788 610 return scalar(o);
8990e307
LW		 611}
612
613OP *
864dbfa3 614Perl_scalar(pTHX_ OP *o)
79072805
LW		 615{
616 OP *kid;
617
a0d0e21e 618 /* assumes no premature commitment */
78fd745e 619 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
5dc0d613 620 || o->op_type == OP_RETURN)
7e363e51 621 {
11343788 622 return o;
7e363e51 623 }
79072805 624
5dc0d613 625 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 626
11343788 627 switch (o->op_type) {
79072805 628 case OP_REPEAT:
11343788 629 scalar(cBINOPo->op_first);
8990e307 630 break;
79072805
LW		 631 case OP_OR:
632 case OP_AND:
633 case OP_COND_EXPR:
11343788 634 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 635 scalar(kid);
79072805 636 break;
a0d0e21e 637 case OP_SPLIT:
11343788 638 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 639 if (!kPMOP->op_pmreplroot)
12bcd1a6 640 deprecate_old("implicit split to @_");
a0d0e21e
LW		 641 }
642 /* FALL THROUGH */
79072805 643 case OP_MATCH:
8782bef2 644 case OP_QR:
79072805
LW		 645 case OP_SUBST:
646 case OP_NULL:
8990e307 647 default:
11343788
MB		 648 if (o->op_flags & OPf_KIDS) {
649 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 650 scalar(kid);
651 }
79072805
LW		 652 break;
653 case OP_LEAVE:
654 case OP_LEAVETRY:
5dc0d613 655 kid = cLISTOPo->op_first;
54310121 656 scalar(kid);
155aba94 657 while ((kid = kid->op_sibling)) {
54310121 658 if (kid->op_sibling)
659 scalarvoid(kid);
660 else
661 scalar(kid);
662 }
620e3b3d 663 PL_curcop = &PL_compiling;
54310121 664 break;
748a9306 665 case OP_SCOPE:
79072805 666 case OP_LINESEQ:
8990e307 667 case OP_LIST:
11343788 668 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 669 if (kid->op_sibling)
670 scalarvoid(kid);
671 else
672 scalar(kid);
673 }
620e3b3d 674 PL_curcop = &PL_compiling;
79072805 675 break;
a801c63c
RGS		 676 case OP_SORT:
677 if (ckWARN(WARN_VOID))
9014280d 678 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 679 }
11343788 680 return o;
79072805
LW		 681}
682
683OP *
864dbfa3 684Perl_scalarvoid(pTHX_ OP *o)
79072805
LW		 685{
686 OP *kid;
f4362cdc 687 const char* useless = NULL;
8990e307 688 SV* sv;
2ebea0a1
GS		 689 U8 want;
690
acb36ea4
GS		 691 if (o->op_type == OP_NEXTSTATE
692 || o->op_type == OP_SETSTATE
693 || o->op_type == OP_DBSTATE
694 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
695 || o->op_targ == OP_SETSTATE
696 || o->op_targ == OP_DBSTATE)))
2ebea0a1 697 PL_curcop = (COP*)o; /* for warning below */
79072805 698
54310121 699 /* assumes no premature commitment */
2ebea0a1
GS		 700 want = o->op_flags & OPf_WANT;
701 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 702 || o->op_type == OP_RETURN)
7e363e51 703 {
11343788 704 return o;
7e363e51 705 }
79072805 706
b162f9ea 707 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 708 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
709 {
b162f9ea 710 return scalar(o); /* As if inside SASSIGN */
7e363e51 711 }
1c846c1f 712
5dc0d613 713 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 714
11343788 715 switch (o->op_type) {
79072805 716 default:
22c35a8c 717 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 718 break;
36477c24 719 /* FALL THROUGH */
720 case OP_REPEAT:
11343788 721 if (o->op_flags & OPf_STACKED)
8990e307 722 break;
5d82c453
GA		 723 goto func_ops;
724 case OP_SUBSTR:
725 if (o->op_private == 4)
726 break;
8990e307
LW		 727 /* FALL THROUGH */
728 case OP_GVSV:
729 case OP_WANTARRAY:
730 case OP_GV:
731 case OP_PADSV:
732 case OP_PADAV:
733 case OP_PADHV:
734 case OP_PADANY:
735 case OP_AV2ARYLEN:
8990e307 736 case OP_REF:
a0d0e21e
LW		 737 case OP_REFGEN:
738 case OP_SREFGEN:
8990e307
LW		 739 case OP_DEFINED:
740 case OP_HEX:
741 case OP_OCT:
742 case OP_LENGTH:
8990e307
LW		 743 case OP_VEC:
744 case OP_INDEX:
745 case OP_RINDEX:
746 case OP_SPRINTF:
747 case OP_AELEM:
748 case OP_AELEMFAST:
749 case OP_ASLICE:
8990e307
LW		 750 case OP_HELEM:
751 case OP_HSLICE:
752 case OP_UNPACK:
753 case OP_PACK:
8990e307
LW		 754 case OP_JOIN:
755 case OP_LSLICE:
756 case OP_ANONLIST:
757 case OP_ANONHASH:
758 case OP_SORT:
759 case OP_REVERSE:
760 case OP_RANGE:
761 case OP_FLIP:
762 case OP_FLOP:
763 case OP_CALLER:
764 case OP_FILENO:
765 case OP_EOF:
766 case OP_TELL:
767 case OP_GETSOCKNAME:
768 case OP_GETPEERNAME:
769 case OP_READLINK:
770 case OP_TELLDIR:
771 case OP_GETPPID:
772 case OP_GETPGRP:
773 case OP_GETPRIORITY:
774 case OP_TIME:
775 case OP_TMS:
776 case OP_LOCALTIME:
777 case OP_GMTIME:
778 case OP_GHBYNAME:
779 case OP_GHBYADDR:
780 case OP_GHOSTENT:
781 case OP_GNBYNAME:
782 case OP_GNBYADDR:
783 case OP_GNETENT:
784 case OP_GPBYNAME:
785 case OP_GPBYNUMBER:
786 case OP_GPROTOENT:
787 case OP_GSBYNAME:
788 case OP_GSBYPORT:
789 case OP_GSERVENT:
790 case OP_GPWNAM:
791 case OP_GPWUID:
792 case OP_GGRNAM:
793 case OP_GGRGID:
794 case OP_GETLOGIN:
5b7ea690 795 case OP_PROTOTYPE:
5d82c453 796 func_ops:
64aac5a9 797 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 798 useless = OP_DESC(o);
8990e307
LW		 799 break;
800
801 case OP_RV2GV:
802 case OP_RV2SV:
803 case OP_RV2AV:
804 case OP_RV2HV:
192587c2 805 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 806 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 807 useless = "a variable";
808 break;
79072805
LW		 809
810 case OP_CONST:
7766f137 811 sv = cSVOPo_sv;
7a52d87a
GS		 812 if (cSVOPo->op_private & OPpCONST_STRICT)
813 no_bareword_allowed(o);
814 else {
d008e5eb
GS		 815 if (ckWARN(WARN_VOID)) {
816 useless = "a constant";
c20147de 817 if (o->op_private & OPpCONST_ARYBASE)
43b2f713 818 useless = NULL;
ce825180
NC		 819 /* don't warn on optimised away booleans, eg
820 * use constant Foo, 5; Foo || print; */
821 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
43b2f713 822 useless = NULL;
960b4253
MG		 823 /* the constants 0 and 1 are permitted as they are
824 conventionally used as dummies in constructs like
825 1 while some_condition_with_side_effects; */
ce825180 826 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
43b2f713 827 useless = NULL;
d008e5eb 828 else if (SvPOK(sv)) {
a52fe3ac
A		 829 /* perl4's way of mixing documentation and code
830 (before the invention of POD) was based on a
831 trick to mix nroff and perl code. The trick was
832 built upon these three nroff macros being used in
833 void context. The pink camel has the details in
834 the script wrapman near page 319. */
8916b559
NC		 835 const char * const maybe_macro = SvPVX_const(sv);
836 if (strnEQ(maybe_macro, "di", 2) ||
837 strnEQ(maybe_macro, "ds", 2) ||
838 strnEQ(maybe_macro, "ig", 2))
43b2f713 839 useless = NULL;
d008e5eb 840 }
8990e307
LW		 841 }
842 }
93c66552 843 op_null(o); /* don't execute or even remember it */
79072805
LW		 844 break;
845
846 case OP_POSTINC:
11343788 847 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 848 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 849 break;
850
851 case OP_POSTDEC:
11343788 852 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 853 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 854 break;
855
c53afe68
NC		 856 case OP_I_POSTINC:
857 o->op_type = OP_I_PREINC; /* pre-increment is faster */
858 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
859 break;
860
861 case OP_I_POSTDEC:
862 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
863 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
864 break;
865
79072805
LW		 866 case OP_OR:
867 case OP_AND:
868 case OP_COND_EXPR:
11343788 869 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 870 scalarvoid(kid);
871 break;
5aabfad6 872
a0d0e21e 873 case OP_NULL:
11343788 874 if (o->op_flags & OPf_STACKED)
a0d0e21e 875 break;
5aabfad6 876 /* FALL THROUGH */
2ebea0a1
GS		 877 case OP_NEXTSTATE:
878 case OP_DBSTATE:
79072805
LW		 879 case OP_ENTERTRY:
880 case OP_ENTER:
11343788 881 if (!(o->op_flags & OPf_KIDS))
79072805 882 break;
54310121 883 /* FALL THROUGH */
463ee0b2 884 case OP_SCOPE:
79072805
LW		 885 case OP_LEAVE:
886 case OP_LEAVETRY:
a0d0e21e 887 case OP_LEAVELOOP:
79072805 888 case OP_LINESEQ:
79072805 889 case OP_LIST:
11343788 890 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 891 scalarvoid(kid);
892 break;
c90c0ff4 893 case OP_ENTEREVAL:
5196be3e 894 scalarkids(o);
c90c0ff4 895 break;
5aabfad6 896 case OP_REQUIRE:
c90c0ff4 897 /* all requires must return a boolean value */
5196be3e 898 o->op_flags &= ~OPf_WANT;
d6483035
GS		 899 /* FALL THROUGH */
900 case OP_SCALAR:
5196be3e 901 return scalar(o);
a0d0e21e 902 case OP_SPLIT:
11343788 903 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 904 if (!kPMOP->op_pmreplroot)
12bcd1a6 905 deprecate_old("implicit split to @_");
a0d0e21e
LW		 906 }
907 break;
79072805 908 }
411caa50 909 if (useless && ckWARN(WARN_VOID))
9014280d 910 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 911 return o;
79072805
LW		 912}
913
914OP *
864dbfa3 915Perl_listkids(pTHX_ OP *o)
79072805 916{
11343788 917 if (o && o->op_flags & OPf_KIDS) {
c501bbfe 918 OP *kid;
11343788 919 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 920 list(kid);
921 }
11343788 922 return o;
79072805
LW		 923}
924
925OP *
864dbfa3 926Perl_list(pTHX_ OP *o)
79072805
LW		 927{
928 OP *kid;
929
a0d0e21e 930 /* assumes no premature commitment */
3280af22 931 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 932 || o->op_type == OP_RETURN)
7e363e51 933 {
11343788 934 return o;
7e363e51 935 }
79072805 936
b162f9ea 937 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 938 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
939 {
b162f9ea 940 return o; /* As if inside SASSIGN */
7e363e51 941 }
1c846c1f 942
5dc0d613 943 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 944
11343788 945 switch (o->op_type) {
79072805
LW		 946 case OP_FLOP:
947 case OP_REPEAT:
11343788 948 list(cBINOPo->op_first);
79072805
LW		 949 break;
950 case OP_OR:
951 case OP_AND:
952 case OP_COND_EXPR:
11343788 953 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 954 list(kid);
955 break;
956 default:
957 case OP_MATCH:
8782bef2 958 case OP_QR:
79072805
LW		 959 case OP_SUBST:
960 case OP_NULL:
11343788 961 if (!(o->op_flags & OPf_KIDS))
79072805 962 break;
11343788
MB		 963 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
964 list(cBINOPo->op_first);
965 return gen_constant_list(o);
79072805
LW		 966 }
967 case OP_LIST:
11343788 968 listkids(o);
79072805
LW		 969 break;
970 case OP_LEAVE:
971 case OP_LEAVETRY:
5dc0d613 972 kid = cLISTOPo->op_first;
54310121 973 list(kid);
155aba94 974 while ((kid = kid->op_sibling)) {
54310121 975 if (kid->op_sibling)
976 scalarvoid(kid);
977 else
978 list(kid);
979 }
620e3b3d 980 PL_curcop = &PL_compiling;
54310121 981 break;
748a9306 982 case OP_SCOPE:
79072805 983 case OP_LINESEQ:
11343788 984 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 985 if (kid->op_sibling)
986 scalarvoid(kid);
987 else
988 list(kid);
989 }
620e3b3d 990 PL_curcop = &PL_compiling;
79072805 991 break;
c90c0ff4 992 case OP_REQUIRE:
993 /* all requires must return a boolean value */
5196be3e
MB		 994 o->op_flags &= ~OPf_WANT;
995 return scalar(o);
79072805 996 }
11343788 997 return o;
79072805
LW		 998}
999
1000OP *
864dbfa3 1001Perl_scalarseq(pTHX_ OP *o)
79072805 1002{
11343788 1003 if (o) {
8c6f7913
AL		 1004 const OPCODE type = o->op_type;
1005
1006 if (type == OP_LINESEQ || type == OP_SCOPE ||
1007 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1008 {
c501bbfe 1009 OP *kid;
11343788 1010 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1011 if (kid->op_sibling) {
463ee0b2 1012 scalarvoid(kid);
ed6116ce 1013 }
463ee0b2 1014 }
3280af22 1015 PL_curcop = &PL_compiling;
79072805 1016 }
11343788 1017 o->op_flags &= ~OPf_PARENS;
3280af22 1018 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1019 o->op_flags |= OPf_PARENS;
79072805 1020 }
8990e307 1021 else
11343788
MB		 1022 o = newOP(OP_STUB, 0);
1023 return o;
79072805
LW		 1024}
1025
76e3520e 1026STATIC OP *
cea2e8a9 1027S_modkids(pTHX_ OP *o, I32 type)
79072805 1028{
11343788 1029 if (o && o->op_flags & OPf_KIDS) {
c501bbfe 1030 OP *kid;
11343788 1031 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1032 mod(kid, type);
79072805 1033 }
11343788 1034 return o;
79072805
LW		 1035}
1036
79072805 1037OP *
864dbfa3 1038Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW		 1039{
1040 OP *kid;
79072805 1041
3280af22 1042 if (!o || PL_error_count)
11343788 1043 return o;
79072805 1044
b162f9ea 1045 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1046 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1047 {
b162f9ea 1048 return o;
7e363e51 1049 }
1c846c1f 1050
11343788 1051 switch (o->op_type) {
68dc0745 1052 case OP_UNDEF:
3280af22 1053 PL_modcount++;
5dc0d613 1054 return o;
a0d0e21e 1055 case OP_CONST:
c20147de 1056 if (!(o->op_private & OPpCONST_ARYBASE))
a0d0e21e 1057 goto nomod;
3280af22 1058 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
2cb86c03
NC		 1059 CopARYBASE_set(&PL_compiling,
1060 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
3280af22 1061 PL_eval_start = 0;
a0d0e21e
LW		 1062 }
1063 else if (!type) {
2cb86c03
NC		 1064 SAVECOPARYBASE(&PL_compiling);
1065 CopARYBASE_set(&PL_compiling, 0);
a0d0e21e
LW		 1066 }
1067 else if (type == OP_REFGEN)
1068 goto nomod;
1069 else
cea2e8a9 1070 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1071 break;
5f05dabc 1072 case OP_STUB:
5196be3e 1073 if (o->op_flags & OPf_PARENS)
5f05dabc 1074 break;
1075 goto nomod;
a0d0e21e
LW		 1076 case OP_ENTERSUB:
1077 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1078 !(o->op_flags & OPf_STACKED)) {
1079 o->op_type = OP_RV2CV; /* entersub => rv2cv */
6aa01a30
NC		 1080 /* The default is to set op_private to the number of children,
1081 which for a UNOP such as RV2CV is always 1. And w're using
1082 the bit for a flag in RV2CV, so we need it clear. */
1083 o->op_private &= ~1;
22c35a8c 1084 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1085 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1086 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1087 break;
1088 }
95f0a2f1
SB		 1089 else if (o->op_private & OPpENTERSUB_NOMOD)
1090 return o;
cd06dffe
GS		 1091 else { /* lvalue subroutine call */
1092 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1093 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1094 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1095 /* Backward compatibility mode: */
1096 o->op_private |= OPpENTERSUB_INARGS;
1097 break;
1098 }
1099 else { /* Compile-time error message: */
1100 OP *kid = cUNOPo->op_first;
1101 CV *cv;
1102 OP *okid;
1103
2213ec13
NC		 1104 if (kid->op_type != OP_PUSHMARK) {
1105 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1106 Perl_croak(aTHX_
1107 "panic: unexpected lvalue entersub "
1108 "args: type/targ %ld:%"UVuf,
1109 (long)kid->op_type, (UV)kid->op_targ);
1110 kid = kLISTOP->op_first;
1111 }
cd06dffe
GS		 1112 while (kid->op_sibling)
1113 kid = kid->op_sibling;
1114 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1115 /* Indirect call */
1116 if (kid->op_type == OP_METHOD_NAMED
1117 || kid->op_type == OP_METHOD)
1118 {
87d7fd28 1119 UNOP *newop;
b2ffa427 1120
87d7fd28 1121 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1122 newop->op_type = OP_RV2CV;
1123 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
5900599a 1124 newop->op_first = NULL;
87d7fd28
GS		 1125 newop->op_next = (OP*)newop;
1126 kid->op_sibling = (OP*)newop;
349fd7b7 1127 newop->op_private |= OPpLVAL_INTRO;
6aa01a30 1128 newop->op_private &= ~1;
cd06dffe
GS		 1129 break;
1130 }
b2ffa427 1131
cd06dffe
GS		 1132 if (kid->op_type != OP_RV2CV)
1133 Perl_croak(aTHX_
1134 "panic: unexpected lvalue entersub "
55140b79 1135 "entry via type/targ %ld:%"UVuf,
3d811634 1136 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1137 kid->op_private |= OPpLVAL_INTRO;
1138 break; /* Postpone until runtime */
1139 }
b2ffa427
NIS		 1140
1141 okid = kid;
cd06dffe
GS		 1142 kid = kUNOP->op_first;
1143 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1144 kid = kUNOP->op_first;
b2ffa427 1145 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1146 Perl_croak(aTHX_
1147 "Unexpected constant lvalue entersub "
55140b79 1148 "entry via type/targ %ld:%"UVuf,
3d811634 1149 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1150 if (kid->op_type != OP_GV) {
1151 /* Restore RV2CV to check lvalueness */
1152 restore_2cv:
1153 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1154 okid->op_next = kid->op_next;
1155 kid->op_next = okid;
1156 }
1157 else
5900599a 1158 okid->op_next = NULL;
cd06dffe
GS		 1159 okid->op_type = OP_RV2CV;
1160 okid->op_targ = 0;
1161 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1162 okid->op_private |= OPpLVAL_INTRO;
6aa01a30 1163 okid->op_private &= ~1;
cd06dffe
GS		 1164 break;
1165 }
b2ffa427 1166
638eceb6 1167 cv = GvCV(kGVOP_gv);
1c846c1f 1168 if (!cv)
cd06dffe
GS		 1169 goto restore_2cv;
1170 if (CvLVALUE(cv))
1171 break;
1172 }
1173 }
79072805
LW		 1174 /* FALL THROUGH */
1175 default:
a0d0e21e 1176 nomod:
3fc4677c
NC		 1177 /* grep, foreach, subcalls, refgen */
1178 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
a0d0e21e 1179 break;
cea2e8a9 1180 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1181 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1182 ? "do block"
1183 : (o->op_type == OP_ENTERSUB
1184 ? "non-lvalue subroutine call"
53e06cf0 1185 : OP_DESC(o))),
22c35a8c 1186 type ? PL_op_desc[type] : "local"));
11343788 1187 return o;
79072805 1188
a0d0e21e
LW		 1189 case OP_PREINC:
1190 case OP_PREDEC:
1191 case OP_POW:
1192 case OP_MULTIPLY:
1193 case OP_DIVIDE:
1194 case OP_MODULO:
1195 case OP_REPEAT:
1196 case OP_ADD:
1197 case OP_SUBTRACT:
1198 case OP_CONCAT:
1199 case OP_LEFT_SHIFT:
1200 case OP_RIGHT_SHIFT:
1201 case OP_BIT_AND:
1202 case OP_BIT_XOR:
1203 case OP_BIT_OR:
1204 case OP_I_MULTIPLY:
1205 case OP_I_DIVIDE:
1206 case OP_I_MODULO:
1207 case OP_I_ADD:
1208 case OP_I_SUBTRACT:
11343788 1209 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1210 goto nomod;
3280af22 1211 PL_modcount++;
a0d0e21e 1212 break;
b2ffa427 1213
79072805 1214 case OP_COND_EXPR:
11343788 1215 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1216 mod(kid, type);
79072805
LW		 1217 break;
1218
1219 case OP_RV2AV:
1220 case OP_RV2HV:
11343788 1221 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1222 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1223 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1224 }
1225 /* FALL THROUGH */
79072805 1226 case OP_RV2GV:
5dc0d613 1227 if (scalar_mod_type(o, type))
3fe9a6f1 1228 goto nomod;
11343788 1229 ref(cUNOPo->op_first, o->op_type);
79072805 1230 /* FALL THROUGH */
79072805
LW		 1231 case OP_ASLICE:
1232 case OP_HSLICE:
78f9721b
SM		 1233 if (type == OP_LEAVESUBLV)
1234 o->op_private |= OPpMAYBE_LVSUB;
1235 /* FALL THROUGH */
1236 case OP_AASSIGN:
93a17b20
LW		 1237 case OP_NEXTSTATE:
1238 case OP_DBSTATE:
e6438c1a 1239 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1240 break;
463ee0b2 1241 case OP_RV2SV:
aeea060c 1242 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1243 /* FALL THROUGH */
79072805 1244 case OP_GV:
463ee0b2 1245 case OP_AV2ARYLEN:
3280af22 1246 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1247 case OP_SASSIGN:
bf4b1e52
GS		 1248 case OP_ANDASSIGN:
1249 case OP_ORASSIGN:
8990e307 1250 case OP_AELEMFAST:
c9f5579e
TP		 1251 /* Needed if maint gets patch 19588
1252 localize = -1;
1253 */
3280af22 1254 PL_modcount++;
8990e307
LW		 1255 break;
1256
748a9306
LW		 1257 case OP_PADAV:
1258 case OP_PADHV:
e6438c1a 1259 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1260 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1261 return o; /* Treat \(@foo) like ordinary list. */
1262 if (scalar_mod_type(o, type))
3fe9a6f1 1263 goto nomod;
78f9721b
SM		 1264 if (type == OP_LEAVESUBLV)
1265 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1266 /* FALL THROUGH */
1267 case OP_PADSV:
3280af22 1268 PL_modcount++;
748a9306 1269 if (!type)
9755d405
JH		 1270 { /* XXX DAPM 2002.08.25 tmp assert test */
1271 /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1272 /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1273
cea2e8a9 1274 Perl_croak(aTHX_ "Can't localize lexical variable %s",
9755d405
JH		 1275 PAD_COMPNAME_PV(o->op_targ));
1276 }
463ee0b2
LW		 1277 break;
1278
4d1ff10f 1279#ifdef USE_5005THREADS
2faa37cc 1280 case OP_THREADSV:
533c011a 1281 PL_modcount++; /* XXX ??? */
554b3eca 1282 break;
4d1ff10f 1283#endif /* USE_5005THREADS */
554b3eca 1284
748a9306
LW		 1285 case OP_PUSHMARK:
1286 break;
b2ffa427 1287
69969c6f
SB		 1288 case OP_KEYS:
1289 if (type != OP_SASSIGN)
1290 goto nomod;
5d82c453
GA		 1291 goto lvalue_func;
1292 case OP_SUBSTR:
1293 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1294 goto nomod;
5f05dabc 1295 /* FALL THROUGH */
a0d0e21e 1296 case OP_POS:
463ee0b2 1297 case OP_VEC:
78f9721b
SM		 1298 if (type == OP_LEAVESUBLV)
1299 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1300 lvalue_func:
11343788
MB		 1301 pad_free(o->op_targ);
1302 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1303 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1304 if (o->op_flags & OPf_KIDS)
1305 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1306 break;
a0d0e21e 1307
463ee0b2
LW		 1308 case OP_AELEM:
1309 case OP_HELEM:
11343788 1310 ref(cBINOPo->op_first, o->op_type);
68dc0745 1311 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1312 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1313 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1314 if (type == OP_LEAVESUBLV)
1315 o->op_private |= OPpMAYBE_LVSUB;
3280af22 1316 PL_modcount++;
463ee0b2
LW		 1317 break;
1318
1319 case OP_SCOPE:
1320 case OP_LEAVE:
1321 case OP_ENTER:
78f9721b 1322 case OP_LINESEQ:
11343788
MB		 1323 if (o->op_flags & OPf_KIDS)
1324 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1325 break;
1326
1327 case OP_NULL:
638bc118
GS		 1328 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1329 goto nomod;
1330 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1331 break;
11343788
MB		 1332 if (o->op_targ != OP_LIST) {
1333 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1334 break;
1335 }
1336 /* FALL THROUGH */
463ee0b2 1337 case OP_LIST:
11343788 1338 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1339 mod(kid, type);
1340 break;
78f9721b
SM		 1341
1342 case OP_RETURN:
1343 if (type != OP_LEAVESUBLV)
1344 goto nomod;
1345 break; /* mod()ing was handled by ck_return() */
463ee0b2 1346 }
58d95175 1347
8be1be90
AMS		 1348 /* [20011101.069] File test operators interpret OPf_REF to mean that
1349 their argument is a filehandle; thus \stat(".") should not set
1350 it. AMS 20011102 */
1351 if (type == OP_REFGEN &&
1352 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1353 return o;
1354
1355 if (type != OP_LEAVESUBLV)
1356 o->op_flags |= OPf_MOD;
1357
1358 if (type == OP_AASSIGN || type == OP_SASSIGN)
1359 o->op_flags |= OPf_SPECIAL|OPf_REF;
1360 else if (!type) {
1361 o->op_private |= OPpLVAL_INTRO;
1362 o->op_flags &= ~OPf_SPECIAL;
1363 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1364 }
8be1be90
AMS		 1365 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1366 && type != OP_LEAVESUBLV)
1367 o->op_flags |= OPf_REF;
11343788 1368 return o;
463ee0b2
LW		 1369}
1370
864dbfa3 1371STATIC bool
5900599a 1372S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 1373{
1374 switch (type) {
1375 case OP_SASSIGN:
5196be3e 1376 if (o->op_type == OP_RV2GV)
3fe9a6f1 1377 return FALSE;
1378 /* FALL THROUGH */
1379 case OP_PREINC:
1380 case OP_PREDEC:
1381 case OP_POSTINC:
1382 case OP_POSTDEC:
1383 case OP_I_PREINC:
1384 case OP_I_PREDEC:
1385 case OP_I_POSTINC:
1386 case OP_I_POSTDEC:
1387 case OP_POW:
1388 case OP_MULTIPLY:
1389 case OP_DIVIDE:
1390 case OP_MODULO:
1391 case OP_REPEAT:
1392 case OP_ADD:
1393 case OP_SUBTRACT:
1394 case OP_I_MULTIPLY:
1395 case OP_I_DIVIDE:
1396 case OP_I_MODULO:
1397 case OP_I_ADD:
1398 case OP_I_SUBTRACT:
1399 case OP_LEFT_SHIFT:
1400 case OP_RIGHT_SHIFT:
1401 case OP_BIT_AND:
1402 case OP_BIT_XOR:
1403 case OP_BIT_OR:
1404 case OP_CONCAT:
1405 case OP_SUBST:
1406 case OP_TRANS:
49e9fbe6
GS		 1407 case OP_READ:
1408 case OP_SYSREAD:
1409 case OP_RECV:
bf4b1e52
GS		 1410 case OP_ANDASSIGN:
1411 case OP_ORASSIGN:
3fe9a6f1 1412 return TRUE;
1413 default:
1414 return FALSE;
1415 }
1416}
1417
35cd451c 1418STATIC bool
5900599a 1419S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c
GS		 1420{
1421 switch (o->op_type) {
1422 case OP_PIPE_OP:
1423 case OP_SOCKPAIR:
547d29e4 1424 if (numargs == 2)
35cd451c
GS		 1425 return TRUE;
1426 /* FALL THROUGH */
1427 case OP_SYSOPEN:
1428 case OP_OPEN:
ded8aa31 1429 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1430 case OP_SOCKET:
1431 case OP_OPEN_DIR:
1432 case OP_ACCEPT:
547d29e4 1433 if (numargs == 1)
35cd451c 1434 return TRUE;
5900599a 1435 /* FALLTHROUGH */
35cd451c
GS		 1436 default:
1437 return FALSE;
1438 }
1439}
1440
463ee0b2 1441OP *
864dbfa3 1442Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1443{
11343788 1444 if (o && o->op_flags & OPf_KIDS) {
c501bbfe 1445 OP *kid;
11343788 1446 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1447 ref(kid, type);
1448 }
11343788 1449 return o;
463ee0b2
LW		 1450}
1451
1452OP *
040becda 1453Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2
LW		 1454{
1455 OP *kid;
463ee0b2 1456
3280af22 1457 if (!o || PL_error_count)
11343788 1458 return o;
463ee0b2 1459
11343788 1460 switch (o->op_type) {
a0d0e21e 1461 case OP_ENTERSUB:
afebc493 1462 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1463 !(o->op_flags & OPf_STACKED)) {
1464 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1465 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1466 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1467 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1468 o->op_flags |= OPf_SPECIAL;
6aa01a30 1469 o->op_private &= ~1;
8990e307
LW		 1470 }
1471 break;
aeea060c 1472
463ee0b2 1473 case OP_COND_EXPR:
11343788 1474 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
040becda 1475 doref(kid, type, set_op_ref);
463ee0b2 1476 break;
8990e307 1477 case OP_RV2SV:
35cd451c
GS		 1478 if (type == OP_DEFINED)
1479 o->op_flags |= OPf_SPECIAL; /* don't create GV */
040becda 1480 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 1481 /* FALL THROUGH */
1482 case OP_PADSV:
5f05dabc 1483 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1484 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1485 : type == OP_RV2HV ? OPpDEREF_HV
1486 : OPpDEREF_SV);
11343788 1487 o->op_flags |= OPf_MOD;
a0d0e21e 1488 }
8990e307 1489 break;
1c846c1f 1490
d44e7566 1491#ifdef USE_5005THREADS
2faa37cc 1492 case OP_THREADSV:
a863c7d1
MB		 1493 o->op_flags |= OPf_MOD; /* XXX ??? */
1494 break;
d44e7566 1495#endif
a863c7d1 1496
463ee0b2
LW		 1497 case OP_RV2AV:
1498 case OP_RV2HV:
040becda
RH		 1499 if (set_op_ref)
1500 o->op_flags |= OPf_REF;
8990e307 1501 /* FALL THROUGH */
463ee0b2 1502 case OP_RV2GV:
35cd451c
GS		 1503 if (type == OP_DEFINED)
1504 o->op_flags |= OPf_SPECIAL; /* don't create GV */
040becda 1505 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 1506 break;
8990e307 1507
463ee0b2
LW		 1508 case OP_PADAV:
1509 case OP_PADHV:
040becda
RH		 1510 if (set_op_ref)
1511 o->op_flags |= OPf_REF;
79072805 1512 break;
aeea060c 1513
8990e307 1514 case OP_SCALAR:
79072805 1515 case OP_NULL:
11343788 1516 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1517 break;
040becda 1518 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 1519 break;
1520 case OP_AELEM:
1521 case OP_HELEM:
040becda 1522 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 1523 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1524 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1525 : type == OP_RV2HV ? OPpDEREF_HV
1526 : OPpDEREF_SV);
11343788 1527 o->op_flags |= OPf_MOD;
8990e307 1528 }
79072805
LW		 1529 break;
1530
463ee0b2 1531 case OP_SCOPE:
79072805 1532 case OP_LEAVE:
040becda
RH		 1533 set_op_ref = FALSE;
1534 /* FALL THROUGH */
79072805 1535 case OP_ENTER:
8990e307 1536 case OP_LIST:
11343788 1537 if (!(o->op_flags & OPf_KIDS))
79072805 1538 break;
040becda 1539 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 1540 break;
a0d0e21e
LW		 1541 default:
1542 break;
79072805 1543 }
11343788 1544 return scalar(o);
8990e307 1545
79072805
LW		 1546}
1547
09bef843
SB		 1548STATIC OP *
1549S_dup_attrlist(pTHX_ OP *o)
1550{
8c89da26 1551 OP *rop;
09bef843
SB		 1552
1553 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1554 * where the first kid is OP_PUSHMARK and the remaining ones
1555 * are OP_CONST. We need to push the OP_CONST values.
1556 */
1557 if (o->op_type == OP_CONST)
be2d5e07 1558 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
09bef843
SB		 1559 else {
1560 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5900599a 1561 rop = NULL;
09bef843
SB		 1562 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1563 if (o->op_type == OP_CONST)
1564 rop = append_elem(OP_LIST, rop,
1565 newSVOP(OP_CONST, o->op_flags,
be2d5e07 1566 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 1567 }
1568 }
1569 return rop;
1570}
1571
1572STATIC void
95f0a2f1 1573S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1574{
09bef843
SB		 1575 SV *stashsv;
1576
1577 /* fake up C<use attributes $pkg,$rv,@attrs> */
1578 ENTER; /* need to protect against side-effects of 'use' */
1579 SAVEINT(PL_expect);
a9164de8 1580 if (stash)
26ab6a78 1581 stashsv = newSVpv(HvNAME_get(stash), 0);
09bef843
SB		 1582 else
1583 stashsv = &PL_sv_no;
e4783991 1584
09bef843 1585#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1586#define ATTRSMODULE_PM "attributes.pm"
1587
1588 if (for_my) {
95f0a2f1 1589 /* Don't force the C<use> if we don't need it. */
d7559646 1590 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 1591 if (svp && *svp != &PL_sv_undef)
c9c8c8e1 1592 NOOP; /* already in %INC */
95f0a2f1
SB		 1593 else
1594 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8916b559 1595 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 1596 }
1597 else {
1598 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
8916b559
NC		 1599 newSVpvs(ATTRSMODULE),
1600 NULL,
95f0a2f1
SB		 1601 prepend_elem(OP_LIST,
1602 newSVOP(OP_CONST, 0, stashsv),
1603 prepend_elem(OP_LIST,
1604 newSVOP(OP_CONST, 0,
1605 newRV(target)),
1606 dup_attrlist(attrs))));
1607 }
09bef843
SB		 1608 LEAVE;
1609}
1610
95f0a2f1
SB		 1611STATIC void
1612S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1613{
1614 OP *pack, *imop, *arg;
1615 SV *meth, *stashsv;
1616
1617 if (!attrs)
1618 return;
1619
1620 assert(target->op_type == OP_PADSV ||
1621 target->op_type == OP_PADHV ||
1622 target->op_type == OP_PADAV);
1623
1624 /* Ensure that attributes.pm is loaded. */
9755d405 1625 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1626
1627 /* Need package name for method call. */
8916b559 1628 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 1629
1630 /* Build up the real arg-list. */
1631 if (stash)
26ab6a78 1632 stashsv = newSVpv(HvNAME_get(stash), 0);
95f0a2f1
SB		 1633 else
1634 stashsv = &PL_sv_no;
1635 arg = newOP(OP_PADSV, 0);
1636 arg->op_targ = target->op_targ;
1637 arg = prepend_elem(OP_LIST,
1638 newSVOP(OP_CONST, 0, stashsv),
1639 prepend_elem(OP_LIST,
1640 newUNOP(OP_REFGEN, 0,
1641 mod(arg, OP_REFGEN)),
1642 dup_attrlist(attrs)));
1643
1644 /* Fake up a method call to import */
d7559646 1645 meth = newSVpvs("import");
95f0a2f1
SB		 1646 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1647 append_elem(OP_LIST,
1648 prepend_elem(OP_LIST, pack, list(arg)),
1649 newSVOP(OP_METHOD_NAMED, 0, meth)));
1650 imop->op_private |= OPpENTERSUB_NOMOD;
1651
1652 /* Combine the ops. */
1653 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1654}
1655
1656/*
1657=notfor apidoc apply_attrs_string
1658
1659Attempts to apply a list of attributes specified by the C<attrstr> and
1660C<len> arguments to the subroutine identified by the C<cv> argument which
1661is expected to be associated with the package identified by the C<stashpv>
1662argument (see L<attributes>). It gets this wrong, though, in that it
1663does not correctly identify the boundaries of the individual attribute
1664specifications within C<attrstr>. This is not really intended for the
1665public API, but has to be listed here for systems such as AIX which
1666need an explicit export list for symbols. (It's called from XS code
1667in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1668to respect attribute syntax properly would be welcome.
1669
1670=cut
1671*/
1672
be3174d2
GS		 1673void
1674Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1675 char *attrstr, STRLEN len)
1676{
5900599a 1677 OP *attrs = NULL;
be3174d2
GS		 1678
1679 if (!len) {
1680 len = strlen(attrstr);
1681 }
1682
1683 while (len) {
1684 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1685 if (len) {
c6d79d47 1686 const char * const sstr = attrstr;
be3174d2
GS		 1687 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1688 attrs = append_elem(OP_LIST, attrs,
1689 newSVOP(OP_CONST, 0,
1690 newSVpvn(sstr, attrstr-sstr)));
1691 }
1692 }
1693
1694 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
8916b559 1695 newSVpvs(ATTRSMODULE),
0e2d6244 1696 NULL, prepend_elem(OP_LIST,
be3174d2
GS		 1697 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1698 prepend_elem(OP_LIST,
1699 newSVOP(OP_CONST, 0,
1700 newRV((SV*)cv)),
1701 attrs)));
1702}
1703
09bef843 1704STATIC OP *
95f0a2f1 1705S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1706{
93a17b20
LW		 1707 I32 type;
1708
3280af22 1709 if (!o || PL_error_count)
11343788 1710 return o;
93a17b20 1711
11343788 1712 type = o->op_type;
93a17b20 1713 if (type == OP_LIST) {
c501bbfe 1714 OP *kid;
11343788 1715 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1716 my_kid(kid, attrs, imopsp);
dab48698 1717 } else if (type == OP_UNDEF) {
7766148a 1718 return o;
77ca0c92
LW		 1719 } else if (type == OP_RV2SV || /* "our" declaration */
1720 type == OP_RV2AV ||
1721 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
5b7ea690 1722 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
d409ca69 1723 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5b7ea690
JH		 1724 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1725 } else if (attrs) {
78fd745e 1726 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5b7ea690 1727 PL_in_my = FALSE;
0e2d6244 1728 PL_in_my_stash = NULL;
5b7ea690
JH		 1729 apply_attrs(GvSTASH(gv),
1730 (type == OP_RV2SV ? GvSV(gv) :
1731 type == OP_RV2AV ? (SV*)GvAV(gv) :
1732 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1733 attrs, FALSE);
1734 }
192587c2 1735 o->op_private |= OPpOUR_INTRO;
77ca0c92 1736 return o;
95f0a2f1
SB		 1737 }
1738 else if (type != OP_PADSV &&
93a17b20
LW		 1739 type != OP_PADAV &&
1740 type != OP_PADHV &&
1741 type != OP_PUSHMARK)
1742 {
eb64745e 1743 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1744 OP_DESC(o),
eb64745e 1745 PL_in_my == KEY_our ? "our" : "my"));
11343788 1746 return o;
93a17b20 1747 }
09bef843
SB		 1748 else if (attrs && type != OP_PUSHMARK) {
1749 HV *stash;
09bef843 1750
eb64745e 1751 PL_in_my = FALSE;
0e2d6244 1752 PL_in_my_stash = NULL;
eb64745e 1753
09bef843 1754 /* check for C<my Dog $spot> when deciding package */
9755d405
JH		 1755 stash = PAD_COMPNAME_TYPE(o->op_targ);
1756 if (!stash)
09bef843 1757 stash = PL_curstash;
95f0a2f1 1758 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1759 }
11343788
MB		 1760 o->op_flags |= OPf_MOD;
1761 o->op_private |= OPpLVAL_INTRO;
1762 return o;
93a17b20
LW		 1763}
1764
1765OP *
09bef843
SB		 1766Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1767{
8c89da26 1768 OP *rops;
95f0a2f1
SB		 1769 int maybe_scalar = 0;
1770
5b7ea690 1771/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1772 C< our(%x); > executing in list mode rather than void mode */
5b7ea690 1773#if 0
09bef843
SB		 1774 if (o->op_flags & OPf_PARENS)
1775 list(o);
95f0a2f1
SB		 1776 else
1777 maybe_scalar = 1;
5b7ea690
JH		 1778#else
1779 maybe_scalar = 1;
1780#endif
09bef843
SB		 1781 if (attrs)
1782 SAVEFREEOP(attrs);
5900599a 1783 rops = NULL;
95f0a2f1
SB		 1784 o = my_kid(o, attrs, &rops);
1785 if (rops) {
1786 if (maybe_scalar && o->op_type == OP_PADSV) {
1787 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1788 o->op_private |= OPpLVAL_INTRO;
1789 }
1790 else
1791 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1792 }
eb64745e 1793 PL_in_my = FALSE;
0e2d6244 1794 PL_in_my_stash = NULL;
eb64745e 1795 return o;
09bef843
SB		 1796}
1797
1798OP *
1799Perl_my(pTHX_ OP *o)
1800{
5900599a 1801 return my_attrs(o, NULL);
09bef843
SB		 1802}
1803
1804OP *
864dbfa3 1805Perl_sawparens(pTHX_ OP *o)
79072805 1806{
1e7ed80e 1807 PERL_UNUSED_CONTEXT;
79072805
LW		 1808 if (o)
1809 o->op_flags |= OPf_PARENS;
1810 return o;
1811}
1812
1813OP *
864dbfa3 1814Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1815{
11343788 1816 OP *o;
8c6f7913
AL		 1817 bool ismatchop;
1818 const OPCODE ltype = left->op_type;
1819 const OPCODE rtype = right->op_type;
79072805 1820
8c6f7913
AL		 1821 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1822 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
f5e9f069 1823 {
8c6f7913
AL		 1824 const char * const desc
1825 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
d2ae4405 1826 ? (int)rtype : OP_MATCH];
8c6f7913
AL		 1827 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1828 ? "@array" : "%hash");
9014280d 1829 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1830 "Applying %s to %s will act on scalar(%s)",
599cee73 1831 desc, sample, sample);
2ae324a7 1832 }
1833
8c6f7913 1834 if (rtype == OP_CONST &&
5cc9e5c9
RH		 1835 cSVOPx(right)->op_private & OPpCONST_BARE &&
1836 cSVOPx(right)->op_private & OPpCONST_STRICT)
1837 {
1838 no_bareword_allowed(right);
1839 }
1840
8c6f7913
AL		 1841 ismatchop = rtype == OP_MATCH ||
1842 rtype == OP_SUBST ||
1843 rtype == OP_TRANS;
1844 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1845 OP *newleft;
1846
79072805 1847 right->op_flags |= OPf_STACKED;
8c6f7913
AL		 1848 if (rtype != OP_MATCH &&
1849 ! (rtype == OP_TRANS &&
3fc4677c 1850 right->op_private & OPpTRANS_IDENTICAL))
8c6f7913
AL		 1851 newleft = mod(left, rtype);
1852 else
1853 newleft = left;
79072805 1854 if (right->op_type == OP_TRANS)
8c6f7913 1855 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 1856 else
8c6f7913 1857 o = prepend_elem(rtype, scalar(newleft), right);
79072805 1858 if (type == OP_NOT)
11343788
MB		 1859 return newUNOP(OP_NOT, 0, scalar(o));
1860 return o;
79072805
LW		 1861 }
1862 else
1863 return bind_match(type, left,
1864 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1865}
1866
1867OP *
864dbfa3 1868Perl_invert(pTHX_ OP *o)
79072805 1869{
11343788
MB		 1870 if (!o)
1871 return o;
79072805 1872 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1873 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 1874}
1875
1876OP *
864dbfa3 1877Perl_scope(pTHX_ OP *o)
79072805
LW		 1878{
1879 if (o) {
3280af22 1880 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 1881 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1882 o->op_type = OP_LEAVE;
22c35a8c 1883 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1884 }
75aa420f
JH		 1885 else if (o->op_type == OP_LINESEQ) {
1886 OP *kid;
1887 o->op_type = OP_SCOPE;
1888 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1889 kid = ((LISTOP*)o)->op_first;
3f3939a9 1890 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
75aa420f 1891 op_null(kid);
3f3939a9
NC		 1892
1893 /* The following deals with things like 'do {1 for 1}' */
1894 kid = kid->op_sibling;
1895 if (kid &&
1896 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1897 op_null(kid);
1898 }
463ee0b2 1899 }
75aa420f 1900 else
5900599a 1901 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 1902 }
1903 return o;
1904}
1905
a0d0e21e 1906int
864dbfa3 1907Perl_block_start(pTHX_ int full)
79072805 1908{
e2b56717 1909 const int retval = PL_savestack_ix;
c240c76d
JH		 1910 /* If there were syntax errors, don't try to start a block */
1911 if (PL_yynerrs) return retval;
b3ac6de7 1912
9755d405 1913 pad_block_start(full);
b3ac6de7 1914 SAVEHINTS();
3280af22 1915 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1916 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1917 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 1918 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1919 SAVEFREESV(PL_compiling.cop_warnings) ;
1920 }
ac27b0f5
NIS		 1921 SAVESPTR(PL_compiling.cop_io);
1922 if (! specialCopIO(PL_compiling.cop_io)) {
1923 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1924 SAVEFREESV(PL_compiling.cop_io) ;
1925 }
a0d0e21e
LW		 1926 return retval;
1927}
1928
1929OP*
864dbfa3 1930Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1931{
c501bbfe 1932 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
78fd745e 1933 OP* const retval = scalarseq(seq);
c240c76d
JH		 1934 /* If there were syntax errors, don't try to close a block */
1935 if (PL_yynerrs) return retval;
e9818f4e 1936 LEAVE_SCOPE(floor);
2cb86c03 1937 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 1938 if (needblockscope)
3280af22 1939 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
9755d405 1940 pad_leavemy();
a0d0e21e
LW		 1941 return retval;
1942}
1943
76e3520e 1944STATIC OP *
cea2e8a9 1945S_newDEFSVOP(pTHX)
54b9620d 1946{
4d1ff10f 1947#ifdef USE_5005THREADS
78fd745e 1948 OP *const o = newOP(OP_THREADSV, 0);
54b9620d
MB		 1949 o->op_targ = find_threadsv("_");
1950 return o;
1951#else
3280af22 1952 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
4d1ff10f 1953#endif /* USE_5005THREADS */
54b9620d
MB		 1954}
1955
a0d0e21e 1956void
864dbfa3 1957Perl_newPROG(pTHX_ OP *o)
a0d0e21e 1958{
3280af22 1959 if (PL_in_eval) {
b295d113
TH		 1960 if (PL_eval_root)
1961 return;
faef0170
HS		 1962 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1963 ((PL_in_eval & EVAL_KEEPERR)
1964 ? OPf_SPECIAL : 0), o);
3280af22 1965 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 1966 PL_eval_root->op_private |= OPpREFCOUNTED;
1967 OpREFCNT_set(PL_eval_root, 1);
3280af22 1968 PL_eval_root->op_next = 0;
a2efc822 1969 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 1970 }
1971 else {
676a8eb5
JH		 1972 if (o->op_type == OP_STUB) {
1973 PL_comppad_name = 0;
1974 PL_compcv = 0;
4a9f3d2e 1975 FreeOp(o);
a0d0e21e 1976 return;
676a8eb5 1977 }
3280af22
NIS		 1978 PL_main_root = scope(sawparens(scalarvoid(o)));
1979 PL_curcop = &PL_compiling;
1980 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 1981 PL_main_root->op_private |= OPpREFCOUNTED;
1982 OpREFCNT_set(PL_main_root, 1);
3280af22 1983 PL_main_root->op_next = 0;
a2efc822 1984 CALL_PEEP(PL_main_start);
3280af22 1985 PL_compcv = 0;
3841441e 1986
4fdae800 1987 /* Register with debugger */
84902520 1988 if (PERLDB_INTER) {
78fd745e 1989 CV * const cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 1990 if (cv) {
1991 dSP;
924508f0 1992 PUSHMARK(SP);
cc49e20b 1993 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1994 PUTBACK;
864dbfa3 1995 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 1996 }
1997 }
79072805 1998 }
79072805
LW		 1999}
2000
2001OP *
864dbfa3 2002Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW		 2003{
2004 if (o->op_flags & OPf_PARENS)
5b7ea690
JH		 2005/* [perl #17376]: this appears to be premature, and results in code such as
2006 C< our(%x); > executing in list mode rather than void mode */
2007#if 0
79072805 2008 list(o);
5b7ea690 2009#else
c9c8c8e1 2010 NOOP;
5b7ea690 2011#endif
8990e307 2012 else {
f5e9f069
NC		 2013 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2014 && ckWARN(WARN_PARENTHESIS))
64420d0d
JH		 2015 {
2016 char *s = PL_bufptr;
2e7fc6b0 2017 bool sigil = FALSE;
64420d0d 2018
0710cc63 2019 /* some heuristics to detect a potential error */
2e7fc6b0 2020 while (*s && (strchr(", \t\n", *s)))
64420d0d 2021 s++;
0710cc63 2022
2e7fc6b0
NC		 2023 while (1) {
2024 if (*s && strchr("@$%*", *s) && *++s
2025 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2026 s++;
2027 sigil = TRUE;
2028 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2029 s++;
2030 while (*s && (strchr(", \t\n", *s)))
2031 s++;
2032 }
2033 else
2034 break;
2035 }
2036 if (sigil && (*s == ';' || *s == '=')) {
2037 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
0710cc63
JH		 2038 "Parentheses missing around \"%s\" list",
2039 lex ? (PL_in_my == KEY_our ? "our" : "my")
2040 : "local");
2041 }
8990e307
LW		 2042 }
2043 }
93a17b20 2044 if (lex)
eb64745e 2045 o = my(o);
93a17b20 2046 else
eb64745e
GS		 2047 o = mod(o, OP_NULL); /* a bit kludgey */
2048 PL_in_my = FALSE;
0e2d6244 2049 PL_in_my_stash = NULL;
eb64745e 2050 return o;
79072805
LW		 2051}
2052
2053OP *
864dbfa3 2054Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2055{
2056 if (o->op_type == OP_LIST) {
4d1ff10f 2057#ifdef USE_5005THREADS
8916b559 2058 OP * const o2 = newOP(OP_THREADSV, 0);
54b9620d 2059 o2->op_targ = find_threadsv(";");
554b3eca 2060#else
8916b559 2061 OP * const o2
43b2f713 2062 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4d1ff10f 2063#endif /* USE_5005THREADS */
554b3eca 2064 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2065 }
2066 return o;
2067}
2068
149f689b
NC		 2069#ifdef PERL_FLEXIBLE_EXCEPTIONS
2070STATIC void *
2071S_vcall_runops(pTHX_ va_list args)
2072{
2073 CALLRUNOPS(aTHX);
2074 return NULL;
2075}
2076#endif
2077
79072805 2078OP *
864dbfa3 2079Perl_fold_constants(pTHX_ register OP *o)
79072805
LW		 2080{
2081 register OP *curop;
17184076
NC		 2082 VOL I32 type = o->op_type;
2083 SV * VOL sv = NULL;
9954b260
NC		 2084 int ret = 0;
2085 I32 oldscope;
2086 OP *old_next;
910ce816
NC		 2087 SV * const oldwarnhook = PL_warnhook;
2088 SV * const olddiehook = PL_diehook;
9954b260 2089 dJMPENV;
79072805 2090
22c35a8c 2091 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2092 scalar(o);
b162f9ea 2093 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2094 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2095
eac055e9
GS		 2096 /* integerize op, unless it happens to be C<-foo>.
2097 * XXX should pp_i_negate() do magic string negation instead? */
2098 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2099 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2100 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2101 {
22c35a8c 2102 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2103 }
85e6fe83 2104
22c35a8c 2105 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2106 goto nope;
2107
de939608 2108 switch (type) {
7a52d87a
GS		 2109 case OP_NEGATE:
2110 /* XXX might want a ck_negate() for this */
2111 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2112 break;
de939608
CS		 2113 case OP_UCFIRST:
2114 case OP_LCFIRST:
2115 case OP_UC:
2116 case OP_LC:
69dcf70c
MB		 2117 case OP_SLT:
2118 case OP_SGT:
2119 case OP_SLE:
2120 case OP_SGE:
2121 case OP_SCMP:
2de3dbcc
JH		 2122 /* XXX what about the numeric ops? */
2123 if (PL_hints & HINT_LOCALE)
de939608
CS		 2124 goto nope;
2125 }
2126
3280af22 2127 if (PL_error_count)
a0d0e21e
LW		 2128 goto nope; /* Don't try to run w/ errors */
2129
79072805 2130 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
8c6f7913
AL		 2131 const OPCODE type = curop->op_type;
2132 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2133 type != OP_LIST &&
2134 type != OP_SCALAR &&
2135 type != OP_NULL &&
2136 type != OP_PUSHMARK)
7a52d87a 2137 {
79072805
LW		 2138 goto nope;
2139 }
2140 }
2141
2142 curop = LINKLIST(o);
9954b260 2143 old_next = o->op_next;
79072805 2144 o->op_next = 0;
533c011a 2145 PL_op = curop;
9954b260
NC		 2146
2147 oldscope = PL_scopestack_ix;
19313ece 2148 push_return(NULL);
6d1a3977 2149 create_eval_scope(G_FAKINGEVAL);
9954b260 2150
910ce816
NC		 2151 PL_warnhook = PERL_WARNHOOK_FATAL;
2152 PL_diehook = NULL;
9954b260 2153
149f689b
NC		 2154#ifdef PERL_FLEXIBLE_EXCEPTIONS
2155 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_runops));
2156#else
2157 JMPENV_PUSH(ret);
2158#endif
9954b260
NC		 2159 switch (ret) {
2160 case 0:
149f689b 2161#ifndef PERL_FLEXIBLE_EXCEPTIONS
9954b260 2162 CALLRUNOPS(aTHX);
149f689b 2163#endif
9954b260
NC		 2164 sv = *(PL_stack_sp--);
2165 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2166 pad_swipe(o->op_targ, FALSE);
2167 else if (SvTEMP(sv)) { /* grab mortal temp? */
be2d5e07 2168 SvREFCNT_inc_simple_void(sv);
9954b260
NC		 2169 SvTEMP_off(sv);
2170 }
2171 break;
2172 case 3:
2173 /* Something tried to die. Abandon constant folding. */
2174 /* Pretend the error never happened. */
2175 sv_setpvn(ERRSV,"",0);
2176 o->op_next = old_next;
2177 break;
2178 default:
2179 JMPENV_POP;
2180 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
910ce816
NC		 2181 PL_warnhook = oldwarnhook;
2182 PL_diehook = olddiehook;
2183 /* XXX note that this croak may fail as we've already blown away
2184 * the stack - eg any nested evals */
9954b260 2185 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
85e6fe83 2186 }
9954b260 2187 JMPENV_POP;
910ce816
NC		 2188 PL_warnhook = oldwarnhook;
2189 PL_diehook = olddiehook;
6d1a3977 2190
19313ece 2191 if (PL_scopestack_ix > oldscope) {
6d1a3977 2192 delete_eval_scope();
19313ece
NC		 2193 pop_return();
2194 }
9954b260
NC		 2195
2196 if (ret)
2197 goto nope;
2198
79072805 2199 op_free(o);
eb527b6b 2200 assert(sv);
79072805 2201 if (type == OP_RV2GV)
b1cb66bf 2202 return newGVOP(OP_GV, 0, (GV*)sv);
75056b2a 2203 return newSVOP(OP_CONST, 0, (SV*)sv);
aeea060c 2204
9954b260 2205 nope:
79072805
LW		 2206 return o;
2207}
2208
2209OP *
864dbfa3 2210Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW		 2211{
2212 register OP *curop;
c501bbfe 2213 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2214
a0d0e21e 2215 list(o);
3280af22 2216 if (PL_error_count)
a0d0e21e
LW		 2217 return o; /* Don't attempt to run with errors */
2218
533c011a 2219 PL_op = curop = LINKLIST(o);
a0d0e21e 2220 o->op_next = 0;
a2efc822 2221 CALL_PEEP(curop);
cea2e8a9
GS		 2222 pp_pushmark();
2223 CALLRUNOPS(aTHX);
533c011a 2224 PL_op = curop;
3fd63905
NC		 2225 assert (!(curop->op_flags & OPf_SPECIAL));
2226 assert(curop->op_type == OP_RANGE);
cea2e8a9 2227 pp_anonlist();
3280af22 2228 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2229
2230 o->op_type = OP_RV2AV;
22c35a8c 2231 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
650939d2
JH		 2232 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2233 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
c13f253a 2234 o->op_seq = 0; /* needs to be revisited in peep() */
79072805 2235 curop = ((UNOP*)o)->op_first;
be2d5e07 2236 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
79072805 2237 op_free(curop);
79072805
LW		 2238 linklist(o);
2239 return list(o);
2240}
2241
2242OP *
864dbfa3 2243Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2244{
11343788 2245 if (!o || o->op_type != OP_LIST)
5900599a 2246 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2247 else
5dc0d613 2248 o->op_flags &= ~OPf_WANT;
79072805 2249
22c35a8c 2250 if (!(PL_opargs[type] & OA_MARK))
93c66552 2251 op_null(cLISTOPo->op_first);
8990e307 2252
eb160463 2253 o->op_type = (OPCODE)type;
22c35a8c 2254 o->op_ppaddr = PL_ppaddr[type];
11343788 2255 o->op_flags |= flags;
79072805 2256
11343788 2257 o = CHECKOP(type, o);
39f667bb 2258 if (o->op_type != (unsigned)type)
11343788 2259 return o;
79072805 2260
11343788 2261 return fold_constants(o);
79072805
LW		 2262}
2263
2264/* List constructors */
2265
2266OP *
864dbfa3 2267Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2268{
2269 if (!first)
2270 return last;
8990e307
LW		 2271
2272 if (!last)
79072805 2273 return first;
8990e307 2274
39f667bb 2275 if (first->op_type != (unsigned)type
155aba94
GS		 2276 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2277 {
2278 return newLISTOP(type, 0, first, last);
2279 }
79072805 2280
a0d0e21e
LW		 2281 if (first->op_flags & OPf_KIDS)
2282 ((LISTOP*)first)->op_last->op_sibling = last;
2283 else {
2284 first->op_flags |= OPf_KIDS;
2285 ((LISTOP*)first)->op_first = last;
2286 }
2287 ((LISTOP*)first)->op_last = last;
a0d0e21e 2288 return first;
79072805
LW		 2289}
2290
2291OP *
864dbfa3 2292Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2293{
2294 if (!first)
2295 return (OP*)last;
8990e307
LW		 2296
2297 if (!last)
79072805 2298 return (OP*)first;
8990e307 2299
39f667bb 2300 if (first->op_type != (unsigned)type)
79072805 2301 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2302
39f667bb 2303 if (last->op_type != (unsigned)type)
79072805
LW		 2304 return append_elem(type, (OP*)first, (OP*)last);
2305
2306 first->op_last->op_sibling = last->op_first;
2307 first->op_last = last->op_last;
117dada2 2308 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2309
238a4c30
NIS		 2310 FreeOp(last);
2311
79072805
LW		 2312 return (OP*)first;
2313}
2314
2315OP *
864dbfa3 2316Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2317{
2318 if (!first)
2319 return last;
8990e307
LW		 2320
2321 if (!last)
79072805 2322 return first;
8990e307 2323
39f667bb 2324 if (last->op_type == (unsigned)type) {
8990e307
LW		 2325 if (type == OP_LIST) { /* already a PUSHMARK there */
2326 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2327 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2328 if (!(first->op_flags & OPf_PARENS))
2329 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2330 }
2331 else {
2332 if (!(last->op_flags & OPf_KIDS)) {
2333 ((LISTOP*)last)->op_last = first;
2334 last->op_flags |= OPf_KIDS;
2335 }
2336 first->op_sibling = ((LISTOP*)last)->op_first;
2337 ((LISTOP*)last)->op_first = first;
79072805 2338 }
117dada2 2339 last->op_flags |= OPf_KIDS;
79072805
LW		 2340 return last;
2341 }
2342
2343 return newLISTOP(type, 0, first, last);
2344}
2345
2346/* Constructors */
2347
2348OP *
864dbfa3 2349Perl_newNULLLIST(pTHX)
79072805 2350{
8990e307
LW		 2351 return newOP(OP_STUB, 0);
2352}
2353
2354OP *
864dbfa3 2355Perl_force_list(pTHX_ OP *o)
8990e307 2356{
11343788 2357 if (!o || o->op_type != OP_LIST)
5900599a 2358 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 2359 op_null(o);
11343788 2360 return o;
79072805
LW		 2361}
2362
2363OP *
864dbfa3 2364Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2365{
2366 LISTOP *listop;
2367
b7dc083c 2368 NewOp(1101, listop, 1, LISTOP);
79072805 2369
eb160463 2370 listop->op_type = (OPCODE)type;
22c35a8c 2371 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2372 if (first || last)
2373 flags |= OPf_KIDS;
eb160463 2374 listop->op_flags = (U8)flags;
79072805
LW		 2375
2376 if (!last && first)
2377 last = first;
2378 else if (!first && last)
2379 first = last;
8990e307
LW		 2380 else if (first)
2381 first->op_sibling = last;
79072805
LW		 2382 listop->op_first = first;
2383 listop->op_last = last;
8990e307 2384 if (type == OP_LIST) {
78fd745e 2385 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 2386 pushop->op_sibling = first;
2387 listop->op_first = pushop;
2388 listop->op_flags |= OPf_KIDS;
2389 if (!last)
2390 listop->op_last = pushop;
2391 }
79072805 2392
676a8eb5 2393 return CHECKOP(type, listop);
79072805
LW		 2394}
2395
2396OP *
864dbfa3 2397Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2398{
11343788 2399 OP *o;
b7dc083c 2400 NewOp(1101, o, 1, OP);
eb160463 2401 o->op_type = (OPCODE)type;
22c35a8c 2402 o->op_ppaddr = PL_ppaddr[type];
eb160463 2403 o->op_flags = (U8)flags;
79072805 2404
11343788 2405 o->op_next = o;
eb160463 2406 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2407 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2408 scalar(o);
22c35a8c 2409 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2410 o->op_targ = pad_alloc(type, SVs_PADTMP);
2411 return CHECKOP(type, o);
79072805
LW		 2412}
2413
2414OP *
864dbfa3 2415Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW		 2416{
2417 UNOP *unop;
2418
93a17b20 2419 if (!first)
aeea060c 2420 first = newOP(OP_STUB, 0);
22c35a8c 2421 if (PL_opargs[type] & OA_MARK)
8990e307 2422 first = force_list(first);
93a17b20 2423
b7dc083c 2424 NewOp(1101, unop, 1, UNOP);
eb160463 2425 unop->op_type = (OPCODE)type;
22c35a8c 2426 unop->op_ppaddr = PL_ppaddr[type];
79072805 2427 unop->op_first = first;
3bad88ff 2428 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2429 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2430 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2431 if (unop->op_next)
2432 return (OP*)unop;
2433
a0d0e21e 2434 return fold_constants((OP *) unop);
79072805
LW		 2435}
2436
2437OP *
864dbfa3 2438Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2439{
2440 BINOP *binop;
b7dc083c 2441 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2442
2443 if (!first)
2444 first = newOP(OP_NULL, 0);
2445
eb160463 2446 binop->op_type = (OPCODE)type;
22c35a8c 2447 binop->op_ppaddr = PL_ppaddr[type];
79072805 2448 binop->op_first = first;
3bad88ff 2449 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 2450 if (!last) {
2451 last = first;
eb160463 2452 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2453 }
2454 else {
eb160463 2455 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2456 first->op_sibling = last;
2457 }
2458
e50aee73 2459 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2460 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2461 return (OP*)binop;
2462
7284ab6f 2463 binop->op_last = binop->op_first->op_sibling;
79072805 2464
a0d0e21e 2465 return fold_constants((OP *)binop);
79072805
LW		 2466}
2467
5900599a
NC		 2468static int uvcompare(const void *a, const void *b)
2469 __attribute__nonnull__(1)
2470 __attribute__nonnull__(2)
2471 __attribute__pure__;
24c2fff4 2472static int uvcompare(const void *a, const void *b)
2b9d42f0 2473{
c05e0e2f 2474 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2475 return -1;
c05e0e2f 2476 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2477 return 1;
c05e0e2f 2478 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2479 return -1;
c05e0e2f 2480 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2481 return 1;
a0ed51b3
LW		 2482 return 0;
2483}
2484
79072805 2485OP *
864dbfa3 2486Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2487{
339a2a6a
AL		 2488 SV * const tstr = ((SVOP*)expr)->op_sv;
2489 SV * const rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2490 STRLEN tlen;
2491 STRLEN rlen;
8ec8dcb0
NC		 2492 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2493 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 2494 register I32 i;
2495 register I32 j;
9b877dbb 2496 I32 grows = 0;
79072805
LW		 2497 register short *tbl;
2498
78fd745e
AL		 2499 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2500 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2501 I32 del = o->op_private & OPpTRANS_DELETE;
800b4dc4 2502 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 2503
036b4402
GS		 2504 if (SvUTF8(tstr))
2505 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2506
2507 if (SvUTF8(rstr))
036b4402 2508 o->op_private |= OPpTRANS_TO_UTF;
79072805 2509
a0ed51b3 2510 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
d7559646 2511 SV* const listsv = newSVpvs("# comment\n");
f4362cdc 2512 SV* transv = NULL;
8ec8dcb0
NC		 2513 const U8* tend = t + tlen;
2514 const U8* rend = r + rlen;
ba210ebe 2515 STRLEN ulen;
f824e39a
JH		 2516 UV tfirst = 1;
2517 UV tlast = 0;
2518 IV tdiff;
2519 UV rfirst = 1;
2520 UV rlast = 0;
2521 IV rdiff;
2522 IV diff;
a0ed51b3
LW		 2523 I32 none = 0;
2524 U32 max = 0;
2525 I32 bits;
a0ed51b3 2526 I32 havefinal = 0;
9c5ffd7c 2527 U32 final = 0;
78fd745e
AL		 2528 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2529 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2530 U8* tsave = NULL;
2531 U8* rsave = NULL;
2532
2533 if (!from_utf) {
2534 STRLEN len = tlen;
5adb6136 2535 t = tsave = bytes_to_utf8((U8 *)t, &len);
bf4a1e57
JH		 2536 tend = t + len;
2537 }
2538 if (!to_utf && rlen) {
2539 STRLEN len = rlen;
5adb6136 2540 r = rsave = bytes_to_utf8((U8 *)r, &len);
bf4a1e57
JH		 2541 rend = r + len;
2542 }
a0ed51b3 2543
2b9d42f0
NIS		 2544/* There are several snags with this code on EBCDIC:
2545 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2546 2. scan_const() in toke.c has encoded chars in native encoding which makes
2547 ranges at least in EBCDIC 0..255 range the bottom odd.
2548*/
2549
a0ed51b3 2550 if (complement) {
a2a469f9 2551 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 2552 UV *cp;
a0ed51b3 2553 UV nextmin = 0;
cd7a8267 2554 Newx(cp, 2*tlen, UV);
a0ed51b3 2555 i = 0;
d7559646 2556 transv = newSVpvs("");
a0ed51b3 2557 while (t < tend) {
5adb6136 2558 cp[2*i] = utf8n_to_uvuni((U8 *)t, tend-t, &ulen, 0);
2b9d42f0
NIS		 2559 t += ulen;
2560 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2561 t++;
5adb6136 2562 cp[2*i+1] = utf8n_to_uvuni((U8 *)t, tend-t, &ulen, 0);
2b9d42f0 2563 t += ulen;
a0ed51b3 2564 }
2b9d42f0
NIS		 2565 else {
2566 cp[2*i+1] = cp[2*i];
2567 }
2568 i++;
a0ed51b3 2569 }
2b9d42f0 2570 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2571 for (j = 0; j < i; j++) {
2b9d42f0 2572 UV val = cp[2*j];
a0ed51b3
LW		 2573 diff = val - nextmin;
2574 if (diff > 0) {
9041c2e3 2575 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2576 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2577 if (diff > 1) {
2b9d42f0 2578 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2579 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2580 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2581 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2582 }
2583 }
2b9d42f0 2584 val = cp[2*j+1];
a0ed51b3
LW		 2585 if (val >= nextmin)
2586 nextmin = val + 1;
2587 }
9041c2e3 2588 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2589 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2590 {
2591 U8 range_mark = UTF_TO_NATIVE(0xff);
2592 sv_catpvn(transv, (char *)&range_mark, 1);
2593 }
b851fbc1
JH		 2594 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2595 UNICODE_ALLOW_SUPER);
dfe13c55 2596 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
23c2bb70 2597 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 2598 tlen = SvCUR(transv);
2599 tend = t + tlen;
455d824a 2600 Safefree(cp);
a0ed51b3
LW		 2601 }
2602 else if (!rlen && !del) {
2603 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2604 }
2605 if (!squash) {
05d340b8 2606 if ((!rlen && !del) || t == r ||
12ae5dfc 2607 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2608 {
4757a243 2609 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2610 }
a0ed51b3
LW		 2611 }
2612
2613 while (t < tend || tfirst <= tlast) {
2614 /* see if we need more "t" chars */
2615 if (tfirst > tlast) {
5adb6136 2616 tfirst = (I32)utf8n_to_uvuni((U8 *)t, tend - t, &ulen, 0);
a0ed51b3 2617 t += ulen;
2b9d42f0 2618 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2619 t++;
5adb6136 2620 tlast = (I32)utf8n_to_uvuni((U8 *)t, tend - t, &ulen, 0);
a0ed51b3
LW		 2621 t += ulen;
2622 }
2623 else
2624 tlast = tfirst;
2625 }
2626
2627 /* now see if we need more "r" chars */
2628 if (rfirst > rlast) {
2629 if (r < rend) {
5adb6136 2630 rfirst = (I32)utf8n_to_uvuni((U8 *)r, rend - r, &ulen, 0);
a0ed51b3 2631 r += ulen;
2b9d42f0 2632 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2633 r++;
5adb6136
NC		 2634 rlast = (I32)utf8n_to_uvuni((U8 *)r, rend - r, &ulen,
2635 0);
a0ed51b3
LW		 2636 r += ulen;
2637 }
2638 else
2639 rlast = rfirst;
2640 }
2641 else {
2642 if (!havefinal++)
2643 final = rlast;
2644 rfirst = rlast = 0xffffffff;
2645 }
2646 }
2647
2648 /* now see which range will peter our first, if either. */
2649 tdiff = tlast - tfirst;
2650 rdiff = rlast - rfirst;
2651
2652 if (tdiff <= rdiff)
2653 diff = tdiff;
2654 else
2655 diff = rdiff;
2656
2657 if (rfirst == 0xffffffff) {
2658 diff = tdiff; /* oops, pretend rdiff is infinite */
2659 if (diff > 0)
894356b3
GS		 2660 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2661 (long)tfirst, (long)tlast);
a0ed51b3 2662 else
894356b3 2663 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2664 }
2665 else {
2666 if (diff > 0)
894356b3
GS		 2667 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2668 (long)tfirst, (long)(tfirst + diff),
2669 (long)rfirst);
a0ed51b3 2670 else
894356b3
GS		 2671 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2672 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2673
2674 if (rfirst + diff > max)
2675 max = rfirst + diff;
9b877dbb 2676 if (!grows)
45005bfb
JH		 2677 grows = (tfirst < rfirst &&
2678 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2679 rfirst += diff + 1;
a0ed51b3
LW		 2680 }
2681 tfirst += diff + 1;
2682 }
2683
2684 none = ++max;
2685 if (del)
2686 del = ++max;
2687
2688 if (max > 0xffff)
2689 bits = 32;
2690 else if (max > 0xff)
2691 bits = 16;
2692 else
2693 bits = 8;
2694
455d824a 2695 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2696 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2697 SvREFCNT_dec(listsv);
be2d5e07 2698 SvREFCNT_dec(transv);
a0ed51b3 2699
45005bfb 2700 if (!del && havefinal && rlen)
b448e4fe
JH		 2701 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2702 newSVuv((UV)final), 0);
a0ed51b3 2703
9b877dbb 2704 if (grows)
a0ed51b3
LW		 2705 o->op_private |= OPpTRANS_GROWS;
2706
be2d5e07
AL		 2707 Safefree(tsave);
2708 Safefree(rsave);
9b877dbb 2709
a0ed51b3
LW		 2710 op_free(expr);
2711 op_free(repl);
2712 return o;
2713 }
2714
2715 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2716 if (complement) {
2717 Zero(tbl, 256, short);
eb160463 2718 for (i = 0; i < (I32)tlen; i++)
ec49126f 2719 tbl[t[i]] = -1;
79072805
LW		 2720 for (i = 0, j = 0; i < 256; i++) {
2721 if (!tbl[i]) {
eb160463 2722 if (j >= (I32)rlen) {
a0ed51b3 2723 if (del)
79072805
LW		 2724 tbl[i] = -2;
2725 else if (rlen)
ec49126f 2726 tbl[i] = r[j-1];
79072805 2727 else
eb160463 2728 tbl[i] = (short)i;
79072805 2729 }
9b877dbb
IH		 2730 else {
2731 if (i < 128 && r[j] >= 128)
2732 grows = 1;
ec49126f 2733 tbl[i] = r[j++];
9b877dbb 2734 }
79072805
LW		 2735 }
2736 }
05d340b8
JH		 2737 if (!del) {
2738 if (!rlen) {
2739 j = rlen;
2740 if (!squash)
2741 o->op_private |= OPpTRANS_IDENTICAL;
2742 }
eb160463 2743 else if (j >= (I32)rlen)
05d340b8
JH		 2744 j = rlen - 1;
2745 else
2746 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3bad88ff 2747 tbl[0x100] = (short)(rlen - j);
eb160463 2748 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 2749 tbl[0x101+i] = r[j+i];
2750 }
79072805
LW		 2751 }
2752 else {
a0ed51b3 2753 if (!rlen && !del) {
79072805 2754 r = t; rlen = tlen;
5d06d08e 2755 if (!squash)
4757a243 2756 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2757 }
94bfe852
RGS		 2758 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2759 o->op_private |= OPpTRANS_IDENTICAL;
2760 }
79072805
LW		 2761 for (i = 0; i < 256; i++)
2762 tbl[i] = -1;
eb160463
GS		 2763 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2764 if (j >= (I32)rlen) {
a0ed51b3 2765 if (del) {
ec49126f 2766 if (tbl[t[i]] == -1)
2767 tbl[t[i]] = -2;
79072805
LW		 2768 continue;
2769 }
2770 --j;
2771 }
9b877dbb
IH		 2772 if (tbl[t[i]] == -1) {
2773 if (t[i] < 128 && r[j] >= 128)
2774 grows = 1;
ec49126f 2775 tbl[t[i]] = r[j];
9b877dbb 2776 }
79072805
LW		 2777 }
2778 }
9b877dbb
IH		 2779 if (grows)
2780 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 2781 op_free(expr);
2782 op_free(repl);
2783
11343788 2784 return o;
79072805
LW		 2785}
2786
2787OP *
864dbfa3 2788Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 2789{
2790 PMOP *pmop;
2791
b7dc083c 2792 NewOp(1101, pmop, 1, PMOP);
eb160463 2793 pmop->op_type = (OPCODE)type;
22c35a8c 2794 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 2795 pmop->op_flags = (U8)flags;
2796 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2797
3280af22 2798 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2799 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2800 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 2801 pmop->op_pmpermflags |= PMf_LOCALE;
2802 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2803
debc9467 2804#ifdef USE_ITHREADS
78fd745e
AL		 2805 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2806 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2807 pmop->op_pmoffset = SvIV(repointer);
2808 SvREPADTMP_off(repointer);
2809 sv_setiv(repointer,0);
2810 } else {
2811 SV * const repointer = newSViv(0);
be2d5e07 2812 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
78fd745e
AL		 2813 pmop->op_pmoffset = av_len(PL_regex_padav);
2814 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 2815 }
debc9467 2816#endif
1eb1540c 2817
1fcf4c12 2818 /* link into pm list */
3280af22
NIS		 2819 if (type != OP_TRANS && PL_curstash) {
2820 pmop->op_pmnext = HvPMROOT(PL_curstash);
2821 HvPMROOT(PL_curstash) = pmop;
cb55de95 2822 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 2823 }
2824
676a8eb5 2825 return CHECKOP(type, pmop);
79072805
LW		 2826}
2827
2828OP *
864dbfa3 2829Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 2830{
2831 PMOP *pm;
2832 LOGOP *rcop;
ce862d02 2833 I32 repl_has_vars = 0;
79072805 2834
11343788
MB		 2835 if (o->op_type == OP_TRANS)
2836 return pmtrans(o, expr, repl);
79072805 2837
3280af22 2838 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2839 pm = (PMOP*)o;
79072805
LW		 2840
2841 if (expr->op_type == OP_CONST) {
463ee0b2 2842 STRLEN plen;
8916b559 2843 SV * const pat = ((SVOP*)expr)->op_sv;
8ec8dcb0 2844 const char *p = SvPV_const(pat, plen);
29652248 2845 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
8ec8dcb0
NC		 2846 U32 was_readonly = SvREADONLY(pat);
2847
2848 if (was_readonly) {
2849 if (SvFAKE(pat)) {
2850 sv_force_normal_flags(pat, 0);
2851 assert(!SvREADONLY(pat));
2852 was_readonly = 0;
2853 } else {
2854 SvREADONLY_off(pat);
2855 }
2856 }
2857
93a17b20 2858 sv_setpvn(pat, "\\s+", 3);
8ec8dcb0
NC		 2859
2860 SvFLAGS(pat) |= was_readonly;
2861
2862 p = SvPV_const(pat, plen);
79072805
LW		 2863 pm->op_pmflags |= PMf_SKIPWHITE;
2864 }
5b71a6a7 2865 if (DO_UTF8(pat))
a5961de5 2866 pm->op_pmdynflags |= PMdf_UTF8;
8ec8dcb0
NC		 2867 /* FIXME - can we make this function take const char * args? */
2868 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
aaa362c4 2869 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2870 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 2871 op_free(expr);
2872 }
2873 else {
3280af22 2874 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2875 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2876 ? OP_REGCRESET
2877 : OP_REGCMAYBE),0,expr);
463ee0b2 2878
b7dc083c 2879 NewOp(1101, rcop, 1, LOGOP);
79072805 2880 rcop->op_type = OP_REGCOMP;
22c35a8c 2881 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2882 rcop->op_first = scalar(expr);
1c846c1f 2883 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2884 ? (OPf_SPECIAL | OPf_KIDS)
2885 : OPf_KIDS);
79072805 2886 rcop->op_private = 1;
11343788 2887 rcop->op_other = o;
79072805
LW		 2888
2889 /* establish postfix order */
3280af22 2890 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 2891 LINKLIST(expr);
2892 rcop->op_next = expr;
2893 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2894 }
2895 else {
2896 rcop->op_next = LINKLIST(expr);
2897 expr->op_next = (OP*)rcop;
2898 }
79072805 2899
11343788 2900 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 2901 }
2902
2903 if (repl) {
748a9306 2904 OP *curop;
0244c3a4 2905 if (pm->op_pmflags & PMf_EVAL) {
8916b559 2906 curop = NULL;
93f3c3fe 2907 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 2908 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2909 }
4d1ff10f 2910#ifdef USE_5005THREADS
2faa37cc 2911 else if (repl->op_type == OP_THREADSV
554b3eca 2912 && strchr("&`'123456789+",
533c011a 2913 PL_threadsv_names[repl->op_targ]))
554b3eca
MB		 2914 {
2915 curop = 0;
2916 }
4d1ff10f 2917#endif /* USE_5005THREADS */
748a9306
LW		 2918 else if (repl->op_type == OP_CONST)
2919 curop = repl;
79072805 2920 else {
f4362cdc 2921 OP *lastop = NULL;
79072805 2922 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
498ae447
NC		 2923 if (curop->op_type == OP_SCOPE
2924 || curop->op_type == OP_LEAVE
2925 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4d1ff10f 2926#ifdef USE_5005THREADS
ce862d02
IZ		 2927 if (curop->op_type == OP_THREADSV) {
2928 repl_has_vars = 1;
be949f6f 2929 if (strchr("&`'123456789+", curop->op_private))
ce862d02 2930 break;
554b3eca
MB		 2931 }
2932#else
79072805 2933 if (curop->op_type == OP_GV) {
8916b559 2934 GV * const gv = cGVOPx_gv(curop);
ce862d02 2935 repl_has_vars = 1;
5835a535 2936 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 2937 break;
2938 }
4d1ff10f 2939#endif /* USE_5005THREADS */
79072805
LW		 2940 else if (curop->op_type == OP_RV2CV)
2941 break;
2942 else if (curop->op_type == OP_RV2SV ||
2943 curop->op_type == OP_RV2AV ||
2944 curop->op_type == OP_RV2HV ||
2945 curop->op_type == OP_RV2GV) {
2946 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2947 break;
2948 }
748a9306
LW		 2949 else if (curop->op_type == OP_PADSV ||
2950 curop->op_type == OP_PADAV ||
2951 curop->op_type == OP_PADHV ||
498ae447
NC		 2952 curop->op_type == OP_PADANY)
2953 {
ce862d02 2954 repl_has_vars = 1;
748a9306 2955 }
1167e5da 2956 else if (curop->op_type == OP_PUSHRE)
c9c8c8e1 2957 NOOP; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 2958 else
2959 break;
2960 }
2961 lastop = curop;
2962 }
748a9306 2963 }
ce862d02 2964 if (curop == repl
1c846c1f 2965 && !(repl_has_vars
aaa362c4
RS		 2966 && (!PM_GETRE(pm)
2967 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2968 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2969 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2970 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 2971 }
2972 else {
aaa362c4 2973 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 2974 pm->op_pmflags |= PMf_MAYBE_CONST;
2975 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2976 }
b7dc083c 2977 NewOp(1101, rcop, 1, LOGOP);
748a9306 2978 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2979 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 2980 rcop->op_first = scalar(repl);
2981 rcop->op_flags |= OPf_KIDS;
2982 rcop->op_private = 1;
11343788 2983 rcop->op_other = o;
748a9306
LW		 2984
2985 /* establish postfix order */
2986 rcop->op_next = LINKLIST(repl);
2987 repl->op_next = (OP*)rcop;
2988
2989 pm->op_pmreplroot = scalar((OP*)rcop);
2990 pm->op_pmreplstart = LINKLIST(rcop);
2991 rcop->op_next = 0;
79072805
LW		 2992 }
2993 }
2994
2995 return (OP*)pm;
2996}
2997
2998OP *
864dbfa3 2999Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 3000{
3001 SVOP *svop;
b7dc083c 3002 NewOp(1101, svop, 1, SVOP);
eb160463 3003 svop->op_type = (OPCODE)type;
22c35a8c 3004 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3005 svop->op_sv = sv;
3006 svop->op_next = (OP*)svop;
eb160463 3007 svop->op_flags = (U8)flags;
22c35a8c 3008 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3009 scalar((OP*)svop);
22c35a8c 3010 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3011 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3012 return CHECKOP(type, svop);
79072805
LW		 3013}
3014
3015OP *
350de78d
GS		 3016Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3017{
3018 PADOP *padop;
3019 NewOp(1101, padop, 1, PADOP);
eb160463 3020 padop->op_type = (OPCODE)type;
350de78d
GS		 3021 padop->op_ppaddr = PL_ppaddr[type];
3022 padop->op_padix = pad_alloc(type, SVs_PADTMP);
9755d405
JH		 3023 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3024 PAD_SETSV(padop->op_padix, sv);
5b7ea690
JH		 3025 if (sv)
3026 SvPADTMP_on(sv);
350de78d 3027 padop->op_next = (OP*)padop;
eb160463 3028 padop->op_flags = (U8)flags;
350de78d
GS		 3029 if (PL_opargs[type] & OA_RETSCALAR)
3030 scalar((OP*)padop);
3031 if (PL_opargs[type] & OA_TARGET)
3032 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3033 return CHECKOP(type, padop);
3034}
3035
3036OP *
864dbfa3 3037Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3038{
350de78d 3039#ifdef USE_ITHREADS
5b7ea690
JH		 3040 if (gv)
3041 GvIN_PAD_on(gv);
be2d5e07 3042 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
350de78d 3043#else
be2d5e07 3044 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
350de78d 3045#endif
79072805
LW		 3046}
3047
3048OP *
864dbfa3 3049Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 3050{
3051 PVOP *pvop;
b7dc083c 3052 NewOp(1101, pvop, 1, PVOP);
eb160463 3053 pvop->op_type = (OPCODE)type;
22c35a8c 3054 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3055 pvop->op_pv = pv;
3056 pvop->op_next = (OP*)pvop;
eb160463 3057 pvop->op_flags = (U8)flags;
22c35a8c 3058 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3059 scalar((OP*)pvop);
22c35a8c 3060 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3061 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3062 return CHECKOP(type, pvop);
79072805
LW		 3063}
3064
79072805 3065void
864dbfa3 3066Perl_package(pTHX_ OP *o)
79072805 3067{
93a17b20 3068 SV *sv;
79072805 3069
3280af22
NIS		 3070 save_hptr(&PL_curstash);
3071 save_item(PL_curstname);
11343788 3072 if (o) {
463ee0b2 3073 STRLEN len;
8ec8dcb0 3074 const char *name;
11343788 3075 sv = cSVOPo->op_sv;
8ec8dcb0 3076 name = SvPV_const(sv, len);
3280af22
NIS		 3077 PL_curstash = gv_stashpvn(name,len,TRUE);
3078 sv_setpvn(PL_curstname, name, len);
11343788 3079 op_free(o);
93a17b20
LW		 3080 }
3081 else {
9014280d 3082 deprecate("\"package\" with no arguments");
3280af22
NIS		 3083 sv_setpv(PL_curstname,"<none>");
3084 PL_curstash = Nullhv;
93a17b20 3085 }
7ad382f4 3086 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3087 PL_copline = NOLINE;
3088 PL_expect = XSTATE;
79072805
LW		 3089}
3090
85e6fe83 3091void
efb84706 3092Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 3093{
a0d0e21e 3094 OP *pack;
a0d0e21e 3095 OP *imop;
b1cb66bf 3096 OP *veop;
85e6fe83 3097
efb84706 3098 if (idop->op_type != OP_CONST)
cea2e8a9 3099 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3100
5900599a 3101 veop = NULL;
b1cb66bf 3102
c9dc1ff4 3103 if (version) {
78fd745e 3104 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 3105
c9dc1ff4 3106 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 3107 arg = version;
3108 }
3109 else {
3110 OP *pack;
0f79a09d 3111 SV *meth;
b1cb66bf 3112
44dcb63b 3113 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3114 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3115
efb84706
JH		 3116 /* Make copy of idop so we don't free it twice */
3117 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 3118
3119 /* Fake up a method call to VERSION */
d7559646 3120 meth = newSVpvs("VERSION");
0f79a09d 3121 sv_upgrade(meth, SVt_PVIV);
155aba94 3122 (void)SvIOK_on(meth);
0da6cfda
SP		 3123 {
3124 U32 hash;
5e7e76a3 3125 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
0da6cfda
SP		 3126 SvUV_set(meth, hash);
3127 }
b1cb66bf 3128 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3129 append_elem(OP_LIST,
0f79a09d
GS		 3130 prepend_elem(OP_LIST, pack, list(version)),
3131 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3132 }
3133 }
aeea060c 3134
a0d0e21e 3135 /* Fake up an import/unimport */
4633a7c4
LW		 3136 if (arg && arg->op_type == OP_STUB)
3137 imop = arg; /* no import on explicit () */
efb84706 3138 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5900599a 3139 imop = NULL; /* use 5.0; */
d9e8c084
NC		 3140 if (!aver)
3141 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 3142 }
4633a7c4 3143 else {
0f79a09d
GS		 3144 SV *meth;
3145
efb84706
JH		 3146 /* Make copy of idop so we don't free it twice */
3147 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 3148
3149 /* Fake up a method call to import/unimport */
d7559646 3150 meth = aver ? newSVpvs("import") : newSVpvs("unimport");
ad4c42df 3151 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 3152 (void)SvIOK_on(meth);
0da6cfda
SP		 3153 {
3154 U32 hash;
5e7e76a3 3155 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
0da6cfda
SP		 3156 SvUV_set(meth, hash);
3157 }
4633a7c4 3158 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3159 append_elem(OP_LIST,
3160 prepend_elem(OP_LIST, pack, list(arg)),
3161 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3162 }
3163
a0d0e21e 3164 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3165 newATTRSUB(floor,
d7559646 3166 newSVOP(OP_CONST, 0, newSVpvs("BEGIN")),
5900599a
NC		 3167 NULL,
3168 NULL,
a0d0e21e 3169 append_elem(OP_LINESEQ,
b1cb66bf 3170 append_elem(OP_LINESEQ,
0e2d6244
SS		 3171 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3172 newSTATEOP(0, NULL, veop)),
3173 newSTATEOP(0, NULL, imop) ));
85e6fe83 3174
70f5e4ed
JH		 3175 /* The "did you use incorrect case?" warning used to be here.
3176 * The problem is that on case-insensitive filesystems one
3177 * might get false positives for "use" (and "require"):
3178 * "use Strict" or "require CARP" will work. This causes
3179 * portability problems for the script: in case-strict
3180 * filesystems the script will stop working.
3181 *
3182 * The "incorrect case" warning checked whether "use Foo"
3183 * imported "Foo" to your namespace, but that is wrong, too:
3184 * there is no requirement nor promise in the language that
3185 * a Foo.pm should or would contain anything in package "Foo".
3186 *
3187 * There is very little Configure-wise that can be done, either:
3188 * the case-sensitivity of the build filesystem of Perl does not
3189 * help in guessing the case-sensitivity of the runtime environment.
3190 */
18fc9488 3191
c305c6a0 3192 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3193 PL_copline = NOLINE;
3194 PL_expect = XSTATE;
4e58e0cf 3195 PL_cop_seqmax++; /* Purely for B::*'s benefit */
85e6fe83
LW		 3196}
3197
7d3fb230 3198/*
ccfc67b7
JH		 3199=head1 Embedding Functions
3200
7d3fb230
BS		 3201=for apidoc load_module
3202
3203Loads the module whose name is pointed to by the string part of name.
3204Note that the actual module name, not its filename, should be given.
3205Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3206PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3207(or 0 for no flags). ver, if specified, provides version semantics
3208similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3209arguments can be used to specify arguments to the module's import()
3210method, similar to C<use Foo::Bar VERSION LIST>.
3211
3212=cut */
3213
e4783991
GS		 3214void
3215Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3216{
3217 va_list args;
3218 va_start(args, ver);
3219 vload_module(flags, name, ver, &args);
3220 va_end(args);
3221}
3222
3223#ifdef PERL_IMPLICIT_CONTEXT
3224void
3225Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3226{
3227 dTHX;
3228 va_list args;
3229 va_start(args, ver);
3230 vload_module(flags, name, ver, &args);
3231 va_end(args);
3232}
3233#endif
3234
3235void
3236Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3237{
78fd745e 3238 OP *veop, *imop;
e4783991 3239
78fd745e 3240 OP * const modname = newSVOP(OP_CONST, 0, name);
e4783991
GS		 3241 modname->op_private |= OPpCONST_BARE;
3242 if (ver) {
3243 veop = newSVOP(OP_CONST, 0, ver);
3244 }
3245 else
5900599a 3246 veop = NULL;
e4783991
GS		 3247 if (flags & PERL_LOADMOD_NOIMPORT) {
3248 imop = sawparens(newNULLLIST());
3249 }
3250 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3251 imop = va_arg(*args, OP*);
3252 }
3253 else {
3254 SV *sv;
5900599a 3255 imop = NULL;
e4783991
GS		 3256 sv = va_arg(*args, SV*);
3257 while (sv) {
3258 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3259 sv = va_arg(*args, SV*);
3260 }
3261 }
81885997 3262 {
c501bbfe
AL		 3263 const line_t ocopline = PL_copline;
3264 COP * const ocurcop = PL_curcop;
3265 const int oexpect = PL_expect;
81885997
GS		 3266
3267 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3268 veop, modname, imop);
3269 PL_expect = oexpect;
3270 PL_copline = ocopline;
975adce1 3271 PL_curcop = ocurcop;
81885997 3272 }
e4783991
GS		 3273}
3274
79072805 3275OP *
c1a140b2
NC		 3276Perl_dofile(pTHX_ OP *term)
3277{
3278 return dofile2(term, 0);
3279}
3280
3281OP *
3282Perl_dofile2(pTHX_ OP *term, I32 force_builtin)
78ca652e
GS		 3283{
3284 OP *doop;
f7e580e2 3285 GV *gv = Nullgv;
78ca652e 3286
f7e580e2 3287 if (!force_builtin) {
b977d03a 3288 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
f7e580e2 3289 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
d7559646
AL		 3290 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3291 gv = gvp ? *gvp : Nullgv;
f7e580e2
NC		 3292 }
3293 }
78ca652e 3294
b9f751c0 3295 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3296 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3297 append_elem(OP_LIST, term,
3298 scalar(newUNOP(OP_RV2CV, 0,
43b2f713 3299 newGVOP(OP_GV, 0, gv))))));
78ca652e
GS		 3300 }
3301 else {
3302 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3303 }
3304 return doop;
3305}
3306
3307OP *
864dbfa3 3308Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3309{
3310 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3311 list(force_list(subscript)),
3312 list(force_list(listval)) );
79072805
LW		 3313}
3314
76e3520e 3315STATIC I32
547d29e4 3316S_is_list_assignment(pTHX_ register const OP *o)
79072805 3317{
8c6f7913
AL		 3318 unsigned type;
3319 U8 flags;
3320
11343788 3321 if (!o)
79072805
LW		 3322 return TRUE;
3323
8c6f7913 3324 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 3325 o = cUNOPo->op_first;
79072805 3326
8c6f7913
AL		 3327 flags = o->op_flags;
3328 type = o->op_type;
3329 if (type == OP_COND_EXPR) {
547d29e4
AL		 3330 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3331 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3332
3333 if (t && f)
3334 return TRUE;
3335 if (t || f)
3336 yyerror("Assignment to both a list and a scalar");
3337 return FALSE;
3338 }
3339
8c6f7913
AL		 3340 if (type == OP_LIST &&
3341 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 3342 o->op_private & OPpLVAL_INTRO)
3343 return FALSE;
3344
8c6f7913
AL		 3345 if (type == OP_LIST || flags & OPf_PARENS ||
3346 type == OP_RV2AV || type == OP_RV2HV ||
3347 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 3348 return TRUE;
3349
8c6f7913 3350 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 3351 return TRUE;
3352
8c6f7913 3353 if (type == OP_RV2SV)
79072805
LW		 3354 return FALSE;
3355
3356 return FALSE;
3357}
3358
3359OP *
864dbfa3 3360Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3361{
11343788 3362 OP *o;
79072805 3363
a0d0e21e
LW		 3364 if (optype) {
3365 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3366 return newLOGOP(optype, 0,
3367 mod(scalar(left), optype),
3368 newUNOP(OP_SASSIGN, 0, scalar(right)));
3369 }
3370 else {
3371 return newBINOP(optype, OPf_STACKED,
3372 mod(scalar(left), optype), scalar(right));
3373 }
3374 }
3375
547d29e4 3376 if (is_list_assignment(left)) {
10c8fecd
GS		 3377 OP *curop;
3378
3280af22 3379 PL_modcount = 0;
9ce07961
NC		 3380 /* Grandfathering $[ assignment here. Bletch.*/
3381 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3382 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
463ee0b2 3383 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3384 if (PL_eval_start)
3385 PL_eval_start = 0;
9ce07961
NC		 3386 else if (left->op_type == OP_CONST) {
3387 /* Result of assignment is always 1 (or we'd be dead already) */
3388 return newSVOP(OP_CONST, 0, newSViv(1));
a0d0e21e 3389 }
10c8fecd
GS		 3390 curop = list(force_list(left));
3391 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3392 o->op_private = (U8)(0 | (flags >> 8));
10c8fecd
GS		 3393 for (curop = ((LISTOP*)curop)->op_first;
3394 curop; curop = curop->op_sibling)
3395 {
3396 if (curop->op_type == OP_RV2HV &&
3397 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3398 o->op_private |= OPpASSIGN_HASH;
3399 break;
3400 }
3401 }
9755d405
JH		 3402
3403 /* PL_generation sorcery:
3404 * an assignment like ($a,$b) = ($c,$d) is easier than
3405 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3406 * To detect whether there are common vars, the global var
3407 * PL_generation is incremented for each assign op we compile.
3408 * Then, while compiling the assign op, we run through all the
3409 * variables on both sides of the assignment, setting a spare slot
3410 * in each of them to PL_generation. If any of them already have
3411 * that value, we know we've got commonality. We could use a
3412 * single bit marker, but then we'd have to make 2 passes, first
3413 * to clear the flag, then to test and set it. To find somewhere
3414 * to store these values, evil chicanery is done with SvCUR().
3415 */
2ee68a73 3416 {
11343788 3417 OP *lastop = o;
3280af22 3418 PL_generation++;
11343788 3419 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3420 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3421 if (curop->op_type == OP_GV) {
638eceb6 3422 GV *gv = cGVOPx_gv(curop);
2ebc12fe
NC		 3423 if (gv == PL_defgv
3424 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
79072805 3425 break;
2ebc12fe 3426 GvASSIGN_GENERATION_set(gv, PL_generation);
79072805 3427 }
748a9306
LW		 3428 else if (curop->op_type == OP_PADSV ||
3429 curop->op_type == OP_PADAV ||
3430 curop->op_type == OP_PADHV ||
9755d405
JH		 3431 curop->op_type == OP_PADANY)
3432 {
c43a4d73 3433 if ((int)PAD_COMPNAME_GEN(curop->op_targ)
9755d405 3434 == PL_generation)
748a9306 3435 break;
a8dc4fe8 3436 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
9755d405 3437
748a9306 3438 }
79072805
LW		 3439 else if (curop->op_type == OP_RV2CV)
3440 break;
3441 else if (curop->op_type == OP_RV2SV ||
3442 curop->op_type == OP_RV2AV ||
3443 curop->op_type == OP_RV2HV ||
3444 curop->op_type == OP_RV2GV) {
3445 if (lastop->op_type != OP_GV) /* funny deref? */
3446 break;
3447 }
1167e5da
SM		 3448 else if (curop->op_type == OP_PUSHRE) {
3449 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3450#ifdef USE_ITHREADS
9755d405
JH		 3451 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3452 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3453#else
1167e5da 3454 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3455#endif
2ebc12fe
NC		 3456 if (gv == PL_defgv
3457 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
1167e5da 3458 break;
2ebc12fe
NC		 3459 GvASSIGN_GENERATION_set(gv, PL_generation);
3460 GvASSIGN_GENERATION_set(gv, PL_generation);
b2ffa427 3461 }
1167e5da 3462 }
79072805
LW		 3463 else
3464 break;
3465 }
3466 lastop = curop;
3467 }
11343788 3468 if (curop != o)
10c8fecd 3469 o->op_private |= OPpASSIGN_COMMON;
2ee68a73 3470 }
c07a80fd 3471 if (right && right->op_type == OP_SPLIT) {
8c6f7913
AL		 3472 OP* tmpop = ((LISTOP*)right)->op_first;
3473 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
78fd745e 3474 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 3475 if (left->op_type == OP_RV2AV &&
3476 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3477 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3478 {
3479 tmpop = ((UNOP*)left)->op_first;
3480 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3481#ifdef USE_ITHREADS
ba89bb6e 3482 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3483 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3484#else
3485 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
0e2d6244 3486 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 3487#endif
c07a80fd 3488 pm->op_pmflags |= PMf_ONCE;
11343788 3489 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3490 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5900599a 3491 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 3492 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3493 op_free(o); /* blow off assign */
54310121 3494 right->op_flags &= ~OPf_WANT;
a5f75d66 3495 /* "I don't know and I don't care." */
c07a80fd 3496 return right;
3497 }
3498 }
3499 else {
e6438c1a 3500 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3501 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3502 {
3503 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3504 if (SvIVX(sv) == 0)
3280af22 3505 sv_setiv(sv, PL_modcount+1);
c07a80fd 3506 }
3507 }
3508 }
3509 }
11343788 3510 return o;
79072805
LW		 3511 }
3512 if (!right)
3513 right = newOP(OP_UNDEF, 0);
3514 if (right->op_type == OP_READLINE) {
3515 right->op_flags |= OPf_STACKED;
463ee0b2 3516 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3517 }
a0d0e21e 3518 else {
3280af22 3519 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3520 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3521 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3522 if (PL_eval_start)
3523 PL_eval_start = 0;
748a9306 3524 else {
c20147de 3525 op_free(o);
2cb86c03 3526 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
c20147de 3527 o->op_private |= OPpCONST_ARYBASE;
a0d0e21e
LW		 3528 }
3529 }
11343788 3530 return o;
79072805
LW		 3531}
3532
3533OP *
864dbfa3 3534Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3535{
c05e0e2f 3536 const U32 seq = intro_my();
79072805
LW		 3537 register COP *cop;
3538
b7dc083c 3539 NewOp(1101, cop, 1, COP);
57843af0 3540 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3541 cop->op_type = OP_DBSTATE;
22c35a8c 3542 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3543 }
3544 else {
3545 cop->op_type = OP_NEXTSTATE;
22c35a8c 3546 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3547 }
eb160463 3548 cop->op_flags = (U8)flags;
2cb86c03 3549 CopHINTS_set(cop, PL_hints);
ff0cee69 3550#ifdef NATIVE_HINTS
3551 cop->op_private |= NATIVE_HINTS;
3552#endif
2cb86c03 3553 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 3554 cop->op_next = (OP*)cop;
3555
463ee0b2
LW		 3556 if (label) {
3557 cop->cop_label = label;
3280af22 3558 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3559 }
bbce6d69 3560 cop->cop_seq = seq;
2cb86c03 3561 CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
0453d815 3562 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3563 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3564 else
599cee73 3565 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3566 if (specialCopIO(PL_curcop->cop_io))
3567 cop->cop_io = PL_curcop->cop_io;
3568 else
3569 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3570
79072805 3571
3280af22 3572 if (PL_copline == NOLINE)
57843af0 3573 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3574 else {
57843af0 3575 CopLINE_set(cop, PL_copline);
3280af22 3576 PL_copline = NOLINE;
79072805 3577 }
57843af0 3578#ifdef USE_ITHREADS
f4dd75d9 3579 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3580#else
f4dd75d9 3581 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3582#endif
11faa288 3583 CopSTASH_set(cop, PL_curstash);
79072805 3584
3280af22 3585 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3f3e5b8d
NC		 3586 AV *av = CopFILEAVx(PL_curcop);
3587 if (av) {
3588 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
3589 if (svp && *svp != &PL_sv_undef ) {
3590 (void)SvIOK_on(*svp);
3591 SvIV_set(*svp, PTR2IV(cop));
3592 }
1eb1540c 3593 }
93a17b20
LW		 3594 }
3595
11343788 3596 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3597}
3598
bbce6d69 3599
79072805 3600OP *
864dbfa3 3601Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3602{
883ffac3
CS		 3603 return new_logop(type, flags, &first, &other);
3604}
3605
3bd495df 3606STATIC OP *
cea2e8a9 3607S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3608{
79072805 3609 LOGOP *logop;
11343788 3610 OP *o;
883ffac3 3611 OP *first = *firstp;
2b856aa6 3612 OP * const other = *otherp;
79072805 3613
a0d0e21e
LW		 3614 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3615 return newBINOP(type, flags, scalar(first), scalar(other));
3616
8990e307 3617 scalarboolean(first);
79072805 3618 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
a28a866d
NC		 3619 if (first->op_type == OP_NOT
3620 && (first->op_flags & OPf_SPECIAL)
3621 && (first->op_flags & OPf_KIDS)) {
79072805
LW		 3622 if (type == OP_AND || type == OP_OR) {
3623 if (type == OP_AND)
3624 type = OP_OR;
3625 else
3626 type = OP_AND;
11343788 3627 o = first;
883ffac3 3628 first = *firstp = cUNOPo->op_first;
11343788
MB		 3629 if (o->op_next)
3630 first->op_next = o->op_next;
5900599a 3631 cUNOPo->op_first = NULL;
11343788 3632 op_free(o);
79072805
LW		 3633 }
3634 }
3635 if (first->op_type == OP_CONST) {
c77beb56
NC		 3636 if (first->op_private & OPpCONST_STRICT)
3637 no_bareword_allowed(first);
f5e9f069 3638 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
5b7ea690 3639 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
79072805
LW		 3640 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3641 op_free(first);
5900599a 3642 *firstp = NULL;
3c4f8c45
NC		 3643 if (other->op_type == OP_CONST)
3644 other->op_private |= OPpCONST_SHORTCIRCUIT;
79072805
LW		 3645 return other;
3646 }
3647 else {
3648 op_free(other);
5900599a 3649 *otherp = NULL;
3c4f8c45
NC		 3650 if (first->op_type == OP_CONST)
3651 first->op_private |= OPpCONST_SHORTCIRCUIT;
79072805
LW		 3652 return first;
3653 }
3654 }
f5e9f069 3655 else if ((first->op_flags & OPf_KIDS) && ckWARN(WARN_MISC)) {
2b856aa6
AL		 3656 const OP * const k1 = ((UNOP*)first)->op_first;
3657 const OP * const k2 = k1->op_sibling;
a6006777 3658 OPCODE warnop = 0;
3659 switch (first->op_type)
3660 {
3661 case OP_NULL:
3662 if (k2 && k2->op_type == OP_READLINE
3663 && (k2->op_flags & OPf_STACKED)
1c846c1f 3664 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3665 {
a6006777 3666 warnop = k2->op_type;
72b16652 3667 }
a6006777 3668 break;
3669
3670 case OP_SASSIGN:
68dc0745 3671 if (k1->op_type == OP_READDIR
3672 || k1->op_type == OP_GLOB
72b16652 3673 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3674 || k1->op_type == OP_EACH)
72b16652
GS		 3675 {
3676 warnop = ((k1->op_type == OP_NULL)
eb160463 3677 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 3678 }
a6006777 3679 break;
3680 }
8ebc5c01 3681 if (warnop) {
c501bbfe 3682 const line_t oldline = CopLINE(PL_curcop);
57843af0 3683 CopLINE_set(PL_curcop, PL_copline);
9014280d 3684 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 3685 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3686 PL_op_desc[warnop],
68dc0745 3687 ((warnop == OP_READLINE || warnop == OP_GLOB)
3688 ? " construct" : "() operator"));
57843af0 3689 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3690 }
a6006777 3691 }
79072805
LW		 3692
3693 if (!other)
3694 return first;
3695
a0d0e21e
LW		 3696 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3697 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3698
b7dc083c 3699 NewOp(1101, logop, 1, LOGOP);
79072805 3700
eb160463 3701 logop->op_type = (OPCODE)type;
22c35a8c 3702 logop->op_ppaddr = PL_ppaddr[type];
79072805 3703 logop->op_first = first;
3bad88ff 3704 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 3705 logop->op_other = LINKLIST(other);
eb160463 3706 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3707
3708 /* establish postfix order */
3709 logop->op_next = LINKLIST(first);
3710 first->op_next = (OP*)logop;
3711 first->op_sibling = other;
3712
676a8eb5
JH		 3713 CHECKOP(type,logop);
3714
11343788
MB		 3715 o = newUNOP(OP_NULL, 0, (OP*)logop);
3716 other->op_next = o;
79072805 3717
11343788 3718 return o;
79072805
LW		 3719}
3720
3721OP *
864dbfa3 3722Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3723{
1a67a97c
SM		 3724 LOGOP *logop;
3725 OP *start;
11343788 3726 OP *o;
79072805 3727
b1cb66bf 3728 if (!falseop)
3729 return newLOGOP(OP_AND, 0, first, trueop);
3730 if (!trueop)
3731 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3732
8990e307 3733 scalarboolean(first);
79072805 3734 if (first->op_type == OP_CONST) {
2bc6235c 3735 if (first->op_private & OPpCONST_BARE &&
2b856aa6
AL		 3736 first->op_private & OPpCONST_STRICT) {
3737 no_bareword_allowed(first);
3738 }
79072805
LW		 3739 if (SvTRUE(((SVOP*)first)->op_sv)) {
3740 op_free(first);
b1cb66bf 3741 op_free(falseop);
3742 return trueop;
79072805
LW		 3743 }
3744 else {
3745 op_free(first);
b1cb66bf 3746 op_free(trueop);
3747 return falseop;
79072805
LW		 3748 }
3749 }
1a67a97c
SM		 3750 NewOp(1101, logop, 1, LOGOP);
3751 logop->op_type = OP_COND_EXPR;
3752 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3753 logop->op_first = first;
3bad88ff 3754 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3755 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 3756 logop->op_other = LINKLIST(trueop);
3757 logop->op_next = LINKLIST(falseop);
79072805 3758
676a8eb5
JH		 3759 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3760 logop);
79072805
LW		 3761
3762 /* establish postfix order */
1a67a97c
SM		 3763 start = LINKLIST(first);
3764 first->op_next = (OP*)logop;
79072805 3765
b1cb66bf 3766 first->op_sibling = trueop;
3767 trueop->op_sibling = falseop;
1a67a97c 3768 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 3769
1a67a97c 3770 trueop->op_next = falseop->op_next = o;
79072805 3771
1a67a97c 3772 o->op_next = start;
11343788 3773 return o;
79072805
LW		 3774}
3775
3776OP *
864dbfa3 3777Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 3778{
1a67a97c 3779 LOGOP *range;
79072805
LW		 3780 OP *flip;
3781 OP *flop;
1a67a97c 3782 OP *leftstart;
11343788 3783 OP *o;
79072805 3784
1a67a97c 3785 NewOp(1101, range, 1, LOGOP);
79072805 3786
1a67a97c
SM		 3787 range->op_type = OP_RANGE;
3788 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3789 range->op_first = left;
3790 range->op_flags = OPf_KIDS;
3791 leftstart = LINKLIST(left);
3792 range->op_other = LINKLIST(right);
eb160463 3793 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3794
3795 left->op_sibling = right;
3796
1a67a97c
SM		 3797 range->op_next = (OP*)range;
3798 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 3799 flop = newUNOP(OP_FLOP, 0, flip);
11343788 3800 o = newUNOP(OP_NULL, 0, flop);
79072805 3801 linklist(flop);
1a67a97c 3802 range->op_next = leftstart;
79072805
LW		 3803
3804 left->op_next = flip;
3805 right->op_next = flop;
3806
1a67a97c
SM		 3807 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3808 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 3809 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 3810 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3811
3812 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3813 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3814
11343788 3815 flip->op_next = o;
79072805 3816 if (!flip->op_private || !flop->op_private)
11343788 3817 linklist(o); /* blow off optimizer unless constant */
79072805 3818
11343788 3819 return o;
79072805
LW		 3820}
3821
3822OP *
864dbfa3 3823Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 3824{
463ee0b2 3825 OP* listop;
11343788 3826 OP* o;
e2b56717 3827 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 3828 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
217ef1d7
AL		 3829
3830 PERL_UNUSED_ARG(debuggable);
93a17b20 3831
463ee0b2
LW		 3832 if (expr) {
3833 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3834 return block; /* do {} while 0 does once */
fb73857a 3835 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3836 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 3837 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3838 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 3839 } else if (expr->op_flags & OPf_KIDS) {
217ef1d7
AL		 3840 const OP * const k1 = ((UNOP*)expr)->op_first;
3841 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 3842 switch (expr->op_type) {
1c846c1f 3843 case OP_NULL:
55d729e4
GS		 3844 if (k2 && k2->op_type == OP_READLINE
3845 && (k2->op_flags & OPf_STACKED)
1c846c1f 3846 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3847 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3848 break;
55d729e4
GS		 3849
3850 case OP_SASSIGN:
c20147de 3851 if (k1 && (k1->op_type == OP_READDIR
55d729e4 3852 || k1->op_type == OP_GLOB
6531c3e6 3853 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
c20147de 3854 || k1->op_type == OP_EACH))
55d729e4
GS		 3855 expr = newUNOP(OP_DEFINED, 0, expr);
3856 break;
3857 }
774d564b 3858 }
463ee0b2 3859 }
93a17b20 3860
4c6e520c
NC		 3861 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3862 * op, in listop. This is wrong. [perl #27024] */
3863 if (!block)
3864 block = newOP(OP_NULL, 0);
8990e307 3865 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 3866 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 3867
883ffac3
CS		 3868 if (listop)
3869 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 3870
11343788
MB		 3871 if (once && o != listop)
3872 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 3873
11343788
MB		 3874 if (o == listop)
3875 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 3876
11343788
MB		 3877 o->op_flags |= flags;
3878 o = scope(o);
3879 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3880 return o;
79072805
LW		 3881}
3882
e211275a
NC		 3883
3884OP *
3885Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
3886 I32 whileline, OP *expr, OP *block, OP *cont)
3887{
3888 return newWHILEOP8(flags, debuggable, loop, whileline, expr, block, cont,
3889 0);
3890}
3891
79072805 3892OP *
e211275a
NC		 3893Perl_newWHILEOP8(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3894whileline, OP *expr, OP *block, OP *cont, I32 has_my)
79072805
LW		 3895{
3896 OP *redo;
f4362cdc 3897 OP *next = NULL;
79072805 3898 OP *listop;
11343788 3899 OP *o;
1ba6ee2b 3900 U8 loopflags = 0;
217ef1d7
AL		 3901
3902 PERL_UNUSED_ARG(debuggable);
79072805 3903
339a2a6a
AL		 3904 if (expr) {
3905 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3906 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3907 expr = newUNOP(OP_DEFINED, 0,
3908 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3909 } else if (expr->op_flags & OPf_KIDS) {
3910 const OP * const k1 = ((UNOP*)expr)->op_first;
3911 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3912 switch (expr->op_type) {
3913 case OP_NULL:
3914 if (k2 && k2->op_type == OP_READLINE
3915 && (k2->op_flags & OPf_STACKED)
3916 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3917 expr = newUNOP(OP_DEFINED, 0, expr);
3918 break;
55d729e4 3919
339a2a6a 3920 case OP_SASSIGN:
c20147de 3921 if (k1 && (k1->op_type == OP_READDIR
339a2a6a
AL		 3922 || k1->op_type == OP_GLOB
3923 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
c20147de 3924 || k1->op_type == OP_EACH))
339a2a6a
AL		 3925 expr = newUNOP(OP_DEFINED, 0, expr);
3926 break;
3927 }
55d729e4 3928 }
748a9306 3929 }
79072805
LW		 3930
3931 if (!block)
3932 block = newOP(OP_NULL, 0);
e211275a 3933 else if (cont || has_my) {
87246558
GS		 3934 block = scope(block);
3935 }
79072805 3936
1ba6ee2b 3937 if (cont) {
79072805 3938 next = LINKLIST(cont);
1ba6ee2b 3939 }
fb73857a 3940 if (expr) {
78fd745e 3941 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 3942 if (!next)
3943 next = unstack;
3944 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 3945 }
79072805 3946
eb527b6b 3947 assert(block);
463ee0b2 3948 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
eb527b6b 3949 assert(listop);
79072805
LW		 3950 redo = LINKLIST(listop);
3951
3952 if (expr) {
eb160463 3953 PL_copline = (line_t)whileline;
883ffac3
CS		 3954 scalar(listop);
3955 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 3956 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 3957 op_free(expr); /* oops, it's a while (0) */
463ee0b2 3958 op_free((OP*)loop);
5900599a 3959 return NULL; /* listop already freed by new_logop */
463ee0b2 3960 }
883ffac3 3961 if (listop)
497b47a8 3962 ((LISTOP*)listop)->op_last->op_next =
883ffac3 3963 (o == listop ? redo : LINKLIST(o));
79072805
LW		 3964 }
3965 else
11343788 3966 o = listop;
79072805
LW		 3967
3968 if (!loop) {
b7dc083c 3969 NewOp(1101,loop,1,LOOP);
79072805 3970 loop->op_type = OP_ENTERLOOP;
22c35a8c 3971 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 3972 loop->op_private = 0;
3973 loop->op_next = (OP*)loop;
3974 }
3975
11343788 3976 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 3977
3978 loop->op_redoop = redo;
11343788 3979 loop->op_lastop = o;
1ba6ee2b 3980 o->op_private |= loopflags;
79072805
LW		 3981
3982 if (next)
3983 loop->op_nextop = next;
3984 else
11343788 3985 loop->op_nextop = o;
79072805 3986
11343788
MB		 3987 o->op_flags |= flags;
3988 o->op_private |= (flags >> 8);
3989 return o;
79072805
LW		 3990}
3991
3992OP *
4996ee04 3993Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
79072805
LW		 3994{
3995 LOOP *loop;
fb73857a 3996 OP *wop;
4bbc6d12 3997 PADOFFSET padoff = 0;
4633a7c4 3998 I32 iterflags = 0;
16c773f9 3999 I32 iterpflags = 0;
79072805 4000
79072805 4001 if (sv) {
85e6fe83 4002 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
16c773f9 4003 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 4004 sv->op_type = OP_RV2GV;
22c35a8c 4005 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
79072805 4006 }
85e6fe83 4007 else if (sv->op_type == OP_PADSV) { /* private variable */
16c773f9 4008 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 4009 padoff = sv->op_targ;
743e66e6 4010 sv->op_targ = 0;
85e6fe83 4011 op_free(sv);
5900599a 4012 sv = NULL;
85e6fe83 4013 }
d44e7566 4014#ifdef USE_5005THREADS
54b9620d
MB		 4015 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4016 padoff = sv->op_targ;
743e66e6 4017 sv->op_targ = 0;
54b9620d
MB		 4018 iterflags |= OPf_SPECIAL;
4019 op_free(sv);
5900599a 4020 sv = NULL;
54b9620d 4021 }
d44e7566 4022#endif
79072805 4023 else
cea2e8a9 4024 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
79072805
LW		 4025 }
4026 else {
4d1ff10f 4027#ifdef USE_5005THREADS
54b9620d
MB		 4028 padoff = find_threadsv("_");
4029 iterflags |= OPf_SPECIAL;
4030#else
3280af22 4031 sv = newGVOP(OP_GV, 0, PL_defgv);
54b9620d 4032#endif
79072805 4033 }
5f05dabc 4034 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 4035 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 4036 iterflags |= OPf_STACKED;
4037 }
89ea2908
GA		 4038 else if (expr->op_type == OP_NULL &&
4039 (expr->op_flags & OPf_KIDS) &&
4040 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4041 {
4042 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4043 * set the STACKED flag to indicate that these values are to be
4044 * treated as min/max values by 'pp_iterinit'.
4045 */
43b2f713 4046 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
78fd745e 4047 LOGOP* const range = (LOGOP*) flip->op_first;
4996ee04
AL		 4048 OP* const left = range->op_first;
4049 OP* const right = left->op_sibling;
5152d7c7 4050 LISTOP* listop;
89ea2908
GA		 4051
4052 range->op_flags &= ~OPf_KIDS;
5900599a 4053 range->op_first = NULL;
89ea2908 4054
5152d7c7 4055 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 4056 listop->op_first->op_next = range->op_next;
4057 left->op_next = range->op_other;
5152d7c7
GS		 4058 right->op_next = (OP*)listop;
4059 listop->op_next = listop->op_first;
89ea2908
GA		 4060
4061 op_free(expr);
5152d7c7 4062 expr = (OP*)(listop);
93c66552 4063 op_null(expr);
89ea2908
GA		 4064 iterflags |= OPf_STACKED;
4065 }
4066 else {
4067 expr = mod(force_list(expr), OP_GREPSTART);
4068 }
4069
4633a7c4 4070 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 4071 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 4072 assert(!loop->op_next);
16c773f9
JH		 4073 /* for my $x () sets OPpLVAL_INTRO;
4074 * for our $x () sets OPpOUR_INTRO; both only used by Deparse.pm */
c43a4d73 4075 loop->op_private = (U8)iterpflags;
b7dc083c 4076#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 4077 {
4078 LOOP *tmp;
4079 NewOp(1234,tmp,1,LOOP);
922661e1 4080 Copy(loop,tmp,1,LISTOP);
238a4c30 4081 FreeOp(loop);
155aba94
GS		 4082 loop = tmp;
4083 }
b7dc083c 4084#else
85e6fe83 4085 Renew(loop, 1, LOOP);
1c846c1f 4086#endif
85e6fe83 4087 loop->op_targ = padoff;
e211275a
NC		 4088 wop = newWHILEOP8(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont,
4089 0);
3280af22 4090 PL_copline = forline;
fb73857a 4091 return newSTATEOP(0, label, wop);
79072805
LW		 4092}
4093
8990e307 4094OP*
864dbfa3 4095Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 4096{
11343788 4097 OP *o;
2d8e6c8d 4098
8990e307 4099 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 4100 /* "last()" means "last" */
4101 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4102 o = newOP(type, OPf_SPECIAL);
4103 else {
4104 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
db1c9db1 4105 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
cdaebead
MB		 4106 : ""));
4107 }
8990e307
LW		 4108 op_free(label);
4109 }
4110 else {
4a04c497
NC		 4111 /* Check whether it's going to be a goto &function */
4112 if (label->op_type == OP_ENTERSUB
4113 && !(label->op_flags & OPf_STACKED))
a0d0e21e 4114 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 4115 o = newUNOP(type, OPf_STACKED, label);
8990e307 4116 }
3280af22 4117 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4118 return o;
8990e307
LW		 4119}
4120
d7afa7f5
JH		 4121/*
4122=for apidoc cv_undef
4123
4124Clear out all the active components of a CV. This can happen either
4125by an explicit C<undef &foo>, or by the reference count going to zero.
4126In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4127children can still follow the full lexical scope chain.
4128
4129=cut
4130*/
4131
79072805 4132void
864dbfa3 4133Perl_cv_undef(pTHX_ CV *cv)
79072805 4134{
4d1ff10f 4135#ifdef USE_5005THREADS
e858de61
MB		 4136 if (CvMUTEXP(cv)) {
4137 MUTEX_DESTROY(CvMUTEXP(cv));
4138 Safefree(CvMUTEXP(cv));
4139 CvMUTEXP(cv) = 0;
4140 }
4d1ff10f 4141#endif /* USE_5005THREADS */
11343788 4142
a636914a 4143#ifdef USE_ITHREADS
b8ad7764 4144 if (CvFILE(cv) && !CvISXSUB(cv)) {
8a51b169 4145 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 4146 Safefree(CvFILE(cv));
a636914a 4147 }
f3e31eb5 4148 CvFILE(cv) = 0;
a636914a
RH		 4149#endif
4150
b8ad7764 4151 if (!CvISXSUB(cv) && CvROOT(cv)) {
4d1ff10f 4152#ifdef USE_5005THREADS
11343788 4153 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
cea2e8a9 4154 Perl_croak(aTHX_ "Can't undef active subroutine");
11343788 4155#else
a0d0e21e 4156 if (CvDEPTH(cv))
cea2e8a9 4157 Perl_croak(aTHX_ "Can't undef active subroutine");
4d1ff10f 4158#endif /* USE_5005THREADS */
8990e307 4159 ENTER;
a0d0e21e 4160
d7afa7f5 4161 PAD_SAVE_SETNULLPAD();
a0d0e21e 4162
282f25c9 4163 op_free(CvROOT(cv));
5900599a
NC		 4164 CvROOT(cv) = NULL;
4165 CvSTART(cv) = NULL;
8990e307 4166 LEAVE;
79072805 4167 }
1d5db326 4168 SvPOK_off((SV*)cv); /* forget prototype */
0e2d6244 4169 CvGV(cv) = NULL;
d7afa7f5
JH		 4170
4171 pad_undef(cv);
4172
4173 /* remove CvOUTSIDE unless this is an undef rather than a free */
4174 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4175 if (!CvWEAKOUTSIDE(cv))
4176 SvREFCNT_dec(CvOUTSIDE(cv));
4177 CvOUTSIDE(cv) = Nullcv;
4178 }
beab0874
JT		 4179 if (CvCONST(cv)) {
4180 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4181 CvCONST_off(cv);
4182 }
50762d59 4183 if (CvXSUB(cv)) {
1e7ed80e 4184 CvXSUB(cv) = NULL;
50762d59 4185 }
d7afa7f5
JH		 4186 /* delete all flags except WEAKOUTSIDE */
4187 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 4188}
4189
3fe9a6f1 4190void
34a11f14
NC		 4191Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4192 const STRLEN len)
4193{
4194 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4195 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4196 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4197 || (p && (len != SvCUR(cv) /* Not the same length. */
4198 || memNE(p, SvPVX_const(cv), len))))
4199 && ckWARN_d(WARN_PROTOTYPE)) {
339a2a6a 4200 SV* const msg = sv_newmortal();
0e2d6244 4201 SV* name = NULL;
3fe9a6f1 4202
4203 if (gv)
34a11f14 4204 gv_efullname3(name = sv_newmortal(), (GV *)gv, NULL);
46fc3d4c 4205 sv_setpv(msg, "Prototype mismatch:");
4206 if (name)
f2139bd3 4207 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
3fe9a6f1 4208 if (SvPOK(cv))
f2139bd3 4209 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
59e7bac0 4210 else
d7559646
AL		 4211 sv_catpvs(msg, ": none");
4212 sv_catpvs(msg, " vs ");
46fc3d4c 4213 if (p)
34a11f14 4214 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
46fc3d4c 4215 else
d7559646 4216 sv_catpvs(msg, "none");
f2139bd3 4217 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
3fe9a6f1 4218 }
4219}
4220
8a51b169
JH		 4221static void const_sv_xsub(pTHX_ CV* cv);
4222
beab0874 4223/*
ccfc67b7
JH		 4224
4225=head1 Optree Manipulation Functions
4226
beab0874
JT		 4227=for apidoc cv_const_sv
4228
4229If C<cv> is a constant sub eligible for inlining. returns the constant
4230value returned by the sub. Otherwise, returns NULL.
4231
4232Constant subs can be created with C<newCONSTSUB> or as described in
4233L<perlsub/"Constant Functions">.
4234
4235=cut
4236*/
760ac839 4237SV *
864dbfa3 4238Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 4239{
1e7ed80e 4240 PERL_UNUSED_CONTEXT;
0211776e
NC		 4241 if (!cv)
4242 return NULL;
4243 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4244 return NULL;
4245 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
fe5e78ed 4246}
760ac839 4247
fe5e78ed 4248SV *
864dbfa3 4249Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed 4250{
0e2d6244 4251 SV *sv = NULL;
fe5e78ed 4252
0f79a09d 4253 if (!o)
0e2d6244 4254 return NULL;
1c846c1f
NIS		 4255
4256 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 4257 o = cLISTOPo->op_first->op_sibling;
4258
4259 for (; o; o = o->op_next) {
c6d79d47 4260 const OPCODE type = o->op_type;
fe5e78ed 4261
1c846c1f 4262 if (sv && o->op_next == o)
fe5e78ed 4263 return sv;
e576b457
JT		 4264 if (o->op_next != o) {
4265 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4266 continue;
4267 if (type == OP_DBSTATE)
4268 continue;
4269 }
54310121 4270 if (type == OP_LEAVESUB || type == OP_RETURN)
4271 break;
4272 if (sv)
0e2d6244 4273 return NULL;
7766f137 4274 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 4275 sv = cSVOPo->op_sv;
7766f137 4276 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
9755d405 4277 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 4278 if (!sv)
0e2d6244 4279 return NULL;
beab0874
JT		 4280 if (CvCONST(cv)) {
4281 /* We get here only from cv_clone2() while creating a closure.
4282 Copy the const value here instead of in cv_clone2 so that
4283 SvREADONLY_on doesn't lead to problems when leaving
4284 scope.
4285 */
4286 sv = newSVsv(sv);
4287 }
4288 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
54310121 4289 return Nullsv;
760ac839 4290 }
54310121 4291 else
0e2d6244 4292 return NULL;
760ac839 4293 }
5aabfad6 4294 if (sv)
4295 SvREADONLY_on(sv);
760ac839
LW		 4296 return sv;
4297}
4298
09bef843
SB		 4299void
4300Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4301{
217ef1d7
AL		 4302 PERL_UNUSED_ARG(floor);
4303
09bef843
SB		 4304 if (o)
4305 SAVEFREEOP(o);
4306 if (proto)
4307 SAVEFREEOP(proto);
4308 if (attrs)
4309 SAVEFREEOP(attrs);
4310 if (block)
4311 SAVEFREEOP(block);
4312 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4313}
4314
748a9306 4315CV *
864dbfa3 4316Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 4317{
5900599a 4318 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
09bef843
SB		 4319}
4320
4321CV *
4322Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4323{
c501bbfe 4324 const char *aname;
83ee9e09 4325 GV *gv;
8ec8dcb0 4326 const char *ps;
2a8de9e2 4327 STRLEN ps_len;
f4362cdc 4328 register CV *cv = NULL;
beab0874 4329 SV *const_sv;
4b6d7cf0
NC		 4330 /* If the subroutine has no body, no attributes, and no builtin attributes
4331 then it's just a sub declaration, and we may be able to get away with
4332 storing with a placeholder scalar in the symbol table, rather than a
4333 full GV and CV. If anything is present then it will take a full CV to
4334 store it. */
4335 const I32 gv_fetch_flags
4336 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4337 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
0e2d6244 4338 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
60e3e0e4
NC		 4339
4340 if (proto) {
4341 assert(proto->op_type == OP_CONST);
8ec8dcb0 4342 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
60e3e0e4
NC		 4343 }
4344 else
0e2d6244 4345 ps = NULL;
60e3e0e4 4346
83ee9e09 4347 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
c9dc1ff4 4348 SV * const sv = sv_newmortal();
c99da370
JH		 4349 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4350 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 4351 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5e7e76a3 4352 aname = SvPVX_const(sv);
83ee9e09
GS		 4353 }
4354 else
0e2d6244 4355 aname = NULL;
9ce07961
NC		 4356
4357 /* There may be future conflict here as change 23766 is not yet merged. */
057b822e
NC		 4358 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4359 : gv_fetchpv(aname ? aname
4360 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4361 gv_fetch_flags, SVt_PVCV);
83ee9e09 4362
11343788 4363 if (o)
5dc0d613 4364 SAVEFREEOP(o);
3fe9a6f1 4365 if (proto)
4366 SAVEFREEOP(proto);
09bef843
SB		 4367 if (attrs)
4368 SAVEFREEOP(attrs);
3fe9a6f1 4369
09bef843 4370 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4371 maximum a prototype before. */
4372 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4373 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4374 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4375 {
9014280d 4376 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 4377 }
34a11f14 4378 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
55d729e4
GS		 4379 }
4380 if (ps)
2a8de9e2 4381 sv_setpvn((SV*)gv, ps, ps_len);
55d729e4
GS		 4382 else
4383 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4384 SvREFCNT_dec(PL_compcv);
4385 cv = PL_compcv = NULL;
4386 PL_sub_generation++;
beab0874 4387 goto done;
55d729e4
GS		 4388 }
4389
beab0874
JT		 4390 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4391
7fb37951
AMS		 4392#ifdef GV_UNIQUE_CHECK
4393 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4394 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4395 }
4396#endif
4397
9ce07961 4398 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
0e2d6244 4399 const_sv = NULL;
beab0874
JT		 4400 else
4401 const_sv = op_const_sv(block, Nullcv);
4402
4403 if (cv) {
c501bbfe 4404 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4405
7fb37951
AMS		 4406#ifdef GV_UNIQUE_CHECK
4407 if (exists && GvUNIQUE(gv)) {
4408 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4409 }
4410#endif
4411
60ed1d8c
GS		 4412 /* if the subroutine doesn't exist and wasn't pre-declared
4413 * with a prototype, assume it will be AUTOLOADed,
4414 * skipping the prototype check
4415 */
4416 if (exists || SvPOK(cv))
34a11f14 4417 cv_ckproto_len(cv, gv, ps, ps_len);
68dc0745 4418 /* already defined (or promised)? */
60ed1d8c 4419 if (exists || GvASSUMECV(gv)) {
09bef843 4420 if (!block && !attrs) {
d3cea301
SB		 4421 if (CvFLAGS(PL_compcv)) {
4422 /* might have had built-in attrs applied */
4423 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4424 }
aa689395 4425 /* just a "sub foo;" when &foo is already defined */
3280af22 4426 SAVEFREESV(PL_compcv);
aa689395 4427 goto done;
4428 }
beab0874
JT		 4429 if (block) {
4430 if (ckWARN(WARN_REDEFINE)
4431 || (CvCONST(cv)
4432 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4433 {
c501bbfe 4434 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4435 if (PL_copline != NOLINE)
4436 CopLINE_set(PL_curcop, PL_copline);
9014280d 4437 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4438 CvCONST(cv) ? "Constant subroutine %s redefined"
4439 : "Subroutine %s redefined", name);
4440 CopLINE_set(PL_curcop, oldline);
4441 }
4442 SvREFCNT_dec(cv);
4443 cv = Nullcv;
79072805 4444 }
79072805
LW		 4445 }
4446 }
beab0874 4447 if (const_sv) {
be2d5e07 4448 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 4449 if (cv) {
0768512c 4450 assert(!CvROOT(cv) && !CvCONST(cv));
2a8de9e2 4451 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
beab0874
JT		 4452 CvXSUBANY(cv).any_ptr = const_sv;
4453 CvXSUB(cv) = const_sv_xsub;
4454 CvCONST_on(cv);
beab0874
JT		 4455 }
4456 else {
4457 GvCV(gv) = Nullcv;
5adb6136 4458 cv = newCONSTSUB(NULL, (char *)name, const_sv);
beab0874
JT		 4459 }
4460 op_free(block);
4461 SvREFCNT_dec(PL_compcv);
4462 PL_compcv = NULL;
4463 PL_sub_generation++;
4464 goto done;
4465 }
09bef843
SB		 4466 if (attrs) {
4467 HV *stash;
4468 SV *rcv;
4469
4470 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4471 * before we clobber PL_compcv.
4472 */
4473 if (cv && !block) {
4474 rcv = (SV*)cv;
020f0e03
SB		 4475 /* Might have had built-in attributes applied -- propagate them. */
4476 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4477 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4478 stash = GvSTASH(CvGV(cv));
a9164de8 4479 else if (CvSTASH(cv))
09bef843
SB		 4480 stash = CvSTASH(cv);
4481 else
4482 stash = PL_curstash;
4483 }
4484 else {
4485 /* possibly about to re-define existing subr -- ignore old cv */
4486 rcv = (SV*)PL_compcv;
a9164de8 4487 if (name && GvSTASH(gv))
09bef843
SB		 4488 stash = GvSTASH(gv);
4489 else
4490 stash = PL_curstash;
4491 }
95f0a2f1 4492 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4493 }
a0d0e21e 4494 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4495 if (!block) {
4496 /* got here with just attrs -- work done, so bug out */
4497 SAVEFREESV(PL_compcv);
4498 goto done;
4499 }
d7afa7f5 4500 /* transfer PL_compcv to cv */
4633a7c4 4501 cv_undef(cv);
3280af22 4502 CvFLAGS(cv) = CvFLAGS(PL_compcv);
7a565e5d
NC		 4503 if (!CvWEAKOUTSIDE(cv))
4504 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 4505 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
d7afa7f5 4506 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 4507 CvOUTSIDE(PL_compcv) = 0;
4508 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4509 CvPADLIST(PL_compcv) = 0;
282f25c9 4510 /* inner references to PL_compcv must be fixed up ... */
9755d405 4511 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 4512 /* ... before we throw it away */
3280af22 4513 SvREFCNT_dec(PL_compcv);
a933f601
IZ		 4514 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4515 ++PL_sub_generation;
a0d0e21e
LW		 4516 }
4517 else {
3280af22 4518 cv = PL_compcv;
44a8e56a 4519 if (name) {
4520 GvCV(gv) = cv;
4521 GvCVGEN(gv) = 0;
3280af22 4522 PL_sub_generation++;
44a8e56a 4523 }
a0d0e21e 4524 }
65c50114 4525 CvGV(cv) = gv;
a636914a 4526 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4527 CvSTASH(cv) = PL_curstash;
4d1ff10f 4528#ifdef USE_5005THREADS
11343788 4529 CvOWNER(cv) = 0;
1cfa4ec7 4530 if (!CvMUTEXP(cv)) {
f6aaf501 4531 New(666, CvMUTEXP(cv), 1, perl_mutex);
1cfa4ec7
GS		 4532 MUTEX_INIT(CvMUTEXP(cv));
4533 }
4d1ff10f 4534#endif /* USE_5005THREADS */
8990e307 4535
3fe9a6f1 4536 if (ps)
2a8de9e2 4537 sv_setpvn((SV*)cv, ps, ps_len);
4633a7c4 4538
3280af22 4539 if (PL_error_count) {
c07a80fd 4540 op_free(block);
5900599a 4541 block = NULL;
68dc0745 4542 if (name) {
c501bbfe 4543 const char *s = strrchr(name, ':');
68dc0745 4544 s = s ? s+1 : name;
6d4c2119 4545 if (strEQ(s, "BEGIN")) {
c05e0e2f 4546 const char not_safe[] =
6d4c2119 4547 "BEGIN not safe after errors--compilation aborted";
faef0170 4548 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4549 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4550 else {
4551 /* force display of errors found but not reported */
38a03e6e 4552 sv_catpv(ERRSV, not_safe);
f2139bd3 4553 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
6d4c2119
CS		 4554 }
4555 }
68dc0745 4556 }
c07a80fd 4557 }
beab0874
JT		 4558 if (!block)
4559 goto done;
a0d0e21e 4560
7766f137 4561 if (CvLVALUE(cv)) {
78f9721b
SM		 4562 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4563 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4564 }
4565 else {
c05be075
AE		 4566 /* This makes sub {}; work as expected. */
4567 if (block->op_type == OP_STUB) {
4568 op_free(block);
0e2d6244 4569 block = newSTATEOP(0, NULL, 0);
c05be075 4570 }
7766f137
GS		 4571 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4572 }
4573 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4574 OpREFCNT_set(CvROOT(cv), 1);
4575 CvSTART(cv) = LINKLIST(CvROOT(cv));
4576 CvROOT(cv)->op_next = 0;
a2efc822 4577 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4578
4579 /* now that optimizer has done its work, adjust pad values */
54310121 4580
9755d405
JH		 4581 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4582
4583 if (CvCLONE(cv)) {
beab0874
JT		 4584 assert(!CvCONST(cv));
4585 if (ps && !*ps && op_const_sv(block, cv))
4586 CvCONST_on(cv);
a0d0e21e 4587 }
79072805 4588
83ee9e09 4589 if (name || aname) {
c501bbfe 4590 const char *s;
8c89da26 4591 const char * const tname = (name ? name : aname);
44a8e56a 4592
3280af22 4593 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
133cdda0 4594 SV * const sv = newSV(0);
1a9219e7 4595 SV * const tmpstr = sv_newmortal();
b977d03a
NC		 4596 GV * const db_postponed = gv_fetchpvs("DB::postponed",
4597 GV_ADDMULTI, SVt_PVHV);
44a8e56a 4598 HV *hv;
4599
ed094faf
GS		 4600 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4601 CopFILE(PL_curcop),
cc49e20b 4602 (long)PL_subline, (long)CopLINE(PL_curcop));
0e2d6244 4603 gv_efullname3(tmpstr, gv, NULL);
5e7e76a3 4604 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4605 hv = GvHVn(db_postponed);
78fd745e
AL		 4606 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4607 CV * const pcv = GvCV(db_postponed);
4608 if (pcv) {
4609 dSP;
4610 PUSHMARK(SP);
4611 XPUSHs(tmpstr);
4612 PUTBACK;
4613 call_sv((SV*)pcv, G_DISCARD);
4614 }
44a8e56a 4615 }
4616 }
79072805 4617
83ee9e09 4618 if ((s = strrchr(tname,':')))
28757baa 4619 s++;
4620 else
83ee9e09 4621 s = tname;
ed094faf 4622
7d30b5c4 4623 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4624 goto done;
4625
68dc0745 4626 if (strEQ(s, "BEGIN")) {
c501bbfe 4627 const I32 oldscope = PL_scopestack_ix;
28757baa 4628 ENTER;
57843af0
GS		 4629 SAVECOPFILE(&PL_compiling);
4630 SAVECOPLINE(&PL_compiling);
28757baa 4631
3280af22
NIS		 4632 if (!PL_beginav)
4633 PL_beginav = newAV();
28757baa 4634 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4635 av_push(PL_beginav, (SV*)cv);
4636 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4637 call_list(oldscope, PL_beginav);
a6006777 4638
3280af22 4639 PL_curcop = &PL_compiling;
2cb86c03 4640 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 4641 LEAVE;
4642 }
3280af22
NIS		 4643 else if (strEQ(s, "END") && !PL_error_count) {
4644 if (!PL_endav)
4645 PL_endav = newAV();
ed094faf 4646 DEBUG_x( dump_sub(gv) );
3280af22 4647 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4648 av_store(PL_endav, 0, (SV*)cv);
4649 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4650 }
7d30b5c4
GS		 4651 else if (strEQ(s, "CHECK") && !PL_error_count) {
4652 if (!PL_checkav)
4653 PL_checkav = newAV();
ed094faf 4654 DEBUG_x( dump_sub(gv) );
ddda08b7 4655 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4656 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4657 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4658 av_store(PL_checkav, 0, (SV*)cv);
4659 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4660 }
3280af22
NIS		 4661 else if (strEQ(s, "INIT") && !PL_error_count) {
4662 if (!PL_initav)
4663 PL_initav = newAV();
ed094faf 4664 DEBUG_x( dump_sub(gv) );
ddda08b7 4665 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4666 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4667 av_push(PL_initav, (SV*)cv);
4668 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4669 }
79072805 4670 }
a6006777 4671
aa689395 4672 done:
3280af22 4673 PL_copline = NOLINE;
8990e307 4674 LEAVE_SCOPE(floor);
a0d0e21e 4675 return cv;
79072805
LW		 4676}
4677
e2755b47 4678/* XXX unsafe for 5005 threads if eval_owner isn't held */
954c1994
GS		 4679/*
4680=for apidoc newCONSTSUB
4681
4682Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4683eligible for inlining at compile-time.
4684
4685=cut
4686*/
4687
beab0874 4688CV *
864dbfa3 4689Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 4690{
beab0874 4691 CV* cv;
34a11f14
NC		 4692#ifdef USE_ITHREADS
4693 const char *const temp_p = CopFILE(PL_curcop);
4694 const STRLEN len = temp_p ? strlen(temp_p) : 0;
4695#else
4696 SV *const temp_sv = CopFILESV(PL_curcop);
4697 STRLEN len;
4698 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
4699#endif
4700 char *const file = savepvn(temp_p, temp_p ? len : 0);
5476c433 4701
11faa288 4702 ENTER;
11faa288 4703
f4dd75d9 4704 SAVECOPLINE(PL_curcop);
11faa288 4705 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4706
4707 SAVEHINTS();
3280af22 4708 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4709
4710 if (stash) {
4711 SAVESPTR(PL_curstash);
4712 SAVECOPSTASH(PL_curcop);
4713 PL_curstash = stash;
05ec9bb3 4714 CopSTASH_set(PL_curcop,stash);
11faa288 4715 }
5476c433 4716
34a11f14
NC		 4717 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
4718 and so doesn't get free()d. (It's expected to be from the C pre-
4719 processor __FILE__ directive). But we need a dynamically allocated one,
233541ae
NC		 4720 and we need it to get freed. */
4721 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
beab0874
JT		 4722 CvXSUBANY(cv).any_ptr = sv;
4723 CvCONST_on(cv);
233541ae 4724 Safefree(file);
5476c433 4725
5d1954da 4726#ifdef USE_ITHREADS
1cf7f83d
JH		 4727 if (stash)
4728 CopSTASH_free(PL_curcop);
5d1954da 4729#endif
11faa288 4730 LEAVE;
beab0874
JT		 4731
4732 return cv;
5476c433
JD		 4733}
4734
233541ae
NC		 4735CV *
4736Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
4737 const char *const filename, const char *const proto,
4738 U32 flags)
4739{
2213ec13 4740 CV *cv = newXS((char*)name, subaddr, (char*)filename);
233541ae
NC		 4741
4742 if (flags & XS_DYNAMIC_FILENAME) {
4743 /* We need to "make arrangements" (ie cheat) to ensure that the
4744 filename lasts as long as the PVCV we just created, but also doesn't
4745 leak */
4746 STRLEN filename_len = strlen(filename);
4747 STRLEN proto_and_file_len = filename_len;
4748 char *proto_and_file;
4749 STRLEN proto_len;
4750
4751 if (proto) {
4752 proto_len = strlen(proto);
4753 proto_and_file_len += proto_len;
4754
4755 Newx(proto_and_file, proto_and_file_len + 1, char);
4756 Copy(proto, proto_and_file, proto_len, char);
4757 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
4758 } else {
4759 proto_len = 0;
4760 proto_and_file = savepvn(filename, filename_len);
4761 }
4762
4763 /* This gets free()d. :-) */
4764 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
4765 SV_HAS_TRAILING_NUL);
4766 if (proto) {
4767 /* This gives us the correct prototype, rather than one with the
4768 file name appended. */
4769 SvCUR_set(cv, proto_len);
4770 } else {
4771 SvPOK_off(cv);
4772 }
4773 CvFILE(cv) = proto_and_file + proto_len;
4774 } else {
4775 sv_setpv((SV *)cv, proto);
4776 }
4777 return cv;
4778}
4779
954c1994
GS		 4780/*
4781=for apidoc U||newXS
4782
233541ae
NC		 4783Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
4784static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 4785
4786=cut
4787*/
4788
57d3b86d 4789CV *
864dbfa3 4790Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 4791{
e7b555a6 4792 GV * const gv = gv_fetchpv(name ? name :
c99da370
JH		 4793 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4794 GV_ADDMULTI, SVt_PVCV);
79072805 4795 register CV *cv;
44a8e56a 4796
155aba94 4797 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4798 if (GvCVGEN(gv)) {
4799 /* just a cached method */
4800 SvREFCNT_dec(cv);
4996ee04 4801 cv = Nullcv;
44a8e56a 4802 }
4803 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4804 /* already defined (or promised) */
228fe6e6 4805 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4996ee04
AL		 4806 if (ckWARN(WARN_REDEFINE)) {
4807 GV * const gvcv = CvGV(cv);
4808 if (gvcv) {
4809 HV * const stash = GvSTASH(gvcv);
4810 if (stash) {
e4720ea4
AL		 4811 const char *redefined_name = HvNAME_get(stash);
4812 if ( strEQ(redefined_name,"autouse") ) {
4996ee04
AL		 4813 const line_t oldline = CopLINE(PL_curcop);
4814 if (PL_copline != NOLINE)
4815 CopLINE_set(PL_curcop, PL_copline);
4816 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4817 CvCONST(cv) ? "Constant subroutine %s redefined"
4818 : "Subroutine %s redefined"
4819 ,name);
4820 CopLINE_set(PL_curcop, oldline);
4821 }
4822 }
4823 }
a0d0e21e
LW		 4824 }
4825 SvREFCNT_dec(cv);
4996ee04 4826 cv = Nullcv;
79072805 4827 }
79072805 4828 }
44a8e56a 4829
4830 if (cv) /* must reuse cv if autoloaded */
4831 cv_undef(cv);
a0d0e21e 4832 else {
133cdda0 4833 cv = (CV*)newSV(0);
a0d0e21e 4834 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 4835 if (name) {
4836 GvCV(gv) = cv;
4837 GvCVGEN(gv) = 0;
3280af22 4838 PL_sub_generation++;
44a8e56a 4839 }
a0d0e21e 4840 }
65c50114 4841 CvGV(cv) = gv;
4d1ff10f 4842#ifdef USE_5005THREADS
12ca11f6 4843 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 4844 MUTEX_INIT(CvMUTEXP(cv));
11343788 4845 CvOWNER(cv) = 0;
4d1ff10f 4846#endif /* USE_5005THREADS */
b195d487 4847 (void)gv_fetchfile(filename);
0473add9 4848 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 4849 an external constant string */
a0d0e21e 4850 CvXSUB(cv) = subaddr;
44a8e56a 4851
28757baa 4852 if (name) {
c05e0e2f 4853 const char *s = strrchr(name,':');
28757baa 4854 if (s)
4855 s++;
4856 else
4857 s = name;
ed094faf 4858
7d30b5c4 4859 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4860 goto done;
4861
28757baa 4862 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 4863 if (!PL_beginav)
4864 PL_beginav = newAV();
ea2f84a3
GS		 4865 av_push(PL_beginav, (SV*)cv);
4866 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4867 }
4868 else if (strEQ(s, "END")) {
3280af22
NIS		 4869 if (!PL_endav)
4870 PL_endav = newAV();
4871 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4872 av_store(PL_endav, 0, (SV*)cv);
4873 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4874 }
7d30b5c4
GS		 4875 else if (strEQ(s, "CHECK")) {
4876 if (!PL_checkav)
4877 PL_checkav = newAV();
ddda08b7 4878 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4879 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4880 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4881 av_store(PL_checkav, 0, (SV*)cv);
4882 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4883 }
7d07dbc2 4884 else if (strEQ(s, "INIT")) {
3280af22
NIS		 4885 if (!PL_initav)
4886 PL_initav = newAV();
ddda08b7 4887 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4888 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4889 av_push(PL_initav, (SV*)cv);
4890 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4891 }
28757baa 4892 }
8990e307 4893 else
a5f75d66 4894 CvANON_on(cv);
44a8e56a 4895
ed094faf 4896done:
a0d0e21e 4897 return cv;
79072805
LW		 4898}
4899
4900void
864dbfa3 4901Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 4902{
4903 register CV *cv;
79072805 4904
8c89da26
AL		 4905 GV * const gv = o
4906 ? gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM)
b977d03a 4907 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8c89da26 4908
7fb37951
AMS		 4909#ifdef GV_UNIQUE_CHECK
4910 if (GvUNIQUE(gv)) {
4911 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 4912 }
4913#endif
a5f75d66 4914 GvMULTI_on(gv);
155aba94 4915 if ((cv = GvFORM(gv))) {
599cee73 4916 if (ckWARN(WARN_REDEFINE)) {
c501bbfe 4917 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4918 if (PL_copline != NOLINE)
4919 CopLINE_set(PL_curcop, PL_copline);
057b822e
NC		 4920 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4921 o ? "Format %"SVf" redefined"
f2139bd3 4922 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
57843af0 4923 CopLINE_set(PL_curcop, oldline);
79072805 4924 }
8990e307 4925 SvREFCNT_dec(cv);
79072805 4926 }
3280af22 4927 cv = PL_compcv;
79072805 4928 GvFORM(gv) = cv;
65c50114 4929 CvGV(cv) = gv;
a636914a 4930 CvFILE_set_from_cop(cv, PL_curcop);
79072805 4931
a0d0e21e 4932
9755d405 4933 pad_tidy(padtidy_FORMAT);
79072805 4934 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 4935 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4936 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 4937 CvSTART(cv) = LINKLIST(CvROOT(cv));
4938 CvROOT(cv)->op_next = 0;
a2efc822 4939 CALL_PEEP(CvSTART(cv));
11343788 4940 op_free(o);
3280af22 4941 PL_copline = NOLINE;
8990e307 4942 LEAVE_SCOPE(floor);
79072805
LW		 4943}
4944
4945OP *
864dbfa3 4946Perl_newANONLIST(pTHX_ OP *o)
79072805 4947{
3fd63905 4948 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 4949}
4950
4951OP *
864dbfa3 4952Perl_newANONHASH(pTHX_ OP *o)
79072805 4953{
3fd63905 4954 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 4955}
4956
4957OP *
864dbfa3 4958Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 4959{
5900599a 4960 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 4961}
4962
4963OP *
4964Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4965{
a0d0e21e 4966 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 4967 newSVOP(OP_ANONCODE, 0,
4968 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 4969}
4970
4971OP *
864dbfa3 4972Perl_oopsAV(pTHX_ OP *o)
79072805 4973{
ed6116ce
LW		 4974 switch (o->op_type) {
4975 case OP_PADSV:
4976 o->op_type = OP_PADAV;
22c35a8c 4977 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 4978 return ref(o, OP_RV2AV);
b2ffa427 4979
ed6116ce 4980 case OP_RV2SV:
79072805 4981 o->op_type = OP_RV2AV;
22c35a8c 4982 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 4983 ref(o, OP_RV2AV);
ed6116ce
LW		 4984 break;
4985
4986 default:
0453d815 4987 if (ckWARN_d(WARN_INTERNAL))
9014280d 4988 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 4989 break;
4990 }
79072805
LW		 4991 return o;
4992}
4993
4994OP *
864dbfa3 4995Perl_oopsHV(pTHX_ OP *o)
79072805 4996{
ed6116ce
LW		 4997 switch (o->op_type) {
4998 case OP_PADSV:
4999 case OP_PADAV:
5000 o->op_type = OP_PADHV;
22c35a8c 5001 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5002 return ref(o, OP_RV2HV);
ed6116ce
LW		 5003
5004 case OP_RV2SV:
5005 case OP_RV2AV:
79072805 5006 o->op_type = OP_RV2HV;
22c35a8c 5007 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5008 ref(o, OP_RV2HV);
ed6116ce
LW		 5009 break;
5010
5011 default:
0453d815 5012 if (ckWARN_d(WARN_INTERNAL))
9014280d 5013 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 5014 break;
5015 }
79072805
LW		 5016 return o;
5017}
5018
5019OP *
864dbfa3 5020Perl_newAVREF(pTHX_ OP *o)
79072805 5021{
ed6116ce
LW		 5022 if (o->op_type == OP_PADANY) {
5023 o->op_type = OP_PADAV;
22c35a8c 5024 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5025 return o;
ed6116ce 5026 }
a1063b2d 5027 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 5028 && ckWARN(WARN_DEPRECATED)) {
5029 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5030 "Using an array as a reference is deprecated");
5031 }
79072805
LW		 5032 return newUNOP(OP_RV2AV, 0, scalar(o));
5033}
5034
5035OP *
864dbfa3 5036Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 5037{
82092f1d 5038 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 5039 return newUNOP(OP_NULL, 0, o);
748a9306 5040 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 5041}
5042
5043OP *
864dbfa3 5044Perl_newHVREF(pTHX_ OP *o)
79072805 5045{
ed6116ce
LW		 5046 if (o->op_type == OP_PADANY) {
5047 o->op_type = OP_PADHV;
22c35a8c 5048 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 5049 return o;
ed6116ce 5050 }
a1063b2d 5051 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 5052 && ckWARN(WARN_DEPRECATED)) {
5053 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5054 "Using a hash as a reference is deprecated");
5055 }
79072805
LW		 5056 return newUNOP(OP_RV2HV, 0, scalar(o));
5057}
5058
5059OP *
864dbfa3 5060Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 5061{
c07a80fd 5062 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 5063}
5064
5065OP *
864dbfa3 5066Perl_newSVREF(pTHX_ OP *o)
79072805 5067{
ed6116ce
LW		 5068 if (o->op_type == OP_PADANY) {
5069 o->op_type = OP_PADSV;
22c35a8c 5070 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 5071 return o;
ed6116ce 5072 }
d44e7566 5073#ifdef USE_5005THREADS
224a4551
MB		 5074 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5075 o->op_flags |= OPpDONE_SVREF;
a863c7d1 5076 return o;
224a4551 5077 }
d44e7566 5078#endif
79072805
LW		 5079 return newUNOP(OP_RV2SV, 0, scalar(o));
5080}
5081
e93457dc
NC		 5082/* Check routines. See the comments at the top of this file for details
5083 * on when these are called */
79072805
LW		 5084
5085OP *
cea2e8a9 5086Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 5087{
9755d405 5088 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
0e2d6244 5089 cSVOPo->op_sv = NULL;
5dc0d613 5090 return o;
5f05dabc 5091}
5092
5093OP *
cea2e8a9 5094Perl_ck_bitop(pTHX_ OP *o)
55497cff 5095{
5b7ea690
JH		 5096#define OP_IS_NUMCOMPARE(op) \
5097 ((op) == OP_LT || (op) == OP_I_LT || \
5098 (op) == OP_GT || (op) == OP_I_GT || \
5099 (op) == OP_LE || (op) == OP_I_LE || \
5100 (op) == OP_GE || (op) == OP_I_GE || \
5101 (op) == OP_EQ || (op) == OP_I_EQ || \
5102 (op) == OP_NE || (op) == OP_I_NE || \
5103 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 5104 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4e58e0cf
JH		 5105 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5106 && (o->op_type == OP_BIT_OR
5107 || o->op_type == OP_BIT_AND
5108 || o->op_type == OP_BIT_XOR))
5b7ea690 5109 {
228fe6e6
AL		 5110 const OP * const left = cBINOPo->op_first;
5111 const OP * const right = left->op_sibling;
313ba7d1
JH		 5112 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5113 (left->op_flags & OPf_PARENS) == 0) ||
5114 (OP_IS_NUMCOMPARE(right->op_type) &&
5115 (right->op_flags & OPf_PARENS) == 0))
5b7ea690
JH		 5116 if (ckWARN(WARN_PRECEDENCE))
5117 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5118 "Possible precedence problem on bitwise %c operator",
5119 o->op_type == OP_BIT_OR ? '|'
5120 : o->op_type == OP_BIT_AND ? '&' : '^'
5121 );
5122 }
5dc0d613 5123 return o;
55497cff 5124}
5125
5126OP *
cea2e8a9 5127Perl_ck_concat(pTHX_ OP *o)
79072805 5128{
8c89da26 5129 const OP * const kid = cUNOPo->op_first;
1e7ed80e 5130 PERL_UNUSED_CONTEXT;
bf790da0
NC		 5131 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5132 !(kUNOP->op_first->op_flags & OPf_MOD))
26776375 5133 o->op_flags |= OPf_STACKED;
11343788 5134 return o;
79072805
LW		 5135}
5136
5137OP *
cea2e8a9 5138Perl_ck_spair(pTHX_ OP *o)
79072805 5139{
11343788 5140 if (o->op_flags & OPf_KIDS) {
79072805 5141 OP* newop;
a0d0e21e 5142 OP* kid;
c501bbfe 5143 const OPCODE type = o->op_type;
5dc0d613 5144 o = modkids(ck_fun(o), type);
11343788 5145 kid = cUNOPo->op_first;
a0d0e21e 5146 newop = kUNOP->op_first->op_sibling;
8c6f7913
AL		 5147 if (newop) {
5148 const OPCODE type = newop->op_type;
5149 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5150 type == OP_PADAV || type == OP_PADHV ||
5151 type == OP_RV2AV || type == OP_RV2HV)
5152 return o;
a0d0e21e
LW		 5153 }
5154 op_free(kUNOP->op_first);
5155 kUNOP->op_first = newop;
5156 }
22c35a8c 5157 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5158 return ck_fun(o);
a0d0e21e
LW		 5159}
5160
5161OP *
cea2e8a9 5162Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5163{
11343788 5164 o = ck_fun(o);
5dc0d613 5165 o->op_private = 0;
11343788 5166 if (o->op_flags & OPf_KIDS) {
78fd745e 5167 OP * const kid = cUNOPo->op_first;
01020589
GS		 5168 switch (kid->op_type) {
5169 case OP_ASLICE:
5170 o->op_flags |= OPf_SPECIAL;
5171 /* FALL THROUGH */
5172 case OP_HSLICE:
5dc0d613 5173 o->op_private |= OPpSLICE;
01020589
GS		 5174 break;
5175 case OP_AELEM:
5176 o->op_flags |= OPf_SPECIAL;
5177 /* FALL THROUGH */
5178 case OP_HELEM:
5179 break;
5180 default:
5181 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 5182 OP_DESC(o));
01020589 5183 }
93c66552 5184 op_null(kid);
79072805 5185 }
11343788 5186 return o;
79072805
LW		 5187}
5188
5189OP *
96e176bf
CL		 5190Perl_ck_die(pTHX_ OP *o)
5191{
5192#ifdef VMS
5193 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5194#endif
5195 return ck_fun(o);
5196}
5197
5198OP *
cea2e8a9 5199Perl_ck_eof(pTHX_ OP *o)
79072805 5200{
c501bbfe 5201 const I32 type = o->op_type;
79072805 5202
11343788
MB		 5203 if (o->op_flags & OPf_KIDS) {
5204 if (cLISTOPo->op_first->op_type == OP_STUB) {
5205 op_free(o);
5835a535 5206 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8990e307 5207 }
11343788 5208 return ck_fun(o);
79072805 5209 }
11343788 5210 return o;
79072805
LW		 5211}
5212
5213OP *
cea2e8a9 5214Perl_ck_eval(pTHX_ OP *o)
79072805 5215{
3280af22 5216 PL_hints |= HINT_BLOCK_SCOPE;
11343788 5217 if (o->op_flags & OPf_KIDS) {
217ef1d7 5218 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 5219
93a17b20 5220 if (!kid) {
11343788 5221 o->op_flags &= ~OPf_KIDS;
93c66552 5222 op_null(o);
79072805 5223 }
d34f9d2e 5224 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 5225 LOGOP *enter;
5226
11343788
MB		 5227 cUNOPo->op_first = 0;
5228 op_free(o);
79072805 5229
b7dc083c 5230 NewOp(1101, enter, 1, LOGOP);
79072805 5231 enter->op_type = OP_ENTERTRY;
22c35a8c 5232 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 5233 enter->op_private = 0;
5234
5235 /* establish postfix order */
5236 enter->op_next = (OP*)enter;
5237
11343788
MB		 5238 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5239 o->op_type = OP_LEAVETRY;
22c35a8c 5240 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 5241 enter->op_other = o;
5242 return o;
79072805 5243 }
c7cc6f1c 5244 else
473986ff 5245 scalar((OP*)kid);
79072805
LW		 5246 }
5247 else {
11343788 5248 op_free(o);
54b9620d 5249 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 5250 }
3280af22 5251 o->op_targ = (PADOFFSET)PL_hints;
11343788 5252 return o;
79072805
LW		 5253}
5254
5255OP *
d98f61e7
GS		 5256Perl_ck_exit(pTHX_ OP *o)
5257{
5258#ifdef VMS
78fd745e 5259 HV * const table = GvHV(PL_hintgv);
d98f61e7 5260 if (table) {
d7559646 5261 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 5262 if (svp && *svp && SvTRUE(*svp))
5263 o->op_private |= OPpEXIT_VMSISH;
5264 }
96e176bf 5265 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 5266#endif
5267 return ck_fun(o);
5268}
5269
5270OP *
cea2e8a9 5271Perl_ck_exec(pTHX_ OP *o)
79072805 5272{
11343788 5273 if (o->op_flags & OPf_STACKED) {
c501bbfe 5274 OP *kid;
11343788
MB		 5275 o = ck_fun(o);
5276 kid = cUNOPo->op_first->op_sibling;
8990e307 5277 if (kid->op_type == OP_RV2GV)
93c66552 5278 op_null(kid);
79072805 5279 }
463ee0b2 5280 else
11343788
MB		 5281 o = listkids(o);
5282 return o;
79072805
LW		 5283}
5284
5285OP *
cea2e8a9 5286Perl_ck_exists(pTHX_ OP *o)
5f05dabc 5287{
5196be3e
MB		 5288 o = ck_fun(o);
5289 if (o->op_flags & OPf_KIDS) {
217ef1d7 5290 OP * const kid = cUNOPo->op_first;
afebc493
GS		 5291 if (kid->op_type == OP_ENTERSUB) {
5292 (void) ref(kid, o->op_type);
5293 if (kid->op_type != OP_RV2CV && !PL_error_count)
5294 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 5295 OP_DESC(o));
afebc493
GS		 5296 o->op_private |= OPpEXISTS_SUB;
5297 }
5298 else if (kid->op_type == OP_AELEM)
01020589
GS		 5299 o->op_flags |= OPf_SPECIAL;
5300 else if (kid->op_type != OP_HELEM)
5301 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 5302 OP_DESC(o));
93c66552 5303 op_null(kid);
5f05dabc 5304 }
5196be3e 5305 return o;
5f05dabc 5306}
5307
79072805 5308OP *
cea2e8a9 5309Perl_ck_rvconst(pTHX_ register OP *o)
79072805 5310{
8c89da26 5311 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 5312
3280af22 5313 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6aa01a30
NC		 5314 if (o->op_type == OP_RV2CV)
5315 o->op_private &= ~1;
5316
79072805 5317 if (kid->op_type == OP_CONST) {
44a8e56a 5318 int iscv;
5319 GV *gv;
547d29e4 5320 SV * const kidsv = kid->op_sv;
44a8e56a 5321
779c5bc9
GS		 5322 /* Is it a constant from cv_const_sv()? */
5323 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8c89da26 5324 SV * const rsv = SvRV(kidsv);
9660d211 5325 const svtype type = SvTYPE(rsv);
0e2d6244 5326 const char *badtype = NULL;
779c5bc9
GS		 5327
5328 switch (o->op_type) {
5329 case OP_RV2SV:
9660d211 5330 if (type > SVt_PVMG)
779c5bc9
GS		 5331 badtype = "a SCALAR";
5332 break;
5333 case OP_RV2AV:
9660d211 5334 if (type != SVt_PVAV)
779c5bc9
GS		 5335 badtype = "an ARRAY";
5336 break;
5337 case OP_RV2HV:
9660d211
AL		 5338 if (type != SVt_PVHV) {
5339 if (type == SVt_PVAV) { /* pseudohash? */
779c5bc9
GS		 5340 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5341 if (ksv && SvROK(*ksv)
5342 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5343 {
5344 break;
5345 }
5346 }
5347 badtype = "a HASH";
5348 }
5349 break;
5350 case OP_RV2CV:
9660d211 5351 if (type != SVt_PVCV)
779c5bc9
GS		 5352 badtype = "a CODE";
5353 break;
5354 }
5355 if (badtype)
cea2e8a9 5356 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5357 return o;
5358 }
3280af22 5359 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5900599a 5360 const char *badthing;
5dc0d613 5361 switch (o->op_type) {
44a8e56a 5362 case OP_RV2SV:
5363 badthing = "a SCALAR";
5364 break;
5365 case OP_RV2AV:
5366 badthing = "an ARRAY";
5367 break;
5368 case OP_RV2HV:
5369 badthing = "a HASH";
5370 break;
5900599a
NC		 5371 default:
5372 badthing = NULL;
5373 break;
44a8e56a 5374 }
5375 if (badthing)
1c846c1f 5376 Perl_croak(aTHX_
f2139bd3
JH		 5377 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5378 (void*)kidsv, badthing);
44a8e56a 5379 }
93233ece
CS		 5380 /*
5381 * This is a little tricky. We only want to add the symbol if we
5382 * didn't add it in the lexer. Otherwise we get duplicate strict
5383 * warnings. But if we didn't add it in the lexer, we must at
5384 * least pretend like we wanted to add it even if it existed before,
5385 * or we get possible typo warnings. OPpCONST_ENTERED says
5386 * whether the lexer already added THIS instance of this symbol.
5387 */
5196be3e 5388 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5389 do {
057b822e 5390 gv = gv_fetchsv(kidsv,
748a9306 5391 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5392 iscv
5393 ? SVt_PVCV
11343788 5394 : o->op_type == OP_RV2SV
a0d0e21e 5395 ? SVt_PV
11343788 5396 : o->op_type == OP_RV2AV
a0d0e21e 5397 ? SVt_PVAV
11343788 5398 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5399 ? SVt_PVHV
5400 : SVt_PVGV);
93233ece
CS		 5401 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5402 if (gv) {
5403 kid->op_type = OP_GV;
5404 SvREFCNT_dec(kid->op_sv);
350de78d 5405#ifdef USE_ITHREADS
638eceb6 5406 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5407 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
9755d405 5408 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 5409 GvIN_PAD_on(gv);
be2d5e07 5410 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
350de78d 5411#else
be2d5e07 5412 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 5413#endif
23f1ca44 5414 kid->op_private = 0;
76cd736e 5415 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5416 }
79072805 5417 }
11343788 5418 return o;
79072805
LW		 5419}
5420
5421OP *
cea2e8a9 5422Perl_ck_ftst(pTHX_ OP *o)
79072805 5423{
c501bbfe 5424 const I32 type = o->op_type;
79072805 5425
d0dca557 5426 if (o->op_flags & OPf_REF) {
c9c8c8e1 5427 NOOP;
d0dca557
JD		 5428 }
5429 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
78fd745e 5430 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8c6f7913 5431 const OPCODE kidtype = kid->op_type;
79072805 5432
8c6f7913 5433 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
78fd745e 5434 OP * const newop = newGVOP(type, OPf_REF,
057b822e 5435 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11343788 5436 op_free(o);
d0dca557 5437 o = newop;
79072805 5438 }
bfd7eeef
JH		 5439 else {
5440 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5441 OP_IS_FILETEST_ACCESS(o))
5442 o->op_private |= OPpFT_ACCESS;
5443 }
79072805
LW		 5444 }
5445 else {
11343788 5446 op_free(o);
79072805 5447 if (type == OP_FTTTY)
5835a535 5448 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5449 else
d0dca557 5450 o = newUNOP(type, 0, newDEFSVOP());
79072805 5451 }
11343788 5452 return o;
79072805
LW		 5453}
5454
5455OP *
cea2e8a9 5456Perl_ck_fun(pTHX_ OP *o)
79072805 5457{
c501bbfe 5458 const int type = o->op_type;
22c35a8c 5459 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5460
11343788 5461 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5462 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5463 oa &= ~OA_OPTIONAL;
5464 else
11343788 5465 return no_fh_allowed(o);
79072805
LW		 5466 }
5467
11343788 5468 if (o->op_flags & OPf_KIDS) {
c501bbfe
AL		 5469 OP **tokid = &cLISTOPo->op_first;
5470 register OP *kid = cLISTOPo->op_first;
5471 OP *sibl;
5472 I32 numargs = 0;
5473
8990e307 5474 if (kid->op_type == OP_PUSHMARK ||
155aba94 5475 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5476 {
79072805
LW		 5477 tokid = &kid->op_sibling;
5478 kid = kid->op_sibling;
5479 }
22c35a8c 5480 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5481 *tokid = kid = newDEFSVOP();
79072805
LW		 5482
5483 while (oa && kid) {
5484 numargs++;
5485 sibl = kid->op_sibling;
5486 switch (oa & 7) {
5487 case OA_SCALAR:
62c18ce2
GS		 5488 /* list seen where single (scalar) arg expected? */
5489 if (numargs == 1 && !(oa >> 4)
5490 && kid->op_type == OP_LIST && type != OP_SCALAR)
5491 {
5492 return too_many_arguments(o,PL_op_desc[type]);
5493 }
79072805
LW		 5494 scalar(kid);
5495 break;
5496 case OA_LIST:
5497 if (oa < 16) {
5498 kid = 0;
5499 continue;
5500 }
5501 else
5502 list(kid);
5503 break;
5504 case OA_AVREF:
936edb8b 5505 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5506 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5507 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5508 "Useless use of %s with no values",
936edb8b 5509 PL_op_desc[type]);
b2ffa427 5510
79072805 5511 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5512 (kid->op_private & OPpCONST_BARE))
5513 {
78fd745e 5514 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
057b822e 5515 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
12bcd1a6
PM		 5516 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5517 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
057b822e 5518 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
f2139bd3 5519 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5520 op_free(kid);
5521 kid = newop;
5522 kid->op_sibling = sibl;
5523 *tokid = kid;
5524 }
8990e307 5525 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5526 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5527 mod(kid, type);
79072805
LW		 5528 break;
5529 case OA_HVREF:
5530 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5531 (kid->op_private & OPpCONST_BARE))
5532 {
78fd745e 5533 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
057b822e 5534 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
12bcd1a6
PM		 5535 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5536 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
057b822e 5537 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
f2139bd3 5538 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5539 op_free(kid);
5540 kid = newop;
5541 kid->op_sibling = sibl;
5542 *tokid = kid;
5543 }
8990e307 5544 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5545 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5546 mod(kid, type);
79072805
LW		 5547 break;
5548 case OA_CVREF:
5549 {
78fd745e 5550 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5551 kid->op_sibling = 0;
5552 linklist(kid);
5553 newop->op_next = newop;
5554 kid = newop;
5555 kid->op_sibling = sibl;
5556 *tokid = kid;
5557 }
5558 break;
5559 case OA_FILEREF:
c340be78 5560 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5561 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5562 (kid->op_private & OPpCONST_BARE))
5563 {
8c89da26 5564 OP * const newop = newGVOP(OP_GV, 0,
057b822e 5565 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 5566 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5567 kid == cLISTOPo->op_last)
364daeac 5568 cLISTOPo->op_last = newop;
79072805
LW		 5569 op_free(kid);
5570 kid = newop;
5571 }
1ea32a52
GS		 5572 else if (kid->op_type == OP_READLINE) {
5573 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5574 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5575 }
79072805 5576 else {
35cd451c 5577 I32 flags = OPf_SPECIAL;
a6c40364 5578 I32 priv = 0;
2c8ac474
GS		 5579 PADOFFSET targ = 0;
5580
35cd451c 5581 /* is this op a FH constructor? */
853846ea 5582 if (is_handle_constructor(o,numargs)) {
0e2d6244 5583 const char *name = NULL;
9755d405 5584 STRLEN len = 0;
2c8ac474
GS		 5585
5586 flags = 0;
5587 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5588 * need to "prove" flag does not mean something
5589 * else already - NI-S 1999/05/07
2c8ac474
GS		 5590 */
5591 priv = OPpDEREF;
5592 if (kid->op_type == OP_PADSV) {
9755d405
JH		 5593 /*XXX DAPM 2002.08.25 tmp assert test */
5594 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5595 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5596
5597 name = PAD_COMPNAME_PV(kid->op_targ);
5598 /* SvCUR of a pad namesv can't be trusted
5599 * (see PL_generation), so calc its length
5600 * manually */
5601 if (name)
5602 len = strlen(name);
5603
2c8ac474
GS		 5604 }
5605 else if (kid->op_type == OP_RV2SV
5606 && kUNOP->op_first->op_type == OP_GV)
5607 {
8c89da26 5608 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 5609 name = GvNAME(gv);
5610 len = GvNAMELEN(gv);
5611 }
afd1915d
GS		 5612 else if (kid->op_type == OP_AELEM
5613 || kid->op_type == OP_HELEM)
5614 {
2213ec13 5615 OP *firstop;
78fd745e 5616 OP *op = ((BINOP*)kid)->op_first;
d7559646 5617 name = NULL;
78fd745e 5618 if (op) {
0e2d6244 5619 SV *tmpstr = NULL;
78fd745e 5620 const char * const a =
a77f7f8b
JH		 5621 kid->op_type == OP_AELEM ?
5622 "[]" : "{}";
5623 if (((op->op_type == OP_RV2AV) ||
5624 (op->op_type == OP_RV2HV)) &&
2213ec13
NC		 5625 (firstop = ((UNOP*)op)->op_first) &&
5626 (firstop->op_type == OP_GV)) {
a77f7f8b 5627 /* packagevar $a[] or $h{} */
2213ec13 5628 GV * const gv = cGVOPx_gv(firstop);
a77f7f8b
JH		 5629 if (gv)
5630 tmpstr =
5631 Perl_newSVpvf(aTHX_
5632 "%s%c...%c",
5633 GvNAME(gv),
5634 a[0], a[1]);
5635 }
5636 else if (op->op_type == OP_PADAV
5637 || op->op_type == OP_PADHV) {
5638 /* lexicalvar $a[] or $h{} */
78fd745e 5639 const char * const padname =
a77f7f8b
JH		 5640 PAD_COMPNAME_PV(op->op_targ);
5641 if (padname)
5642 tmpstr =
5643 Perl_newSVpvf(aTHX_
5644 "%s%c...%c",
5645 padname + 1,
5646 a[0], a[1]);
a77f7f8b
JH		 5647 }
5648 if (tmpstr) {
23c2bb70 5649 name = SvPV_const(tmpstr, len);
a77f7f8b
JH		 5650 sv_2mortal(tmpstr);
5651 }
5652 }
5653 if (!name) {
5654 name = "__ANONIO__";
5655 len = 10;
5656 }
5657 mod(kid, type);
afd1915d 5658 }
2c8ac474
GS		 5659 if (name) {
5660 SV *namesv;
5661 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
9755d405 5662 namesv = PAD_SVl(targ);
155aba94 5663 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5664 if (*name != '$')
5665 sv_setpvn(namesv, "$", 1);
5666 sv_catpvn(namesv, name, len);
5667 }
853846ea 5668 }
79072805 5669 kid->op_sibling = 0;
35cd451c 5670 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5671 kid->op_targ = targ;
5672 kid->op_private |= priv;
79072805
LW		 5673 }
5674 kid->op_sibling = sibl;
5675 *tokid = kid;
5676 }
5677 scalar(kid);
5678 break;
5679 case OA_SCALARREF:
a0d0e21e 5680 mod(scalar(kid), type);
79072805
LW		 5681 break;
5682 }
5683 oa >>= 4;
5684 tokid = &kid->op_sibling;
5685 kid = kid->op_sibling;
5686 }
11343788 5687 o->op_private |= numargs;
79072805 5688 if (kid)
53e06cf0 5689 return too_many_arguments(o,OP_DESC(o));
11343788 5690 listkids(o);
79072805 5691 }
22c35a8c 5692 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5693 op_free(o);
54b9620d 5694 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5695 }
5696
79072805
LW		 5697 if (oa) {
5698 while (oa & OA_OPTIONAL)
5699 oa >>= 4;
5700 if (oa && oa != OA_LIST)
53e06cf0 5701 return too_few_arguments(o,OP_DESC(o));
79072805 5702 }
11343788 5703 return o;
79072805
LW		 5704}
5705
5706OP *
cea2e8a9 5707Perl_ck_glob(pTHX_ OP *o)
79072805 5708{
fb73857a 5709 GV *gv;
5710
649da076 5711 o = ck_fun(o);
1f2bfc8a 5712 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5713 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5714
b977d03a 5715 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 5716 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5717 {
b977d03a 5718 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 5719 }
b1cb66bf 5720
52bb0670 5721#if !defined(PERL_EXTERNAL_GLOB)
72b16652 5722 /* XXX this can be tightened up and made more failsafe. */
62afcd3d 5723 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 5724 GV *glob_gv;
72b16652 5725 ENTER;
00ca71c1 5726 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
d7559646 5727 newSVpvs("File::Glob"), NULL, NULL, NULL);
b977d03a
NC		 5728 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5729 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7d3fb230 5730 GvCV(gv) = GvCV(glob_gv);
be2d5e07 5731 SvREFCNT_inc_void((SV*)GvCV(gv));
7d3fb230 5732 GvIMPORTED_CV_on(gv);
72b16652
GS		 5733 LEAVE;
5734 }
52bb0670 5735#endif /* PERL_EXTERNAL_GLOB */
72b16652 5736
b9f751c0 5737 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5738 append_elem(OP_GLOB, o,
80252599 5739 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5740 o->op_type = OP_LIST;
22c35a8c 5741 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5742 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5743 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
2e7fc6b0 5744 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 5745 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5746 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5747 scalar(newUNOP(OP_RV2CV, 0,
5748 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5749 o = newUNOP(OP_NULL, 0, ck_subr(o));
5750 o->op_targ = OP_GLOB; /* hint at what it used to be */
5751 return o;
b1cb66bf 5752 }
5753 gv = newGVgen("main");
a0d0e21e 5754 gv_IOadd(gv);
11343788
MB		 5755 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5756 scalarkids(o);
649da076 5757 return o;
79072805
LW		 5758}
5759
5760OP *
cea2e8a9 5761Perl_ck_grep(pTHX_ OP *o)
79072805 5762{
c20147de 5763 LOGOP *gwop = NULL;
79072805 5764 OP *kid;
c501bbfe 5765 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 5766
22c35a8c 5767 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
c20147de 5768 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
aeea060c 5769
11343788 5770 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5771 OP* k;
11343788
MB		 5772 o = ck_sort(o);
5773 kid = cLISTOPo->op_first->op_sibling;
9648d1c1
NC		 5774 if (!cUNOPx(kid)->op_next)
5775 Perl_croak(aTHX_ "panic: ck_grep");
b035a42e 5776 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 5777 kid = k;
5778 }
c20147de 5779 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 5780 kid->op_next = (OP*)gwop;
11343788 5781 o->op_flags &= ~OPf_STACKED;
93a17b20 5782 }
11343788 5783 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5784 if (type == OP_MAPWHILE)
5785 list(kid);
5786 else
5787 scalar(kid);
11343788 5788 o = ck_fun(o);
3280af22 5789 if (PL_error_count)
11343788 5790 return o;
aeea060c 5791 kid = cLISTOPo->op_first->op_sibling;
79072805 5792 if (kid->op_type != OP_NULL)
cea2e8a9 5793 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5794 kid = kUNOP->op_first;
5795
c20147de
JH		 5796 if (!gwop)
5797 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 5798 gwop->op_type = type;
22c35a8c 5799 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5800 gwop->op_first = listkids(o);
79072805
LW		 5801 gwop->op_flags |= OPf_KIDS;
5802 gwop->op_private = 1;
5803 gwop->op_other = LINKLIST(kid);
a0d0e21e 5804 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 5805 kid->op_next = (OP*)gwop;
5806
11343788 5807 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5808 if (!kid || !kid->op_sibling)
53e06cf0 5809 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5810 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5811 mod(kid, OP_GREPSTART);
5812
79072805
LW		 5813 return (OP*)gwop;
5814}
5815
5816OP *
cea2e8a9 5817Perl_ck_index(pTHX_ OP *o)
79072805 5818{
11343788
MB		 5819 if (o->op_flags & OPf_KIDS) {
5820 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5821 if (kid)
5822 kid = kid->op_sibling; /* get past "big" */
79072805 5823 if (kid && kid->op_type == OP_CONST)
2779dcf1 5824 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5825 }
11343788 5826 return ck_fun(o);
79072805
LW		 5827}
5828
5829OP *
cea2e8a9 5830Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5831{
5832 /* XXX length optimization goes here */
11343788 5833 return ck_fun(o);
79072805
LW		 5834}
5835
5836OP *
cea2e8a9 5837Perl_ck_lfun(pTHX_ OP *o)
79072805 5838{
c501bbfe 5839 const OPCODE type = o->op_type;
5dc0d613 5840 return modkids(ck_fun(o), type);
79072805
LW		 5841}
5842
5843OP *
cea2e8a9 5844Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5845{
12bcd1a6 5846 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5847 switch (cUNOPo->op_first->op_type) {
5848 case OP_RV2AV:
a8739d98
JH		 5849 /* This is needed for
5850 if (defined %stash::)
5851 to work. Do not break Tk.
5852 */
1c846c1f 5853 break; /* Globals via GV can be undef */
d0334bed
GS		 5854 case OP_PADAV:
5855 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5856 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5857 "defined(@array) is deprecated");
12bcd1a6 5858 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5859 "\t(Maybe you should just omit the defined()?)\n");
69794302 5860 break;
d0334bed 5861 case OP_RV2HV:
a8739d98
JH		 5862 /* This is needed for
5863 if (defined %stash::)
5864 to work. Do not break Tk.
5865 */
1c846c1f 5866 break; /* Globals via GV can be undef */
d0334bed 5867 case OP_PADHV:
12bcd1a6 5868 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5869 "defined(%%hash) is deprecated");
12bcd1a6 5870 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5871 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5872 break;
5873 default:
5874 /* no warning */
5875 break;
5876 }
69794302
MJD		 5877 }
5878 return ck_rfun(o);
5879}
5880
5881OP *
cea2e8a9 5882Perl_ck_rfun(pTHX_ OP *o)
8990e307 5883{
c501bbfe 5884 const OPCODE type = o->op_type;
5dc0d613 5885 return refkids(ck_fun(o), type);
8990e307
LW		 5886}
5887
5888OP *
cea2e8a9 5889Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5890{
5891 register OP *kid;
aeea060c 5892
11343788 5893 kid = cLISTOPo->op_first;
79072805 5894 if (!kid) {
11343788
MB		 5895 o = force_list(o);
5896 kid = cLISTOPo->op_first;
79072805
LW		 5897 }
5898 if (kid->op_type == OP_PUSHMARK)
5899 kid = kid->op_sibling;
11343788 5900 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 5901 kid = kid->op_sibling;
5902 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5903 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 5904 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 5905 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 5906 cLISTOPo->op_first->op_sibling = kid;
5907 cLISTOPo->op_last = kid;
79072805
LW		 5908 kid = kid->op_sibling;
5909 }
5910 }
b2ffa427 5911
79072805 5912 if (!kid)
54b9620d 5913 append_elem(o->op_type, o, newDEFSVOP());
79072805 5914
2de3dbcc 5915 return listkids(o);
bbce6d69 5916}
5917
5918OP *
b162f9ea
IZ		 5919Perl_ck_sassign(pTHX_ OP *o)
5920{
8c6f7913 5921 OP * const kid = cLISTOPo->op_first;
b162f9ea
IZ		 5922 /* has a disposable target? */
5923 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 5924 && !(kid->op_flags & OPf_STACKED)
5925 /* Cannot steal the second time! */
5926 && !(kid->op_private & OPpTARGET_MY))
b162f9ea 5927 {
78fd745e 5928 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 5929
5930 /* Can just relocate the target. */
2c2d71f5
JH		 5931 if (kkid && kkid->op_type == OP_PADSV
5932 && !(kkid->op_private & OPpLVAL_INTRO))
5933 {
b162f9ea 5934 kid->op_targ = kkid->op_targ;
743e66e6 5935 kkid->op_targ = 0;
b162f9ea
IZ		 5936 /* Now we do not need PADSV and SASSIGN. */
5937 kid->op_sibling = o->op_sibling; /* NULL */
5938 cLISTOPo->op_first = NULL;
5939 op_free(o);
5940 op_free(kkid);
5941 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5942 return kid;
5943 }
5944 }
5945 return o;
5946}
5947
5948OP *
cea2e8a9 5949Perl_ck_match(pTHX_ OP *o)
79072805 5950{
5dc0d613 5951 o->op_private |= OPpRUNTIME;
11343788 5952 return o;
79072805
LW		 5953}
5954
5955OP *
f5d5a27c
CS		 5956Perl_ck_method(pTHX_ OP *o)
5957{
78fd745e 5958 OP * const kid = cUNOPo->op_first;
f5d5a27c
CS		 5959 if (kid->op_type == OP_CONST) {
5960 SV* sv = kSVOP->op_sv;
d7559646
AL		 5961 const char * const method = SvPVX_const(sv);
5962 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 5963 OP *cmop;
1c846c1f 5964 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
d7559646 5965 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 5966 }
5967 else {
0e2d6244 5968 kSVOP->op_sv = NULL;
1c846c1f 5969 }
f5d5a27c 5970 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 5971 op_free(o);
5972 return cmop;
5973 }
5974 }
5975 return o;
5976}
5977
5978OP *
cea2e8a9 5979Perl_ck_null(pTHX_ OP *o)
79072805 5980{
1e7ed80e 5981 PERL_UNUSED_CONTEXT;
11343788 5982 return o;
79072805
LW		 5983}
5984
5985OP *
16fe6d59
GS		 5986Perl_ck_open(pTHX_ OP *o)
5987{
78fd745e 5988 HV * const table = GvHV(PL_hintgv);
16fe6d59 5989 if (table) {
d7559646 5990 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 5991 if (svp && *svp) {
78fd745e 5992 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 5993 if (mode & O_BINARY)
5994 o->op_private |= OPpOPEN_IN_RAW;
5995 else if (mode & O_TEXT)
5996 o->op_private |= OPpOPEN_IN_CRLF;
5997 }
5998
d7559646 5999 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 6000 if (svp && *svp) {
78fd745e 6001 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 6002 if (mode & O_BINARY)
6003 o->op_private |= OPpOPEN_OUT_RAW;
6004 else if (mode & O_TEXT)
6005 o->op_private |= OPpOPEN_OUT_CRLF;
6006 }
6007 }
6008 if (o->op_type == OP_BACKTICK)
6009 return o;
a77f7f8b
JH		 6010 {
6011 /* In case of three-arg dup open remove strictness
6012 * from the last arg if it is a bareword. */
78fd745e
AL		 6013 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6014 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
a77f7f8b 6015 OP *oa;
5e7e76a3 6016 const char *mode;
a77f7f8b
JH		 6017
6018 if ((last->op_type == OP_CONST) && /* The bareword. */
6019 (last->op_private & OPpCONST_BARE) &&
6020 (last->op_private & OPpCONST_STRICT) &&
6021 (oa = first->op_sibling) && /* The fh. */
6022 (oa = oa->op_sibling) && /* The mode. */
9ce07961 6023 (oa->op_type == OP_CONST) &&
a77f7f8b 6024 SvPOK(((SVOP*)oa)->op_sv) &&
5e7e76a3 6025 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
a77f7f8b
JH		 6026 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6027 (last == oa->op_sibling)) /* The bareword. */
6028 last->op_private &= ~OPpCONST_STRICT;
6029 }
16fe6d59
GS		 6030 return ck_fun(o);
6031}
6032
6033OP *
cea2e8a9 6034Perl_ck_repeat(pTHX_ OP *o)
79072805 6035{
11343788
MB		 6036 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6037 o->op_private |= OPpREPEAT_DOLIST;
6038 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 6039 }
6040 else
11343788
MB		 6041 scalar(o);
6042 return o;
79072805
LW		 6043}
6044
6045OP *
cea2e8a9 6046Perl_ck_require(pTHX_ OP *o)
8990e307 6047{
f7e580e2 6048 GV* gv = Nullgv;
ec4ab249 6049
11343788 6050 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
78fd745e 6051 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 6052
6053 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
78fd745e 6054 SV * const sv = kid->op_sv;
8ec8dcb0 6055 U32 was_readonly = SvREADONLY(sv);
8990e307 6056 char *s;
8ec8dcb0
NC		 6057
6058 if (was_readonly) {
6059 if (SvFAKE(sv)) {
6060 sv_force_normal_flags(sv, 0);
6061 assert(!SvREADONLY(sv));
6062 was_readonly = 0;
6063 } else {
6064 SvREADONLY_off(sv);
6065 }
6066 }
6067
6068 for (s = SvPVX(sv); *s; s++) {
a0d0e21e 6069 if (*s == ':' && s[1] == ':') {
aae6d3c0 6070 const STRLEN len = strlen(s+2)+1;
a0d0e21e 6071 *s = '/';
aae6d3c0 6072 Move(s+2, s+1, len, char);
8ec8dcb0 6073 SvCUR_set(sv, SvCUR(sv) - 1);
a0d0e21e 6074 }
8990e307 6075 }
d7559646 6076 sv_catpvs(sv, ".pm");
8ec8dcb0 6077 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 6078 }
6079 }
ec4ab249 6080
f7e580e2
NC		 6081 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6082 /* handle override, if any */
b977d03a 6083 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
87c3f7b6 6084 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
d7559646
AL		 6085 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6086 gv = gvp ? *gvp : Nullgv;
87c3f7b6 6087 }
f7e580e2 6088 }
ec4ab249 6089
b9f751c0 6090 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78fd745e 6091 OP * const kid = cUNOPo->op_first;
ec4ab249
GA		 6092 cUNOPo->op_first = 0;
6093 op_free(o);
6094 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6095 append_elem(OP_LIST, kid,
6096 scalar(newUNOP(OP_RV2CV, 0,
6097 newGVOP(OP_GV, 0,
6098 gv))))));
6099 }
6100
11343788 6101 return ck_fun(o);
8990e307
LW		 6102}
6103
78f9721b
SM		 6104OP *
6105Perl_ck_return(pTHX_ OP *o)
6106{
78f9721b 6107 if (CvLVALUE(PL_compcv)) {
c501bbfe 6108 OP *kid;
78f9721b
SM		 6109 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6110 mod(kid, OP_LEAVESUBLV);
6111 }
6112 return o;
6113}
6114
79072805 6115OP *
cea2e8a9 6116Perl_ck_select(pTHX_ OP *o)
79072805 6117{
c07a80fd 6118 OP* kid;
11343788
MB		 6119 if (o->op_flags & OPf_KIDS) {
6120 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 6121 if (kid && kid->op_sibling) {
11343788 6122 o->op_type = OP_SSELECT;
22c35a8c 6123 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 6124 o = ck_fun(o);
6125 return fold_constants(o);
79072805
LW		 6126 }
6127 }
11343788
MB		 6128 o = ck_fun(o);
6129 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 6130 if (kid && kid->op_type == OP_RV2GV)
6131 kid->op_private &= ~HINT_STRICT_REFS;
11343788 6132 return o;
79072805
LW		 6133}
6134
6135OP *
cea2e8a9 6136Perl_ck_shift(pTHX_ OP *o)
79072805 6137{
c501bbfe 6138 const I32 type = o->op_type;
79072805 6139
11343788 6140 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 6141 OP *argop;
b2ffa427 6142
11343788 6143 op_free(o);
4d1ff10f 6144#ifdef USE_5005THREADS
533c011a 6145 if (!CvUNIQUE(PL_compcv)) {
6d4ff0d2 6146 argop = newOP(OP_PADAV, OPf_REF);
9755d405 6147 argop->op_targ = 0; /* PAD_SV(0) is @_ */
6d4ff0d2
MB		 6148 }
6149 else {
6150 argop = newUNOP(OP_RV2AV, 0,
6151 scalar(newGVOP(OP_GV, 0,
6152 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6153 }
6154#else
6155 argop = newUNOP(OP_RV2AV, 0,
5835a535 6156 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
4d1ff10f 6157#endif /* USE_5005THREADS */
6d4ff0d2 6158 return newUNOP(type, 0, scalar(argop));
79072805 6159 }
11343788 6160 return scalar(modkids(ck_fun(o), type));
79072805
LW		 6161}
6162
6163OP *
cea2e8a9 6164Perl_ck_sort(pTHX_ OP *o)
79072805 6165{
8e3f9bdf 6166 OP *firstkid;
bbce6d69 6167
9ea6e965 6168 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 6169 simplify_sort(o);
8e3f9bdf
GS		 6170 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6171 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 6172 OP *k = NULL;
8e3f9bdf 6173 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 6174
463ee0b2 6175 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 6176 linklist(kid);
463ee0b2
LW		 6177 if (kid->op_type == OP_SCOPE) {
6178 k = kid->op_next;
6179 kid->op_next = 0;
79072805 6180 }
463ee0b2 6181 else if (kid->op_type == OP_LEAVE) {
11343788 6182 if (o->op_type == OP_SORT) {
93c66552 6183 op_null(kid); /* wipe out leave */
748a9306 6184 kid->op_next = kid;
463ee0b2 6185
748a9306
LW		 6186 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6187 if (k->op_next == kid)
6188 k->op_next = 0;
71a29c3c
GS		 6189 /* don't descend into loops */
6190 else if (k->op_type == OP_ENTERLOOP
6191 || k->op_type == OP_ENTERITER)
6192 {
6193 k = cLOOPx(k)->op_lastop;
6194 }
748a9306 6195 }
463ee0b2 6196 }
748a9306
LW		 6197 else
6198 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 6199 k = kLISTOP->op_first;
463ee0b2 6200 }
a2efc822 6201 CALL_PEEP(k);
a0d0e21e 6202
8e3f9bdf
GS		 6203 kid = firstkid;
6204 if (o->op_type == OP_SORT) {
6205 /* provide scalar context for comparison function/block */
6206 kid = scalar(kid);
a0d0e21e 6207 kid->op_next = kid;
8e3f9bdf 6208 }
a0d0e21e
LW		 6209 else
6210 kid->op_next = k;
11343788 6211 o->op_flags |= OPf_SPECIAL;
79072805 6212 }
c6e96bcb 6213 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 6214 op_null(firstkid);
8e3f9bdf
GS		 6215
6216 firstkid = firstkid->op_sibling;
79072805 6217 }
bbce6d69 6218
8e3f9bdf
GS		 6219 /* provide list context for arguments */
6220 if (o->op_type == OP_SORT)
6221 list(firstkid);
6222
11343788 6223 return o;
79072805 6224}
bda4119b
GS		 6225
6226STATIC void
cea2e8a9 6227S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 6228{
6229 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6230 OP *k;
e3ca4107 6231 int descending;
350de78d 6232 GV *gv;
29652248 6233 const char *gvname;
9c007264
JH		 6234 if (!(o->op_flags & OPf_STACKED))
6235 return;
b977d03a
NC		 6236 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
6237 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 6238 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 6239 if (kid->op_type != OP_SCOPE)
6240 return;
6241 kid = kLISTOP->op_last; /* get past scope */
6242 switch(kid->op_type) {
6243 case OP_NCMP:
6244 case OP_I_NCMP:
6245 case OP_SCMP:
6246 break;
6247 default:
6248 return;
6249 }
6250 k = kid; /* remember this node*/
6251 if (kBINOP->op_first->op_type != OP_RV2SV)
6252 return;
6253 kid = kBINOP->op_first; /* get past cmp */
6254 if (kUNOP->op_first->op_type != OP_GV)
6255 return;
6256 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6257 gv = kGVOP_gv;
350de78d 6258 if (GvSTASH(gv) != PL_curstash)
9c007264 6259 return;
29652248
NC		 6260 gvname = GvNAME(gv);
6261 if (*gvname == 'a' && gvname[1] == '\0')
e3ca4107 6262 descending = 0;
29652248 6263 else if (*gvname == 'b' && gvname[1] == '\0')
e3ca4107 6264 descending = 1;
9c007264
JH		 6265 else
6266 return;
e3ca4107 6267
9c007264
JH		 6268 kid = k; /* back to cmp */
6269 if (kBINOP->op_last->op_type != OP_RV2SV)
6270 return;
6271 kid = kBINOP->op_last; /* down to 2nd arg */
6272 if (kUNOP->op_first->op_type != OP_GV)
6273 return;
6274 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6275 gv = kGVOP_gv;
29652248
NC		 6276 if (GvSTASH(gv) != PL_curstash)
6277 return;
6278 gvname = GvNAME(gv);
6279 if ( descending
6280 ? !(*gvname == 'a' && gvname[1] == '\0')
6281 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 6282 return;
6283 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
e3ca4107
DN		 6284 if (descending)
6285 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 6286 if (k->op_type == OP_NCMP)
6287 o->op_private |= OPpSORT_NUMERIC;
6288 if (k->op_type == OP_I_NCMP)
6289 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 6290 kid = cLISTOPo->op_first->op_sibling;
6291 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6292 op_free(kid); /* then delete it */
9c007264 6293}
79072805
LW		 6294
6295OP *
cea2e8a9 6296Perl_ck_split(pTHX_ OP *o)
79072805
LW		 6297{
6298 register OP *kid;
aeea060c 6299
11343788
MB		 6300 if (o->op_flags & OPf_STACKED)
6301 return no_fh_allowed(o);
79072805 6302
11343788 6303 kid = cLISTOPo->op_first;
8990e307 6304 if (kid->op_type != OP_NULL)
cea2e8a9 6305 Perl_croak(aTHX_ "panic: ck_split");
8990e307 6306 kid = kid->op_sibling;
11343788
MB		 6307 op_free(cLISTOPo->op_first);
6308 cLISTOPo->op_first = kid;
85e6fe83 6309 if (!kid) {
d7559646 6310 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 6311 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 6312 }
79072805 6313
de4bf5b3 6314 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
78fd745e 6315 OP * const sibl = kid->op_sibling;
463ee0b2 6316 kid->op_sibling = 0;
79072805 6317 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 6318 if (cLISTOPo->op_first == cLISTOPo->op_last)
6319 cLISTOPo->op_last = kid;
6320 cLISTOPo->op_first = kid;
79072805
LW		 6321 kid->op_sibling = sibl;
6322 }
6323
6324 kid->op_type = OP_PUSHRE;
22c35a8c 6325 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 6326 scalar(kid);
f5e9f069 6327 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
f34840d8
MJD		 6328 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6329 "Use of /g modifier is meaningless in split");
6330 }
79072805
LW		 6331
6332 if (!kid->op_sibling)
54b9620d 6333 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 6334
6335 kid = kid->op_sibling;
6336 scalar(kid);
6337
6338 if (!kid->op_sibling)
11343788 6339 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
eb527b6b 6340 assert(kid->op_sibling);
79072805
LW		 6341
6342 kid = kid->op_sibling;
6343 scalar(kid);
6344
6345 if (kid->op_sibling)
53e06cf0 6346 return too_many_arguments(o,OP_DESC(o));
79072805 6347
11343788 6348 return o;
79072805
LW		 6349}
6350
6351OP *
1c846c1f 6352Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 6353{
78fd745e 6354 const OP * const kid = cLISTOPo->op_first->op_sibling;
f5e9f069
NC		 6355 if (kid && kid->op_type == OP_MATCH) {
6356 if (ckWARN(WARN_SYNTAX)) {
c501bbfe
AL		 6357 const REGEXP *re = PM_GETRE(kPMOP);
6358 const char *pmstr = re ? re->precomp : "STRING";
9014280d 6359 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 6360 "/%s/ should probably be written as \"%s\"",
6361 pmstr, pmstr);
6362 }
6363 }
6364 return ck_fun(o);
6365}
6366
6367OP *
cea2e8a9 6368Perl_ck_subr(pTHX_ OP *o)
79072805 6369{
11343788
MB		 6370 OP *prev = ((cUNOPo->op_first->op_sibling)
6371 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6372 OP *o2 = prev->op_sibling;
4633a7c4 6373 OP *cvop;
34a11f14
NC		 6374 const char *proto = NULL;
6375 const char *proto_end = NULL;
f4362cdc
AL		 6376 CV *cv = NULL;
6377 GV *namegv = NULL;
4633a7c4
LW		 6378 int optional = 0;
6379 I32 arg = 0;
5b794e05 6380 I32 contextclass = 0;
209f66d7 6381 const char *e = NULL;
4633a7c4 6382
d3011074 6383 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6384 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6385 if (cvop->op_type == OP_RV2CV) {
6386 SVOP* tmpop;
11343788 6387 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6388 op_null(cvop); /* disable rv2cv */
4633a7c4 6389 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6390 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6391 GV *gv = cGVOPx_gv(tmpop);
350de78d 6392 cv = GvCVu(gv);
76cd736e
GS		 6393 if (!cv)
6394 tmpop->op_private |= OPpEARLY_CV;
6395 else if (SvPOK(cv)) {
34a11f14 6396 STRLEN len;
350de78d 6397 namegv = CvANON(cv) ? gv : CvGV(cv);
34a11f14
NC		 6398 proto = SvPV((SV*)cv, len);
6399 proto_end = proto + len;
46fc3d4c 6400 }
4633a7c4
LW		 6401 }
6402 }
f5d5a27c 6403 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6404 if (o2->op_type == OP_CONST)
6405 o2->op_private &= ~OPpCONST_STRICT;
58a40671 6406 else if (o2->op_type == OP_LIST) {
5900599a
NC		 6407 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
6408 if (sib && sib->op_type == OP_CONST)
6409 sib->op_private &= ~OPpCONST_STRICT;
58a40671 6410 }
7a52d87a 6411 }
3280af22
NIS		 6412 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6413 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6414 o->op_private |= OPpENTERSUB_DB;
6415 while (o2 != cvop) {
4633a7c4 6416 if (proto) {
34a11f14 6417 if (proto >= proto_end)
5dc0d613 6418 return too_many_arguments(o, gv_ename(namegv));
34a11f14
NC		 6419
6420 switch (*proto) {
4633a7c4
LW		 6421 case ';':
6422 optional = 1;
6423 proto++;
6424 continue;
6425 case '$':
6426 proto++;
6427 arg++;
11343788 6428 scalar(o2);
4633a7c4
LW		 6429 break;
6430 case '%':
6431 case '@':
11343788 6432 list(o2);
4633a7c4
LW		 6433 arg++;
6434 break;
6435 case '&':
6436 proto++;
6437 arg++;
11343788 6438 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6439 bad_type(arg,
6440 arg == 1 ? "block or sub {}" : "sub {}",
6441 gv_ename(namegv), o2);
4633a7c4
LW		 6442 break;
6443 case '*':
2ba6ecf4 6444 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6445 proto++;
6446 arg++;
11343788 6447 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6448 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6449 else if (o2->op_type == OP_CONST)
6450 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6451 else if (o2->op_type == OP_ENTERSUB) {
6452 /* accidental subroutine, revert to bareword */
6453 OP *gvop = ((UNOP*)o2)->op_first;
6454 if (gvop && gvop->op_type == OP_NULL) {
6455 gvop = ((UNOP*)gvop)->op_first;
6456 if (gvop) {
6457 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6458 ;
6459 if (gvop &&
6460 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6461 (gvop = ((UNOP*)gvop)->op_first) &&
6462 gvop->op_type == OP_GV)
6463 {
78fd745e
AL		 6464 GV * const gv = cGVOPx_gv(gvop);
6465 OP * const sibling = o2->op_sibling;
d7559646 6466 SV * const n = newSVpvs("");
9675f7ac 6467 op_free(o2);
3c71ae1e 6468 gv_fullname4(n, gv, "", FALSE);
2692f720 6469 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6470 prev->op_sibling = o2;
6471 o2->op_sibling = sibling;
6472 }
6473 }
6474 }
6475 }
2ba6ecf4
GS		 6476 scalar(o2);
6477 break;
5b794e05
JH		 6478 case '[': case ']':
6479 goto oops;
6480 break;
4633a7c4
LW		 6481 case '\\':
6482 proto++;
6483 arg++;
5b794e05 6484 again:
4633a7c4 6485 switch (*proto++) {
5b794e05
JH		 6486 case '[':
6487 if (contextclass++ == 0) {
841d93c8 6488 e = strchr(proto, ']');
5b794e05
JH		 6489 if (!e || e == proto)
6490 goto oops;
6491 }
6492 else
6493 goto oops;
6494 goto again;
6495 break;
6496 case ']':
466bafcd 6497 if (contextclass) {
34a11f14
NC		 6498 const char *p = proto;
6499 const char *const end = proto;
466bafcd 6500 contextclass = 0;
466bafcd 6501 while (*--p != '[');
34a11f14
NC		 6502 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
6503 (int)(end - p), p),
6504 gv_ename(namegv), o2);
466bafcd 6505 } else
5b794e05
JH		 6506 goto oops;
6507 break;
4633a7c4 6508 case '*':
5b794e05
JH		 6509 if (o2->op_type == OP_RV2GV)
6510 goto wrapref;
6511 if (!contextclass)
6512 bad_type(arg, "symbol", gv_ename(namegv), o2);
6513 break;
4633a7c4 6514 case '&':
5b794e05
JH		 6515 if (o2->op_type == OP_ENTERSUB)
6516 goto wrapref;
6517 if (!contextclass)
6518 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6519 break;
4633a7c4 6520 case '$':
5b794e05
JH		 6521 if (o2->op_type == OP_RV2SV ||
6522 o2->op_type == OP_PADSV ||
6523 o2->op_type == OP_HELEM ||
d44e7566
NC		 6524 o2->op_type == OP_AELEM
6525#ifdef USE_5005THREADS
6526 || o2->op_type == OP_THREADSV
6527#endif
6528 )
5b794e05
JH		 6529 goto wrapref;
6530 if (!contextclass)
5dc0d613 6531 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6532 break;
4633a7c4 6533 case '@':
5b794e05
JH		 6534 if (o2->op_type == OP_RV2AV ||
6535 o2->op_type == OP_PADAV)
6536 goto wrapref;
6537 if (!contextclass)
5dc0d613 6538 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6539 break;
4633a7c4 6540 case '%':
5b794e05
JH		 6541 if (o2->op_type == OP_RV2HV ||
6542 o2->op_type == OP_PADHV)
6543 goto wrapref;
6544 if (!contextclass)
6545 bad_type(arg, "hash", gv_ename(namegv), o2);
6546 break;
6547 wrapref:
4633a7c4 6548 {
78fd745e
AL		 6549 OP* const kid = o2;
6550 OP* const sib = kid->op_sibling;
4633a7c4 6551 kid->op_sibling = 0;
6fa846a0
GS		 6552 o2 = newUNOP(OP_REFGEN, 0, kid);
6553 o2->op_sibling = sib;
e858de61 6554 prev->op_sibling = o2;
4633a7c4 6555 }
841d93c8 6556 if (contextclass && e) {
5b794e05
JH		 6557 proto = e + 1;
6558 contextclass = 0;
6559 }
4633a7c4
LW		 6560 break;
6561 default: goto oops;
6562 }
5b794e05
JH		 6563 if (contextclass)
6564 goto again;
4633a7c4 6565 break;
b1cb66bf 6566 case ' ':
6567 proto++;
6568 continue;
4633a7c4
LW		 6569 default:
6570 oops:
c293eb2b 6571 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
f2139bd3 6572 gv_ename(namegv), (void*)cv);
4633a7c4
LW		 6573 }
6574 }
6575 else
11343788
MB		 6576 list(o2);
6577 mod(o2, OP_ENTERSUB);
6578 prev = o2;
6579 o2 = o2->op_sibling;
78fd745e 6580 } /* while */
34a11f14
NC		 6581 if (proto && !optional && proto_end > proto &&
6582 (*proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6583 return too_few_arguments(o, gv_ename(namegv));
11343788 6584 return o;
79072805
LW		 6585}
6586
6587OP *
cea2e8a9 6588Perl_ck_svconst(pTHX_ OP *o)
8990e307 6589{
1e7ed80e 6590 PERL_UNUSED_CONTEXT;
11343788
MB		 6591 SvREADONLY_on(cSVOPo->op_sv);
6592 return o;
8990e307
LW		 6593}
6594
6595OP *
cea2e8a9 6596Perl_ck_trunc(pTHX_ OP *o)
79072805 6597{
11343788
MB		 6598 if (o->op_flags & OPf_KIDS) {
6599 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6600
a0d0e21e
LW		 6601 if (kid->op_type == OP_NULL)
6602 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6603 if (kid && kid->op_type == OP_CONST &&
6604 (kid->op_private & OPpCONST_BARE))
6605 {
11343788 6606 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6607 kid->op_private &= ~OPpCONST_STRICT;
6608 }
79072805 6609 }
11343788 6610 return ck_fun(o);
79072805
LW		 6611}
6612
35fba0d9
RG		 6613OP *
6614Perl_ck_substr(pTHX_ OP *o)
6615{
6616 o = ck_fun(o);
6617 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6618 OP *kid = cLISTOPo->op_first;
6619
6620 if (kid->op_type == OP_NULL)
6621 kid = kid->op_sibling;
6622 if (kid)
6623 kid->op_flags |= OPf_MOD;
6624
6625 }
6626 return o;
6627}
6628
e93457dc
NC		 6629/* A peephole optimizer. We visit the ops in the order they're to execute.
6630 * See the comments at the top of this file for more details about when
6631 * peep() is called */
463ee0b2 6632
79072805 6633void
864dbfa3 6634Perl_peep(pTHX_ register OP *o)
79072805 6635{
f4362cdc 6636 register OP* oldop = NULL;
2d8e6c8d
GS		 6637 STRLEN n_a;
6638
a0d0e21e 6639 if (!o || o->op_seq)
79072805 6640 return;
a0d0e21e 6641 ENTER;
462e5cf6 6642 SAVEOP();
7766f137 6643 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6644 for (; o; o = o->op_next) {
6645 if (o->op_seq)
6646 break;
338501c1
JH		 6647 /* The special value -1 is used by the B::C compiler backend to indicate
6648 * that an op is statically defined and should not be freed */
6649 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6650 PL_op_seqmax = 1;
533c011a 6651 PL_op = o;
a0d0e21e 6652 switch (o->op_type) {
acb36ea4 6653 case OP_SETSTATE:
a0d0e21e
LW		 6654 case OP_NEXTSTATE:
6655 case OP_DBSTATE:
3280af22
NIS		 6656 PL_curcop = ((COP*)o); /* for warnings */
6657 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6658 break;
6659
a0d0e21e 6660 case OP_CONST:
7a52d87a
GS		 6661 if (cSVOPo->op_private & OPpCONST_STRICT)
6662 no_bareword_allowed(o);
7766f137 6663#ifdef USE_ITHREADS
a868f49f 6664 case OP_METHOD_NAMED:
7766f137
GS		 6665 /* Relocate sv to the pad for thread safety.
6666 * Despite being a "constant", the SV is written to,
6667 * for reference counts, sv_upgrade() etc. */
6668 if (cSVOP->op_sv) {
c501bbfe 6669 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
a868f49f 6670 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6671 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6672 * some pad, so make a copy. */
9755d405
JH		 6673 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6674 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6675 SvREFCNT_dec(cSVOPo->op_sv);
6676 }
4901df5f
NC		 6677 else if (o->op_type == OP_CONST
6678 && cSVOPo->op_sv == &PL_sv_undef) {
6679 /* PL_sv_undef is hack - it's unsafe to store it in the
6680 AV that is the pad, because av_fetch treats values of
6681 PL_sv_undef as a "free" AV entry and will merrily
6682 replace them with a new SV, causing pad_alloc to think
6683 that this pad slot is free. (When, clearly, it is not)
6684 */
6685 SvOK_off(PAD_SVl(ix));
6686 SvPADTMP_on(PAD_SVl(ix));
6687 SvREADONLY_on(PAD_SVl(ix));
6688 }
6a7129a1 6689 else {
9755d405 6690 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6691 SvPADTMP_on(cSVOPo->op_sv);
9755d405 6692 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6693 /* XXX I don't know how this isn't readonly already. */
9755d405 6694 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6695 }
0e2d6244 6696 cSVOPo->op_sv = NULL;
7766f137
GS		 6697 o->op_targ = ix;
6698 }
6699#endif
07447971
GS		 6700 o->op_seq = PL_op_seqmax++;
6701 break;
6702
bf790da0
NC		 6703 case OP_CONCAT:
6704 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6705 if (o->op_next->op_private & OPpTARGET_MY) {
6706 if (o->op_flags & OPf_STACKED) /* chained concats */
6707 goto ignore_optimization;
6708 else {
6709 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6710 o->op_targ = o->op_next->op_targ;
6711 o->op_next->op_targ = 0;
6712 o->op_private |= OPpTARGET_MY;
6713 }
6714 }
6715 op_null(o->op_next);
6716 }
6717 ignore_optimization:
6718 o->op_seq = PL_op_seqmax++;
6719 break;
8990e307 6720 case OP_STUB:
54310121 6721 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 6722 o->op_seq = PL_op_seqmax++;
54310121 6723 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6724 }
748a9306 6725 goto nothin;
79072805 6726 case OP_NULL:
acb36ea4
GS		 6727 if (o->op_targ == OP_NEXTSTATE
6728 || o->op_targ == OP_DBSTATE
6729 || o->op_targ == OP_SETSTATE)
6730 {
3280af22 6731 PL_curcop = ((COP*)o);
acb36ea4 6732 }
dad75012
AMS		 6733 /* XXX: We avoid setting op_seq here to prevent later calls
6734 to peep() from mistakenly concluding that optimisation
6735 has already occurred. This doesn't fix the real problem,
6736 though (See 20010220.007). AMS 20010719 */
6737 if (oldop && o->op_next) {
6738 oldop->op_next = o->op_next;
6739 continue;
6740 }
6741 break;
79072805 6742 case OP_SCALAR:
93a17b20 6743 case OP_LINESEQ:
463ee0b2 6744 case OP_SCOPE:
748a9306 6745 nothin:
a0d0e21e
LW		 6746 if (oldop && o->op_next) {
6747 oldop->op_next = o->op_next;
79072805
LW		 6748 continue;
6749 }
3280af22 6750 o->op_seq = PL_op_seqmax++;
79072805
LW		 6751 break;
6752
c9f5579e 6753 case OP_PADAV:
79072805 6754 case OP_GV:
c9f5579e 6755 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8c89da26 6756 OP* const pop = (o->op_type == OP_PADAV) ?
c9f5579e 6757 o->op_next : o->op_next->op_next;
a0d0e21e 6758 IV i;
f9dc862f 6759 if (pop && pop->op_type == OP_CONST &&
65b7047c 6760 ((PL_op = pop->op_next)) &&
8990e307 6761 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6762 !(pop->op_next->op_private &
78f9721b 6763 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
2cb86c03 6764 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
a0d0e21e 6765 <= 255 &&
8990e307
LW		 6766 i >= 0)
6767 {
350de78d 6768 GV *gv;
65b7047c
HS		 6769 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6770 no_bareword_allowed(pop);
c9f5579e
TP		 6771 if (o->op_type == OP_GV)
6772 op_null(o->op_next);
93c66552
DM		 6773 op_null(pop->op_next);
6774 op_null(pop);
a0d0e21e
LW		 6775 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6776 o->op_next = pop->op_next->op_next;
22c35a8c 6777 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6778 o->op_private = (U8)i;
c9f5579e
TP		 6779 if (o->op_type == OP_GV) {
6780 gv = cGVOPo_gv;
6781 GvAVn(gv);
6782 }
6783 else
6784 o->op_flags |= OPf_SPECIAL;
6785 o->op_type = OP_AELEMFAST;
6786 }
6787 o->op_seq = PL_op_seqmax++;
6788 break;
6789 }
6790
6791 if (o->op_next->op_type == OP_RV2SV) {
6792 if (!(o->op_next->op_private & OPpDEREF)) {
6793 op_null(o->op_next);
6794 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6795 | OPpOUR_INTRO);
6796 o->op_next = o->op_next->op_next;
6797 o->op_type = OP_GVSV;
6798 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 6799 }
79072805 6800 }
e476b1b5 6801 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
78fd745e 6802 GV * const gv = cGVOPo_gv;
5e7e76a3 6803 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 6804 /* XXX could check prototype here instead of just carping */
78fd745e 6805 SV * const sv = sv_newmortal();
0e2d6244 6806 gv_efullname3(sv, gv, NULL);
9014280d 6807 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
c293eb2b 6808 "%"SVf"() called too early to check prototype",
f2139bd3 6809 (void*)sv);
76cd736e
GS		 6810 }
6811 }
89de2904
AMS		 6812 else if (o->op_next->op_type == OP_READLINE
6813 && o->op_next->op_next->op_type == OP_CONCAT
6814 && (o->op_next->op_next->op_flags & OPf_STACKED))
6815 {
d2c45030
AMS		 6816 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6817 o->op_type = OP_RCATLINE;
6818 o->op_flags |= OPf_STACKED;
6819 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6820 op_null(o->op_next->op_next);
d2c45030 6821 op_null(o->op_next);
89de2904 6822 }
76cd736e 6823
3280af22 6824 o->op_seq = PL_op_seqmax++;
79072805
LW		 6825 break;
6826
a0d0e21e 6827 case OP_MAPWHILE:
79072805
LW		 6828 case OP_GREPWHILE:
6829 case OP_AND:
6830 case OP_OR:
2c2d71f5
JH		 6831 case OP_ANDASSIGN:
6832 case OP_ORASSIGN:
1a67a97c
SM		 6833 case OP_COND_EXPR:
6834 case OP_RANGE:
3280af22 6835 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 6836 while (cLOGOP->op_other->op_type == OP_NULL)
6837 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 6838 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 6839 break;
6840
79072805 6841 case OP_ENTERLOOP:
9c2ca71a 6842 case OP_ENTERITER:
3280af22 6843 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 6844 while (cLOOP->op_redoop->op_type == OP_NULL)
6845 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6846 peep(cLOOP->op_redoop);
58cccf98
SM		 6847 while (cLOOP->op_nextop->op_type == OP_NULL)
6848 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6849 peep(cLOOP->op_nextop);
58cccf98
SM		 6850 while (cLOOP->op_lastop->op_type == OP_NULL)
6851 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6852 peep(cLOOP->op_lastop);
6853 break;
6854
8782bef2 6855 case OP_QR:
79072805
LW		 6856 case OP_MATCH:
6857 case OP_SUBST:
3280af22 6858 o->op_seq = PL_op_seqmax++;
9041c2e3 6859 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6860 cPMOP->op_pmreplstart->op_type == OP_NULL)
6861 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6862 peep(cPMOP->op_pmreplstart);
79072805
LW		 6863 break;
6864
a0d0e21e 6865 case OP_EXEC:
3280af22 6866 o->op_seq = PL_op_seqmax++;
f5e9f069
NC		 6867 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6868 && ckWARN(WARN_SYNTAX))
6869 {
8c6f7913
AL		 6870 if (o->op_next->op_sibling) {
6871 const OPCODE type = o->op_next->op_sibling->op_type;
6872 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
6873 const line_t oldline = CopLINE(PL_curcop);
6874 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6875 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6876 "Statement unlikely to be reached");
6877 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6878 "\t(Maybe you meant system() when you said exec()?)\n");
6879 CopLINE_set(PL_curcop, oldline);
6880 }
a0d0e21e
LW		 6881 }
6882 }
6883 break;
b2ffa427 6884
c750a3ec
MB		 6885 case OP_HELEM: {
6886 UNOP *rop;
6887 SV *lexname;
6888 GV **fields;
9615e741 6889 SV **svp, **indsvp, *sv;
c750a3ec 6890 I32 ind;
23c2bb70 6891 const char *key = NULL;
c750a3ec 6892 STRLEN keylen;
b2ffa427 6893
9615e741 6894 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 6895
6896 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6897 break;
1c846c1f
NIS		 6898
6899 /* Make the CONST have a shared SV */
6900 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6901 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
23c2bb70 6902 key = SvPV_const(sv, keylen);
25716404 6903 lexname = newSVpvn_share(key,
9f01e09a 6904 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
25716404 6905 0);
1c846c1f
NIS		 6906 SvREFCNT_dec(sv);
6907 *svp = lexname;
6908 }
6909
6910 if ((o->op_private & (OPpLVAL_INTRO)))
6911 break;
6912
c750a3ec
MB		 6913 rop = (UNOP*)((BINOP*)o)->op_first;
6914 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6915 break;
3280af22 6916 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
62d59642 6917 if (!SvPAD_TYPED(lexname))
c750a3ec 6918 break;
d7559646 6919 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
c750a3ec
MB		 6920 if (!fields || !GvHV(*fields))
6921 break;
23c2bb70 6922 key = SvPV_const(*svp, keylen);
25716404 6923 indsvp = hv_fetch(GvHV(*fields), key,
9f01e09a 6924 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE);
c750a3ec 6925 if (!indsvp) {
23c2bb70
NC		 6926 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6927 "in variable %s of type %s",
6928 key, SvPV_nolen_const(lexname),
6929 HvNAME_get(SvSTASH(lexname)));
c750a3ec
MB		 6930 }
6931 ind = SvIV(*indsvp);
6932 if (ind < 1)
cea2e8a9 6933 Perl_croak(aTHX_ "Bad index while coercing array into hash");
c750a3ec 6934 rop->op_type = OP_RV2AV;
22c35a8c 6935 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
c750a3ec 6936 o->op_type = OP_AELEM;
22c35a8c 6937 o->op_ppaddr = PL_ppaddr[OP_AELEM];
9615e741
GS		 6938 sv = newSViv(ind);
6939 if (SvREADONLY(*svp))
6940 SvREADONLY_on(sv);
6941 SvFLAGS(sv) |= (SvFLAGS(*svp)
6942 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
c750a3ec 6943 SvREFCNT_dec(*svp);
9615e741 6944 *svp = sv;
c750a3ec
MB		 6945 break;
6946 }
b2ffa427 6947
345599ca
GS		 6948 case OP_HSLICE: {
6949 UNOP *rop;
6950 SV *lexname;
6951 GV **fields;
9615e741 6952 SV **svp, **indsvp, *sv;
345599ca 6953 I32 ind;
23c2bb70 6954 const char *key;
345599ca
GS		 6955 STRLEN keylen;
6956 SVOP *first_key_op, *key_op;
9615e741
GS		 6957
6958 o->op_seq = PL_op_seqmax++;
345599ca
GS		 6959 if ((o->op_private & (OPpLVAL_INTRO))
6960 /* I bet there's always a pushmark... */
6961 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6962 /* hmmm, no optimization if list contains only one key. */
6963 break;
6964 rop = (UNOP*)((LISTOP*)o)->op_last;
6965 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6966 break;
6967 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
62d59642 6968 if (!SvPAD_TYPED(lexname))
345599ca 6969 break;
d7559646 6970 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
345599ca
GS		 6971 if (!fields || !GvHV(*fields))
6972 break;
6973 /* Again guessing that the pushmark can be jumped over.... */
6974 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6975 ->op_first->op_sibling;
6976 /* Check that the key list contains only constants. */
6977 for (key_op = first_key_op; key_op;
6978 key_op = (SVOP*)key_op->op_sibling)
6979 if (key_op->op_type != OP_CONST)
6980 break;
6981 if (key_op)
6982 break;
6983 rop->op_type = OP_RV2AV;
6984 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6985 o->op_type = OP_ASLICE;
6986 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6987 for (key_op = first_key_op; key_op;
6988 key_op = (SVOP*)key_op->op_sibling) {
6989 svp = cSVOPx_svp(key_op);
23c2bb70 6990 key = SvPV_const(*svp, keylen);
25716404 6991 indsvp = hv_fetch(GvHV(*fields), key,
9f01e09a
MHM		 6992 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen,
6993 FALSE);
345599ca 6994 if (!indsvp) {
9615e741
GS		 6995 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6996 "in variable %s of type %s",
26ab6a78 6997 key, SvPV(lexname, n_a), HvNAME_get(SvSTASH(lexname)));
345599ca
GS		 6998 }
6999 ind = SvIV(*indsvp);
7000 if (ind < 1)
7001 Perl_croak(aTHX_ "Bad index while coercing array into hash");
9615e741
GS		 7002 sv = newSViv(ind);
7003 if (SvREADONLY(*svp))
7004 SvREADONLY_on(sv);
7005 SvFLAGS(sv) |= (SvFLAGS(*svp)
7006 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
345599ca 7007 SvREFCNT_dec(*svp);
9615e741 7008 *svp = sv;
345599ca
GS		 7009 }
7010 break;
7011 }
c750a3ec 7012
f3bda03a 7013 case OP_SORT: {
f3bda03a 7014 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
78fd745e 7015 OP *oleft;
f3bda03a
NC		 7016 OP *o2;
7017
f3bda03a 7018 /* check that RHS of sort is a single plain array */
78fd745e 7019 OP *oright = cUNOPo->op_first;
f3bda03a
NC		 7020 if (!oright || oright->op_type != OP_PUSHMARK)
7021 break;
e3ca4107
DN		 7022
7023 /* reverse sort ... can be optimised. */
7024 if (!cUNOPo->op_sibling) {
7025 /* Nothing follows us on the list. */
78fd745e 7026 OP * const reverse = o->op_next;
e3ca4107
DN		 7027
7028 if (reverse->op_type == OP_REVERSE &&
7029 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
78fd745e 7030 OP * const pushmark = cUNOPx(reverse)->op_first;
e3ca4107
DN		 7031 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7032 && (cUNOPx(pushmark)->op_sibling == o)) {
7033 /* reverse -> pushmark -> sort */
7034 o->op_private |= OPpSORT_REVERSE;
7035 op_null(reverse);
7036 pushmark->op_next = oright->op_next;
7037 op_null(oright);
7038 }
7039 }
7040 }
7041
7042 /* make @a = sort @a act in-place */
7043
7044 o->op_seq = PL_op_seqmax++;
7045
f3bda03a
NC		 7046 oright = cUNOPx(oright)->op_sibling;
7047 if (!oright)
7048 break;
7049 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7050 oright = cUNOPx(oright)->op_sibling;
7051 }
7052
7053 if (!oright ||
7054 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7055 || oright->op_next != o
7056 || (oright->op_private & OPpLVAL_INTRO)
7057 )
7058 break;
7059
7060 /* o2 follows the chain of op_nexts through the LHS of the
7061 * assign (if any) to the aassign op itself */
7062 o2 = o->op_next;
7063 if (!o2 || o2->op_type != OP_NULL)
7064 break;
7065 o2 = o2->op_next;
7066 if (!o2 || o2->op_type != OP_PUSHMARK)
7067 break;
7068 o2 = o2->op_next;
7069 if (o2 && o2->op_type == OP_GV)
7070 o2 = o2->op_next;
7071 if (!o2
7072 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7073 || (o2->op_private & OPpLVAL_INTRO)
7074 )
7075 break;
7076 oleft = o2;
7077 o2 = o2->op_next;
7078 if (!o2 || o2->op_type != OP_NULL)
7079 break;
7080 o2 = o2->op_next;
7081 if (!o2 || o2->op_type != OP_AASSIGN
7082 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7083 break;
7084
159683d3
NC		 7085 /* check that the sort is the first arg on RHS of assign */
7086
7087 o2 = cUNOPx(o2)->op_first;
7088 if (!o2 || o2->op_type != OP_NULL)
7089 break;
7090 o2 = cUNOPx(o2)->op_first;
7091 if (!o2 || o2->op_type != OP_PUSHMARK)
7092 break;
7093 if (o2->op_sibling != o)
7094 break;
7095
f3bda03a
NC		 7096 /* check the array is the same on both sides */
7097 if (oleft->op_type == OP_RV2AV) {
7098 if (oright->op_type != OP_RV2AV
7099 || !cUNOPx(oright)->op_first
7100 || cUNOPx(oright)->op_first->op_type != OP_GV
7101 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7102 cGVOPx_gv(cUNOPx(oright)->op_first)
7103 )
7104 break;
7105 }
7106 else if (oright->op_type != OP_PADAV
7107 || oright->op_targ != oleft->op_targ
7108 )
7109 break;
7110
7111 /* transfer MODishness etc from LHS arg to RHS arg */
7112 oright->op_flags = oleft->op_flags;
7113 o->op_private |= OPpSORT_INPLACE;
7114
7115 /* excise push->gv->rv2av->null->aassign */
7116 o2 = o->op_next->op_next;
7117 op_null(o2); /* PUSHMARK */
7118 o2 = o2->op_next;
7119 if (o2->op_type == OP_GV) {
7120 op_null(o2); /* GV */
7121 o2 = o2->op_next;
7122 }
7123 op_null(o2); /* RV2AV or PADAV */
7124 o2 = o2->op_next->op_next;
7125 op_null(o2); /* AASSIGN */
7126
7127 o->op_next = o2->op_next;
7128
7129 break;
7130 }
9f6a40a7
NC		 7131
7132 case OP_REVERSE: {
7133 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7134 OP *gvop = NULL;
7135 LISTOP *enter, *exlist;
7136 o->op_seq = PL_op_seqmax++;
7137
7138 enter = (LISTOP *) o->op_next;
7139 if (!enter)
7140 break;
7141 if (enter->op_type == OP_NULL) {
7142 enter = (LISTOP *) enter->op_next;
7143 if (!enter)
7144 break;
7145 }
7146 /* for $a (...) will have OP_GV then OP_RV2GV here.
7147 for (...) just has an OP_GV. */
7148 if (enter->op_type == OP_GV) {
7149 gvop = (OP *) enter;
7150 enter = (LISTOP *) enter->op_next;
7151 if (!enter)
7152 break;
7153 if (enter->op_type == OP_RV2GV) {
7154 enter = (LISTOP *) enter->op_next;
7155 if (!enter)
7156 break;
7157 }
7158 }
7159
7160 if (enter->op_type != OP_ENTERITER)
7161 break;
7162
7163 iter = enter->op_next;
7164 if (!iter || iter->op_type != OP_ITER)
7165 break;
7166
7167 expushmark = enter->op_first;
7168 if (!expushmark || expushmark->op_type != OP_NULL
7169 || expushmark->op_targ != OP_PUSHMARK)
7170 break;
7171
7172 exlist = (LISTOP *) expushmark->op_sibling;
7173 if (!exlist || exlist->op_type != OP_NULL
7174 || exlist->op_targ != OP_LIST)
7175 break;
7176
7177 if (exlist->op_last != o) {
7178 /* Mmm. Was expecting to point back to this op. */
7179 break;
7180 }
7181 theirmark = exlist->op_first;
7182 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7183 break;
7184
7185 if (theirmark->op_sibling != o) {
7186 /* There's something between the mark and the reverse, eg
7187 for (1, reverse (...))
7188 so no go. */
7189 break;
7190 }
7191
7192 ourmark = ((LISTOP *)o)->op_first;
7193 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7194 break;
7195
7196 ourlast = ((LISTOP *)o)->op_last;
7197 if (!ourlast || ourlast->op_next != o)
7198 break;
7199
7200 rv2av = ourmark->op_sibling;
7201 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7202 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7203 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7204 /* We're just reversing a single array. */
7205 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7206 enter->op_flags |= OPf_STACKED;
7207 }
7208
7209 /* We don't have control over who points to theirmark, so sacrifice
7210 ours. */
7211 theirmark->op_next = ourmark->op_next;
7212 theirmark->op_flags = ourmark->op_flags;
7213 ourlast->op_next = gvop ? gvop : (OP *) enter;
7214 op_null(ourmark);
7215 op_null(o);
7216 enter->op_private |= OPpITER_REVERSED;
7217 iter->op_private |= OPpITER_REVERSED;
7218
7219 break;
7220 }
6aa01a30
NC		 7221
7222 case OP_SASSIGN: {
7223 OP *rv2gv;
7224 UNOP *refgen, *rv2cv;
7225 LISTOP *exlist;
7226
7227 /* I do not understand this, but if o->op_opt isn't set to 1,
7228 various tests in ext/B/t/bytecode.t fail with no readily
7229 apparent cause. */
7230 /* Converted from op_opt to op_seq for 5.8.x. */
7231
7232 o->op_seq = PL_op_seqmax++;
7233
7234
7235 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7236 break;
7237
7238 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7239 break;
7240
7241 rv2gv = ((BINOP *)o)->op_last;
7242 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7243 break;
7244
7245 refgen = (UNOP *)((BINOP *)o)->op_first;
7246
7247 if (!refgen || refgen->op_type != OP_REFGEN)
7248 break;
7249
7250 exlist = (LISTOP *)refgen->op_first;
7251 if (!exlist || exlist->op_type != OP_NULL
7252 || exlist->op_targ != OP_LIST)
7253 break;
7254
7255 if (exlist->op_first->op_type != OP_PUSHMARK)
7256 break;
7257
7258 rv2cv = (UNOP*)exlist->op_last;
7259
7260 if (rv2cv->op_type != OP_RV2CV)
7261 break;
7262
7263 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7264 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7265 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7266
7267 o->op_private |= OPpASSIGN_CV_TO_GV;
7268 rv2gv->op_private |= OPpDONT_INIT_GV;
7269 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7270
7271 break;
7272 }
7273
f3bda03a 7274
79072805 7275 default:
3280af22 7276 o->op_seq = PL_op_seqmax++;
79072805
LW		 7277 break;
7278 }
a0d0e21e 7279 oldop = o;
79072805 7280 }
a0d0e21e 7281 LEAVE;
79072805 7282}
beab0874 7283
ec6f298e
AL		 7284char*
7285Perl_custom_op_name(pTHX_ OP* o)
53e06cf0 7286{
c05e0e2f 7287 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 7288 SV* keysv;
7289 HE* he;
7290
7291 if (!PL_custom_op_names) /* This probably shouldn't happen */
fe20fd30 7292 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 7293
7294 keysv = sv_2mortal(newSViv(index));
7295
7296 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7297 if (!he)
fe20fd30 7298 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 7299
7300 return SvPV_nolen(HeVAL(he));
7301}
7302
ec6f298e
AL		 7303char*
7304Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0 7305{
c05e0e2f 7306 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 7307 SV* keysv;
7308 HE* he;
7309
7310 if (!PL_custom_op_descs)
fe20fd30 7311 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 7312
7313 keysv = sv_2mortal(newSViv(index));
7314
7315 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7316 if (!he)
fe20fd30 7317 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 7318
7319 return SvPV_nolen(HeVAL(he));
7320}
19e8ce8e 7321
beab0874
JT		 7322#include "XSUB.h"
7323
7324/* Efficient sub that returns a constant scalar value. */
7325static void
acfe0abc 7326const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 7327{
7328 dXSARGS;
9cbac4c7 7329 if (items != 0) {
c9c8c8e1 7330 NOOP;
9cbac4c7
DM		 7331#if 0
7332 Perl_croak(aTHX_ "usage: %s::%s()",
26ab6a78 7333 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 7334#endif
7335 }
9a049f1c 7336 EXTEND(sp, 1);
0768512c 7337 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 7338 XSRETURN(1);
7339}
0da6cfda
SP		 7340
7341/*
7342 * Local variables:
7343 * c-indentation-style: bsd
7344 * c-basic-offset: 4
7345 * indent-tabs-mode: t
7346 * End:
7347 *
d8294a4d
NC		 7348 * ex: set ts=8 sts=4 sw=4 noet:
7349 */
Unnamed repository; edit this file 'description' to name the repository.