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