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