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