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