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