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