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
Add appropriate skips to t/io/fs.t to fix test failures on Cygwin.
[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 }
beab0874
JT		 4348 if (block) {
4349 if (ckWARN(WARN_REDEFINE)
4350 || (CvCONST(cv)
4351 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4352 {
6867be6d 4353 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4354 if (PL_copline != NOLINE)
4355 CopLINE_set(PL_curcop, PL_copline);
9014280d 4356 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4357 CvCONST(cv) ? "Constant subroutine %s redefined"
4358 : "Subroutine %s redefined", name);
4359 CopLINE_set(PL_curcop, oldline);
4360 }
4361 SvREFCNT_dec(cv);
4362 cv = Nullcv;
79072805 4363 }
79072805
LW		 4364 }
4365 }
beab0874 4366 if (const_sv) {
7fc63493 4367 (void)SvREFCNT_inc(const_sv);
beab0874 4368 if (cv) {
0768512c 4369 assert(!CvROOT(cv) && !CvCONST(cv));
c69006e4 4370 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
beab0874
JT		 4371 CvXSUBANY(cv).any_ptr = const_sv;
4372 CvXSUB(cv) = const_sv_xsub;
4373 CvCONST_on(cv);
beab0874
JT		 4374 }
4375 else {
4376 GvCV(gv) = Nullcv;
4377 cv = newCONSTSUB(NULL, name, const_sv);
4378 }
4379 op_free(block);
4380 SvREFCNT_dec(PL_compcv);
4381 PL_compcv = NULL;
4382 PL_sub_generation++;
4383 goto done;
4384 }
09bef843
SB		 4385 if (attrs) {
4386 HV *stash;
4387 SV *rcv;
4388
4389 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4390 * before we clobber PL_compcv.
4391 */
4392 if (cv && !block) {
4393 rcv = (SV*)cv;
020f0e03
SB		 4394 /* Might have had built-in attributes applied -- propagate them. */
4395 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4396 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4397 stash = GvSTASH(CvGV(cv));
a9164de8 4398 else if (CvSTASH(cv))
09bef843
SB		 4399 stash = CvSTASH(cv);
4400 else
4401 stash = PL_curstash;
4402 }
4403 else {
4404 /* possibly about to re-define existing subr -- ignore old cv */
4405 rcv = (SV*)PL_compcv;
a9164de8 4406 if (name && GvSTASH(gv))
09bef843
SB		 4407 stash = GvSTASH(gv);
4408 else
4409 stash = PL_curstash;
4410 }
95f0a2f1 4411 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4412 }
a0d0e21e 4413 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4414 if (!block) {
4415 /* got here with just attrs -- work done, so bug out */
4416 SAVEFREESV(PL_compcv);
4417 goto done;
4418 }
a3985cdc 4419 /* transfer PL_compcv to cv */
4633a7c4 4420 cv_undef(cv);
3280af22 4421 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5c41a5fa
DM		 4422 if (!CvWEAKOUTSIDE(cv))
4423 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 4424 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 4425 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 4426 CvOUTSIDE(PL_compcv) = 0;
4427 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4428 CvPADLIST(PL_compcv) = 0;
282f25c9 4429 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 4430 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 4431 /* ... before we throw it away */
3280af22 4432 SvREFCNT_dec(PL_compcv);
b5c19bd7 4433 PL_compcv = cv;
a933f601
IZ		 4434 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4435 ++PL_sub_generation;
a0d0e21e
LW		 4436 }
4437 else {
3280af22 4438 cv = PL_compcv;
44a8e56a 4439 if (name) {
4440 GvCV(gv) = cv;
4441 GvCVGEN(gv) = 0;
3280af22 4442 PL_sub_generation++;
44a8e56a 4443 }
a0d0e21e 4444 }
65c50114 4445 CvGV(cv) = gv;
a636914a 4446 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4447 CvSTASH(cv) = PL_curstash;
8990e307 4448
3fe9a6f1 4449 if (ps)
ea6e9374 4450 sv_setpvn((SV*)cv, ps, ps_len);
4633a7c4 4451
3280af22 4452 if (PL_error_count) {
c07a80fd 4453 op_free(block);
4454 block = Nullop;
68dc0745 4455 if (name) {
6867be6d 4456 const char *s = strrchr(name, ':');
68dc0745 4457 s = s ? s+1 : name;
6d4c2119 4458 if (strEQ(s, "BEGIN")) {
e1ec3a88 4459 const char not_safe[] =
6d4c2119 4460 "BEGIN not safe after errors--compilation aborted";
faef0170 4461 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4462 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4463 else {
4464 /* force display of errors found but not reported */
38a03e6e 4465 sv_catpv(ERRSV, not_safe);
35c1215d 4466 Perl_croak(aTHX_ "%"SVf, ERRSV);
6d4c2119
CS		 4467 }
4468 }
68dc0745 4469 }
c07a80fd 4470 }
beab0874
JT		 4471 if (!block)
4472 goto done;
a0d0e21e 4473
7766f137 4474 if (CvLVALUE(cv)) {
78f9721b
SM		 4475 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4476 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4477 }
4478 else {
09c2fd24
AE		 4479 /* This makes sub {}; work as expected. */
4480 if (block->op_type == OP_STUB) {
4481 op_free(block);
4482 block = newSTATEOP(0, Nullch, 0);
4483 }
7766f137
GS		 4484 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4485 }
4486 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4487 OpREFCNT_set(CvROOT(cv), 1);
4488 CvSTART(cv) = LINKLIST(CvROOT(cv));
4489 CvROOT(cv)->op_next = 0;
a2efc822 4490 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4491
4492 /* now that optimizer has done its work, adjust pad values */
54310121 4493
dd2155a4
DM		 4494 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4495
4496 if (CvCLONE(cv)) {
beab0874
JT		 4497 assert(!CvCONST(cv));
4498 if (ps && !*ps && op_const_sv(block, cv))
4499 CvCONST_on(cv);
a0d0e21e 4500 }
79072805 4501
83ee9e09 4502 if (name || aname) {
6867be6d
AL		 4503 const char *s;
4504 const char *tname = (name ? name : aname);
44a8e56a 4505
3280af22 4506 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
c4420975
AL		 4507 SV * const sv = NEWSV(0,0);
4508 SV * const tmpstr = sv_newmortal();
dcda55fc 4509 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
44a8e56a 4510 HV *hv;
4511
ed094faf
GS		 4512 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4513 CopFILE(PL_curcop),
cc49e20b 4514 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4515 gv_efullname3(tmpstr, gv, Nullch);
b15aece3 4516 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4517 hv = GvHVn(db_postponed);
551405c4
AL		 4518 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4519 CV * const pcv = GvCV(db_postponed);
4520 if (pcv) {
4521 dSP;
4522 PUSHMARK(SP);
4523 XPUSHs(tmpstr);
4524 PUTBACK;
4525 call_sv((SV*)pcv, G_DISCARD);
4526 }
44a8e56a 4527 }
4528 }
79072805 4529
83ee9e09 4530 if ((s = strrchr(tname,':')))
28757baa 4531 s++;
4532 else
83ee9e09 4533 s = tname;
ed094faf 4534
7d30b5c4 4535 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4536 goto done;
4537
7678c486 4538 if (strEQ(s, "BEGIN") && !PL_error_count) {
6867be6d 4539 const I32 oldscope = PL_scopestack_ix;
28757baa 4540 ENTER;
57843af0
GS		 4541 SAVECOPFILE(&PL_compiling);
4542 SAVECOPLINE(&PL_compiling);
28757baa 4543
3280af22
NIS		 4544 if (!PL_beginav)
4545 PL_beginav = newAV();
28757baa 4546 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4547 av_push(PL_beginav, (SV*)cv);
4548 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4549 call_list(oldscope, PL_beginav);
a6006777 4550
3280af22 4551 PL_curcop = &PL_compiling;
eb160463 4552 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
28757baa 4553 LEAVE;
4554 }
3280af22
NIS		 4555 else if (strEQ(s, "END") && !PL_error_count) {
4556 if (!PL_endav)
4557 PL_endav = newAV();
ed094faf 4558 DEBUG_x( dump_sub(gv) );
3280af22 4559 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4560 av_store(PL_endav, 0, (SV*)cv);
4561 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4562 }
7d30b5c4
GS		 4563 else if (strEQ(s, "CHECK") && !PL_error_count) {
4564 if (!PL_checkav)
4565 PL_checkav = newAV();
ed094faf 4566 DEBUG_x( dump_sub(gv) );
ddda08b7 4567 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4568 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4569 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4570 av_store(PL_checkav, 0, (SV*)cv);
4571 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4572 }
3280af22
NIS		 4573 else if (strEQ(s, "INIT") && !PL_error_count) {
4574 if (!PL_initav)
4575 PL_initav = newAV();
ed094faf 4576 DEBUG_x( dump_sub(gv) );
ddda08b7 4577 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4578 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4579 av_push(PL_initav, (SV*)cv);
4580 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4581 }
79072805 4582 }
a6006777 4583
aa689395 4584 done:
3280af22 4585 PL_copline = NOLINE;
8990e307 4586 LEAVE_SCOPE(floor);
a0d0e21e 4587 return cv;
79072805
LW		 4588}
4589
b099ddc0 4590/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4591/*
4592=for apidoc newCONSTSUB
4593
4594Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4595eligible for inlining at compile-time.
4596
4597=cut
4598*/
4599
beab0874 4600CV *
e1ec3a88 4601Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 4602{
27da23d5 4603 dVAR;
beab0874 4604 CV* cv;
5476c433 4605
11faa288 4606 ENTER;
11faa288 4607
f4dd75d9 4608 SAVECOPLINE(PL_curcop);
11faa288 4609 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4610
4611 SAVEHINTS();
3280af22 4612 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4613
4614 if (stash) {
4615 SAVESPTR(PL_curstash);
4616 SAVECOPSTASH(PL_curcop);
4617 PL_curstash = stash;
05ec9bb3 4618 CopSTASH_set(PL_curcop,stash);
11faa288 4619 }
5476c433 4620
91a15d0d 4621 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
beab0874
JT		 4622 CvXSUBANY(cv).any_ptr = sv;
4623 CvCONST_on(cv);
c69006e4 4624 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5476c433 4625
02f28d44
MHM		 4626 if (stash)
4627 CopSTASH_free(PL_curcop);
4628
11faa288 4629 LEAVE;
beab0874
JT		 4630
4631 return cv;
5476c433
JD		 4632}
4633
954c1994
GS		 4634/*
4635=for apidoc U||newXS
4636
4637Used by C<xsubpp> to hook up XSUBs as Perl subs.
4638
4639=cut
4640*/
4641
57d3b86d 4642CV *
bfed75c6 4643Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 4644{
9a957fbc 4645 GV * const gv = gv_fetchpv(name ? name :
c99da370
JH		 4646 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4647 GV_ADDMULTI, SVt_PVCV);
79072805 4648 register CV *cv;
44a8e56a 4649
1ecdd9a8
HS		 4650 if (!subaddr)
4651 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4652
155aba94 4653 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4654 if (GvCVGEN(gv)) {
4655 /* just a cached method */
4656 SvREFCNT_dec(cv);
66a1b24b 4657 cv = Nullcv;
44a8e56a 4658 }
4659 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4660 /* already defined (or promised) */
1df70142 4661 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 4662 if (ckWARN(WARN_REDEFINE)) {
4663 GV * const gvcv = CvGV(cv);
4664 if (gvcv) {
4665 HV * const stash = GvSTASH(gvcv);
4666 if (stash) {
4667 const char *name = HvNAME_get(stash);
4668 if ( strEQ(name,"autouse") ) {
4669 const line_t oldline = CopLINE(PL_curcop);
4670 if (PL_copline != NOLINE)
4671 CopLINE_set(PL_curcop, PL_copline);
4672 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4673 CvCONST(cv) ? "Constant subroutine %s redefined"
4674 : "Subroutine %s redefined"
4675 ,name);
4676 CopLINE_set(PL_curcop, oldline);
4677 }
4678 }
4679 }
a0d0e21e
LW		 4680 }
4681 SvREFCNT_dec(cv);
66a1b24b 4682 cv = Nullcv;
79072805 4683 }
79072805 4684 }
44a8e56a 4685
4686 if (cv) /* must reuse cv if autoloaded */
4687 cv_undef(cv);
a0d0e21e
LW		 4688 else {
4689 cv = (CV*)NEWSV(1105,0);
4690 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 4691 if (name) {
4692 GvCV(gv) = cv;
4693 GvCVGEN(gv) = 0;
3280af22 4694 PL_sub_generation++;
44a8e56a 4695 }
a0d0e21e 4696 }
65c50114 4697 CvGV(cv) = gv;
b195d487 4698 (void)gv_fetchfile(filename);
dd374669 4699 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 4700 an external constant string */
a0d0e21e 4701 CvXSUB(cv) = subaddr;
44a8e56a 4702
28757baa 4703 if (name) {
e1ec3a88 4704 const char *s = strrchr(name,':');
28757baa 4705 if (s)
4706 s++;
4707 else
4708 s = name;
ed094faf 4709
7d30b5c4 4710 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4711 goto done;
4712
28757baa 4713 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 4714 if (!PL_beginav)
4715 PL_beginav = newAV();
ea2f84a3
GS		 4716 av_push(PL_beginav, (SV*)cv);
4717 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4718 }
4719 else if (strEQ(s, "END")) {
3280af22
NIS		 4720 if (!PL_endav)
4721 PL_endav = newAV();
4722 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4723 av_store(PL_endav, 0, (SV*)cv);
4724 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4725 }
7d30b5c4
GS		 4726 else if (strEQ(s, "CHECK")) {
4727 if (!PL_checkav)
4728 PL_checkav = newAV();
ddda08b7 4729 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4730 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4731 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4732 av_store(PL_checkav, 0, (SV*)cv);
4733 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4734 }
7d07dbc2 4735 else if (strEQ(s, "INIT")) {
3280af22
NIS		 4736 if (!PL_initav)
4737 PL_initav = newAV();
ddda08b7 4738 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4739 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4740 av_push(PL_initav, (SV*)cv);
4741 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4742 }
28757baa 4743 }
8990e307 4744 else
a5f75d66 4745 CvANON_on(cv);
44a8e56a 4746
ed094faf 4747done:
a0d0e21e 4748 return cv;
79072805
LW		 4749}
4750
4751void
864dbfa3 4752Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 4753{
4754 register CV *cv;
79072805 4755 GV *gv;
79072805 4756
11343788 4757 if (o)
7a5fd60d 4758 gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
79072805 4759 else
7a5fd60d
NC		 4760 gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4761
7fb37951
AMS		 4762#ifdef GV_UNIQUE_CHECK
4763 if (GvUNIQUE(gv)) {
4764 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 4765 }
4766#endif
a5f75d66 4767 GvMULTI_on(gv);
155aba94 4768 if ((cv = GvFORM(gv))) {
599cee73 4769 if (ckWARN(WARN_REDEFINE)) {
6867be6d 4770 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4771 if (PL_copline != NOLINE)
4772 CopLINE_set(PL_curcop, PL_copline);
7a5fd60d
NC		 4773 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4774 o ? "Format %"SVf" redefined"
4775 : "Format STDOUT redefined" ,cSVOPo->op_sv);
57843af0 4776 CopLINE_set(PL_curcop, oldline);
79072805 4777 }
8990e307 4778 SvREFCNT_dec(cv);
79072805 4779 }
3280af22 4780 cv = PL_compcv;
79072805 4781 GvFORM(gv) = cv;
65c50114 4782 CvGV(cv) = gv;
a636914a 4783 CvFILE_set_from_cop(cv, PL_curcop);
79072805 4784
a0d0e21e 4785
dd2155a4 4786 pad_tidy(padtidy_FORMAT);
79072805 4787 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 4788 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4789 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 4790 CvSTART(cv) = LINKLIST(CvROOT(cv));
4791 CvROOT(cv)->op_next = 0;
a2efc822 4792 CALL_PEEP(CvSTART(cv));
11343788 4793 op_free(o);
3280af22 4794 PL_copline = NOLINE;
8990e307 4795 LEAVE_SCOPE(floor);
79072805
LW		 4796}
4797
4798OP *
864dbfa3 4799Perl_newANONLIST(pTHX_ OP *o)
79072805 4800{
93a17b20 4801 return newUNOP(OP_REFGEN, 0,
11343788 4802 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 4803}
4804
4805OP *
864dbfa3 4806Perl_newANONHASH(pTHX_ OP *o)
79072805 4807{
93a17b20 4808 return newUNOP(OP_REFGEN, 0,
11343788 4809 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 4810}
4811
4812OP *
864dbfa3 4813Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 4814{
09bef843
SB		 4815 return newANONATTRSUB(floor, proto, Nullop, block);
4816}
4817
4818OP *
4819Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4820{
a0d0e21e 4821 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 4822 newSVOP(OP_ANONCODE, 0,
4823 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 4824}
4825
4826OP *
864dbfa3 4827Perl_oopsAV(pTHX_ OP *o)
79072805 4828{
27da23d5 4829 dVAR;
ed6116ce
LW		 4830 switch (o->op_type) {
4831 case OP_PADSV:
4832 o->op_type = OP_PADAV;
22c35a8c 4833 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 4834 return ref(o, OP_RV2AV);
b2ffa427 4835
ed6116ce 4836 case OP_RV2SV:
79072805 4837 o->op_type = OP_RV2AV;
22c35a8c 4838 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 4839 ref(o, OP_RV2AV);
ed6116ce
LW		 4840 break;
4841
4842 default:
0453d815 4843 if (ckWARN_d(WARN_INTERNAL))
9014280d 4844 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 4845 break;
4846 }
79072805
LW		 4847 return o;
4848}
4849
4850OP *
864dbfa3 4851Perl_oopsHV(pTHX_ OP *o)
79072805 4852{
27da23d5 4853 dVAR;
ed6116ce
LW		 4854 switch (o->op_type) {
4855 case OP_PADSV:
4856 case OP_PADAV:
4857 o->op_type = OP_PADHV;
22c35a8c 4858 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 4859 return ref(o, OP_RV2HV);
ed6116ce
LW		 4860
4861 case OP_RV2SV:
4862 case OP_RV2AV:
79072805 4863 o->op_type = OP_RV2HV;
22c35a8c 4864 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 4865 ref(o, OP_RV2HV);
ed6116ce
LW		 4866 break;
4867
4868 default:
0453d815 4869 if (ckWARN_d(WARN_INTERNAL))
9014280d 4870 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 4871 break;
4872 }
79072805
LW		 4873 return o;
4874}
4875
4876OP *
864dbfa3 4877Perl_newAVREF(pTHX_ OP *o)
79072805 4878{
27da23d5 4879 dVAR;
ed6116ce
LW		 4880 if (o->op_type == OP_PADANY) {
4881 o->op_type = OP_PADAV;
22c35a8c 4882 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 4883 return o;
ed6116ce 4884 }
a1063b2d 4885 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 4886 && ckWARN(WARN_DEPRECATED)) {
4887 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4888 "Using an array as a reference is deprecated");
4889 }
79072805
LW		 4890 return newUNOP(OP_RV2AV, 0, scalar(o));
4891}
4892
4893OP *
864dbfa3 4894Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 4895{
82092f1d 4896 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 4897 return newUNOP(OP_NULL, 0, o);
748a9306 4898 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 4899}
4900
4901OP *
864dbfa3 4902Perl_newHVREF(pTHX_ OP *o)
79072805 4903{
27da23d5 4904 dVAR;
ed6116ce
LW		 4905 if (o->op_type == OP_PADANY) {
4906 o->op_type = OP_PADHV;
22c35a8c 4907 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 4908 return o;
ed6116ce 4909 }
a1063b2d 4910 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 4911 && ckWARN(WARN_DEPRECATED)) {
4912 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4913 "Using a hash as a reference is deprecated");
4914 }
79072805
LW		 4915 return newUNOP(OP_RV2HV, 0, scalar(o));
4916}
4917
4918OP *
864dbfa3 4919Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 4920{
c07a80fd 4921 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 4922}
4923
4924OP *
864dbfa3 4925Perl_newSVREF(pTHX_ OP *o)
79072805 4926{
27da23d5 4927 dVAR;
ed6116ce
LW		 4928 if (o->op_type == OP_PADANY) {
4929 o->op_type = OP_PADSV;
22c35a8c 4930 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 4931 return o;
ed6116ce 4932 }
224a4551
MB		 4933 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4934 o->op_flags |= OPpDONE_SVREF;
a863c7d1 4935 return o;
224a4551 4936 }
79072805
LW		 4937 return newUNOP(OP_RV2SV, 0, scalar(o));
4938}
4939
61b743bb
DM		 4940/* Check routines. See the comments at the top of this file for details
4941 * on when these are called */
79072805
LW		 4942
4943OP *
cea2e8a9 4944Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 4945{
dd2155a4 4946 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5dc0d613 4947 cSVOPo->op_sv = Nullsv;
5dc0d613 4948 return o;
5f05dabc 4949}
4950
4951OP *
cea2e8a9 4952Perl_ck_bitop(pTHX_ OP *o)
55497cff 4953{
276b2a0c
RGS		 4954#define OP_IS_NUMCOMPARE(op) \
4955 ((op) == OP_LT || (op) == OP_I_LT || \
4956 (op) == OP_GT || (op) == OP_I_GT || \
4957 (op) == OP_LE || (op) == OP_I_LE || \
4958 (op) == OP_GE || (op) == OP_I_GE || \
4959 (op) == OP_EQ || (op) == OP_I_EQ || \
4960 (op) == OP_NE || (op) == OP_I_NE || \
4961 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 4962 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2b84528b
RGS		 4963 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4964 && (o->op_type == OP_BIT_OR
4965 || o->op_type == OP_BIT_AND
4966 || o->op_type == OP_BIT_XOR))
276b2a0c 4967 {
1df70142
AL		 4968 const OP * const left = cBINOPo->op_first;
4969 const OP * const right = left->op_sibling;
96a925ab
YST		 4970 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4971 (left->op_flags & OPf_PARENS) == 0) ||
4972 (OP_IS_NUMCOMPARE(right->op_type) &&
4973 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 4974 if (ckWARN(WARN_PRECEDENCE))
4975 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4976 "Possible precedence problem on bitwise %c operator",
4977 o->op_type == OP_BIT_OR ? '|'
4978 : o->op_type == OP_BIT_AND ? '&' : '^'
4979 );
4980 }
5dc0d613 4981 return o;
55497cff 4982}
4983
4984OP *
cea2e8a9 4985Perl_ck_concat(pTHX_ OP *o)
79072805 4986{
6867be6d 4987 const OP *kid = cUNOPo->op_first;
df91b2c5
AE		 4988 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4989 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 4990 o->op_flags |= OPf_STACKED;
11343788 4991 return o;
79072805
LW		 4992}
4993
4994OP *
cea2e8a9 4995Perl_ck_spair(pTHX_ OP *o)
79072805 4996{
27da23d5 4997 dVAR;
11343788 4998 if (o->op_flags & OPf_KIDS) {
79072805 4999 OP* newop;
a0d0e21e 5000 OP* kid;
6867be6d 5001 const OPCODE type = o->op_type;
5dc0d613 5002 o = modkids(ck_fun(o), type);
11343788 5003 kid = cUNOPo->op_first;
a0d0e21e
LW		 5004 newop = kUNOP->op_first->op_sibling;
5005 if (newop &&
5006 (newop->op_sibling ||
22c35a8c 5007 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 5008 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5009 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 5010
11343788 5011 return o;
a0d0e21e
LW		 5012 }
5013 op_free(kUNOP->op_first);
5014 kUNOP->op_first = newop;
5015 }
22c35a8c 5016 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5017 return ck_fun(o);
a0d0e21e
LW		 5018}
5019
5020OP *
cea2e8a9 5021Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5022{
11343788 5023 o = ck_fun(o);
5dc0d613 5024 o->op_private = 0;
11343788 5025 if (o->op_flags & OPf_KIDS) {
551405c4 5026 OP * const kid = cUNOPo->op_first;
01020589
GS		 5027 switch (kid->op_type) {
5028 case OP_ASLICE:
5029 o->op_flags |= OPf_SPECIAL;
5030 /* FALL THROUGH */
5031 case OP_HSLICE:
5dc0d613 5032 o->op_private |= OPpSLICE;
01020589
GS		 5033 break;
5034 case OP_AELEM:
5035 o->op_flags |= OPf_SPECIAL;
5036 /* FALL THROUGH */
5037 case OP_HELEM:
5038 break;
5039 default:
5040 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 5041 OP_DESC(o));
01020589 5042 }
93c66552 5043 op_null(kid);
79072805 5044 }
11343788 5045 return o;
79072805
LW		 5046}
5047
5048OP *
96e176bf
CL		 5049Perl_ck_die(pTHX_ OP *o)
5050{
5051#ifdef VMS
5052 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5053#endif
5054 return ck_fun(o);
5055}
5056
5057OP *
cea2e8a9 5058Perl_ck_eof(pTHX_ OP *o)
79072805 5059{
6867be6d 5060 const I32 type = o->op_type;
79072805 5061
11343788
MB		 5062 if (o->op_flags & OPf_KIDS) {
5063 if (cLISTOPo->op_first->op_type == OP_STUB) {
5064 op_free(o);
8fde6460 5065 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8990e307 5066 }
11343788 5067 return ck_fun(o);
79072805 5068 }
11343788 5069 return o;
79072805
LW		 5070}
5071
5072OP *
cea2e8a9 5073Perl_ck_eval(pTHX_ OP *o)
79072805 5074{
27da23d5 5075 dVAR;
3280af22 5076 PL_hints |= HINT_BLOCK_SCOPE;
11343788 5077 if (o->op_flags & OPf_KIDS) {
46c461b5 5078 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 5079
93a17b20 5080 if (!kid) {
11343788 5081 o->op_flags &= ~OPf_KIDS;
93c66552 5082 op_null(o);
79072805 5083 }
b14574b4 5084 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 5085 LOGOP *enter;
5086
11343788
MB		 5087 cUNOPo->op_first = 0;
5088 op_free(o);
79072805 5089
b7dc083c 5090 NewOp(1101, enter, 1, LOGOP);
79072805 5091 enter->op_type = OP_ENTERTRY;
22c35a8c 5092 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 5093 enter->op_private = 0;
5094
5095 /* establish postfix order */
5096 enter->op_next = (OP*)enter;
5097
11343788
MB		 5098 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5099 o->op_type = OP_LEAVETRY;
22c35a8c 5100 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 5101 enter->op_other = o;
5102 return o;
79072805 5103 }
b5c19bd7 5104 else {
473986ff 5105 scalar((OP*)kid);
b5c19bd7
DM		 5106 PL_cv_has_eval = 1;
5107 }
79072805
LW		 5108 }
5109 else {
11343788 5110 op_free(o);
54b9620d 5111 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 5112 }
3280af22 5113 o->op_targ = (PADOFFSET)PL_hints;
11343788 5114 return o;
79072805
LW		 5115}
5116
5117OP *
d98f61e7
GS		 5118Perl_ck_exit(pTHX_ OP *o)
5119{
5120#ifdef VMS
551405c4 5121 HV * const table = GvHV(PL_hintgv);
d98f61e7 5122 if (table) {
551405c4 5123 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
d98f61e7
GS		 5124 if (svp && *svp && SvTRUE(*svp))
5125 o->op_private |= OPpEXIT_VMSISH;
5126 }
96e176bf 5127 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 5128#endif
5129 return ck_fun(o);
5130}
5131
5132OP *
cea2e8a9 5133Perl_ck_exec(pTHX_ OP *o)
79072805 5134{
11343788 5135 if (o->op_flags & OPf_STACKED) {
6867be6d 5136 OP *kid;
11343788
MB		 5137 o = ck_fun(o);
5138 kid = cUNOPo->op_first->op_sibling;
8990e307 5139 if (kid->op_type == OP_RV2GV)
93c66552 5140 op_null(kid);
79072805 5141 }
463ee0b2 5142 else
11343788
MB		 5143 o = listkids(o);
5144 return o;
79072805
LW		 5145}
5146
5147OP *
cea2e8a9 5148Perl_ck_exists(pTHX_ OP *o)
5f05dabc 5149{
5196be3e
MB		 5150 o = ck_fun(o);
5151 if (o->op_flags & OPf_KIDS) {
46c461b5 5152 OP * const kid = cUNOPo->op_first;
afebc493
GS		 5153 if (kid->op_type == OP_ENTERSUB) {
5154 (void) ref(kid, o->op_type);
5155 if (kid->op_type != OP_RV2CV && !PL_error_count)
5156 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 5157 OP_DESC(o));
afebc493
GS		 5158 o->op_private |= OPpEXISTS_SUB;
5159 }
5160 else if (kid->op_type == OP_AELEM)
01020589
GS		 5161 o->op_flags |= OPf_SPECIAL;
5162 else if (kid->op_type != OP_HELEM)
5163 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 5164 OP_DESC(o));
93c66552 5165 op_null(kid);
5f05dabc 5166 }
5196be3e 5167 return o;
5f05dabc 5168}
5169
79072805 5170OP *
cea2e8a9 5171Perl_ck_rvconst(pTHX_ register OP *o)
79072805 5172{
27da23d5 5173 dVAR;
11343788 5174 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 5175
3280af22 5176 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 5177 if (kid->op_type == OP_CONST) {
44a8e56a 5178 int iscv;
5179 GV *gv;
504618e9 5180 SV * const kidsv = kid->op_sv;
44a8e56a 5181
779c5bc9
GS		 5182 /* Is it a constant from cv_const_sv()? */
5183 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5184 SV *rsv = SvRV(kidsv);
504618e9 5185 const int svtype = SvTYPE(rsv);
e1ec3a88 5186 const char *badtype = Nullch;
779c5bc9
GS		 5187
5188 switch (o->op_type) {
5189 case OP_RV2SV:
5190 if (svtype > SVt_PVMG)
5191 badtype = "a SCALAR";
5192 break;
5193 case OP_RV2AV:
5194 if (svtype != SVt_PVAV)
5195 badtype = "an ARRAY";
5196 break;
5197 case OP_RV2HV:
6d822dc4 5198 if (svtype != SVt_PVHV)
779c5bc9 5199 badtype = "a HASH";
779c5bc9
GS		 5200 break;
5201 case OP_RV2CV:
5202 if (svtype != SVt_PVCV)
5203 badtype = "a CODE";
5204 break;
5205 }
5206 if (badtype)
cea2e8a9 5207 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5208 return o;
5209 }
3280af22 5210 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
e1ec3a88 5211 const char *badthing = Nullch;
5dc0d613 5212 switch (o->op_type) {
44a8e56a 5213 case OP_RV2SV:
5214 badthing = "a SCALAR";
5215 break;
5216 case OP_RV2AV:
5217 badthing = "an ARRAY";
5218 break;
5219 case OP_RV2HV:
5220 badthing = "a HASH";
5221 break;
5222 }
5223 if (badthing)
1c846c1f 5224 Perl_croak(aTHX_
7a5fd60d
NC		 5225 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5226 kidsv, badthing);
44a8e56a 5227 }
93233ece
CS		 5228 /*
5229 * This is a little tricky. We only want to add the symbol if we
5230 * didn't add it in the lexer. Otherwise we get duplicate strict
5231 * warnings. But if we didn't add it in the lexer, we must at
5232 * least pretend like we wanted to add it even if it existed before,
5233 * or we get possible typo warnings. OPpCONST_ENTERED says
5234 * whether the lexer already added THIS instance of this symbol.
5235 */
5196be3e 5236 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5237 do {
7a5fd60d 5238 gv = gv_fetchsv(kidsv,
748a9306 5239 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5240 iscv
5241 ? SVt_PVCV
11343788 5242 : o->op_type == OP_RV2SV
a0d0e21e 5243 ? SVt_PV
11343788 5244 : o->op_type == OP_RV2AV
a0d0e21e 5245 ? SVt_PVAV
11343788 5246 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5247 ? SVt_PVHV
5248 : SVt_PVGV);
93233ece
CS		 5249 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5250 if (gv) {
5251 kid->op_type = OP_GV;
5252 SvREFCNT_dec(kid->op_sv);
350de78d 5253#ifdef USE_ITHREADS
638eceb6 5254 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5255 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 5256 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 5257 GvIN_PAD_on(gv);
dd2155a4 5258 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
350de78d 5259#else
93233ece 5260 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5261#endif
23f1ca44 5262 kid->op_private = 0;
76cd736e 5263 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5264 }
79072805 5265 }
11343788 5266 return o;
79072805
LW		 5267}
5268
5269OP *
cea2e8a9 5270Perl_ck_ftst(pTHX_ OP *o)
79072805 5271{
27da23d5 5272 dVAR;
6867be6d 5273 const I32 type = o->op_type;
79072805 5274
d0dca557
JD		 5275 if (o->op_flags & OPf_REF) {
5276 /* nothing */
5277 }
5278 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 5279 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5280
5281 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 5282 OP * const newop = newGVOP(type, OPf_REF,
7a5fd60d 5283 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
11343788 5284 op_free(o);
d0dca557 5285 o = newop;
181bc48d 5286 return o;
79072805 5287 }
1af34c76
JH		 5288 else {
5289 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5290 OP_IS_FILETEST_ACCESS(o))
5291 o->op_private |= OPpFT_ACCESS;
5292 }
fbb0b3b3
RGS		 5293 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5294 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5295 o->op_private |= OPpFT_STACKED;
79072805
LW		 5296 }
5297 else {
11343788 5298 op_free(o);
79072805 5299 if (type == OP_FTTTY)
8fde6460 5300 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5301 else
d0dca557 5302 o = newUNOP(type, 0, newDEFSVOP());
79072805 5303 }
11343788 5304 return o;
79072805
LW		 5305}
5306
5307OP *
cea2e8a9 5308Perl_ck_fun(pTHX_ OP *o)
79072805 5309{
6867be6d 5310 const int type = o->op_type;
22c35a8c 5311 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5312
11343788 5313 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5314 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5315 oa &= ~OA_OPTIONAL;
5316 else
11343788 5317 return no_fh_allowed(o);
79072805
LW		 5318 }
5319
11343788 5320 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 5321 OP **tokid = &cLISTOPo->op_first;
5322 register OP *kid = cLISTOPo->op_first;
5323 OP *sibl;
5324 I32 numargs = 0;
5325
8990e307 5326 if (kid->op_type == OP_PUSHMARK ||
155aba94 5327 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5328 {
79072805
LW		 5329 tokid = &kid->op_sibling;
5330 kid = kid->op_sibling;
5331 }
22c35a8c 5332 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5333 *tokid = kid = newDEFSVOP();
79072805
LW		 5334
5335 while (oa && kid) {
5336 numargs++;
5337 sibl = kid->op_sibling;
5338 switch (oa & 7) {
5339 case OA_SCALAR:
62c18ce2
GS		 5340 /* list seen where single (scalar) arg expected? */
5341 if (numargs == 1 && !(oa >> 4)
5342 && kid->op_type == OP_LIST && type != OP_SCALAR)
5343 {
5344 return too_many_arguments(o,PL_op_desc[type]);
5345 }
79072805
LW		 5346 scalar(kid);
5347 break;
5348 case OA_LIST:
5349 if (oa < 16) {
5350 kid = 0;
5351 continue;
5352 }
5353 else
5354 list(kid);
5355 break;
5356 case OA_AVREF:
936edb8b 5357 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5358 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5359 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5360 "Useless use of %s with no values",
936edb8b 5361 PL_op_desc[type]);
b2ffa427 5362
79072805 5363 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5364 (kid->op_private & OPpCONST_BARE))
5365 {
551405c4 5366 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7a5fd60d 5367 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
12bcd1a6
PM		 5368 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5369 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d
NC		 5370 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5371 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5372 op_free(kid);
5373 kid = newop;
5374 kid->op_sibling = sibl;
5375 *tokid = kid;
5376 }
8990e307 5377 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5378 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5379 mod(kid, type);
79072805
LW		 5380 break;
5381 case OA_HVREF:
5382 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5383 (kid->op_private & OPpCONST_BARE))
5384 {
551405c4 5385 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7a5fd60d 5386 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
12bcd1a6
PM		 5387 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5388 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d
NC		 5389 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5390 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5391 op_free(kid);
5392 kid = newop;
5393 kid->op_sibling = sibl;
5394 *tokid = kid;
5395 }
8990e307 5396 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5397 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5398 mod(kid, type);
79072805
LW		 5399 break;
5400 case OA_CVREF:
5401 {
551405c4 5402 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5403 kid->op_sibling = 0;
5404 linklist(kid);
5405 newop->op_next = newop;
5406 kid = newop;
5407 kid->op_sibling = sibl;
5408 *tokid = kid;
5409 }
5410 break;
5411 case OA_FILEREF:
c340be78 5412 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5413 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5414 (kid->op_private & OPpCONST_BARE))
5415 {
79072805 5416 OP *newop = newGVOP(OP_GV, 0,
7a5fd60d 5417 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
afbdacea 5418 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5419 kid == cLISTOPo->op_last)
364daeac 5420 cLISTOPo->op_last = newop;
79072805
LW		 5421 op_free(kid);
5422 kid = newop;
5423 }
1ea32a52
GS		 5424 else if (kid->op_type == OP_READLINE) {
5425 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5426 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5427 }
79072805 5428 else {
35cd451c 5429 I32 flags = OPf_SPECIAL;
a6c40364 5430 I32 priv = 0;
2c8ac474
GS		 5431 PADOFFSET targ = 0;
5432
35cd451c 5433 /* is this op a FH constructor? */
853846ea 5434 if (is_handle_constructor(o,numargs)) {
e1ec3a88 5435 const char *name = Nullch;
dd2155a4 5436 STRLEN len = 0;
2c8ac474
GS		 5437
5438 flags = 0;
5439 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5440 * need to "prove" flag does not mean something
5441 * else already - NI-S 1999/05/07
2c8ac474
GS		 5442 */
5443 priv = OPpDEREF;
5444 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 5445 name = PAD_COMPNAME_PV(kid->op_targ);
5446 /* SvCUR of a pad namesv can't be trusted
5447 * (see PL_generation), so calc its length
5448 * manually */
5449 if (name)
5450 len = strlen(name);
5451
2c8ac474
GS		 5452 }
5453 else if (kid->op_type == OP_RV2SV
5454 && kUNOP->op_first->op_type == OP_GV)
5455 {
5456 GV *gv = cGVOPx_gv(kUNOP->op_first);
5457 name = GvNAME(gv);
5458 len = GvNAMELEN(gv);
5459 }
afd1915d
GS		 5460 else if (kid->op_type == OP_AELEM
5461 || kid->op_type == OP_HELEM)
5462 {
551405c4 5463 OP *op = ((BINOP*)kid)->op_first;
0c4b0a3f 5464 name = 0;
551405c4 5465 if (op) {
0c4b0a3f 5466 SV *tmpstr = Nullsv;
551405c4 5467 const char * const a =
0c4b0a3f
JH		 5468 kid->op_type == OP_AELEM ?
5469 "[]" : "{}";
5470 if (((op->op_type == OP_RV2AV) ||
5471 (op->op_type == OP_RV2HV)) &&
5472 (op = ((UNOP*)op)->op_first) &&
5473 (op->op_type == OP_GV)) {
5474 /* packagevar $a[] or $h{} */
551405c4 5475 GV * const gv = cGVOPx_gv(op);
0c4b0a3f
JH		 5476 if (gv)
5477 tmpstr =
5478 Perl_newSVpvf(aTHX_
5479 "%s%c...%c",
5480 GvNAME(gv),
5481 a[0], a[1]);
5482 }
5483 else if (op->op_type == OP_PADAV
5484 || op->op_type == OP_PADHV) {
5485 /* lexicalvar $a[] or $h{} */
551405c4 5486 const char * const padname =
0c4b0a3f
JH		 5487 PAD_COMPNAME_PV(op->op_targ);
5488 if (padname)
5489 tmpstr =
5490 Perl_newSVpvf(aTHX_
5491 "%s%c...%c",
5492 padname + 1,
5493 a[0], a[1]);
0c4b0a3f
JH		 5494 }
5495 if (tmpstr) {
93524f2b 5496 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 5497 sv_2mortal(tmpstr);
5498 }
5499 }
5500 if (!name) {
5501 name = "__ANONIO__";
5502 len = 10;
5503 }
5504 mod(kid, type);
afd1915d 5505 }
2c8ac474
GS		 5506 if (name) {
5507 SV *namesv;
5508 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 5509 namesv = PAD_SVl(targ);
862a34c6 5510 SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5511 if (*name != '$')
5512 sv_setpvn(namesv, "$", 1);
5513 sv_catpvn(namesv, name, len);
5514 }
853846ea 5515 }
79072805 5516 kid->op_sibling = 0;
35cd451c 5517 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5518 kid->op_targ = targ;
5519 kid->op_private |= priv;
79072805
LW		 5520 }
5521 kid->op_sibling = sibl;
5522 *tokid = kid;
5523 }
5524 scalar(kid);
5525 break;
5526 case OA_SCALARREF:
a0d0e21e 5527 mod(scalar(kid), type);
79072805
LW		 5528 break;
5529 }
5530 oa >>= 4;
5531 tokid = &kid->op_sibling;
5532 kid = kid->op_sibling;
5533 }
11343788 5534 o->op_private |= numargs;
79072805 5535 if (kid)
53e06cf0 5536 return too_many_arguments(o,OP_DESC(o));
11343788 5537 listkids(o);
79072805 5538 }
22c35a8c 5539 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5540 op_free(o);
54b9620d 5541 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5542 }
5543
79072805
LW		 5544 if (oa) {
5545 while (oa & OA_OPTIONAL)
5546 oa >>= 4;
5547 if (oa && oa != OA_LIST)
53e06cf0 5548 return too_few_arguments(o,OP_DESC(o));
79072805 5549 }
11343788 5550 return o;
79072805
LW		 5551}
5552
5553OP *
cea2e8a9 5554Perl_ck_glob(pTHX_ OP *o)
79072805 5555{
27da23d5 5556 dVAR;
fb73857a 5557 GV *gv;
5558
649da076 5559 o = ck_fun(o);
1f2bfc8a 5560 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5561 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5562
b9f751c0
GS		 5563 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5564 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5565 {
fb73857a 5566 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b9f751c0 5567 }
b1cb66bf 5568
52bb0670 5569#if !defined(PERL_EXTERNAL_GLOB)
72b16652 5570 /* XXX this can be tightened up and made more failsafe. */
f444d496 5571 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 5572 GV *glob_gv;
72b16652 5573 ENTER;
00ca71c1
NIS		 5574 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5575 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
72b16652 5576 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5577 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5578 GvCV(gv) = GvCV(glob_gv);
7fc63493 5579 (void)SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5580 GvIMPORTED_CV_on(gv);
72b16652
GS		 5581 LEAVE;
5582 }
52bb0670 5583#endif /* PERL_EXTERNAL_GLOB */
72b16652 5584
b9f751c0 5585 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5586 append_elem(OP_GLOB, o,
80252599 5587 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5588 o->op_type = OP_LIST;
22c35a8c 5589 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5590 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5591 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 5592 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 5593 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5594 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5595 scalar(newUNOP(OP_RV2CV, 0,
5596 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5597 o = newUNOP(OP_NULL, 0, ck_subr(o));
5598 o->op_targ = OP_GLOB; /* hint at what it used to be */
5599 return o;
b1cb66bf 5600 }
5601 gv = newGVgen("main");
a0d0e21e 5602 gv_IOadd(gv);
11343788
MB		 5603 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5604 scalarkids(o);
649da076 5605 return o;
79072805
LW		 5606}
5607
5608OP *
cea2e8a9 5609Perl_ck_grep(pTHX_ OP *o)
79072805 5610{
27da23d5 5611 dVAR;
79072805
LW		 5612 LOGOP *gwop;
5613 OP *kid;
6867be6d 5614 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
59f00321 5615 I32 offset;
79072805 5616
22c35a8c 5617 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5618 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5619
11343788 5620 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5621 OP* k;
11343788
MB		 5622 o = ck_sort(o);
5623 kid = cLISTOPo->op_first->op_sibling;
d09ad856
BS		 5624 if (!cUNOPx(kid)->op_next)
5625 Perl_croak(aTHX_ "panic: ck_grep");
e3c9a8b9 5626 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 5627 kid = k;
5628 }
5629 kid->op_next = (OP*)gwop;
11343788 5630 o->op_flags &= ~OPf_STACKED;
93a17b20 5631 }
11343788 5632 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5633 if (type == OP_MAPWHILE)
5634 list(kid);
5635 else
5636 scalar(kid);
11343788 5637 o = ck_fun(o);
3280af22 5638 if (PL_error_count)
11343788 5639 return o;
aeea060c 5640 kid = cLISTOPo->op_first->op_sibling;
79072805 5641 if (kid->op_type != OP_NULL)
cea2e8a9 5642 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5643 kid = kUNOP->op_first;
5644
a0d0e21e 5645 gwop->op_type = type;
22c35a8c 5646 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5647 gwop->op_first = listkids(o);
79072805 5648 gwop->op_flags |= OPf_KIDS;
79072805 5649 gwop->op_other = LINKLIST(kid);
79072805 5650 kid->op_next = (OP*)gwop;
59f00321
RGS		 5651 offset = pad_findmy("$_");
5652 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5653 o->op_private = gwop->op_private = 0;
5654 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5655 }
5656 else {
5657 o->op_private = gwop->op_private = OPpGREP_LEX;
5658 gwop->op_targ = o->op_targ = offset;
5659 }
79072805 5660
11343788 5661 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5662 if (!kid || !kid->op_sibling)
53e06cf0 5663 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5664 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5665 mod(kid, OP_GREPSTART);
5666
79072805
LW		 5667 return (OP*)gwop;
5668}
5669
5670OP *
cea2e8a9 5671Perl_ck_index(pTHX_ OP *o)
79072805 5672{
11343788
MB		 5673 if (o->op_flags & OPf_KIDS) {
5674 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5675 if (kid)
5676 kid = kid->op_sibling; /* get past "big" */
79072805 5677 if (kid && kid->op_type == OP_CONST)
2779dcf1 5678 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5679 }
11343788 5680 return ck_fun(o);
79072805
LW		 5681}
5682
5683OP *
cea2e8a9 5684Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5685{
5686 /* XXX length optimization goes here */
11343788 5687 return ck_fun(o);
79072805
LW		 5688}
5689
5690OP *
cea2e8a9 5691Perl_ck_lfun(pTHX_ OP *o)
79072805 5692{
6867be6d 5693 const OPCODE type = o->op_type;
5dc0d613 5694 return modkids(ck_fun(o), type);
79072805
LW		 5695}
5696
5697OP *
cea2e8a9 5698Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5699{
12bcd1a6 5700 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5701 switch (cUNOPo->op_first->op_type) {
5702 case OP_RV2AV:
a8739d98
JH		 5703 /* This is needed for
5704 if (defined %stash::)
5705 to work. Do not break Tk.
5706 */
1c846c1f 5707 break; /* Globals via GV can be undef */
d0334bed
GS		 5708 case OP_PADAV:
5709 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5710 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5711 "defined(@array) is deprecated");
12bcd1a6 5712 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5713 "\t(Maybe you should just omit the defined()?)\n");
69794302 5714 break;
d0334bed 5715 case OP_RV2HV:
a8739d98
JH		 5716 /* This is needed for
5717 if (defined %stash::)
5718 to work. Do not break Tk.
5719 */
1c846c1f 5720 break; /* Globals via GV can be undef */
d0334bed 5721 case OP_PADHV:
12bcd1a6 5722 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5723 "defined(%%hash) is deprecated");
12bcd1a6 5724 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5725 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5726 break;
5727 default:
5728 /* no warning */
5729 break;
5730 }
69794302
MJD		 5731 }
5732 return ck_rfun(o);
5733}
5734
5735OP *
cea2e8a9 5736Perl_ck_rfun(pTHX_ OP *o)
8990e307 5737{
6867be6d 5738 const OPCODE type = o->op_type;
5dc0d613 5739 return refkids(ck_fun(o), type);
8990e307
LW		 5740}
5741
5742OP *
cea2e8a9 5743Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5744{
5745 register OP *kid;
aeea060c 5746
11343788 5747 kid = cLISTOPo->op_first;
79072805 5748 if (!kid) {
11343788
MB		 5749 o = force_list(o);
5750 kid = cLISTOPo->op_first;
79072805
LW		 5751 }
5752 if (kid->op_type == OP_PUSHMARK)
5753 kid = kid->op_sibling;
11343788 5754 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 5755 kid = kid->op_sibling;
5756 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5757 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 5758 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 5759 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 5760 cLISTOPo->op_first->op_sibling = kid;
5761 cLISTOPo->op_last = kid;
79072805
LW		 5762 kid = kid->op_sibling;
5763 }
5764 }
b2ffa427 5765
79072805 5766 if (!kid)
54b9620d 5767 append_elem(o->op_type, o, newDEFSVOP());
79072805 5768
2de3dbcc 5769 return listkids(o);
bbce6d69 5770}
5771
5772OP *
b162f9ea
IZ		 5773Perl_ck_sassign(pTHX_ OP *o)
5774{
5775 OP *kid = cLISTOPo->op_first;
5776 /* has a disposable target? */
5777 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 5778 && !(kid->op_flags & OPf_STACKED)
5779 /* Cannot steal the second time! */
5780 && !(kid->op_private & OPpTARGET_MY))
b162f9ea 5781 {
551405c4 5782 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 5783
5784 /* Can just relocate the target. */
2c2d71f5
JH		 5785 if (kkid && kkid->op_type == OP_PADSV
5786 && !(kkid->op_private & OPpLVAL_INTRO))
5787 {
b162f9ea 5788 kid->op_targ = kkid->op_targ;
743e66e6 5789 kkid->op_targ = 0;
b162f9ea
IZ		 5790 /* Now we do not need PADSV and SASSIGN. */
5791 kid->op_sibling = o->op_sibling; /* NULL */
5792 cLISTOPo->op_first = NULL;
5793 op_free(o);
5794 op_free(kkid);
5795 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5796 return kid;
5797 }
5798 }
b9d46b39
RGS		 5799 /* optimise C<my $x = undef> to C<my $x> */
5800 if (kid->op_type == OP_UNDEF) {
551405c4 5801 OP * const kkid = kid->op_sibling;
b9d46b39
RGS		 5802 if (kkid && kkid->op_type == OP_PADSV
5803 && (kkid->op_private & OPpLVAL_INTRO))
5804 {
5805 cLISTOPo->op_first = NULL;
5806 kid->op_sibling = NULL;
5807 op_free(o);
5808 op_free(kid);
5809 return kkid;
5810 }
5811 }
b162f9ea
IZ		 5812 return o;
5813}
5814
5815OP *
cea2e8a9 5816Perl_ck_match(pTHX_ OP *o)
79072805 5817{
59f00321 5818 if (o->op_type != OP_QR) {
6867be6d 5819 const I32 offset = pad_findmy("$_");
59f00321
RGS		 5820 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5821 o->op_targ = offset;
5822 o->op_private |= OPpTARGET_MY;
5823 }
5824 }
5825 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5826 o->op_private |= OPpRUNTIME;
11343788 5827 return o;
79072805
LW		 5828}
5829
5830OP *
f5d5a27c
CS		 5831Perl_ck_method(pTHX_ OP *o)
5832{
551405c4 5833 OP * const kid = cUNOPo->op_first;
f5d5a27c
CS		 5834 if (kid->op_type == OP_CONST) {
5835 SV* sv = kSVOP->op_sv;
b15aece3 5836 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
f5d5a27c 5837 OP *cmop;
1c846c1f 5838 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
b15aece3 5839 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
1c846c1f
NIS		 5840 }
5841 else {
5842 kSVOP->op_sv = Nullsv;
5843 }
f5d5a27c 5844 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 5845 op_free(o);
5846 return cmop;
5847 }
5848 }
5849 return o;
5850}
5851
5852OP *
cea2e8a9 5853Perl_ck_null(pTHX_ OP *o)
79072805 5854{
11343788 5855 return o;
79072805
LW		 5856}
5857
5858OP *
16fe6d59
GS		 5859Perl_ck_open(pTHX_ OP *o)
5860{
551405c4 5861 HV * const table = GvHV(PL_hintgv);
16fe6d59 5862 if (table) {
551405c4 5863 SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
16fe6d59 5864 if (svp && *svp) {
551405c4 5865 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 5866 if (mode & O_BINARY)
5867 o->op_private |= OPpOPEN_IN_RAW;
5868 else if (mode & O_TEXT)
5869 o->op_private |= OPpOPEN_IN_CRLF;
5870 }
5871
5872 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5873 if (svp && *svp) {
551405c4 5874 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 5875 if (mode & O_BINARY)
5876 o->op_private |= OPpOPEN_OUT_RAW;
5877 else if (mode & O_TEXT)
5878 o->op_private |= OPpOPEN_OUT_CRLF;
5879 }
5880 }
5881 if (o->op_type == OP_BACKTICK)
5882 return o;
3b82e551
JH		 5883 {
5884 /* In case of three-arg dup open remove strictness
5885 * from the last arg if it is a bareword. */
551405c4
AL		 5886 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
5887 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 5888 OP *oa;
b15aece3 5889 const char *mode;
3b82e551
JH		 5890
5891 if ((last->op_type == OP_CONST) && /* The bareword. */
5892 (last->op_private & OPpCONST_BARE) &&
5893 (last->op_private & OPpCONST_STRICT) &&
5894 (oa = first->op_sibling) && /* The fh. */
5895 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 5896 (oa->op_type == OP_CONST) &&
3b82e551 5897 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 5898 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 5899 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5900 (last == oa->op_sibling)) /* The bareword. */
5901 last->op_private &= ~OPpCONST_STRICT;
5902 }
16fe6d59
GS		 5903 return ck_fun(o);
5904}
5905
5906OP *
cea2e8a9 5907Perl_ck_repeat(pTHX_ OP *o)
79072805 5908{
11343788
MB		 5909 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5910 o->op_private |= OPpREPEAT_DOLIST;
5911 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 5912 }
5913 else
11343788
MB		 5914 scalar(o);
5915 return o;
79072805
LW		 5916}
5917
5918OP *
cea2e8a9 5919Perl_ck_require(pTHX_ OP *o)
8990e307 5920{
a72a1c8b 5921 GV* gv = Nullgv;
ec4ab249 5922
11343788 5923 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 5924 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 5925
5926 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 5927 SV * const sv = kid->op_sv;
5c144d81 5928 U32 was_readonly = SvREADONLY(sv);
8990e307 5929 char *s;
5c144d81
NC		 5930
5931 if (was_readonly) {
5932 if (SvFAKE(sv)) {
5933 sv_force_normal_flags(sv, 0);
5934 assert(!SvREADONLY(sv));
5935 was_readonly = 0;
5936 } else {
5937 SvREADONLY_off(sv);
5938 }
5939 }
5940
5941 for (s = SvPVX(sv); *s; s++) {
a0d0e21e
LW		 5942 if (*s == ':' && s[1] == ':') {
5943 *s = '/';
1aef975c 5944 Move(s+2, s+1, strlen(s+2)+1, char);
5c144d81 5945 SvCUR_set(sv, SvCUR(sv) - 1);
a0d0e21e 5946 }
8990e307 5947 }
5c144d81
NC		 5948 sv_catpvn(sv, ".pm", 3);
5949 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 5950 }
5951 }
ec4ab249 5952
a72a1c8b
RGS		 5953 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
5954 /* handle override, if any */
5955 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
d6a985f2 5956 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
551405c4
AL		 5957 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
5958 gv = gvp ? *gvp : Nullgv;
d6a985f2 5959 }
a72a1c8b 5960 }
ec4ab249 5961
b9f751c0 5962 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 5963 OP * const kid = cUNOPo->op_first;
ec4ab249
GA		 5964 cUNOPo->op_first = 0;
5965 op_free(o);
5966 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5967 append_elem(OP_LIST, kid,
5968 scalar(newUNOP(OP_RV2CV, 0,
5969 newGVOP(OP_GV, 0,
5970 gv))))));
5971 }
5972
11343788 5973 return ck_fun(o);
8990e307
LW		 5974}
5975
78f9721b
SM		 5976OP *
5977Perl_ck_return(pTHX_ OP *o)
5978{
78f9721b 5979 if (CvLVALUE(PL_compcv)) {
6867be6d 5980 OP *kid;
78f9721b
SM		 5981 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5982 mod(kid, OP_LEAVESUBLV);
5983 }
5984 return o;
5985}
5986
79072805 5987OP *
cea2e8a9 5988Perl_ck_select(pTHX_ OP *o)
79072805 5989{
27da23d5 5990 dVAR;
c07a80fd 5991 OP* kid;
11343788
MB		 5992 if (o->op_flags & OPf_KIDS) {
5993 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 5994 if (kid && kid->op_sibling) {
11343788 5995 o->op_type = OP_SSELECT;
22c35a8c 5996 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 5997 o = ck_fun(o);
5998 return fold_constants(o);
79072805
LW		 5999 }
6000 }
11343788
MB		 6001 o = ck_fun(o);
6002 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 6003 if (kid && kid->op_type == OP_RV2GV)
6004 kid->op_private &= ~HINT_STRICT_REFS;
11343788 6005 return o;
79072805
LW		 6006}
6007
6008OP *
cea2e8a9 6009Perl_ck_shift(pTHX_ OP *o)
79072805 6010{
6867be6d 6011 const I32 type = o->op_type;
79072805 6012
11343788 6013 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 6014 OP *argop;
b2ffa427 6015
11343788 6016 op_free(o);
6d4ff0d2 6017 argop = newUNOP(OP_RV2AV, 0,
8fde6460 6018 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6d4ff0d2 6019 return newUNOP(type, 0, scalar(argop));
79072805 6020 }
11343788 6021 return scalar(modkids(ck_fun(o), type));
79072805
LW		 6022}
6023
6024OP *
cea2e8a9 6025Perl_ck_sort(pTHX_ OP *o)
79072805 6026{
8e3f9bdf 6027 OP *firstkid;
bbce6d69 6028
9ea6e965 6029 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 6030 simplify_sort(o);
8e3f9bdf
GS		 6031 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6032 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 6033 OP *k = NULL;
8e3f9bdf 6034 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 6035
463ee0b2 6036 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 6037 linklist(kid);
463ee0b2
LW		 6038 if (kid->op_type == OP_SCOPE) {
6039 k = kid->op_next;
6040 kid->op_next = 0;
79072805 6041 }
463ee0b2 6042 else if (kid->op_type == OP_LEAVE) {
11343788 6043 if (o->op_type == OP_SORT) {
93c66552 6044 op_null(kid); /* wipe out leave */
748a9306 6045 kid->op_next = kid;
463ee0b2 6046
748a9306
LW		 6047 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6048 if (k->op_next == kid)
6049 k->op_next = 0;
71a29c3c
GS		 6050 /* don't descend into loops */
6051 else if (k->op_type == OP_ENTERLOOP
6052 || k->op_type == OP_ENTERITER)
6053 {
6054 k = cLOOPx(k)->op_lastop;
6055 }
748a9306 6056 }
463ee0b2 6057 }
748a9306
LW		 6058 else
6059 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 6060 k = kLISTOP->op_first;
463ee0b2 6061 }
a2efc822 6062 CALL_PEEP(k);
a0d0e21e 6063
8e3f9bdf
GS		 6064 kid = firstkid;
6065 if (o->op_type == OP_SORT) {
6066 /* provide scalar context for comparison function/block */
6067 kid = scalar(kid);
a0d0e21e 6068 kid->op_next = kid;
8e3f9bdf 6069 }
a0d0e21e
LW		 6070 else
6071 kid->op_next = k;
11343788 6072 o->op_flags |= OPf_SPECIAL;
79072805 6073 }
c6e96bcb 6074 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 6075 op_null(firstkid);
8e3f9bdf
GS		 6076
6077 firstkid = firstkid->op_sibling;
79072805 6078 }
bbce6d69 6079
8e3f9bdf
GS		 6080 /* provide list context for arguments */
6081 if (o->op_type == OP_SORT)
6082 list(firstkid);
6083
11343788 6084 return o;
79072805 6085}
bda4119b
GS		 6086
6087STATIC void
cea2e8a9 6088S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 6089{
6090 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6091 OP *k;
eb209983 6092 int descending;
350de78d 6093 GV *gv;
770526c1 6094 const char *gvname;
9c007264
JH		 6095 if (!(o->op_flags & OPf_STACKED))
6096 return;
1c846c1f
NIS		 6097 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6098 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 6099 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 6100 if (kid->op_type != OP_SCOPE)
6101 return;
6102 kid = kLISTOP->op_last; /* get past scope */
6103 switch(kid->op_type) {
6104 case OP_NCMP:
6105 case OP_I_NCMP:
6106 case OP_SCMP:
6107 break;
6108 default:
6109 return;
6110 }
6111 k = kid; /* remember this node*/
6112 if (kBINOP->op_first->op_type != OP_RV2SV)
6113 return;
6114 kid = kBINOP->op_first; /* get past cmp */
6115 if (kUNOP->op_first->op_type != OP_GV)
6116 return;
6117 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6118 gv = kGVOP_gv;
350de78d 6119 if (GvSTASH(gv) != PL_curstash)
9c007264 6120 return;
770526c1
NC		 6121 gvname = GvNAME(gv);
6122 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 6123 descending = 0;
770526c1 6124 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 6125 descending = 1;
9c007264
JH		 6126 else
6127 return;
eb209983 6128
9c007264
JH		 6129 kid = k; /* back to cmp */
6130 if (kBINOP->op_last->op_type != OP_RV2SV)
6131 return;
6132 kid = kBINOP->op_last; /* down to 2nd arg */
6133 if (kUNOP->op_first->op_type != OP_GV)
6134 return;
6135 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6136 gv = kGVOP_gv;
770526c1
NC		 6137 if (GvSTASH(gv) != PL_curstash)
6138 return;
6139 gvname = GvNAME(gv);
6140 if ( descending
6141 ? !(*gvname == 'a' && gvname[1] == '\0')
6142 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 6143 return;
6144 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 6145 if (descending)
6146 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 6147 if (k->op_type == OP_NCMP)
6148 o->op_private |= OPpSORT_NUMERIC;
6149 if (k->op_type == OP_I_NCMP)
6150 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 6151 kid = cLISTOPo->op_first->op_sibling;
6152 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6153 op_free(kid); /* then delete it */
9c007264 6154}
79072805
LW		 6155
6156OP *
cea2e8a9 6157Perl_ck_split(pTHX_ OP *o)
79072805 6158{
27da23d5 6159 dVAR;
79072805 6160 register OP *kid;
aeea060c 6161
11343788
MB		 6162 if (o->op_flags & OPf_STACKED)
6163 return no_fh_allowed(o);
79072805 6164
11343788 6165 kid = cLISTOPo->op_first;
8990e307 6166 if (kid->op_type != OP_NULL)
cea2e8a9 6167 Perl_croak(aTHX_ "panic: ck_split");
8990e307 6168 kid = kid->op_sibling;
11343788
MB		 6169 op_free(cLISTOPo->op_first);
6170 cLISTOPo->op_first = kid;
85e6fe83 6171 if (!kid) {
79cb57f6 6172 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 6173 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 6174 }
79072805 6175
de4bf5b3 6176 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 6177 OP * const sibl = kid->op_sibling;
463ee0b2 6178 kid->op_sibling = 0;
131b3ad0 6179 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 6180 if (cLISTOPo->op_first == cLISTOPo->op_last)
6181 cLISTOPo->op_last = kid;
6182 cLISTOPo->op_first = kid;
79072805
LW		 6183 kid->op_sibling = sibl;
6184 }
6185
6186 kid->op_type = OP_PUSHRE;
22c35a8c 6187 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 6188 scalar(kid);
041457d9 6189 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
f34840d8
MJD		 6190 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6191 "Use of /g modifier is meaningless in split");
6192 }
79072805
LW		 6193
6194 if (!kid->op_sibling)
54b9620d 6195 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 6196
6197 kid = kid->op_sibling;
6198 scalar(kid);
6199
6200 if (!kid->op_sibling)
11343788 6201 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 6202
6203 kid = kid->op_sibling;
6204 scalar(kid);
6205
6206 if (kid->op_sibling)
53e06cf0 6207 return too_many_arguments(o,OP_DESC(o));
79072805 6208
11343788 6209 return o;
79072805
LW		 6210}
6211
6212OP *
1c846c1f 6213Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 6214{
551405c4 6215 const OP * const kid = cLISTOPo->op_first->op_sibling;
041457d9
DM		 6216 if (kid && kid->op_type == OP_MATCH) {
6217 if (ckWARN(WARN_SYNTAX)) {
6867be6d
AL		 6218 const REGEXP *re = PM_GETRE(kPMOP);
6219 const char *pmstr = re ? re->precomp : "STRING";
9014280d 6220 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 6221 "/%s/ should probably be written as \"%s\"",
6222 pmstr, pmstr);
6223 }
6224 }
6225 return ck_fun(o);
6226}
6227
6228OP *
cea2e8a9 6229Perl_ck_subr(pTHX_ OP *o)
79072805 6230{
11343788
MB		 6231 OP *prev = ((cUNOPo->op_first->op_sibling)
6232 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6233 OP *o2 = prev->op_sibling;
4633a7c4
LW		 6234 OP *cvop;
6235 char *proto = 0;
6236 CV *cv = 0;
46fc3d4c 6237 GV *namegv = 0;
4633a7c4
LW		 6238 int optional = 0;
6239 I32 arg = 0;
5b794e05 6240 I32 contextclass = 0;
90b7f708 6241 char *e = 0;
0723351e 6242 bool delete_op = 0;
4633a7c4 6243
d3011074 6244 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6245 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6246 if (cvop->op_type == OP_RV2CV) {
6247 SVOP* tmpop;
11343788 6248 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6249 op_null(cvop); /* disable rv2cv */
4633a7c4 6250 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6251 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6252 GV *gv = cGVOPx_gv(tmpop);
350de78d 6253 cv = GvCVu(gv);
76cd736e
GS		 6254 if (!cv)
6255 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 6256 else {
6257 if (SvPOK(cv)) {
6258 namegv = CvANON(cv) ? gv : CvGV(cv);
8b6b16e7 6259 proto = SvPV_nolen((SV*)cv);
06492da6
SF		 6260 }
6261 if (CvASSERTION(cv)) {
6262 if (PL_hints & HINT_ASSERTING) {
6263 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6264 o->op_private |= OPpENTERSUB_DB;
6265 }
8fa7688f 6266 else {
0723351e 6267 delete_op = 1;
041457d9 6268 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
8fa7688f
SF		 6269 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6270 "Impossible to activate assertion call");
6271 }
6272 }
06492da6 6273 }
46fc3d4c 6274 }
4633a7c4
LW		 6275 }
6276 }
f5d5a27c 6277 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6278 if (o2->op_type == OP_CONST)
6279 o2->op_private &= ~OPpCONST_STRICT;
58a40671 6280 else if (o2->op_type == OP_LIST) {
551405c4 6281 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
58a40671
GS		 6282 if (o && o->op_type == OP_CONST)
6283 o->op_private &= ~OPpCONST_STRICT;
6284 }
7a52d87a 6285 }
3280af22
NIS		 6286 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6287 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6288 o->op_private |= OPpENTERSUB_DB;
6289 while (o2 != cvop) {
4633a7c4
LW		 6290 if (proto) {
6291 switch (*proto) {
6292 case '\0':
5dc0d613 6293 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 6294 case ';':
6295 optional = 1;
6296 proto++;
6297 continue;
6298 case '$':
6299 proto++;
6300 arg++;
11343788 6301 scalar(o2);
4633a7c4
LW		 6302 break;
6303 case '%':
6304 case '@':
11343788 6305 list(o2);
4633a7c4
LW		 6306 arg++;
6307 break;
6308 case '&':
6309 proto++;
6310 arg++;
11343788 6311 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6312 bad_type(arg,
6313 arg == 1 ? "block or sub {}" : "sub {}",
6314 gv_ename(namegv), o2);
4633a7c4
LW		 6315 break;
6316 case '*':
2ba6ecf4 6317 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6318 proto++;
6319 arg++;
11343788 6320 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6321 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6322 else if (o2->op_type == OP_CONST)
6323 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6324 else if (o2->op_type == OP_ENTERSUB) {
6325 /* accidental subroutine, revert to bareword */
6326 OP *gvop = ((UNOP*)o2)->op_first;
6327 if (gvop && gvop->op_type == OP_NULL) {
6328 gvop = ((UNOP*)gvop)->op_first;
6329 if (gvop) {
6330 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6331 ;
6332 if (gvop &&
6333 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6334 (gvop = ((UNOP*)gvop)->op_first) &&
6335 gvop->op_type == OP_GV)
6336 {
551405c4
AL		 6337 GV * const gv = cGVOPx_gv(gvop);
6338 OP * const sibling = o2->op_sibling;
6339 SV * const n = newSVpvn("",0);
9675f7ac 6340 op_free(o2);
2a797ae2 6341 gv_fullname4(n, gv, "", FALSE);
2692f720 6342 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6343 prev->op_sibling = o2;
6344 o2->op_sibling = sibling;
6345 }
6346 }
6347 }
6348 }
2ba6ecf4
GS		 6349 scalar(o2);
6350 break;
5b794e05
JH		 6351 case '[': case ']':
6352 goto oops;
6353 break;
4633a7c4
LW		 6354 case '\\':
6355 proto++;
6356 arg++;
5b794e05 6357 again:
4633a7c4 6358 switch (*proto++) {
5b794e05
JH		 6359 case '[':
6360 if (contextclass++ == 0) {
841d93c8 6361 e = strchr(proto, ']');
5b794e05
JH		 6362 if (!e || e == proto)
6363 goto oops;
6364 }
6365 else
6366 goto oops;
6367 goto again;
6368 break;
6369 case ']':
466bafcd 6370 if (contextclass) {
6867be6d
AL		 6371 char *p = proto;
6372 const char s = *p;
466bafcd
RGS		 6373 contextclass = 0;
6374 *p = '\0';
6375 while (*--p != '[');
1eb1540c 6376 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6377 gv_ename(namegv), o2);
6378 *proto = s;
6379 } else
5b794e05
JH		 6380 goto oops;
6381 break;
4633a7c4 6382 case '*':
5b794e05
JH		 6383 if (o2->op_type == OP_RV2GV)
6384 goto wrapref;
6385 if (!contextclass)
6386 bad_type(arg, "symbol", gv_ename(namegv), o2);
6387 break;
4633a7c4 6388 case '&':
5b794e05
JH		 6389 if (o2->op_type == OP_ENTERSUB)
6390 goto wrapref;
6391 if (!contextclass)
6392 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6393 break;
4633a7c4 6394 case '$':
5b794e05
JH		 6395 if (o2->op_type == OP_RV2SV ||
6396 o2->op_type == OP_PADSV ||
6397 o2->op_type == OP_HELEM ||
6398 o2->op_type == OP_AELEM ||
6399 o2->op_type == OP_THREADSV)
6400 goto wrapref;
6401 if (!contextclass)
5dc0d613 6402 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6403 break;
4633a7c4 6404 case '@':
5b794e05
JH		 6405 if (o2->op_type == OP_RV2AV ||
6406 o2->op_type == OP_PADAV)
6407 goto wrapref;
6408 if (!contextclass)
5dc0d613 6409 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6410 break;
4633a7c4 6411 case '%':
5b794e05
JH		 6412 if (o2->op_type == OP_RV2HV ||
6413 o2->op_type == OP_PADHV)
6414 goto wrapref;
6415 if (!contextclass)
6416 bad_type(arg, "hash", gv_ename(namegv), o2);
6417 break;
6418 wrapref:
4633a7c4 6419 {
551405c4
AL		 6420 OP* const kid = o2;
6421 OP* const sib = kid->op_sibling;
4633a7c4 6422 kid->op_sibling = 0;
6fa846a0
GS		 6423 o2 = newUNOP(OP_REFGEN, 0, kid);
6424 o2->op_sibling = sib;
e858de61 6425 prev->op_sibling = o2;
4633a7c4 6426 }
841d93c8 6427 if (contextclass && e) {
5b794e05
JH		 6428 proto = e + 1;
6429 contextclass = 0;
6430 }
4633a7c4
LW		 6431 break;
6432 default: goto oops;
6433 }
5b794e05
JH		 6434 if (contextclass)
6435 goto again;
4633a7c4 6436 break;
b1cb66bf 6437 case ' ':
6438 proto++;
6439 continue;
4633a7c4
LW		 6440 default:
6441 oops:
35c1215d
NC		 6442 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6443 gv_ename(namegv), cv);
4633a7c4
LW		 6444 }
6445 }
6446 else
11343788
MB		 6447 list(o2);
6448 mod(o2, OP_ENTERSUB);
6449 prev = o2;
6450 o2 = o2->op_sibling;
551405c4 6451 } /* while */
fb73857a 6452 if (proto && !optional &&
6453 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6454 return too_few_arguments(o, gv_ename(namegv));
0723351e 6455 if(delete_op) {
06492da6
SF		 6456 op_free(o);
6457 o=newSVOP(OP_CONST, 0, newSViv(0));
6458 }
11343788 6459 return o;
79072805
LW		 6460}
6461
6462OP *
cea2e8a9 6463Perl_ck_svconst(pTHX_ OP *o)
8990e307 6464{
11343788
MB		 6465 SvREADONLY_on(cSVOPo->op_sv);
6466 return o;
8990e307
LW		 6467}
6468
6469OP *
cea2e8a9 6470Perl_ck_trunc(pTHX_ OP *o)
79072805 6471{
11343788
MB		 6472 if (o->op_flags & OPf_KIDS) {
6473 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6474
a0d0e21e
LW		 6475 if (kid->op_type == OP_NULL)
6476 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6477 if (kid && kid->op_type == OP_CONST &&
6478 (kid->op_private & OPpCONST_BARE))
6479 {
11343788 6480 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6481 kid->op_private &= ~OPpCONST_STRICT;
6482 }
79072805 6483 }
11343788 6484 return ck_fun(o);
79072805
LW		 6485}
6486
35fba0d9 6487OP *
bab9c0ac
RGS		 6488Perl_ck_unpack(pTHX_ OP *o)
6489{
6490 OP *kid = cLISTOPo->op_first;
6491 if (kid->op_sibling) {
6492 kid = kid->op_sibling;
6493 if (!kid->op_sibling)
6494 kid->op_sibling = newDEFSVOP();
6495 }
6496 return ck_fun(o);
6497}
6498
6499OP *
35fba0d9
RG		 6500Perl_ck_substr(pTHX_ OP *o)
6501{
6502 o = ck_fun(o);
6503 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6504 OP *kid = cLISTOPo->op_first;
6505
6506 if (kid->op_type == OP_NULL)
6507 kid = kid->op_sibling;
6508 if (kid)
6509 kid->op_flags |= OPf_MOD;
6510
6511 }
6512 return o;
6513}
6514
61b743bb
DM		 6515/* A peephole optimizer. We visit the ops in the order they're to execute.
6516 * See the comments at the top of this file for more details about when
6517 * peep() is called */
463ee0b2 6518
79072805 6519void
864dbfa3 6520Perl_peep(pTHX_ register OP *o)
79072805 6521{
27da23d5 6522 dVAR;
79072805 6523 register OP* oldop = 0;
2d8e6c8d 6524
2814eb74 6525 if (!o || o->op_opt)
79072805 6526 return;
a0d0e21e 6527 ENTER;
462e5cf6 6528 SAVEOP();
7766f137 6529 SAVEVPTR(PL_curcop);
a0d0e21e 6530 for (; o; o = o->op_next) {
2814eb74 6531 if (o->op_opt)
a0d0e21e 6532 break;
533c011a 6533 PL_op = o;
a0d0e21e 6534 switch (o->op_type) {
acb36ea4 6535 case OP_SETSTATE:
a0d0e21e
LW		 6536 case OP_NEXTSTATE:
6537 case OP_DBSTATE:
3280af22 6538 PL_curcop = ((COP*)o); /* for warnings */
2814eb74 6539 o->op_opt = 1;
a0d0e21e
LW		 6540 break;
6541
a0d0e21e 6542 case OP_CONST:
7a52d87a
GS		 6543 if (cSVOPo->op_private & OPpCONST_STRICT)
6544 no_bareword_allowed(o);
7766f137 6545#ifdef USE_ITHREADS
3848b962 6546 case OP_METHOD_NAMED:
7766f137
GS		 6547 /* Relocate sv to the pad for thread safety.
6548 * Despite being a "constant", the SV is written to,
6549 * for reference counts, sv_upgrade() etc. */
6550 if (cSVOP->op_sv) {
6867be6d 6551 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 6552 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6553 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6554 * some pad, so make a copy. */
dd2155a4
DM		 6555 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6556 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6557 SvREFCNT_dec(cSVOPo->op_sv);
6558 }
6559 else {
dd2155a4 6560 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6561 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 6562 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6563 /* XXX I don't know how this isn't readonly already. */
dd2155a4 6564 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6565 }
7766f137
GS		 6566 cSVOPo->op_sv = Nullsv;
6567 o->op_targ = ix;
6568 }
6569#endif
2814eb74 6570 o->op_opt = 1;
07447971
GS		 6571 break;
6572
df91b2c5
AE		 6573 case OP_CONCAT:
6574 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6575 if (o->op_next->op_private & OPpTARGET_MY) {
6576 if (o->op_flags & OPf_STACKED) /* chained concats */
6577 goto ignore_optimization;
6578 else {
6579 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6580 o->op_targ = o->op_next->op_targ;
6581 o->op_next->op_targ = 0;
6582 o->op_private |= OPpTARGET_MY;
6583 }
6584 }
6585 op_null(o->op_next);
6586 }
6587 ignore_optimization:
2814eb74 6588 o->op_opt = 1;
df91b2c5 6589 break;
8990e307 6590 case OP_STUB:
54310121 6591 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
2814eb74 6592 o->op_opt = 1;
54310121 6593 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6594 }
748a9306 6595 goto nothin;
79072805 6596 case OP_NULL:
acb36ea4
GS		 6597 if (o->op_targ == OP_NEXTSTATE
6598 || o->op_targ == OP_DBSTATE
6599 || o->op_targ == OP_SETSTATE)
6600 {
3280af22 6601 PL_curcop = ((COP*)o);
acb36ea4 6602 }
dad75012
AMS		 6603 /* XXX: We avoid setting op_seq here to prevent later calls
6604 to peep() from mistakenly concluding that optimisation
6605 has already occurred. This doesn't fix the real problem,
6606 though (See 20010220.007). AMS 20010719 */
2814eb74 6607 /* op_seq functionality is now replaced by op_opt */
dad75012
AMS		 6608 if (oldop && o->op_next) {
6609 oldop->op_next = o->op_next;
6610 continue;
6611 }
6612 break;
79072805 6613 case OP_SCALAR:
93a17b20 6614 case OP_LINESEQ:
463ee0b2 6615 case OP_SCOPE:
748a9306 6616 nothin:
a0d0e21e
LW		 6617 if (oldop && o->op_next) {
6618 oldop->op_next = o->op_next;
79072805
LW		 6619 continue;
6620 }
2814eb74 6621 o->op_opt = 1;
79072805
LW		 6622 break;
6623
6a077020 6624 case OP_PADAV:
79072805 6625 case OP_GV:
6a077020
DM		 6626 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6627 OP* pop = (o->op_type == OP_PADAV) ?
6628 o->op_next : o->op_next->op_next;
a0d0e21e 6629 IV i;
f9dc862f 6630 if (pop && pop->op_type == OP_CONST &&
af5acbb4 6631 ((PL_op = pop->op_next)) &&
8990e307 6632 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6633 !(pop->op_next->op_private &
78f9721b 6634 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6635 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6636 <= 255 &&
8990e307
LW		 6637 i >= 0)
6638 {
350de78d 6639 GV *gv;
af5acbb4
DM		 6640 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6641 no_bareword_allowed(pop);
6a077020
DM		 6642 if (o->op_type == OP_GV)
6643 op_null(o->op_next);
93c66552
DM		 6644 op_null(pop->op_next);
6645 op_null(pop);
a0d0e21e
LW		 6646 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6647 o->op_next = pop->op_next->op_next;
22c35a8c 6648 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6649 o->op_private = (U8)i;
6a077020
DM		 6650 if (o->op_type == OP_GV) {
6651 gv = cGVOPo_gv;
6652 GvAVn(gv);
6653 }
6654 else
6655 o->op_flags |= OPf_SPECIAL;
6656 o->op_type = OP_AELEMFAST;
6657 }
6658 o->op_opt = 1;
6659 break;
6660 }
6661
6662 if (o->op_next->op_type == OP_RV2SV) {
6663 if (!(o->op_next->op_private & OPpDEREF)) {
6664 op_null(o->op_next);
6665 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6666 | OPpOUR_INTRO);
6667 o->op_next = o->op_next->op_next;
6668 o->op_type = OP_GVSV;
6669 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 6670 }
79072805 6671 }
e476b1b5 6672 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 6673 GV * const gv = cGVOPo_gv;
b15aece3 6674 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 6675 /* XXX could check prototype here instead of just carping */
551405c4 6676 SV * const sv = sv_newmortal();
76cd736e 6677 gv_efullname3(sv, gv, Nullch);
9014280d 6678 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d
NC		 6679 "%"SVf"() called too early to check prototype",
6680 sv);
76cd736e
GS		 6681 }
6682 }
89de2904
AMS		 6683 else if (o->op_next->op_type == OP_READLINE
6684 && o->op_next->op_next->op_type == OP_CONCAT
6685 && (o->op_next->op_next->op_flags & OPf_STACKED))
6686 {
d2c45030
AMS		 6687 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6688 o->op_type = OP_RCATLINE;
6689 o->op_flags |= OPf_STACKED;
6690 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6691 op_null(o->op_next->op_next);
d2c45030 6692 op_null(o->op_next);
89de2904 6693 }
76cd736e 6694
2814eb74 6695 o->op_opt = 1;
79072805
LW		 6696 break;
6697
a0d0e21e 6698 case OP_MAPWHILE:
79072805
LW		 6699 case OP_GREPWHILE:
6700 case OP_AND:
6701 case OP_OR:
c963b151 6702 case OP_DOR:
2c2d71f5
JH		 6703 case OP_ANDASSIGN:
6704 case OP_ORASSIGN:
c963b151 6705 case OP_DORASSIGN:
1a67a97c
SM		 6706 case OP_COND_EXPR:
6707 case OP_RANGE:
2814eb74 6708 o->op_opt = 1;
fd4d1407
IZ		 6709 while (cLOGOP->op_other->op_type == OP_NULL)
6710 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 6711 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 6712 break;
6713
79072805 6714 case OP_ENTERLOOP:
9c2ca71a 6715 case OP_ENTERITER:
2814eb74 6716 o->op_opt = 1;
58cccf98
SM		 6717 while (cLOOP->op_redoop->op_type == OP_NULL)
6718 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6719 peep(cLOOP->op_redoop);
58cccf98
SM		 6720 while (cLOOP->op_nextop->op_type == OP_NULL)
6721 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6722 peep(cLOOP->op_nextop);
58cccf98
SM		 6723 while (cLOOP->op_lastop->op_type == OP_NULL)
6724 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6725 peep(cLOOP->op_lastop);
6726 break;
6727
8782bef2 6728 case OP_QR:
79072805
LW		 6729 case OP_MATCH:
6730 case OP_SUBST:
2814eb74 6731 o->op_opt = 1;
9041c2e3 6732 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6733 cPMOP->op_pmreplstart->op_type == OP_NULL)
6734 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6735 peep(cPMOP->op_pmreplstart);
79072805
LW		 6736 break;
6737
a0d0e21e 6738 case OP_EXEC:
2814eb74 6739 o->op_opt = 1;
041457d9
DM		 6740 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6741 && ckWARN(WARN_SYNTAX))
6742 {
a0d0e21e 6743 if (o->op_next->op_sibling &&
20408e3c
GS		 6744 o->op_next->op_sibling->op_type != OP_EXIT &&
6745 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6746 o->op_next->op_sibling->op_type != OP_DIE) {
6867be6d 6747 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 6748
57843af0 6749 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 6750 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 6751 "Statement unlikely to be reached");
9014280d 6752 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 6753 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 6754 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 6755 }
6756 }
6757 break;
b2ffa427 6758
c750a3ec 6759 case OP_HELEM: {
e75d1f10 6760 UNOP *rop;
6d822dc4 6761 SV *lexname;
e75d1f10 6762 GV **fields;
6d822dc4 6763 SV **svp, *sv;
d5263905 6764 const char *key = NULL;
c750a3ec 6765 STRLEN keylen;
b2ffa427 6766
2814eb74 6767 o->op_opt = 1;
1c846c1f
NIS		 6768
6769 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6770 break;
1c846c1f
NIS		 6771
6772 /* Make the CONST have a shared SV */
6773 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6774 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
d5263905 6775 key = SvPV_const(sv, keylen);
25716404
GS		 6776 lexname = newSVpvn_share(key,
6777 SvUTF8(sv) ? -(I32)keylen : keylen,
6778 0);
1c846c1f
NIS		 6779 SvREFCNT_dec(sv);
6780 *svp = lexname;
6781 }
e75d1f10
RD		 6782
6783 if ((o->op_private & (OPpLVAL_INTRO)))
6784 break;
6785
6786 rop = (UNOP*)((BINOP*)o)->op_first;
6787 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6788 break;
6789 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6790 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6791 break;
6792 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6793 if (!fields || !GvHV(*fields))
6794 break;
93524f2b 6795 key = SvPV_const(*svp, keylen);
e75d1f10
RD		 6796 if (!hv_fetch(GvHV(*fields), key,
6797 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6798 {
6799 Perl_croak(aTHX_ "No such class field \"%s\" "
6800 "in variable %s of type %s",
93524f2b 6801 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 6802 }
6803
6d822dc4
MS		 6804 break;
6805 }
c750a3ec 6806
e75d1f10
RD		 6807 case OP_HSLICE: {
6808 UNOP *rop;
6809 SV *lexname;
6810 GV **fields;
6811 SV **svp;
93524f2b 6812 const char *key;
e75d1f10
RD		 6813 STRLEN keylen;
6814 SVOP *first_key_op, *key_op;
6815
6816 if ((o->op_private & (OPpLVAL_INTRO))
6817 /* I bet there's always a pushmark... */
6818 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6819 /* hmmm, no optimization if list contains only one key. */
6820 break;
6821 rop = (UNOP*)((LISTOP*)o)->op_last;
6822 if (rop->op_type != OP_RV2HV)
6823 break;
6824 if (rop->op_first->op_type == OP_PADSV)
6825 /* @$hash{qw(keys here)} */
6826 rop = (UNOP*)rop->op_first;
6827 else {
6828 /* @{$hash}{qw(keys here)} */
6829 if (rop->op_first->op_type == OP_SCOPE
6830 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6831 {
6832 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6833 }
6834 else
6835 break;
6836 }
6837
6838 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6839 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6840 break;
6841 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6842 if (!fields || !GvHV(*fields))
6843 break;
6844 /* Again guessing that the pushmark can be jumped over.... */
6845 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6846 ->op_first->op_sibling;
6847 for (key_op = first_key_op; key_op;
6848 key_op = (SVOP*)key_op->op_sibling) {
6849 if (key_op->op_type != OP_CONST)
6850 continue;
6851 svp = cSVOPx_svp(key_op);
93524f2b 6852 key = SvPV_const(*svp, keylen);
e75d1f10
RD		 6853 if (!hv_fetch(GvHV(*fields), key,
6854 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6855 {
6856 Perl_croak(aTHX_ "No such class field \"%s\" "
6857 "in variable %s of type %s",
bfcb3514 6858 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 6859 }
6860 }
6861 break;
6862 }
6863
fe1bc4cf 6864 case OP_SORT: {
fe1bc4cf 6865 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 6866 OP *oleft;
fe1bc4cf
DM		 6867 OP *o2;
6868
fe1bc4cf 6869 /* check that RHS of sort is a single plain array */
551405c4 6870 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 6871 if (!oright || oright->op_type != OP_PUSHMARK)
6872 break;
471178c0
NC		 6873
6874 /* reverse sort ... can be optimised. */
6875 if (!cUNOPo->op_sibling) {
6876 /* Nothing follows us on the list. */
551405c4 6877 OP * const reverse = o->op_next;
471178c0
NC		 6878
6879 if (reverse->op_type == OP_REVERSE &&
6880 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 6881 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 6882 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6883 && (cUNOPx(pushmark)->op_sibling == o)) {
6884 /* reverse -> pushmark -> sort */
6885 o->op_private |= OPpSORT_REVERSE;
6886 op_null(reverse);
6887 pushmark->op_next = oright->op_next;
6888 op_null(oright);
6889 }
6890 }
6891 }
6892
6893 /* make @a = sort @a act in-place */
6894
6895 o->op_opt = 1;
6896
fe1bc4cf
DM		 6897 oright = cUNOPx(oright)->op_sibling;
6898 if (!oright)
6899 break;
6900 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6901 oright = cUNOPx(oright)->op_sibling;
6902 }
6903
6904 if (!oright ||
6905 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6906 || oright->op_next != o
6907 || (oright->op_private & OPpLVAL_INTRO)
6908 )
6909 break;
6910
6911 /* o2 follows the chain of op_nexts through the LHS of the
6912 * assign (if any) to the aassign op itself */
6913 o2 = o->op_next;
6914 if (!o2 || o2->op_type != OP_NULL)
6915 break;
6916 o2 = o2->op_next;
6917 if (!o2 || o2->op_type != OP_PUSHMARK)
6918 break;
6919 o2 = o2->op_next;
6920 if (o2 && o2->op_type == OP_GV)
6921 o2 = o2->op_next;
6922 if (!o2
6923 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6924 || (o2->op_private & OPpLVAL_INTRO)
6925 )
6926 break;
6927 oleft = o2;
6928 o2 = o2->op_next;
6929 if (!o2 || o2->op_type != OP_NULL)
6930 break;
6931 o2 = o2->op_next;
6932 if (!o2 || o2->op_type != OP_AASSIGN
6933 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6934 break;
6935
db7511db
DM		 6936 /* check that the sort is the first arg on RHS of assign */
6937
6938 o2 = cUNOPx(o2)->op_first;
6939 if (!o2 || o2->op_type != OP_NULL)
6940 break;
6941 o2 = cUNOPx(o2)->op_first;
6942 if (!o2 || o2->op_type != OP_PUSHMARK)
6943 break;
6944 if (o2->op_sibling != o)
6945 break;
6946
fe1bc4cf
DM		 6947 /* check the array is the same on both sides */
6948 if (oleft->op_type == OP_RV2AV) {
6949 if (oright->op_type != OP_RV2AV
6950 || !cUNOPx(oright)->op_first
6951 || cUNOPx(oright)->op_first->op_type != OP_GV
6952 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6953 cGVOPx_gv(cUNOPx(oright)->op_first)
6954 )
6955 break;
6956 }
6957 else if (oright->op_type != OP_PADAV
6958 || oright->op_targ != oleft->op_targ
6959 )
6960 break;
6961
6962 /* transfer MODishness etc from LHS arg to RHS arg */
6963 oright->op_flags = oleft->op_flags;
6964 o->op_private |= OPpSORT_INPLACE;
6965
6966 /* excise push->gv->rv2av->null->aassign */
6967 o2 = o->op_next->op_next;
6968 op_null(o2); /* PUSHMARK */
6969 o2 = o2->op_next;
6970 if (o2->op_type == OP_GV) {
6971 op_null(o2); /* GV */
6972 o2 = o2->op_next;
6973 }
6974 op_null(o2); /* RV2AV or PADAV */
6975 o2 = o2->op_next->op_next;
6976 op_null(o2); /* AASSIGN */
6977
6978 o->op_next = o2->op_next;
6979
6980 break;
6981 }
ef3e5ea9
NC		 6982
6983 case OP_REVERSE: {
e682d7b7 6984 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 6985 OP *gvop = NULL;
ef3e5ea9
NC		 6986 LISTOP *enter, *exlist;
6987 o->op_opt = 1;
6988
6989 enter = (LISTOP *) o->op_next;
6990 if (!enter)
6991 break;
6992 if (enter->op_type == OP_NULL) {
6993 enter = (LISTOP *) enter->op_next;
6994 if (!enter)
6995 break;
6996 }
d46f46af
NC		 6997 /* for $a (...) will have OP_GV then OP_RV2GV here.
6998 for (...) just has an OP_GV. */
ce335f37
NC		 6999 if (enter->op_type == OP_GV) {
7000 gvop = (OP *) enter;
7001 enter = (LISTOP *) enter->op_next;
7002 if (!enter)
7003 break;
d46f46af
NC		 7004 if (enter->op_type == OP_RV2GV) {
7005 enter = (LISTOP *) enter->op_next;
7006 if (!enter)
ce335f37 7007 break;
d46f46af 7008 }
ce335f37
NC		 7009 }
7010
ef3e5ea9
NC		 7011 if (enter->op_type != OP_ENTERITER)
7012 break;
7013
7014 iter = enter->op_next;
7015 if (!iter || iter->op_type != OP_ITER)
7016 break;
7017
ce335f37
NC		 7018 expushmark = enter->op_first;
7019 if (!expushmark || expushmark->op_type != OP_NULL
7020 || expushmark->op_targ != OP_PUSHMARK)
7021 break;
7022
7023 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 7024 if (!exlist || exlist->op_type != OP_NULL
7025 || exlist->op_targ != OP_LIST)
7026 break;
7027
7028 if (exlist->op_last != o) {
7029 /* Mmm. Was expecting to point back to this op. */
7030 break;
7031 }
7032 theirmark = exlist->op_first;
7033 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7034 break;
7035
c491ecac 7036 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 7037 /* There's something between the mark and the reverse, eg
7038 for (1, reverse (...))
7039 so no go. */
7040 break;
7041 }
7042
c491ecac
NC		 7043 ourmark = ((LISTOP *)o)->op_first;
7044 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7045 break;
7046
ef3e5ea9
NC		 7047 ourlast = ((LISTOP *)o)->op_last;
7048 if (!ourlast || ourlast->op_next != o)
7049 break;
7050
e682d7b7
NC		 7051 rv2av = ourmark->op_sibling;
7052 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7053 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7054 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7055 /* We're just reversing a single array. */
7056 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7057 enter->op_flags |= OPf_STACKED;
7058 }
7059
ef3e5ea9
NC		 7060 /* We don't have control over who points to theirmark, so sacrifice
7061 ours. */
7062 theirmark->op_next = ourmark->op_next;
7063 theirmark->op_flags = ourmark->op_flags;
ce335f37 7064 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 7065 op_null(ourmark);
7066 op_null(o);
7067 enter->op_private |= OPpITER_REVERSED;
7068 iter->op_private |= OPpITER_REVERSED;
7069
7070 break;
7071 }
fe1bc4cf 7072
79072805 7073 default:
2814eb74 7074 o->op_opt = 1;
79072805
LW		 7075 break;
7076 }
a0d0e21e 7077 oldop = o;
79072805 7078 }
a0d0e21e 7079 LEAVE;
79072805 7080}
beab0874 7081
1cb0ed9b
RGS		 7082char*
7083Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 7084{
e1ec3a88 7085 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 7086 SV* keysv;
7087 HE* he;
7088
7089 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 7090 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 7091
7092 keysv = sv_2mortal(newSViv(index));
7093
7094 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7095 if (!he)
27da23d5 7096 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 7097
7098 return SvPV_nolen(HeVAL(he));
7099}
7100
1cb0ed9b
RGS		 7101char*
7102Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 7103{
e1ec3a88 7104 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 7105 SV* keysv;
7106 HE* he;
7107
7108 if (!PL_custom_op_descs)
27da23d5 7109 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 7110
7111 keysv = sv_2mortal(newSViv(index));
7112
7113 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7114 if (!he)
27da23d5 7115 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 7116
7117 return SvPV_nolen(HeVAL(he));
7118}
19e8ce8e 7119
beab0874
JT		 7120#include "XSUB.h"
7121
7122/* Efficient sub that returns a constant scalar value. */
7123static void
acfe0abc 7124const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 7125{
7126 dXSARGS;
9cbac4c7
DM		 7127 if (items != 0) {
7128#if 0
7129 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 7130 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 7131#endif
7132 }
9a049f1c 7133 EXTEND(sp, 1);
0768512c 7134 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 7135 XSRETURN(1);
7136}
4946a0fa
NC		 7137
7138/*
7139 * Local variables:
7140 * c-indentation-style: bsd
7141 * c-basic-offset: 4
7142 * indent-tabs-mode: t
7143 * End:
7144 *
37442d52
RGS		 7145 * ex: set ts=8 sts=4 sw=4 noet:
7146 */
Unnamed repository; edit this file 'description' to name the repository.