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