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
Ultrix VAX is like VMS VAX in floating point.
[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 3753 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 3754 * for our $x () sets OPpOUR_INTRO */
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
5383bea4
MHM		 3799static void const_sv_xsub(pTHX_ CV* cv);
3800
7dafbf52
DM		 3801/*
3802=for apidoc cv_undef
3803
3804Clear out all the active components of a CV. This can happen either
3805by an explicit C<undef &foo>, or by the reference count going to zero.
3806In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3807children can still follow the full lexical scope chain.
3808
3809=cut
3810*/
3811
79072805 3812void
864dbfa3 3813Perl_cv_undef(pTHX_ CV *cv)
79072805 3814{
a636914a 3815#ifdef USE_ITHREADS
5383bea4
MHM		 3816 if (CvFILE(cv) && (!CvXSUB(cv) || CvXSUB(cv) == const_sv_xsub)) {
3817 /* for XSUBs CvFILE point directly to static memory; __FILE__
3818 * except when XSUB was constructed via newCONSTSUB() */
a636914a 3819 Safefree(CvFILE(cv));
a636914a 3820 }
f3e31eb5 3821 CvFILE(cv) = 0;
a636914a
RH		 3822#endif
3823
a0d0e21e
LW		 3824 if (!CvXSUB(cv) && CvROOT(cv)) {
3825 if (CvDEPTH(cv))
cea2e8a9 3826 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 3827 ENTER;
a0d0e21e 3828
f3548bdc 3829 PAD_SAVE_SETNULLPAD();
a0d0e21e 3830
282f25c9 3831 op_free(CvROOT(cv));
79072805 3832 CvROOT(cv) = Nullop;
8990e307 3833 LEAVE;
79072805 3834 }
1d5db326 3835 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 3836 CvGV(cv) = Nullgv;
a3985cdc
DM		 3837
3838 pad_undef(cv);
3839
7dafbf52
DM		 3840 /* remove CvOUTSIDE unless this is an undef rather than a free */
3841 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3842 if (!CvWEAKOUTSIDE(cv))
3843 SvREFCNT_dec(CvOUTSIDE(cv));
3844 CvOUTSIDE(cv) = Nullcv;
3845 }
beab0874
JT		 3846 if (CvCONST(cv)) {
3847 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3848 CvCONST_off(cv);
3849 }
50762d59
DM		 3850 if (CvXSUB(cv)) {
3851 CvXSUB(cv) = 0;
3852 }
7dafbf52
DM		 3853 /* delete all flags except WEAKOUTSIDE */
3854 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 3855}
3856
3fe9a6f1 3857void
864dbfa3 3858Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 3859{
e476b1b5 3860 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 3861 SV* msg = sv_newmortal();
3fe9a6f1 3862 SV* name = Nullsv;
3863
3864 if (gv)
46fc3d4c 3865 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3866 sv_setpv(msg, "Prototype mismatch:");
3867 if (name)
894356b3 3868 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 3869 if (SvPOK(cv))
35c1215d 3870 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
46fc3d4c 3871 sv_catpv(msg, " vs ");
3872 if (p)
cea2e8a9 3873 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 3874 else
3875 sv_catpv(msg, "none");
9014280d 3876 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3fe9a6f1 3877 }
3878}
3879
beab0874 3880/*
ccfc67b7
JH		 3881
3882=head1 Optree Manipulation Functions
3883
beab0874
JT		 3884=for apidoc cv_const_sv
3885
3886If C<cv> is a constant sub eligible for inlining. returns the constant
3887value returned by the sub. Otherwise, returns NULL.
3888
3889Constant subs can be created with C<newCONSTSUB> or as described in
3890L<perlsub/"Constant Functions">.
3891
3892=cut
3893*/
760ac839 3894SV *
864dbfa3 3895Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 3896{
beab0874 3897 if (!cv || !CvCONST(cv))
54310121 3898 return Nullsv;
beab0874 3899 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 3900}
760ac839 3901
b5c19bd7
DM		 3902/* op_const_sv: examine an optree to determine whether it's in-lineable.
3903 * Can be called in 3 ways:
3904 *
3905 * !cv
3906 * look for a single OP_CONST with attached value: return the value
3907 *
3908 * cv && CvCLONE(cv) && !CvCONST(cv)
3909 *
3910 * examine the clone prototype, and if contains only a single
3911 * OP_CONST referencing a pad const, or a single PADSV referencing
3912 * an outer lexical, return a non-zero value to indicate the CV is
3913 * a candidate for "constizing" at clone time
3914 *
3915 * cv && CvCONST(cv)
3916 *
3917 * We have just cloned an anon prototype that was marked as a const
3918 * candidiate. Try to grab the current value, and in the case of
3919 * PADSV, ignore it if it has multiple references. Return the value.
3920 */
3921
fe5e78ed 3922SV *
864dbfa3 3923Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 3924{
3925 SV *sv = Nullsv;
3926
0f79a09d 3927 if (!o)
fe5e78ed 3928 return Nullsv;
1c846c1f
NIS		 3929
3930 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 3931 o = cLISTOPo->op_first->op_sibling;
3932
3933 for (; o; o = o->op_next) {
54310121 3934 OPCODE type = o->op_type;
fe5e78ed 3935
1c846c1f 3936 if (sv && o->op_next == o)
fe5e78ed 3937 return sv;
e576b457
JT		 3938 if (o->op_next != o) {
3939 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3940 continue;
3941 if (type == OP_DBSTATE)
3942 continue;
3943 }
54310121 3944 if (type == OP_LEAVESUB || type == OP_RETURN)
3945 break;
3946 if (sv)
3947 return Nullsv;
7766f137 3948 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 3949 sv = cSVOPo->op_sv;
b5c19bd7 3950 else if (cv && type == OP_CONST) {
dd2155a4 3951 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874
JT		 3952 if (!sv)
3953 return Nullsv;
b5c19bd7
DM		 3954 }
3955 else if (cv && type == OP_PADSV) {
3956 if (CvCONST(cv)) { /* newly cloned anon */
3957 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3958 /* the candidate should have 1 ref from this pad and 1 ref
3959 * from the parent */
3960 if (!sv || SvREFCNT(sv) != 2)
3961 return Nullsv;
beab0874 3962 sv = newSVsv(sv);
b5c19bd7
DM		 3963 SvREADONLY_on(sv);
3964 return sv;
3965 }
3966 else {
3967 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3968 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 3969 }
760ac839 3970 }
b5c19bd7 3971 else {
54310121 3972 return Nullsv;
b5c19bd7 3973 }
760ac839
LW		 3974 }
3975 return sv;
3976}
3977
09bef843
SB		 3978void
3979Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3980{
3981 if (o)
3982 SAVEFREEOP(o);
3983 if (proto)
3984 SAVEFREEOP(proto);
3985 if (attrs)
3986 SAVEFREEOP(attrs);
3987 if (block)
3988 SAVEFREEOP(block);
3989 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3990}
3991
748a9306 3992CV *
864dbfa3 3993Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 3994{
09bef843
SB		 3995 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3996}
3997
3998CV *
3999Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4000{
2d8e6c8d 4001 STRLEN n_a;
83ee9e09
GS		 4002 char *name;
4003 char *aname;
4004 GV *gv;
2d8e6c8d 4005 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 4006 register CV *cv=0;
beab0874 4007 SV *const_sv;
79072805 4008
83ee9e09
GS		 4009 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4010 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4011 SV *sv = sv_newmortal();
c99da370
JH		 4012 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4013 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09
GS		 4014 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4015 aname = SvPVX(sv);
4016 }
4017 else
4018 aname = Nullch;
c99da370
JH		 4019 gv = gv_fetchpv(name ? name : (aname ? aname :
4020 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
83ee9e09
GS		 4021 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4022 SVt_PVCV);
4023
11343788 4024 if (o)
5dc0d613 4025 SAVEFREEOP(o);
3fe9a6f1 4026 if (proto)
4027 SAVEFREEOP(proto);
09bef843
SB		 4028 if (attrs)
4029 SAVEFREEOP(attrs);
3fe9a6f1 4030
09bef843 4031 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4032 maximum a prototype before. */
4033 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4034 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4035 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4036 {
9014280d 4037 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 4038 }
55d729e4
GS		 4039 cv_ckproto((CV*)gv, NULL, ps);
4040 }
4041 if (ps)
4042 sv_setpv((SV*)gv, ps);
4043 else
4044 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4045 SvREFCNT_dec(PL_compcv);
4046 cv = PL_compcv = NULL;
4047 PL_sub_generation++;
beab0874 4048 goto done;
55d729e4
GS		 4049 }
4050
beab0874
JT		 4051 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4052
7fb37951
AMS		 4053#ifdef GV_UNIQUE_CHECK
4054 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4055 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4056 }
4057#endif
4058
beab0874
JT		 4059 if (!block || !ps || *ps || attrs)
4060 const_sv = Nullsv;
4061 else
4062 const_sv = op_const_sv(block, Nullcv);
4063
4064 if (cv) {
60ed1d8c 4065 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4066
7fb37951
AMS		 4067#ifdef GV_UNIQUE_CHECK
4068 if (exists && GvUNIQUE(gv)) {
4069 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4070 }
4071#endif
4072
60ed1d8c
GS		 4073 /* if the subroutine doesn't exist and wasn't pre-declared
4074 * with a prototype, assume it will be AUTOLOADed,
4075 * skipping the prototype check
4076 */
4077 if (exists || SvPOK(cv))
01ec43d0 4078 cv_ckproto(cv, gv, ps);
68dc0745 4079 /* already defined (or promised)? */
60ed1d8c 4080 if (exists || GvASSUMECV(gv)) {
09bef843 4081 if (!block && !attrs) {
d3cea301
SB		 4082 if (CvFLAGS(PL_compcv)) {
4083 /* might have had built-in attrs applied */
4084 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4085 }
aa689395 4086 /* just a "sub foo;" when &foo is already defined */
3280af22 4087 SAVEFREESV(PL_compcv);
aa689395 4088 goto done;
4089 }
7bac28a0 4090 /* ahem, death to those who redefine active sort subs */
3280af22 4091 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4092 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4093 if (block) {
4094 if (ckWARN(WARN_REDEFINE)
4095 || (CvCONST(cv)
4096 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4097 {
4098 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4099 if (PL_copline != NOLINE)
4100 CopLINE_set(PL_curcop, PL_copline);
9014280d 4101 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4102 CvCONST(cv) ? "Constant subroutine %s redefined"
4103 : "Subroutine %s redefined", name);
4104 CopLINE_set(PL_curcop, oldline);
4105 }
4106 SvREFCNT_dec(cv);
4107 cv = Nullcv;
79072805 4108 }
79072805
LW		 4109 }
4110 }
beab0874
JT		 4111 if (const_sv) {
4112 SvREFCNT_inc(const_sv);
4113 if (cv) {
0768512c 4114 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4115 sv_setpv((SV*)cv, ""); /* prototype is "" */
4116 CvXSUBANY(cv).any_ptr = const_sv;
4117 CvXSUB(cv) = const_sv_xsub;
4118 CvCONST_on(cv);
beab0874
JT		 4119 }
4120 else {
4121 GvCV(gv) = Nullcv;
4122 cv = newCONSTSUB(NULL, name, const_sv);
4123 }
4124 op_free(block);
4125 SvREFCNT_dec(PL_compcv);
4126 PL_compcv = NULL;
4127 PL_sub_generation++;
4128 goto done;
4129 }
09bef843
SB		 4130 if (attrs) {
4131 HV *stash;
4132 SV *rcv;
4133
4134 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4135 * before we clobber PL_compcv.
4136 */
4137 if (cv && !block) {
4138 rcv = (SV*)cv;
020f0e03
SB		 4139 /* Might have had built-in attributes applied -- propagate them. */
4140 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4141 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4142 stash = GvSTASH(CvGV(cv));
a9164de8 4143 else if (CvSTASH(cv))
09bef843
SB		 4144 stash = CvSTASH(cv);
4145 else
4146 stash = PL_curstash;
4147 }
4148 else {
4149 /* possibly about to re-define existing subr -- ignore old cv */
4150 rcv = (SV*)PL_compcv;
a9164de8 4151 if (name && GvSTASH(gv))
09bef843
SB		 4152 stash = GvSTASH(gv);
4153 else
4154 stash = PL_curstash;
4155 }
95f0a2f1 4156 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4157 }
a0d0e21e 4158 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4159 if (!block) {
4160 /* got here with just attrs -- work done, so bug out */
4161 SAVEFREESV(PL_compcv);
4162 goto done;
4163 }
a3985cdc 4164 /* transfer PL_compcv to cv */
4633a7c4 4165 cv_undef(cv);
3280af22
NIS		 4166 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4167 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 4168 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 4169 CvOUTSIDE(PL_compcv) = 0;
4170 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4171 CvPADLIST(PL_compcv) = 0;
282f25c9 4172 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 4173 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 4174 /* ... before we throw it away */
3280af22 4175 SvREFCNT_dec(PL_compcv);
b5c19bd7 4176 PL_compcv = cv;
a933f601
IZ		 4177 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4178 ++PL_sub_generation;
a0d0e21e
LW		 4179 }
4180 else {
3280af22 4181 cv = PL_compcv;
44a8e56a 4182 if (name) {
4183 GvCV(gv) = cv;
4184 GvCVGEN(gv) = 0;
3280af22 4185 PL_sub_generation++;
44a8e56a 4186 }
a0d0e21e 4187 }
65c50114 4188 CvGV(cv) = gv;
a636914a 4189 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4190 CvSTASH(cv) = PL_curstash;
8990e307 4191
3fe9a6f1 4192 if (ps)
4193 sv_setpv((SV*)cv, ps);
4633a7c4 4194
3280af22 4195 if (PL_error_count) {
c07a80fd 4196 op_free(block);
4197 block = Nullop;
68dc0745 4198 if (name) {
4199 char *s = strrchr(name, ':');
4200 s = s ? s+1 : name;
6d4c2119
CS		 4201 if (strEQ(s, "BEGIN")) {
4202 char *not_safe =
4203 "BEGIN not safe after errors--compilation aborted";
faef0170 4204 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4205 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4206 else {
4207 /* force display of errors found but not reported */
38a03e6e 4208 sv_catpv(ERRSV, not_safe);
35c1215d 4209 Perl_croak(aTHX_ "%"SVf, ERRSV);
6d4c2119
CS		 4210 }
4211 }
68dc0745 4212 }
c07a80fd 4213 }
beab0874
JT		 4214 if (!block)
4215 goto done;
a0d0e21e 4216
7766f137 4217 if (CvLVALUE(cv)) {
78f9721b
SM		 4218 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4219 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4220 }
4221 else {
4222 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4223 }
4224 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4225 OpREFCNT_set(CvROOT(cv), 1);
4226 CvSTART(cv) = LINKLIST(CvROOT(cv));
4227 CvROOT(cv)->op_next = 0;
a2efc822 4228 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4229
4230 /* now that optimizer has done its work, adjust pad values */
54310121 4231
dd2155a4
DM		 4232 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4233
4234 if (CvCLONE(cv)) {
beab0874
JT		 4235 assert(!CvCONST(cv));
4236 if (ps && !*ps && op_const_sv(block, cv))
4237 CvCONST_on(cv);
a0d0e21e 4238 }
79072805 4239
83ee9e09 4240 if (name || aname) {
44a8e56a 4241 char *s;
83ee9e09 4242 char *tname = (name ? name : aname);
44a8e56a 4243
3280af22 4244 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 4245 SV *sv = NEWSV(0,0);
44a8e56a 4246 SV *tmpstr = sv_newmortal();
549bb64a 4247 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 4248 CV *pcv;
44a8e56a 4249 HV *hv;
4250
ed094faf
GS		 4251 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4252 CopFILE(PL_curcop),
cc49e20b 4253 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4254 gv_efullname3(tmpstr, gv, Nullch);
3280af22 4255 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4256 hv = GvHVn(db_postponed);
9607fc9c 4257 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 4258 && (pcv = GvCV(db_postponed)))
4259 {
44a8e56a 4260 dSP;
924508f0 4261 PUSHMARK(SP);
44a8e56a 4262 XPUSHs(tmpstr);
4263 PUTBACK;
83ee9e09 4264 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 4265 }
4266 }
79072805 4267
83ee9e09 4268 if ((s = strrchr(tname,':')))
28757baa 4269 s++;
4270 else
83ee9e09 4271 s = tname;
ed094faf 4272
7d30b5c4 4273 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4274 goto done;
4275
7678c486 4276 if (strEQ(s, "BEGIN") && !PL_error_count) {
3280af22 4277 I32 oldscope = PL_scopestack_ix;
28757baa 4278 ENTER;
57843af0
GS		 4279 SAVECOPFILE(&PL_compiling);
4280 SAVECOPLINE(&PL_compiling);
28757baa 4281
3280af22
NIS		 4282 if (!PL_beginav)
4283 PL_beginav = newAV();
28757baa 4284 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4285 av_push(PL_beginav, (SV*)cv);
4286 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4287 call_list(oldscope, PL_beginav);
a6006777 4288
3280af22 4289 PL_curcop = &PL_compiling;
eb160463 4290 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
28757baa 4291 LEAVE;
4292 }
3280af22
NIS		 4293 else if (strEQ(s, "END") && !PL_error_count) {
4294 if (!PL_endav)
4295 PL_endav = newAV();
ed094faf 4296 DEBUG_x( dump_sub(gv) );
3280af22 4297 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4298 av_store(PL_endav, 0, (SV*)cv);
4299 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4300 }
7d30b5c4
GS		 4301 else if (strEQ(s, "CHECK") && !PL_error_count) {
4302 if (!PL_checkav)
4303 PL_checkav = newAV();
ed094faf 4304 DEBUG_x( dump_sub(gv) );
ddda08b7 4305 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4306 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4307 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4308 av_store(PL_checkav, 0, (SV*)cv);
4309 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4310 }
3280af22
NIS		 4311 else if (strEQ(s, "INIT") && !PL_error_count) {
4312 if (!PL_initav)
4313 PL_initav = newAV();
ed094faf 4314 DEBUG_x( dump_sub(gv) );
ddda08b7 4315 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4316 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4317 av_push(PL_initav, (SV*)cv);
4318 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4319 }
79072805 4320 }
a6006777 4321
aa689395 4322 done:
3280af22 4323 PL_copline = NOLINE;
8990e307 4324 LEAVE_SCOPE(floor);
a0d0e21e 4325 return cv;
79072805
LW		 4326}
4327
b099ddc0 4328/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4329/*
4330=for apidoc newCONSTSUB
4331
4332Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4333eligible for inlining at compile-time.
4334
4335=cut
4336*/
4337
beab0874 4338CV *
864dbfa3 4339Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 4340{
beab0874 4341 CV* cv;
5476c433 4342
11faa288 4343 ENTER;
11faa288 4344
f4dd75d9 4345 SAVECOPLINE(PL_curcop);
11faa288 4346 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4347
4348 SAVEHINTS();
3280af22 4349 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4350
4351 if (stash) {
4352 SAVESPTR(PL_curstash);
4353 SAVECOPSTASH(PL_curcop);
4354 PL_curstash = stash;
05ec9bb3 4355 CopSTASH_set(PL_curcop,stash);
11faa288 4356 }
5476c433 4357
91a15d0d 4358 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
beab0874
JT		 4359 CvXSUBANY(cv).any_ptr = sv;
4360 CvCONST_on(cv);
4361 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 4362
5383bea4
MHM		 4363 if (stash)
4364 CopSTASH_free(PL_curcop);
4365
11faa288 4366 LEAVE;
beab0874
JT		 4367
4368 return cv;
5476c433
JD		 4369}
4370
954c1994
GS		 4371/*
4372=for apidoc U||newXS
4373
4374Used by C<xsubpp> to hook up XSUBs as Perl subs.
4375
4376=cut
4377*/
4378
57d3b86d 4379CV *
864dbfa3 4380Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 4381{
c99da370
JH		 4382 GV *gv = gv_fetchpv(name ? name :
4383 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4384 GV_ADDMULTI, SVt_PVCV);
79072805 4385 register CV *cv;
44a8e56a 4386
1ecdd9a8
HS		 4387 if (!subaddr)
4388 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4389
155aba94 4390 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4391 if (GvCVGEN(gv)) {
4392 /* just a cached method */
4393 SvREFCNT_dec(cv);
4394 cv = 0;
4395 }
4396 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4397 /* already defined (or promised) */
599cee73 4398 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4 4399 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 4400 line_t oldline = CopLINE(PL_curcop);
51f6edd3 4401 if (PL_copline != NOLINE)
57843af0 4402 CopLINE_set(PL_curcop, PL_copline);
9014280d 4403 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4404 CvCONST(cv) ? "Constant subroutine %s redefined"
4405 : "Subroutine %s redefined"
4406 ,name);
57843af0 4407 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 4408 }
4409 SvREFCNT_dec(cv);
4410 cv = 0;
79072805 4411 }
79072805 4412 }
44a8e56a 4413
4414 if (cv) /* must reuse cv if autoloaded */
4415 cv_undef(cv);
a0d0e21e
LW		 4416 else {
4417 cv = (CV*)NEWSV(1105,0);
4418 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 4419 if (name) {
4420 GvCV(gv) = cv;
4421 GvCVGEN(gv) = 0;
3280af22 4422 PL_sub_generation++;
44a8e56a 4423 }
a0d0e21e 4424 }
65c50114 4425 CvGV(cv) = gv;
b195d487 4426 (void)gv_fetchfile(filename);
57843af0
GS		 4427 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4428 an external constant string */
a0d0e21e 4429 CvXSUB(cv) = subaddr;
44a8e56a 4430
28757baa 4431 if (name) {
4432 char *s = strrchr(name,':');
4433 if (s)
4434 s++;
4435 else
4436 s = name;
ed094faf 4437
7d30b5c4 4438 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4439 goto done;
4440
28757baa 4441 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 4442 if (!PL_beginav)
4443 PL_beginav = newAV();
ea2f84a3
GS		 4444 av_push(PL_beginav, (SV*)cv);
4445 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4446 }
4447 else if (strEQ(s, "END")) {
3280af22
NIS		 4448 if (!PL_endav)
4449 PL_endav = newAV();
4450 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4451 av_store(PL_endav, 0, (SV*)cv);
4452 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4453 }
7d30b5c4
GS		 4454 else if (strEQ(s, "CHECK")) {
4455 if (!PL_checkav)
4456 PL_checkav = newAV();
ddda08b7 4457 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4458 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4459 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4460 av_store(PL_checkav, 0, (SV*)cv);
4461 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4462 }
7d07dbc2 4463 else if (strEQ(s, "INIT")) {
3280af22
NIS		 4464 if (!PL_initav)
4465 PL_initav = newAV();
ddda08b7 4466 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4467 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4468 av_push(PL_initav, (SV*)cv);
4469 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4470 }
28757baa 4471 }
8990e307 4472 else
a5f75d66 4473 CvANON_on(cv);
44a8e56a 4474
ed094faf 4475done:
a0d0e21e 4476 return cv;
79072805
LW		 4477}
4478
4479void
864dbfa3 4480Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 4481{
4482 register CV *cv;
4483 char *name;
4484 GV *gv;
2d8e6c8d 4485 STRLEN n_a;
79072805 4486
11343788 4487 if (o)
2d8e6c8d 4488 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 4489 else
4490 name = "STDOUT";
85e6fe83 4491 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
7fb37951
AMS		 4492#ifdef GV_UNIQUE_CHECK
4493 if (GvUNIQUE(gv)) {
4494 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 4495 }
4496#endif
a5f75d66 4497 GvMULTI_on(gv);
155aba94 4498 if ((cv = GvFORM(gv))) {
599cee73 4499 if (ckWARN(WARN_REDEFINE)) {
57843af0 4500 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4501 if (PL_copline != NOLINE)
4502 CopLINE_set(PL_curcop, PL_copline);
9014280d 4503 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
57843af0 4504 CopLINE_set(PL_curcop, oldline);
79072805 4505 }
8990e307 4506 SvREFCNT_dec(cv);
79072805 4507 }
3280af22 4508 cv = PL_compcv;
79072805 4509 GvFORM(gv) = cv;
65c50114 4510 CvGV(cv) = gv;
a636914a 4511 CvFILE_set_from_cop(cv, PL_curcop);
79072805 4512
a0d0e21e 4513
dd2155a4 4514 pad_tidy(padtidy_FORMAT);
79072805 4515 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 4516 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4517 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 4518 CvSTART(cv) = LINKLIST(CvROOT(cv));
4519 CvROOT(cv)->op_next = 0;
a2efc822 4520 CALL_PEEP(CvSTART(cv));
11343788 4521 op_free(o);
3280af22 4522 PL_copline = NOLINE;
8990e307 4523 LEAVE_SCOPE(floor);
79072805
LW		 4524}
4525
4526OP *
864dbfa3 4527Perl_newANONLIST(pTHX_ OP *o)
79072805 4528{
93a17b20 4529 return newUNOP(OP_REFGEN, 0,
11343788 4530 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 4531}
4532
4533OP *
864dbfa3 4534Perl_newANONHASH(pTHX_ OP *o)
79072805 4535{
93a17b20 4536 return newUNOP(OP_REFGEN, 0,
11343788 4537 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 4538}
4539
4540OP *
864dbfa3 4541Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 4542{
09bef843
SB		 4543 return newANONATTRSUB(floor, proto, Nullop, block);
4544}
4545
4546OP *
4547Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4548{
a0d0e21e 4549 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 4550 newSVOP(OP_ANONCODE, 0,
4551 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 4552}
4553
4554OP *
864dbfa3 4555Perl_oopsAV(pTHX_ OP *o)
79072805 4556{
ed6116ce
LW		 4557 switch (o->op_type) {
4558 case OP_PADSV:
4559 o->op_type = OP_PADAV;
22c35a8c 4560 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 4561 return ref(o, OP_RV2AV);
b2ffa427 4562
ed6116ce 4563 case OP_RV2SV:
79072805 4564 o->op_type = OP_RV2AV;
22c35a8c 4565 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 4566 ref(o, OP_RV2AV);
ed6116ce
LW		 4567 break;
4568
4569 default:
0453d815 4570 if (ckWARN_d(WARN_INTERNAL))
9014280d 4571 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 4572 break;
4573 }
79072805
LW		 4574 return o;
4575}
4576
4577OP *
864dbfa3 4578Perl_oopsHV(pTHX_ OP *o)
79072805 4579{
ed6116ce
LW		 4580 switch (o->op_type) {
4581 case OP_PADSV:
4582 case OP_PADAV:
4583 o->op_type = OP_PADHV;
22c35a8c 4584 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 4585 return ref(o, OP_RV2HV);
ed6116ce
LW		 4586
4587 case OP_RV2SV:
4588 case OP_RV2AV:
79072805 4589 o->op_type = OP_RV2HV;
22c35a8c 4590 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 4591 ref(o, OP_RV2HV);
ed6116ce
LW		 4592 break;
4593
4594 default:
0453d815 4595 if (ckWARN_d(WARN_INTERNAL))
9014280d 4596 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 4597 break;
4598 }
79072805
LW		 4599 return o;
4600}
4601
4602OP *
864dbfa3 4603Perl_newAVREF(pTHX_ OP *o)
79072805 4604{
ed6116ce
LW		 4605 if (o->op_type == OP_PADANY) {
4606 o->op_type = OP_PADAV;
22c35a8c 4607 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 4608 return o;
ed6116ce 4609 }
a1063b2d 4610 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 4611 && ckWARN(WARN_DEPRECATED)) {
4612 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4613 "Using an array as a reference is deprecated");
4614 }
79072805
LW		 4615 return newUNOP(OP_RV2AV, 0, scalar(o));
4616}
4617
4618OP *
864dbfa3 4619Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 4620{
82092f1d 4621 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 4622 return newUNOP(OP_NULL, 0, o);
748a9306 4623 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 4624}
4625
4626OP *
864dbfa3 4627Perl_newHVREF(pTHX_ OP *o)
79072805 4628{
ed6116ce
LW		 4629 if (o->op_type == OP_PADANY) {
4630 o->op_type = OP_PADHV;
22c35a8c 4631 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 4632 return o;
ed6116ce 4633 }
a1063b2d 4634 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 4635 && ckWARN(WARN_DEPRECATED)) {
4636 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4637 "Using a hash as a reference is deprecated");
4638 }
79072805
LW		 4639 return newUNOP(OP_RV2HV, 0, scalar(o));
4640}
4641
4642OP *
864dbfa3 4643Perl_oopsCV(pTHX_ OP *o)
79072805 4644{
cea2e8a9 4645 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 4646 /* STUB */
4647 return o;
4648}
4649
4650OP *
864dbfa3 4651Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 4652{
c07a80fd 4653 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 4654}
4655
4656OP *
864dbfa3 4657Perl_newSVREF(pTHX_ OP *o)
79072805 4658{
ed6116ce
LW		 4659 if (o->op_type == OP_PADANY) {
4660 o->op_type = OP_PADSV;
22c35a8c 4661 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 4662 return o;
ed6116ce 4663 }
224a4551
MB		 4664 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4665 o->op_flags |= OPpDONE_SVREF;
a863c7d1 4666 return o;
224a4551 4667 }
79072805
LW		 4668 return newUNOP(OP_RV2SV, 0, scalar(o));
4669}
4670
4671/* Check routines. */
4672
4673OP *
cea2e8a9 4674Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 4675{
dd2155a4 4676 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5dc0d613 4677 cSVOPo->op_sv = Nullsv;
5dc0d613 4678 return o;
5f05dabc 4679}
4680
4681OP *
cea2e8a9 4682Perl_ck_bitop(pTHX_ OP *o)
55497cff 4683{
276b2a0c
RGS		 4684#define OP_IS_NUMCOMPARE(op) \
4685 ((op) == OP_LT || (op) == OP_I_LT || \
4686 (op) == OP_GT || (op) == OP_I_GT || \
4687 (op) == OP_LE || (op) == OP_I_LE || \
4688 (op) == OP_GE || (op) == OP_I_GE || \
4689 (op) == OP_EQ || (op) == OP_I_EQ || \
4690 (op) == OP_NE || (op) == OP_I_NE || \
4691 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 4692 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2b84528b
RGS		 4693 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4694 && (o->op_type == OP_BIT_OR
4695 || o->op_type == OP_BIT_AND
4696 || o->op_type == OP_BIT_XOR))
276b2a0c 4697 {
96a925ab
YST		 4698 OP * left = cBINOPo->op_first;
4699 OP * right = left->op_sibling;
4700 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4701 (left->op_flags & OPf_PARENS) == 0) ||
4702 (OP_IS_NUMCOMPARE(right->op_type) &&
4703 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 4704 if (ckWARN(WARN_PRECEDENCE))
4705 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4706 "Possible precedence problem on bitwise %c operator",
4707 o->op_type == OP_BIT_OR ? '|'
4708 : o->op_type == OP_BIT_AND ? '&' : '^'
4709 );
4710 }
5dc0d613 4711 return o;
55497cff 4712}
4713
4714OP *
cea2e8a9 4715Perl_ck_concat(pTHX_ OP *o)
79072805 4716{
0165acc7
AE		 4717 OP *kid = cUNOPo->op_first;
4718 if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
4719 o->op_flags |= OPf_STACKED;
11343788 4720 return o;
79072805
LW		 4721}
4722
4723OP *
cea2e8a9 4724Perl_ck_spair(pTHX_ OP *o)
79072805 4725{
11343788 4726 if (o->op_flags & OPf_KIDS) {
79072805 4727 OP* newop;
a0d0e21e 4728 OP* kid;
5dc0d613
MB		 4729 OPCODE type = o->op_type;
4730 o = modkids(ck_fun(o), type);
11343788 4731 kid = cUNOPo->op_first;
a0d0e21e
LW		 4732 newop = kUNOP->op_first->op_sibling;
4733 if (newop &&
4734 (newop->op_sibling ||
22c35a8c 4735 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 4736 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4737 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 4738
11343788 4739 return o;
a0d0e21e
LW		 4740 }
4741 op_free(kUNOP->op_first);
4742 kUNOP->op_first = newop;
4743 }
22c35a8c 4744 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 4745 return ck_fun(o);
a0d0e21e
LW		 4746}
4747
4748OP *
cea2e8a9 4749Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 4750{
11343788 4751 o = ck_fun(o);
5dc0d613 4752 o->op_private = 0;
11343788
MB		 4753 if (o->op_flags & OPf_KIDS) {
4754 OP *kid = cUNOPo->op_first;
01020589
GS		 4755 switch (kid->op_type) {
4756 case OP_ASLICE:
4757 o->op_flags |= OPf_SPECIAL;
4758 /* FALL THROUGH */
4759 case OP_HSLICE:
5dc0d613 4760 o->op_private |= OPpSLICE;
01020589
GS		 4761 break;
4762 case OP_AELEM:
4763 o->op_flags |= OPf_SPECIAL;
4764 /* FALL THROUGH */
4765 case OP_HELEM:
4766 break;
4767 default:
4768 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 4769 OP_DESC(o));
01020589 4770 }
93c66552 4771 op_null(kid);
79072805 4772 }
11343788 4773 return o;
79072805
LW		 4774}
4775
4776OP *
96e176bf
CL		 4777Perl_ck_die(pTHX_ OP *o)
4778{
4779#ifdef VMS
4780 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4781#endif
4782 return ck_fun(o);
4783}
4784
4785OP *
cea2e8a9 4786Perl_ck_eof(pTHX_ OP *o)
79072805 4787{
11343788 4788 I32 type = o->op_type;
79072805 4789
11343788
MB		 4790 if (o->op_flags & OPf_KIDS) {
4791 if (cLISTOPo->op_first->op_type == OP_STUB) {
4792 op_free(o);
8fde6460 4793 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8990e307 4794 }
11343788 4795 return ck_fun(o);
79072805 4796 }
11343788 4797 return o;
79072805
LW		 4798}
4799
4800OP *
cea2e8a9 4801Perl_ck_eval(pTHX_ OP *o)
79072805 4802{
3280af22 4803 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 4804 if (o->op_flags & OPf_KIDS) {
4805 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 4806
93a17b20 4807 if (!kid) {
11343788 4808 o->op_flags &= ~OPf_KIDS;
93c66552 4809 op_null(o);
79072805 4810 }
b14574b4 4811 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 4812 LOGOP *enter;
4813
11343788
MB		 4814 cUNOPo->op_first = 0;
4815 op_free(o);
79072805 4816
b7dc083c 4817 NewOp(1101, enter, 1, LOGOP);
79072805 4818 enter->op_type = OP_ENTERTRY;
22c35a8c 4819 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 4820 enter->op_private = 0;
4821
4822 /* establish postfix order */
4823 enter->op_next = (OP*)enter;
4824
11343788
MB		 4825 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4826 o->op_type = OP_LEAVETRY;
22c35a8c 4827 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 4828 enter->op_other = o;
4829 return o;
79072805 4830 }
b5c19bd7 4831 else {
473986ff 4832 scalar((OP*)kid);
b5c19bd7
DM		 4833 PL_cv_has_eval = 1;
4834 }
79072805
LW		 4835 }
4836 else {
11343788 4837 op_free(o);
54b9620d 4838 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 4839 }
3280af22 4840 o->op_targ = (PADOFFSET)PL_hints;
11343788 4841 return o;
79072805
LW		 4842}
4843
4844OP *
d98f61e7
GS		 4845Perl_ck_exit(pTHX_ OP *o)
4846{
4847#ifdef VMS
4848 HV *table = GvHV(PL_hintgv);
4849 if (table) {
4850 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4851 if (svp && *svp && SvTRUE(*svp))
4852 o->op_private |= OPpEXIT_VMSISH;
4853 }
96e176bf 4854 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 4855#endif
4856 return ck_fun(o);
4857}
4858
4859OP *
cea2e8a9 4860Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 4861{
4862 OP *kid;
11343788
MB		 4863 if (o->op_flags & OPf_STACKED) {
4864 o = ck_fun(o);
4865 kid = cUNOPo->op_first->op_sibling;
8990e307 4866 if (kid->op_type == OP_RV2GV)
93c66552 4867 op_null(kid);
79072805 4868 }
463ee0b2 4869 else
11343788
MB		 4870 o = listkids(o);
4871 return o;
79072805
LW		 4872}
4873
4874OP *
cea2e8a9 4875Perl_ck_exists(pTHX_ OP *o)
5f05dabc 4876{
5196be3e
MB		 4877 o = ck_fun(o);
4878 if (o->op_flags & OPf_KIDS) {
4879 OP *kid = cUNOPo->op_first;
afebc493
GS		 4880 if (kid->op_type == OP_ENTERSUB) {
4881 (void) ref(kid, o->op_type);
4882 if (kid->op_type != OP_RV2CV && !PL_error_count)
4883 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 4884 OP_DESC(o));
afebc493
GS		 4885 o->op_private |= OPpEXISTS_SUB;
4886 }
4887 else if (kid->op_type == OP_AELEM)
01020589
GS		 4888 o->op_flags |= OPf_SPECIAL;
4889 else if (kid->op_type != OP_HELEM)
4890 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 4891 OP_DESC(o));
93c66552 4892 op_null(kid);
5f05dabc 4893 }
5196be3e 4894 return o;
5f05dabc 4895}
4896
22c35a8c 4897#if 0
5f05dabc 4898OP *
cea2e8a9 4899Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 4900{
4901 o = fold_constants(o);
4902 if (o->op_type == OP_CONST)
4903 o->op_type = OP_GV;
4904 return o;
4905}
22c35a8c 4906#endif
79072805
LW		 4907
4908OP *
cea2e8a9 4909Perl_ck_rvconst(pTHX_ register OP *o)
79072805 4910{
11343788 4911 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 4912
3280af22 4913 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 4914 if (kid->op_type == OP_CONST) {
44a8e56a 4915 char *name;
4916 int iscv;
4917 GV *gv;
779c5bc9 4918 SV *kidsv = kid->op_sv;
2d8e6c8d 4919 STRLEN n_a;
44a8e56a 4920
779c5bc9
GS		 4921 /* Is it a constant from cv_const_sv()? */
4922 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4923 SV *rsv = SvRV(kidsv);
4924 int svtype = SvTYPE(rsv);
4925 char *badtype = Nullch;
4926
4927 switch (o->op_type) {
4928 case OP_RV2SV:
4929 if (svtype > SVt_PVMG)
4930 badtype = "a SCALAR";
4931 break;
4932 case OP_RV2AV:
4933 if (svtype != SVt_PVAV)
4934 badtype = "an ARRAY";
4935 break;
4936 case OP_RV2HV:
6d822dc4 4937 if (svtype != SVt_PVHV)
779c5bc9 4938 badtype = "a HASH";
779c5bc9
GS		 4939 break;
4940 case OP_RV2CV:
4941 if (svtype != SVt_PVCV)
4942 badtype = "a CODE";
4943 break;
4944 }
4945 if (badtype)
cea2e8a9 4946 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 4947 return o;
4948 }
2d8e6c8d 4949 name = SvPV(kidsv, n_a);
3280af22 4950 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 4951 char *badthing = Nullch;
5dc0d613 4952 switch (o->op_type) {
44a8e56a 4953 case OP_RV2SV:
4954 badthing = "a SCALAR";
4955 break;
4956 case OP_RV2AV:
4957 badthing = "an ARRAY";
4958 break;
4959 case OP_RV2HV:
4960 badthing = "a HASH";
4961 break;
4962 }
4963 if (badthing)
1c846c1f 4964 Perl_croak(aTHX_
44a8e56a 4965 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4966 name, badthing);
4967 }
93233ece
CS		 4968 /*
4969 * This is a little tricky. We only want to add the symbol if we
4970 * didn't add it in the lexer. Otherwise we get duplicate strict
4971 * warnings. But if we didn't add it in the lexer, we must at
4972 * least pretend like we wanted to add it even if it existed before,
4973 * or we get possible typo warnings. OPpCONST_ENTERED says
4974 * whether the lexer already added THIS instance of this symbol.
4975 */
5196be3e 4976 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 4977 do {
44a8e56a 4978 gv = gv_fetchpv(name,
748a9306 4979 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 4980 iscv
4981 ? SVt_PVCV
11343788 4982 : o->op_type == OP_RV2SV
a0d0e21e 4983 ? SVt_PV
11343788 4984 : o->op_type == OP_RV2AV
a0d0e21e 4985 ? SVt_PVAV
11343788 4986 : o->op_type == OP_RV2HV
a0d0e21e
LW		 4987 ? SVt_PVHV
4988 : SVt_PVGV);
93233ece
CS		 4989 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4990 if (gv) {
4991 kid->op_type = OP_GV;
4992 SvREFCNT_dec(kid->op_sv);
350de78d 4993#ifdef USE_ITHREADS
638eceb6 4994 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 4995 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 4996 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 4997 GvIN_PAD_on(gv);
dd2155a4 4998 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
350de78d 4999#else
93233ece 5000 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5001#endif
23f1ca44 5002 kid->op_private = 0;
76cd736e 5003 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5004 }
79072805 5005 }
11343788 5006 return o;
79072805
LW		 5007}
5008
5009OP *
cea2e8a9 5010Perl_ck_ftst(pTHX_ OP *o)
79072805 5011{
11343788 5012 I32 type = o->op_type;
79072805 5013
d0dca557
JD		 5014 if (o->op_flags & OPf_REF) {
5015 /* nothing */
5016 }
5017 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5018 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5019
5020 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5021 STRLEN n_a;
a0d0e21e 5022 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5023 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5024 op_free(o);
d0dca557 5025 o = newop;
79072805 5026 }
1af34c76
JH		 5027 else {
5028 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5029 OP_IS_FILETEST_ACCESS(o))
5030 o->op_private |= OPpFT_ACCESS;
5031 }
79072805
LW		 5032 }
5033 else {
11343788 5034 op_free(o);
79072805 5035 if (type == OP_FTTTY)
8fde6460 5036 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5037 else
d0dca557 5038 o = newUNOP(type, 0, newDEFSVOP());
79072805 5039 }
11343788 5040 return o;
79072805
LW		 5041}
5042
5043OP *
cea2e8a9 5044Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5045{
5046 register OP *kid;
5047 OP **tokid;
5048 OP *sibl;
5049 I32 numargs = 0;
11343788 5050 int type = o->op_type;
22c35a8c 5051 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5052
11343788 5053 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5054 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5055 oa &= ~OA_OPTIONAL;
5056 else
11343788 5057 return no_fh_allowed(o);
79072805
LW		 5058 }
5059
11343788 5060 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5061 STRLEN n_a;
11343788
MB		 5062 tokid = &cLISTOPo->op_first;
5063 kid = cLISTOPo->op_first;
8990e307 5064 if (kid->op_type == OP_PUSHMARK ||
155aba94 5065 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5066 {
79072805
LW		 5067 tokid = &kid->op_sibling;
5068 kid = kid->op_sibling;
5069 }
22c35a8c 5070 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5071 *tokid = kid = newDEFSVOP();
79072805
LW		 5072
5073 while (oa && kid) {
5074 numargs++;
5075 sibl = kid->op_sibling;
5076 switch (oa & 7) {
5077 case OA_SCALAR:
62c18ce2
GS		 5078 /* list seen where single (scalar) arg expected? */
5079 if (numargs == 1 && !(oa >> 4)
5080 && kid->op_type == OP_LIST && type != OP_SCALAR)
5081 {
5082 return too_many_arguments(o,PL_op_desc[type]);
5083 }
79072805
LW		 5084 scalar(kid);
5085 break;
5086 case OA_LIST:
5087 if (oa < 16) {
5088 kid = 0;
5089 continue;
5090 }
5091 else
5092 list(kid);
5093 break;
5094 case OA_AVREF:
936edb8b 5095 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5096 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5097 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5098 "Useless use of %s with no values",
936edb8b 5099 PL_op_desc[type]);
b2ffa427 5100
79072805 5101 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5102 (kid->op_private & OPpCONST_BARE))
5103 {
2d8e6c8d 5104 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5105 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5106 gv_fetchpv(name, TRUE, SVt_PVAV) ));
12bcd1a6
PM		 5107 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5108 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5109 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5110 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5111 op_free(kid);
5112 kid = newop;
5113 kid->op_sibling = sibl;
5114 *tokid = kid;
5115 }
8990e307 5116 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5117 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5118 mod(kid, type);
79072805
LW		 5119 break;
5120 case OA_HVREF:
5121 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5122 (kid->op_private & OPpCONST_BARE))
5123 {
2d8e6c8d 5124 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5125 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5126 gv_fetchpv(name, TRUE, SVt_PVHV) ));
12bcd1a6
PM		 5127 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5128 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5129 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5130 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5131 op_free(kid);
5132 kid = newop;
5133 kid->op_sibling = sibl;
5134 *tokid = kid;
5135 }
8990e307 5136 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5137 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5138 mod(kid, type);
79072805
LW		 5139 break;
5140 case OA_CVREF:
5141 {
a0d0e21e 5142 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5143 kid->op_sibling = 0;
5144 linklist(kid);
5145 newop->op_next = newop;
5146 kid = newop;
5147 kid->op_sibling = sibl;
5148 *tokid = kid;
5149 }
5150 break;
5151 case OA_FILEREF:
c340be78 5152 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5153 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5154 (kid->op_private & OPpCONST_BARE))
5155 {
79072805 5156 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5157 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5158 SVt_PVIO) );
afbdacea 5159 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5160 kid == cLISTOPo->op_last)
364daeac 5161 cLISTOPo->op_last = newop;
79072805
LW		 5162 op_free(kid);
5163 kid = newop;
5164 }
1ea32a52
GS		 5165 else if (kid->op_type == OP_READLINE) {
5166 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5167 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5168 }
79072805 5169 else {
35cd451c 5170 I32 flags = OPf_SPECIAL;
a6c40364 5171 I32 priv = 0;
2c8ac474
GS		 5172 PADOFFSET targ = 0;
5173
35cd451c 5174 /* is this op a FH constructor? */
853846ea 5175 if (is_handle_constructor(o,numargs)) {
2c8ac474 5176 char *name = Nullch;
dd2155a4 5177 STRLEN len = 0;
2c8ac474
GS		 5178
5179 flags = 0;
5180 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5181 * need to "prove" flag does not mean something
5182 * else already - NI-S 1999/05/07
2c8ac474
GS		 5183 */
5184 priv = OPpDEREF;
5185 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 5186 name = PAD_COMPNAME_PV(kid->op_targ);
5187 /* SvCUR of a pad namesv can't be trusted
5188 * (see PL_generation), so calc its length
5189 * manually */
5190 if (name)
5191 len = strlen(name);
5192
2c8ac474
GS		 5193 }
5194 else if (kid->op_type == OP_RV2SV
5195 && kUNOP->op_first->op_type == OP_GV)
5196 {
5197 GV *gv = cGVOPx_gv(kUNOP->op_first);
5198 name = GvNAME(gv);
5199 len = GvNAMELEN(gv);
5200 }
afd1915d
GS		 5201 else if (kid->op_type == OP_AELEM
5202 || kid->op_type == OP_HELEM)
5203 {
0c4b0a3f
JH		 5204 OP *op;
5205
5206 name = 0;
5207 if ((op = ((BINOP*)kid)->op_first)) {
5208 SV *tmpstr = Nullsv;
5209 char *a =
5210 kid->op_type == OP_AELEM ?
5211 "[]" : "{}";
5212 if (((op->op_type == OP_RV2AV) ||
5213 (op->op_type == OP_RV2HV)) &&
5214 (op = ((UNOP*)op)->op_first) &&
5215 (op->op_type == OP_GV)) {
5216 /* packagevar $a[] or $h{} */
5217 GV *gv = cGVOPx_gv(op);
5218 if (gv)
5219 tmpstr =
5220 Perl_newSVpvf(aTHX_
5221 "%s%c...%c",
5222 GvNAME(gv),
5223 a[0], a[1]);
5224 }
5225 else if (op->op_type == OP_PADAV
5226 || op->op_type == OP_PADHV) {
5227 /* lexicalvar $a[] or $h{} */
5228 char *padname =
5229 PAD_COMPNAME_PV(op->op_targ);
5230 if (padname)
5231 tmpstr =
5232 Perl_newSVpvf(aTHX_
5233 "%s%c...%c",
5234 padname + 1,
5235 a[0], a[1]);
5236
5237 }
5238 if (tmpstr) {
5239 name = savepv(SvPVX(tmpstr));
5240 len = strlen(name);
5241 sv_2mortal(tmpstr);
5242 }
5243 }
5244 if (!name) {
5245 name = "__ANONIO__";
5246 len = 10;
5247 }
5248 mod(kid, type);
afd1915d 5249 }
2c8ac474
GS		 5250 if (name) {
5251 SV *namesv;
5252 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 5253 namesv = PAD_SVl(targ);
155aba94 5254 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5255 if (*name != '$')
5256 sv_setpvn(namesv, "$", 1);
5257 sv_catpvn(namesv, name, len);
5258 }
853846ea 5259 }
79072805 5260 kid->op_sibling = 0;
35cd451c 5261 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5262 kid->op_targ = targ;
5263 kid->op_private |= priv;
79072805
LW		 5264 }
5265 kid->op_sibling = sibl;
5266 *tokid = kid;
5267 }
5268 scalar(kid);
5269 break;
5270 case OA_SCALARREF:
a0d0e21e 5271 mod(scalar(kid), type);
79072805
LW		 5272 break;
5273 }
5274 oa >>= 4;
5275 tokid = &kid->op_sibling;
5276 kid = kid->op_sibling;
5277 }
11343788 5278 o->op_private |= numargs;
79072805 5279 if (kid)
53e06cf0 5280 return too_many_arguments(o,OP_DESC(o));
11343788 5281 listkids(o);
79072805 5282 }
22c35a8c 5283 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5284 op_free(o);
54b9620d 5285 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5286 }
5287
79072805
LW		 5288 if (oa) {
5289 while (oa & OA_OPTIONAL)
5290 oa >>= 4;
5291 if (oa && oa != OA_LIST)
53e06cf0 5292 return too_few_arguments(o,OP_DESC(o));
79072805 5293 }
11343788 5294 return o;
79072805
LW		 5295}
5296
5297OP *
cea2e8a9 5298Perl_ck_glob(pTHX_ OP *o)
79072805 5299{
fb73857a 5300 GV *gv;
5301
649da076 5302 o = ck_fun(o);
1f2bfc8a 5303 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5304 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5305
b9f751c0
GS		 5306 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5307 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5308 {
fb73857a 5309 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b9f751c0 5310 }
b1cb66bf 5311
52bb0670 5312#if !defined(PERL_EXTERNAL_GLOB)
72b16652
GS		 5313 /* XXX this can be tightened up and made more failsafe. */
5314 if (!gv) {
7d3fb230 5315 GV *glob_gv;
72b16652 5316 ENTER;
00ca71c1
NIS		 5317 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5318 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
72b16652 5319 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5320 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5321 GvCV(gv) = GvCV(glob_gv);
445266f0 5322 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5323 GvIMPORTED_CV_on(gv);
72b16652
GS		 5324 LEAVE;
5325 }
52bb0670 5326#endif /* PERL_EXTERNAL_GLOB */
72b16652 5327
b9f751c0 5328 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5329 append_elem(OP_GLOB, o,
80252599 5330 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5331 o->op_type = OP_LIST;
22c35a8c 5332 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5333 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5334 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
1f2bfc8a 5335 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5336 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5337 scalar(newUNOP(OP_RV2CV, 0,
5338 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5339 o = newUNOP(OP_NULL, 0, ck_subr(o));
5340 o->op_targ = OP_GLOB; /* hint at what it used to be */
5341 return o;
b1cb66bf 5342 }
5343 gv = newGVgen("main");
a0d0e21e 5344 gv_IOadd(gv);
11343788
MB		 5345 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5346 scalarkids(o);
649da076 5347 return o;
79072805
LW		 5348}
5349
5350OP *
cea2e8a9 5351Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 5352{
5353 LOGOP *gwop;
5354 OP *kid;
11343788 5355 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 5356
22c35a8c 5357 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5358 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5359
11343788 5360 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5361 OP* k;
11343788
MB		 5362 o = ck_sort(o);
5363 kid = cLISTOPo->op_first->op_sibling;
5364 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 5365 kid = k;
5366 }
5367 kid->op_next = (OP*)gwop;
11343788 5368 o->op_flags &= ~OPf_STACKED;
93a17b20 5369 }
11343788 5370 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5371 if (type == OP_MAPWHILE)
5372 list(kid);
5373 else
5374 scalar(kid);
11343788 5375 o = ck_fun(o);
3280af22 5376 if (PL_error_count)
11343788 5377 return o;
aeea060c 5378 kid = cLISTOPo->op_first->op_sibling;
79072805 5379 if (kid->op_type != OP_NULL)
cea2e8a9 5380 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5381 kid = kUNOP->op_first;
5382
a0d0e21e 5383 gwop->op_type = type;
22c35a8c 5384 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5385 gwop->op_first = listkids(o);
79072805
LW		 5386 gwop->op_flags |= OPf_KIDS;
5387 gwop->op_private = 1;
5388 gwop->op_other = LINKLIST(kid);
a0d0e21e 5389 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 5390 kid->op_next = (OP*)gwop;
5391
11343788 5392 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5393 if (!kid || !kid->op_sibling)
53e06cf0 5394 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5395 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5396 mod(kid, OP_GREPSTART);
5397
79072805
LW		 5398 return (OP*)gwop;
5399}
5400
5401OP *
cea2e8a9 5402Perl_ck_index(pTHX_ OP *o)
79072805 5403{
11343788
MB		 5404 if (o->op_flags & OPf_KIDS) {
5405 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5406 if (kid)
5407 kid = kid->op_sibling; /* get past "big" */
79072805 5408 if (kid && kid->op_type == OP_CONST)
2779dcf1 5409 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5410 }
11343788 5411 return ck_fun(o);
79072805
LW		 5412}
5413
5414OP *
cea2e8a9 5415Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5416{
5417 /* XXX length optimization goes here */
11343788 5418 return ck_fun(o);
79072805
LW		 5419}
5420
5421OP *
cea2e8a9 5422Perl_ck_lfun(pTHX_ OP *o)
79072805 5423{
5dc0d613
MB		 5424 OPCODE type = o->op_type;
5425 return modkids(ck_fun(o), type);
79072805
LW		 5426}
5427
5428OP *
cea2e8a9 5429Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5430{
12bcd1a6 5431 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5432 switch (cUNOPo->op_first->op_type) {
5433 case OP_RV2AV:
a8739d98
JH		 5434 /* This is needed for
5435 if (defined %stash::)
5436 to work. Do not break Tk.
5437 */
1c846c1f 5438 break; /* Globals via GV can be undef */
d0334bed
GS		 5439 case OP_PADAV:
5440 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5441 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5442 "defined(@array) is deprecated");
12bcd1a6 5443 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5444 "\t(Maybe you should just omit the defined()?)\n");
69794302 5445 break;
d0334bed 5446 case OP_RV2HV:
a8739d98
JH		 5447 /* This is needed for
5448 if (defined %stash::)
5449 to work. Do not break Tk.
5450 */
1c846c1f 5451 break; /* Globals via GV can be undef */
d0334bed 5452 case OP_PADHV:
12bcd1a6 5453 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5454 "defined(%%hash) is deprecated");
12bcd1a6 5455 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5456 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5457 break;
5458 default:
5459 /* no warning */
5460 break;
5461 }
69794302
MJD		 5462 }
5463 return ck_rfun(o);
5464}
5465
5466OP *
cea2e8a9 5467Perl_ck_rfun(pTHX_ OP *o)
8990e307 5468{
5dc0d613
MB		 5469 OPCODE type = o->op_type;
5470 return refkids(ck_fun(o), type);
8990e307
LW		 5471}
5472
5473OP *
cea2e8a9 5474Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5475{
5476 register OP *kid;
aeea060c 5477
11343788 5478 kid = cLISTOPo->op_first;
79072805 5479 if (!kid) {
11343788
MB		 5480 o = force_list(o);
5481 kid = cLISTOPo->op_first;
79072805
LW		 5482 }
5483 if (kid->op_type == OP_PUSHMARK)
5484 kid = kid->op_sibling;
11343788 5485 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 5486 kid = kid->op_sibling;
5487 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5488 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 5489 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 5490 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 5491 cLISTOPo->op_first->op_sibling = kid;
5492 cLISTOPo->op_last = kid;
79072805
LW		 5493 kid = kid->op_sibling;
5494 }
5495 }
b2ffa427 5496
79072805 5497 if (!kid)
54b9620d 5498 append_elem(o->op_type, o, newDEFSVOP());
79072805 5499
2de3dbcc 5500 return listkids(o);
bbce6d69 5501}
5502
5503OP *
b162f9ea
IZ		 5504Perl_ck_sassign(pTHX_ OP *o)
5505{
5506 OP *kid = cLISTOPo->op_first;
5507 /* has a disposable target? */
5508 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 5509 && !(kid->op_flags & OPf_STACKED)
5510 /* Cannot steal the second time! */
5511 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 5512 {
5513 OP *kkid = kid->op_sibling;
5514
5515 /* Can just relocate the target. */
2c2d71f5
JH		 5516 if (kkid && kkid->op_type == OP_PADSV
5517 && !(kkid->op_private & OPpLVAL_INTRO))
5518 {
b162f9ea 5519 kid->op_targ = kkid->op_targ;
743e66e6 5520 kkid->op_targ = 0;
b162f9ea
IZ		 5521 /* Now we do not need PADSV and SASSIGN. */
5522 kid->op_sibling = o->op_sibling; /* NULL */
5523 cLISTOPo->op_first = NULL;
5524 op_free(o);
5525 op_free(kkid);
5526 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5527 return kid;
5528 }
5529 }
5530 return o;
5531}
5532
5533OP *
cea2e8a9 5534Perl_ck_match(pTHX_ OP *o)
79072805 5535{
5dc0d613 5536 o->op_private |= OPpRUNTIME;
11343788 5537 return o;
79072805
LW		 5538}
5539
5540OP *
f5d5a27c
CS		 5541Perl_ck_method(pTHX_ OP *o)
5542{
5543 OP *kid = cUNOPo->op_first;
5544 if (kid->op_type == OP_CONST) {
5545 SV* sv = kSVOP->op_sv;
5546 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5547 OP *cmop;
1c846c1f
NIS		 5548 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5549 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5550 }
5551 else {
5552 kSVOP->op_sv = Nullsv;
5553 }
f5d5a27c 5554 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 5555 op_free(o);
5556 return cmop;
5557 }
5558 }
5559 return o;
5560}
5561
5562OP *
cea2e8a9 5563Perl_ck_null(pTHX_ OP *o)
79072805 5564{
11343788 5565 return o;
79072805
LW		 5566}
5567
5568OP *
16fe6d59
GS		 5569Perl_ck_open(pTHX_ OP *o)
5570{
5571 HV *table = GvHV(PL_hintgv);
5572 if (table) {
5573 SV **svp;
5574 I32 mode;
5575 svp = hv_fetch(table, "open_IN", 7, FALSE);
5576 if (svp && *svp) {
5577 mode = mode_from_discipline(*svp);
5578 if (mode & O_BINARY)
5579 o->op_private |= OPpOPEN_IN_RAW;
5580 else if (mode & O_TEXT)
5581 o->op_private |= OPpOPEN_IN_CRLF;
5582 }
5583
5584 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5585 if (svp && *svp) {
5586 mode = mode_from_discipline(*svp);
5587 if (mode & O_BINARY)
5588 o->op_private |= OPpOPEN_OUT_RAW;
5589 else if (mode & O_TEXT)
5590 o->op_private |= OPpOPEN_OUT_CRLF;
5591 }
5592 }
5593 if (o->op_type == OP_BACKTICK)
5594 return o;
3b82e551
JH		 5595 {
5596 /* In case of three-arg dup open remove strictness
5597 * from the last arg if it is a bareword. */
5598 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5599 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5600 OP *oa;
5601 char *mode;
5602
5603 if ((last->op_type == OP_CONST) && /* The bareword. */
5604 (last->op_private & OPpCONST_BARE) &&
5605 (last->op_private & OPpCONST_STRICT) &&
5606 (oa = first->op_sibling) && /* The fh. */
5607 (oa = oa->op_sibling) && /* The mode. */
5608 SvPOK(((SVOP*)oa)->op_sv) &&
5609 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5610 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5611 (last == oa->op_sibling)) /* The bareword. */
5612 last->op_private &= ~OPpCONST_STRICT;
5613 }
16fe6d59
GS		 5614 return ck_fun(o);
5615}
5616
5617OP *
cea2e8a9 5618Perl_ck_repeat(pTHX_ OP *o)
79072805 5619{
11343788
MB		 5620 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5621 o->op_private |= OPpREPEAT_DOLIST;
5622 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 5623 }
5624 else
11343788
MB		 5625 scalar(o);
5626 return o;
79072805
LW		 5627}
5628
5629OP *
cea2e8a9 5630Perl_ck_require(pTHX_ OP *o)
8990e307 5631{
ec4ab249
GA		 5632 GV* gv;
5633
11343788
MB		 5634 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5635 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 5636
5637 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 5638 char *s;
a0d0e21e
LW		 5639 for (s = SvPVX(kid->op_sv); *s; s++) {
5640 if (*s == ':' && s[1] == ':') {
5641 *s = '/';
1aef975c 5642 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 5643 --SvCUR(kid->op_sv);
5644 }
8990e307 5645 }
ce3b816e
GS		 5646 if (SvREADONLY(kid->op_sv)) {
5647 SvREADONLY_off(kid->op_sv);
5648 sv_catpvn(kid->op_sv, ".pm", 3);
5649 SvREADONLY_on(kid->op_sv);
5650 }
5651 else
5652 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 5653 }
5654 }
ec4ab249
GA		 5655
5656 /* handle override, if any */
5657 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
b9f751c0 5658 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
ec4ab249
GA		 5659 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5660
b9f751c0 5661 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
ec4ab249
GA		 5662 OP *kid = cUNOPo->op_first;
5663 cUNOPo->op_first = 0;
5664 op_free(o);
5665 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5666 append_elem(OP_LIST, kid,
5667 scalar(newUNOP(OP_RV2CV, 0,
5668 newGVOP(OP_GV, 0,
5669 gv))))));
5670 }
5671
11343788 5672 return ck_fun(o);
8990e307
LW		 5673}
5674
78f9721b
SM		 5675OP *
5676Perl_ck_return(pTHX_ OP *o)
5677{
5678 OP *kid;
5679 if (CvLVALUE(PL_compcv)) {
5680 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5681 mod(kid, OP_LEAVESUBLV);
5682 }
5683 return o;
5684}
5685
22c35a8c 5686#if 0
8990e307 5687OP *
cea2e8a9 5688Perl_ck_retarget(pTHX_ OP *o)
79072805 5689{
cea2e8a9 5690 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 5691 /* STUB */
11343788 5692 return o;
79072805 5693}
22c35a8c 5694#endif
79072805
LW		 5695
5696OP *
cea2e8a9 5697Perl_ck_select(pTHX_ OP *o)
79072805 5698{
c07a80fd 5699 OP* kid;
11343788
MB		 5700 if (o->op_flags & OPf_KIDS) {
5701 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 5702 if (kid && kid->op_sibling) {
11343788 5703 o->op_type = OP_SSELECT;
22c35a8c 5704 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 5705 o = ck_fun(o);
5706 return fold_constants(o);
79072805
LW		 5707 }
5708 }
11343788
MB		 5709 o = ck_fun(o);
5710 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 5711 if (kid && kid->op_type == OP_RV2GV)
5712 kid->op_private &= ~HINT_STRICT_REFS;
11343788 5713 return o;
79072805
LW		 5714}
5715
5716OP *
cea2e8a9 5717Perl_ck_shift(pTHX_ OP *o)
79072805 5718{
11343788 5719 I32 type = o->op_type;
79072805 5720
11343788 5721 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 5722 OP *argop;
b2ffa427 5723
11343788 5724 op_free(o);
6d4ff0d2 5725 argop = newUNOP(OP_RV2AV, 0,
8fde6460 5726 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6d4ff0d2 5727 return newUNOP(type, 0, scalar(argop));
79072805 5728 }
11343788 5729 return scalar(modkids(ck_fun(o), type));
79072805
LW		 5730}
5731
5732OP *
cea2e8a9 5733Perl_ck_sort(pTHX_ OP *o)
79072805 5734{
8e3f9bdf 5735 OP *firstkid;
bbce6d69 5736
9ea6e965 5737 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 5738 simplify_sort(o);
8e3f9bdf
GS		 5739 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5740 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 5741 OP *k = NULL;
8e3f9bdf 5742 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 5743
463ee0b2 5744 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 5745 linklist(kid);
463ee0b2
LW		 5746 if (kid->op_type == OP_SCOPE) {
5747 k = kid->op_next;
5748 kid->op_next = 0;
79072805 5749 }
463ee0b2 5750 else if (kid->op_type == OP_LEAVE) {
11343788 5751 if (o->op_type == OP_SORT) {
93c66552 5752 op_null(kid); /* wipe out leave */
748a9306 5753 kid->op_next = kid;
463ee0b2 5754
748a9306
LW		 5755 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5756 if (k->op_next == kid)
5757 k->op_next = 0;
71a29c3c
GS		 5758 /* don't descend into loops */
5759 else if (k->op_type == OP_ENTERLOOP
5760 || k->op_type == OP_ENTERITER)
5761 {
5762 k = cLOOPx(k)->op_lastop;
5763 }
748a9306 5764 }
463ee0b2 5765 }
748a9306
LW		 5766 else
5767 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 5768 k = kLISTOP->op_first;
463ee0b2 5769 }
a2efc822 5770 CALL_PEEP(k);
a0d0e21e 5771
8e3f9bdf
GS		 5772 kid = firstkid;
5773 if (o->op_type == OP_SORT) {
5774 /* provide scalar context for comparison function/block */
5775 kid = scalar(kid);
a0d0e21e 5776 kid->op_next = kid;
8e3f9bdf 5777 }
a0d0e21e
LW		 5778 else
5779 kid->op_next = k;
11343788 5780 o->op_flags |= OPf_SPECIAL;
79072805 5781 }
c6e96bcb 5782 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 5783 op_null(firstkid);
8e3f9bdf
GS		 5784
5785 firstkid = firstkid->op_sibling;
79072805 5786 }
bbce6d69 5787
8e3f9bdf
GS		 5788 /* provide list context for arguments */
5789 if (o->op_type == OP_SORT)
5790 list(firstkid);
5791
11343788 5792 return o;
79072805 5793}
bda4119b
GS		 5794
5795STATIC void
cea2e8a9 5796S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 5797{
5798 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5799 OP *k;
5800 int reversed;
350de78d 5801 GV *gv;
9c007264
JH		 5802 if (!(o->op_flags & OPf_STACKED))
5803 return;
1c846c1f
NIS		 5804 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5805 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 5806 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 5807 if (kid->op_type != OP_SCOPE)
5808 return;
5809 kid = kLISTOP->op_last; /* get past scope */
5810 switch(kid->op_type) {
5811 case OP_NCMP:
5812 case OP_I_NCMP:
5813 case OP_SCMP:
5814 break;
5815 default:
5816 return;
5817 }
5818 k = kid; /* remember this node*/
5819 if (kBINOP->op_first->op_type != OP_RV2SV)
5820 return;
5821 kid = kBINOP->op_first; /* get past cmp */
5822 if (kUNOP->op_first->op_type != OP_GV)
5823 return;
5824 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5825 gv = kGVOP_gv;
350de78d 5826 if (GvSTASH(gv) != PL_curstash)
9c007264 5827 return;
350de78d 5828 if (strEQ(GvNAME(gv), "a"))
9c007264 5829 reversed = 0;
0f79a09d 5830 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 5831 reversed = 1;
5832 else
5833 return;
5834 kid = k; /* back to cmp */
5835 if (kBINOP->op_last->op_type != OP_RV2SV)
5836 return;
5837 kid = kBINOP->op_last; /* down to 2nd arg */
5838 if (kUNOP->op_first->op_type != OP_GV)
5839 return;
5840 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5841 gv = kGVOP_gv;
350de78d 5842 if (GvSTASH(gv) != PL_curstash
9c007264 5843 || ( reversed
350de78d
GS		 5844 ? strNE(GvNAME(gv), "a")
5845 : strNE(GvNAME(gv), "b")))
9c007264
JH		 5846 return;
5847 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5848 if (reversed)
5849 o->op_private |= OPpSORT_REVERSE;
5850 if (k->op_type == OP_NCMP)
5851 o->op_private |= OPpSORT_NUMERIC;
5852 if (k->op_type == OP_I_NCMP)
5853 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 5854 kid = cLISTOPo->op_first->op_sibling;
5855 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5856 op_free(kid); /* then delete it */
9c007264 5857}
79072805
LW		 5858
5859OP *
cea2e8a9 5860Perl_ck_split(pTHX_ OP *o)
79072805
LW		 5861{
5862 register OP *kid;
aeea060c 5863
11343788
MB		 5864 if (o->op_flags & OPf_STACKED)
5865 return no_fh_allowed(o);
79072805 5866
11343788 5867 kid = cLISTOPo->op_first;
8990e307 5868 if (kid->op_type != OP_NULL)
cea2e8a9 5869 Perl_croak(aTHX_ "panic: ck_split");
8990e307 5870 kid = kid->op_sibling;
11343788
MB		 5871 op_free(cLISTOPo->op_first);
5872 cLISTOPo->op_first = kid;
85e6fe83 5873 if (!kid) {
79cb57f6 5874 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 5875 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 5876 }
79072805 5877
de4bf5b3 5878 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 5879 OP *sibl = kid->op_sibling;
463ee0b2 5880 kid->op_sibling = 0;
79072805 5881 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 5882 if (cLISTOPo->op_first == cLISTOPo->op_last)
5883 cLISTOPo->op_last = kid;
5884 cLISTOPo->op_first = kid;
79072805
LW		 5885 kid->op_sibling = sibl;
5886 }
5887
5888 kid->op_type = OP_PUSHRE;
22c35a8c 5889 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 5890 scalar(kid);
f34840d8
MJD		 5891 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5892 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5893 "Use of /g modifier is meaningless in split");
5894 }
79072805
LW		 5895
5896 if (!kid->op_sibling)
54b9620d 5897 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 5898
5899 kid = kid->op_sibling;
5900 scalar(kid);
5901
5902 if (!kid->op_sibling)
11343788 5903 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 5904
5905 kid = kid->op_sibling;
5906 scalar(kid);
5907
5908 if (kid->op_sibling)
53e06cf0 5909 return too_many_arguments(o,OP_DESC(o));
79072805 5910
11343788 5911 return o;
79072805
LW		 5912}
5913
5914OP *
1c846c1f 5915Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 5916{
5917 if (ckWARN(WARN_SYNTAX)) {
5918 OP *kid = cLISTOPo->op_first->op_sibling;
5919 if (kid && kid->op_type == OP_MATCH) {
5920 char *pmstr = "STRING";
aaa362c4
RS		 5921 if (PM_GETRE(kPMOP))
5922 pmstr = PM_GETRE(kPMOP)->precomp;
9014280d 5923 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 5924 "/%s/ should probably be written as \"%s\"",
5925 pmstr, pmstr);
5926 }
5927 }
5928 return ck_fun(o);
5929}
5930
5931OP *
cea2e8a9 5932Perl_ck_subr(pTHX_ OP *o)
79072805 5933{
11343788
MB		 5934 OP *prev = ((cUNOPo->op_first->op_sibling)
5935 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5936 OP *o2 = prev->op_sibling;
4633a7c4
LW		 5937 OP *cvop;
5938 char *proto = 0;
5939 CV *cv = 0;
46fc3d4c 5940 GV *namegv = 0;
4633a7c4
LW		 5941 int optional = 0;
5942 I32 arg = 0;
5b794e05 5943 I32 contextclass = 0;
90b7f708 5944 char *e = 0;
2d8e6c8d 5945 STRLEN n_a;
06492da6 5946 bool delete=0;
4633a7c4 5947
d3011074 5948 o->op_private |= OPpENTERSUB_HASTARG;
11343788 5949 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 5950 if (cvop->op_type == OP_RV2CV) {
5951 SVOP* tmpop;
11343788 5952 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 5953 op_null(cvop); /* disable rv2cv */
4633a7c4 5954 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 5955 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 5956 GV *gv = cGVOPx_gv(tmpop);
350de78d 5957 cv = GvCVu(gv);
76cd736e
GS		 5958 if (!cv)
5959 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 5960 else {
5961 if (SvPOK(cv)) {
5962 namegv = CvANON(cv) ? gv : CvGV(cv);
5963 proto = SvPV((SV*)cv, n_a);
5964 }
5965 if (CvASSERTION(cv)) {
5966 if (PL_hints & HINT_ASSERTING) {
5967 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5968 o->op_private |= OPpENTERSUB_DB;
5969 }
8fa7688f
SF		 5970 else {
5971 delete=1;
5972 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5973 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5974 "Impossible to activate assertion call");
5975 }
5976 }
06492da6 5977 }
46fc3d4c 5978 }
4633a7c4
LW		 5979 }
5980 }
f5d5a27c 5981 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 5982 if (o2->op_type == OP_CONST)
5983 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 5984 else if (o2->op_type == OP_LIST) {
5985 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5986 if (o && o->op_type == OP_CONST)
5987 o->op_private &= ~OPpCONST_STRICT;
5988 }
7a52d87a 5989 }
3280af22
NIS		 5990 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5991 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 5992 o->op_private |= OPpENTERSUB_DB;
5993 while (o2 != cvop) {
4633a7c4
LW		 5994 if (proto) {
5995 switch (*proto) {
5996 case '\0':
5dc0d613 5997 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 5998 case ';':
5999 optional = 1;
6000 proto++;
6001 continue;
6002 case '$':
6003 proto++;
6004 arg++;
11343788 6005 scalar(o2);
4633a7c4
LW		 6006 break;
6007 case '%':
6008 case '@':
11343788 6009 list(o2);
4633a7c4
LW		 6010 arg++;
6011 break;
6012 case '&':
6013 proto++;
6014 arg++;
11343788 6015 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6016 bad_type(arg,
6017 arg == 1 ? "block or sub {}" : "sub {}",
6018 gv_ename(namegv), o2);
4633a7c4
LW		 6019 break;
6020 case '*':
2ba6ecf4 6021 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6022 proto++;
6023 arg++;
11343788 6024 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6025 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6026 else if (o2->op_type == OP_CONST)
6027 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6028 else if (o2->op_type == OP_ENTERSUB) {
6029 /* accidental subroutine, revert to bareword */
6030 OP *gvop = ((UNOP*)o2)->op_first;
6031 if (gvop && gvop->op_type == OP_NULL) {
6032 gvop = ((UNOP*)gvop)->op_first;
6033 if (gvop) {
6034 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6035 ;
6036 if (gvop &&
6037 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6038 (gvop = ((UNOP*)gvop)->op_first) &&
6039 gvop->op_type == OP_GV)
6040 {
638eceb6 6041 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6042 OP *sibling = o2->op_sibling;
2692f720 6043 SV *n = newSVpvn("",0);
9675f7ac 6044 op_free(o2);
2692f720
GS		 6045 gv_fullname3(n, gv, "");
6046 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6047 sv_chop(n, SvPVX(n)+6);
6048 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6049 prev->op_sibling = o2;
6050 o2->op_sibling = sibling;
6051 }
6052 }
6053 }
6054 }
2ba6ecf4
GS		 6055 scalar(o2);
6056 break;
5b794e05
JH		 6057 case '[': case ']':
6058 goto oops;
6059 break;
4633a7c4
LW		 6060 case '\\':
6061 proto++;
6062 arg++;
5b794e05 6063 again:
4633a7c4 6064 switch (*proto++) {
5b794e05
JH		 6065 case '[':
6066 if (contextclass++ == 0) {
841d93c8 6067 e = strchr(proto, ']');
5b794e05
JH		 6068 if (!e || e == proto)
6069 goto oops;
6070 }
6071 else
6072 goto oops;
6073 goto again;
6074 break;
6075 case ']':
466bafcd
RGS		 6076 if (contextclass) {
6077 char *p = proto;
6078 char s = *p;
6079 contextclass = 0;
6080 *p = '\0';
6081 while (*--p != '[');
1eb1540c 6082 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6083 gv_ename(namegv), o2);
6084 *proto = s;
6085 } else
5b794e05
JH		 6086 goto oops;
6087 break;
4633a7c4 6088 case '*':
5b794e05
JH		 6089 if (o2->op_type == OP_RV2GV)
6090 goto wrapref;
6091 if (!contextclass)
6092 bad_type(arg, "symbol", gv_ename(namegv), o2);
6093 break;
4633a7c4 6094 case '&':
5b794e05
JH		 6095 if (o2->op_type == OP_ENTERSUB)
6096 goto wrapref;
6097 if (!contextclass)
6098 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6099 break;
4633a7c4 6100 case '$':
5b794e05
JH		 6101 if (o2->op_type == OP_RV2SV ||
6102 o2->op_type == OP_PADSV ||
6103 o2->op_type == OP_HELEM ||
6104 o2->op_type == OP_AELEM ||
6105 o2->op_type == OP_THREADSV)
6106 goto wrapref;
6107 if (!contextclass)
5dc0d613 6108 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6109 break;
4633a7c4 6110 case '@':
5b794e05
JH		 6111 if (o2->op_type == OP_RV2AV ||
6112 o2->op_type == OP_PADAV)
6113 goto wrapref;
6114 if (!contextclass)
5dc0d613 6115 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6116 break;
4633a7c4 6117 case '%':
5b794e05
JH		 6118 if (o2->op_type == OP_RV2HV ||
6119 o2->op_type == OP_PADHV)
6120 goto wrapref;
6121 if (!contextclass)
6122 bad_type(arg, "hash", gv_ename(namegv), o2);
6123 break;
6124 wrapref:
4633a7c4 6125 {
11343788 6126 OP* kid = o2;
6fa846a0 6127 OP* sib = kid->op_sibling;
4633a7c4 6128 kid->op_sibling = 0;
6fa846a0
GS		 6129 o2 = newUNOP(OP_REFGEN, 0, kid);
6130 o2->op_sibling = sib;
e858de61 6131 prev->op_sibling = o2;
4633a7c4 6132 }
841d93c8 6133 if (contextclass && e) {
5b794e05
JH		 6134 proto = e + 1;
6135 contextclass = 0;
6136 }
4633a7c4
LW		 6137 break;
6138 default: goto oops;
6139 }
5b794e05
JH		 6140 if (contextclass)
6141 goto again;
4633a7c4 6142 break;
b1cb66bf 6143 case ' ':
6144 proto++;
6145 continue;
4633a7c4
LW		 6146 default:
6147 oops:
35c1215d
NC		 6148 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6149 gv_ename(namegv), cv);
4633a7c4
LW		 6150 }
6151 }
6152 else
11343788
MB		 6153 list(o2);
6154 mod(o2, OP_ENTERSUB);
6155 prev = o2;
6156 o2 = o2->op_sibling;
4633a7c4 6157 }
fb73857a 6158 if (proto && !optional &&
6159 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6160 return too_few_arguments(o, gv_ename(namegv));
06492da6
SF		 6161 if(delete) {
6162 op_free(o);
6163 o=newSVOP(OP_CONST, 0, newSViv(0));
6164 }
11343788 6165 return o;
79072805
LW		 6166}
6167
6168OP *
cea2e8a9 6169Perl_ck_svconst(pTHX_ OP *o)
8990e307 6170{
11343788
MB		 6171 SvREADONLY_on(cSVOPo->op_sv);
6172 return o;
8990e307
LW		 6173}
6174
6175OP *
cea2e8a9 6176Perl_ck_trunc(pTHX_ OP *o)
79072805 6177{
11343788
MB		 6178 if (o->op_flags & OPf_KIDS) {
6179 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6180
a0d0e21e
LW		 6181 if (kid->op_type == OP_NULL)
6182 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6183 if (kid && kid->op_type == OP_CONST &&
6184 (kid->op_private & OPpCONST_BARE))
6185 {
11343788 6186 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6187 kid->op_private &= ~OPpCONST_STRICT;
6188 }
79072805 6189 }
11343788 6190 return ck_fun(o);
79072805
LW		 6191}
6192
35fba0d9
RG		 6193OP *
6194Perl_ck_substr(pTHX_ OP *o)
6195{
6196 o = ck_fun(o);
6197 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6198 OP *kid = cLISTOPo->op_first;
6199
6200 if (kid->op_type == OP_NULL)
6201 kid = kid->op_sibling;
6202 if (kid)
6203 kid->op_flags |= OPf_MOD;
6204
6205 }
6206 return o;
6207}
6208
463ee0b2
LW		 6209/* A peephole optimizer. We visit the ops in the order they're to execute. */
6210
79072805 6211void
864dbfa3 6212Perl_peep(pTHX_ register OP *o)
79072805
LW		 6213{
6214 register OP* oldop = 0;
2d8e6c8d 6215
a0d0e21e 6216 if (!o || o->op_seq)
79072805 6217 return;
a0d0e21e 6218 ENTER;
462e5cf6 6219 SAVEOP();
7766f137 6220 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6221 for (; o; o = o->op_next) {
6222 if (o->op_seq)
6223 break;
cfa2c302
PJ		 6224 /* The special value -1 is used by the B::C compiler backend to indicate
6225 * that an op is statically defined and should not be freed */
6226 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6227 PL_op_seqmax = 1;
533c011a 6228 PL_op = o;
a0d0e21e 6229 switch (o->op_type) {
acb36ea4 6230 case OP_SETSTATE:
a0d0e21e
LW		 6231 case OP_NEXTSTATE:
6232 case OP_DBSTATE:
3280af22
NIS		 6233 PL_curcop = ((COP*)o); /* for warnings */
6234 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6235 break;
6236
a0d0e21e 6237 case OP_CONST:
7a52d87a
GS		 6238 if (cSVOPo->op_private & OPpCONST_STRICT)
6239 no_bareword_allowed(o);
7766f137 6240#ifdef USE_ITHREADS
3848b962 6241 case OP_METHOD_NAMED:
7766f137
GS		 6242 /* Relocate sv to the pad for thread safety.
6243 * Despite being a "constant", the SV is written to,
6244 * for reference counts, sv_upgrade() etc. */
6245 if (cSVOP->op_sv) {
6246 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 6247 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6248 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6249 * some pad, so make a copy. */
dd2155a4
DM		 6250 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6251 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6252 SvREFCNT_dec(cSVOPo->op_sv);
6253 }
6254 else {
dd2155a4 6255 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6256 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 6257 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6258 /* XXX I don't know how this isn't readonly already. */
dd2155a4 6259 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6260 }
7766f137
GS		 6261 cSVOPo->op_sv = Nullsv;
6262 o->op_targ = ix;
6263 }
6264#endif
07447971
GS		 6265 o->op_seq = PL_op_seqmax++;
6266 break;
6267
ed7ab888 6268 case OP_CONCAT:
b162f9ea
IZ		 6269 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6270 if (o->op_next->op_private & OPpTARGET_MY) {
69b47968 6271 if (o->op_flags & OPf_STACKED) /* chained concats */
b162f9ea 6272 goto ignore_optimization;
cd06dffe 6273 else {
07447971 6274 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
b162f9ea 6275 o->op_targ = o->op_next->op_targ;
743e66e6 6276 o->op_next->op_targ = 0;
2c2d71f5 6277 o->op_private |= OPpTARGET_MY;
b162f9ea
IZ		 6278 }
6279 }
93c66552 6280 op_null(o->op_next);
b162f9ea
IZ		 6281 }
6282 ignore_optimization:
3280af22 6283 o->op_seq = PL_op_seqmax++;
a0d0e21e 6284 break;
8990e307 6285 case OP_STUB:
54310121 6286 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 6287 o->op_seq = PL_op_seqmax++;
54310121 6288 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6289 }
748a9306 6290 goto nothin;
79072805 6291 case OP_NULL:
acb36ea4
GS		 6292 if (o->op_targ == OP_NEXTSTATE
6293 || o->op_targ == OP_DBSTATE
6294 || o->op_targ == OP_SETSTATE)
6295 {
3280af22 6296 PL_curcop = ((COP*)o);
acb36ea4 6297 }
dad75012
AMS		 6298 /* XXX: We avoid setting op_seq here to prevent later calls
6299 to peep() from mistakenly concluding that optimisation
6300 has already occurred. This doesn't fix the real problem,
6301 though (See 20010220.007). AMS 20010719 */
6302 if (oldop && o->op_next) {
6303 oldop->op_next = o->op_next;
6304 continue;
6305 }
6306 break;
79072805 6307 case OP_SCALAR:
93a17b20 6308 case OP_LINESEQ:
463ee0b2 6309 case OP_SCOPE:
748a9306 6310 nothin:
a0d0e21e
LW		 6311 if (oldop && o->op_next) {
6312 oldop->op_next = o->op_next;
79072805
LW		 6313 continue;
6314 }
3280af22 6315 o->op_seq = PL_op_seqmax++;
79072805
LW		 6316 break;
6317
6318 case OP_GV:
a0d0e21e 6319 if (o->op_next->op_type == OP_RV2SV) {
64aac5a9 6320 if (!(o->op_next->op_private & OPpDEREF)) {
93c66552 6321 op_null(o->op_next);
64aac5a9
GS		 6322 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6323 | OPpOUR_INTRO);
a0d0e21e
LW		 6324 o->op_next = o->op_next->op_next;
6325 o->op_type = OP_GVSV;
22c35a8c 6326 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307
LW		 6327 }
6328 }
a0d0e21e
LW		 6329 else if (o->op_next->op_type == OP_RV2AV) {
6330 OP* pop = o->op_next->op_next;
6331 IV i;
f9dc862f 6332 if (pop && pop->op_type == OP_CONST &&
533c011a 6333 (PL_op = pop->op_next) &&
8990e307 6334 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6335 !(pop->op_next->op_private &
78f9721b 6336 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6337 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6338 <= 255 &&
8990e307
LW		 6339 i >= 0)
6340 {
350de78d 6341 GV *gv;
93c66552
DM		 6342 op_null(o->op_next);
6343 op_null(pop->op_next);
6344 op_null(pop);
a0d0e21e
LW		 6345 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6346 o->op_next = pop->op_next->op_next;
6347 o->op_type = OP_AELEMFAST;
22c35a8c 6348 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6349 o->op_private = (U8)i;
638eceb6 6350 gv = cGVOPo_gv;
350de78d 6351 GvAVn(gv);
8990e307 6352 }
79072805 6353 }
e476b1b5 6354 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 6355 GV *gv = cGVOPo_gv;
76cd736e
GS		 6356 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6357 /* XXX could check prototype here instead of just carping */
6358 SV *sv = sv_newmortal();
6359 gv_efullname3(sv, gv, Nullch);
9014280d 6360 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d
NC		 6361 "%"SVf"() called too early to check prototype",
6362 sv);
76cd736e
GS		 6363 }
6364 }
89de2904
AMS		 6365 else if (o->op_next->op_type == OP_READLINE
6366 && o->op_next->op_next->op_type == OP_CONCAT
6367 && (o->op_next->op_next->op_flags & OPf_STACKED))
6368 {
d2c45030
AMS		 6369 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6370 o->op_type = OP_RCATLINE;
6371 o->op_flags |= OPf_STACKED;
6372 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6373 op_null(o->op_next->op_next);
d2c45030 6374 op_null(o->op_next);
89de2904 6375 }
76cd736e 6376
3280af22 6377 o->op_seq = PL_op_seqmax++;
79072805
LW		 6378 break;
6379
a0d0e21e 6380 case OP_MAPWHILE:
79072805
LW		 6381 case OP_GREPWHILE:
6382 case OP_AND:
6383 case OP_OR:
c963b151 6384 case OP_DOR:
2c2d71f5
JH		 6385 case OP_ANDASSIGN:
6386 case OP_ORASSIGN:
c963b151 6387 case OP_DORASSIGN:
1a67a97c
SM		 6388 case OP_COND_EXPR:
6389 case OP_RANGE:
3280af22 6390 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 6391 while (cLOGOP->op_other->op_type == OP_NULL)
6392 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 6393 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 6394 break;
6395
79072805 6396 case OP_ENTERLOOP:
9c2ca71a 6397 case OP_ENTERITER:
3280af22 6398 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 6399 while (cLOOP->op_redoop->op_type == OP_NULL)
6400 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6401 peep(cLOOP->op_redoop);
58cccf98
SM		 6402 while (cLOOP->op_nextop->op_type == OP_NULL)
6403 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6404 peep(cLOOP->op_nextop);
58cccf98
SM		 6405 while (cLOOP->op_lastop->op_type == OP_NULL)
6406 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6407 peep(cLOOP->op_lastop);
6408 break;
6409
8782bef2 6410 case OP_QR:
79072805
LW		 6411 case OP_MATCH:
6412 case OP_SUBST:
3280af22 6413 o->op_seq = PL_op_seqmax++;
9041c2e3 6414 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6415 cPMOP->op_pmreplstart->op_type == OP_NULL)
6416 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6417 peep(cPMOP->op_pmreplstart);
79072805
LW		 6418 break;
6419
a0d0e21e 6420 case OP_EXEC:
3280af22 6421 o->op_seq = PL_op_seqmax++;
1c846c1f 6422 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 6423 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 6424 if (o->op_next->op_sibling &&
20408e3c
GS		 6425 o->op_next->op_sibling->op_type != OP_EXIT &&
6426 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6427 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 6428 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 6429
57843af0 6430 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 6431 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 6432 "Statement unlikely to be reached");
9014280d 6433 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 6434 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 6435 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 6436 }
6437 }
6438 break;
b2ffa427 6439
c750a3ec 6440 case OP_HELEM: {
6d822dc4
MS		 6441 SV *lexname;
6442 SV **svp, *sv;
1c846c1f 6443 char *key = NULL;
c750a3ec 6444 STRLEN keylen;
b2ffa427 6445
9615e741 6446 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 6447
6448 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6449 break;
1c846c1f
NIS		 6450
6451 /* Make the CONST have a shared SV */
6452 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6453 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 6454 key = SvPV(sv, keylen);
25716404
GS		 6455 lexname = newSVpvn_share(key,
6456 SvUTF8(sv) ? -(I32)keylen : keylen,
6457 0);
1c846c1f
NIS		 6458 SvREFCNT_dec(sv);
6459 *svp = lexname;
6460 }
6d822dc4
MS		 6461 break;
6462 }
c750a3ec 6463
79072805 6464 default:
3280af22 6465 o->op_seq = PL_op_seqmax++;
79072805
LW		 6466 break;
6467 }
a0d0e21e 6468 oldop = o;
79072805 6469 }
a0d0e21e 6470 LEAVE;
79072805 6471}
beab0874 6472
19e8ce8e
AB		 6473
6474
6475char* Perl_custom_op_name(pTHX_ OP* o)
53e06cf0
SC		 6476{
6477 IV index = PTR2IV(o->op_ppaddr);
6478 SV* keysv;
6479 HE* he;
6480
6481 if (!PL_custom_op_names) /* This probably shouldn't happen */
6482 return PL_op_name[OP_CUSTOM];
6483
6484 keysv = sv_2mortal(newSViv(index));
6485
6486 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6487 if (!he)
6488 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6489
6490 return SvPV_nolen(HeVAL(he));
6491}
6492
19e8ce8e 6493char* Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0
SC		 6494{
6495 IV index = PTR2IV(o->op_ppaddr);
6496 SV* keysv;
6497 HE* he;
6498
6499 if (!PL_custom_op_descs)
6500 return PL_op_desc[OP_CUSTOM];
6501
6502 keysv = sv_2mortal(newSViv(index));
6503
6504 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6505 if (!he)
6506 return PL_op_desc[OP_CUSTOM];
6507
6508 return SvPV_nolen(HeVAL(he));
6509}
19e8ce8e 6510
53e06cf0 6511
beab0874
JT		 6512#include "XSUB.h"
6513
6514/* Efficient sub that returns a constant scalar value. */
6515static void
acfe0abc 6516const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 6517{
6518 dXSARGS;
9cbac4c7
DM		 6519 if (items != 0) {
6520#if 0
6521 Perl_croak(aTHX_ "usage: %s::%s()",
6522 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6523#endif
6524 }
9a049f1c 6525 EXTEND(sp, 1);
0768512c 6526 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 6527 XSRETURN(1);
6528}
Unnamed repository; edit this file 'description' to name the repository.