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