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
Duplicate definition bad.
[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,
197 PL_in_my == KEY_our,
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 {
f52873be 1832 if (o->op_type == OP_STUB)
a0d0e21e 1833 return;
3280af22
NIS		 1834 PL_main_root = scope(sawparens(scalarvoid(o)));
1835 PL_curcop = &PL_compiling;
1836 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 1837 PL_main_root->op_private |= OPpREFCOUNTED;
1838 OpREFCNT_set(PL_main_root, 1);
3280af22 1839 PL_main_root->op_next = 0;
a2efc822 1840 CALL_PEEP(PL_main_start);
3280af22 1841 PL_compcv = 0;
3841441e 1842
4fdae800 1843 /* Register with debugger */
84902520 1844 if (PERLDB_INTER) {
864dbfa3 1845 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 1846 if (cv) {
1847 dSP;
924508f0 1848 PUSHMARK(SP);
cc49e20b 1849 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1850 PUTBACK;
864dbfa3 1851 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 1852 }
1853 }
79072805 1854 }
79072805
LW		 1855}
1856
1857OP *
864dbfa3 1858Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW		 1859{
1860 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 1861/* [perl #17376]: this appears to be premature, and results in code such as
1862 C< our(%x); > executing in list mode rather than void mode */
1863#if 0
79072805 1864 list(o);
d2be0de5
YST		 1865#else
1866 ;
1867#endif
8990e307 1868 else {
64420d0d
JH		 1869 if (ckWARN(WARN_PARENTHESIS)
1870 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1871 {
1872 char *s = PL_bufptr;
8473848f 1873 int sigil = 0;
64420d0d 1874
8473848f
RGS		 1875 /* some heuristics to detect a potential error */
1876 while (*s && (strchr(", \t\n", *s)
1877 || (strchr("@$%*", *s) && ++sigil) ))
64420d0d 1878 s++;
8473848f
RGS		 1879 if (sigil) {
1880 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1881 || strchr("@$%*, \t\n", *s)))
1882 s++;
1883
1884 if (*s == ';' || *s == '=')
1885 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1886 "Parentheses missing around \"%s\" list",
1887 lex ? (PL_in_my == KEY_our ? "our" : "my")
1888 : "local");
1889 }
8990e307
LW		 1890 }
1891 }
93a17b20 1892 if (lex)
eb64745e 1893 o = my(o);
93a17b20 1894 else
eb64745e
GS		 1895 o = mod(o, OP_NULL); /* a bit kludgey */
1896 PL_in_my = FALSE;
1897 PL_in_my_stash = Nullhv;
1898 return o;
79072805
LW		 1899}
1900
1901OP *
864dbfa3 1902Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 1903{
1904 if (o->op_type == OP_LIST) {
554b3eca 1905 OP *o2;
554b3eca 1906 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
554b3eca 1907 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 1908 }
1909 return o;
1910}
1911
1912OP *
864dbfa3 1913Perl_fold_constants(pTHX_ register OP *o)
79072805
LW		 1914{
1915 register OP *curop;
1916 I32 type = o->op_type;
748a9306 1917 SV *sv;
79072805 1918
22c35a8c 1919 if (PL_opargs[type] & OA_RETSCALAR)
79072805 1920 scalar(o);
b162f9ea 1921 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 1922 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 1923
eac055e9
GS		 1924 /* integerize op, unless it happens to be C<-foo>.
1925 * XXX should pp_i_negate() do magic string negation instead? */
1926 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1927 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1928 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1929 {
22c35a8c 1930 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 1931 }
85e6fe83 1932
22c35a8c 1933 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 1934 goto nope;
1935
de939608 1936 switch (type) {
7a52d87a
GS		 1937 case OP_NEGATE:
1938 /* XXX might want a ck_negate() for this */
1939 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1940 break;
de939608
CS		 1941 case OP_SPRINTF:
1942 case OP_UCFIRST:
1943 case OP_LCFIRST:
1944 case OP_UC:
1945 case OP_LC:
69dcf70c
MB		 1946 case OP_SLT:
1947 case OP_SGT:
1948 case OP_SLE:
1949 case OP_SGE:
1950 case OP_SCMP:
2de3dbcc
JH		 1951 /* XXX what about the numeric ops? */
1952 if (PL_hints & HINT_LOCALE)
de939608
CS		 1953 goto nope;
1954 }
1955
3280af22 1956 if (PL_error_count)
a0d0e21e
LW		 1957 goto nope; /* Don't try to run w/ errors */
1958
79072805 1959 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 1960 if ((curop->op_type != OP_CONST ||
1961 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 1962 curop->op_type != OP_LIST &&
1963 curop->op_type != OP_SCALAR &&
1964 curop->op_type != OP_NULL &&
1965 curop->op_type != OP_PUSHMARK)
1966 {
79072805
LW		 1967 goto nope;
1968 }
1969 }
1970
1971 curop = LINKLIST(o);
1972 o->op_next = 0;
533c011a 1973 PL_op = curop;
cea2e8a9 1974 CALLRUNOPS(aTHX);
3280af22 1975 sv = *(PL_stack_sp--);
748a9306 1976 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 1977 pad_swipe(o->op_targ, FALSE);
748a9306
LW		 1978 else if (SvTEMP(sv)) { /* grab mortal temp? */
1979 (void)SvREFCNT_inc(sv);
1980 SvTEMP_off(sv);
85e6fe83 1981 }
79072805
LW		 1982 op_free(o);
1983 if (type == OP_RV2GV)
b1cb66bf 1984 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 1985 return newSVOP(OP_CONST, 0, sv);
aeea060c 1986
79072805 1987 nope:
79072805
LW		 1988 return o;
1989}
1990
1991OP *
864dbfa3 1992Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW		 1993{
1994 register OP *curop;
3280af22 1995 I32 oldtmps_floor = PL_tmps_floor;
79072805 1996
a0d0e21e 1997 list(o);
3280af22 1998 if (PL_error_count)
a0d0e21e
LW		 1999 return o; /* Don't attempt to run with errors */
2000
533c011a 2001 PL_op = curop = LINKLIST(o);
a0d0e21e 2002 o->op_next = 0;
a2efc822 2003 CALL_PEEP(curop);
cea2e8a9
GS		 2004 pp_pushmark();
2005 CALLRUNOPS(aTHX);
533c011a 2006 PL_op = curop;
cea2e8a9 2007 pp_anonlist();
3280af22 2008 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2009
2010 o->op_type = OP_RV2AV;
22c35a8c 2011 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
c13f253a 2012 o->op_seq = 0; /* needs to be revisited in peep() */
79072805 2013 curop = ((UNOP*)o)->op_first;
3280af22 2014 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2015 op_free(curop);
79072805
LW		 2016 linklist(o);
2017 return list(o);
2018}
2019
2020OP *
864dbfa3 2021Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2022{
11343788
MB		 2023 if (!o || o->op_type != OP_LIST)
2024 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2025 else
5dc0d613 2026 o->op_flags &= ~OPf_WANT;
79072805 2027
22c35a8c 2028 if (!(PL_opargs[type] & OA_MARK))
93c66552 2029 op_null(cLISTOPo->op_first);
8990e307 2030
eb160463 2031 o->op_type = (OPCODE)type;
22c35a8c 2032 o->op_ppaddr = PL_ppaddr[type];
11343788 2033 o->op_flags |= flags;
79072805 2034
11343788
MB		 2035 o = CHECKOP(type, o);
2036 if (o->op_type != type)
2037 return o;
79072805 2038
11343788 2039 return fold_constants(o);
79072805
LW		 2040}
2041
2042/* List constructors */
2043
2044OP *
864dbfa3 2045Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2046{
2047 if (!first)
2048 return last;
8990e307
LW		 2049
2050 if (!last)
79072805 2051 return first;
8990e307 2052
155aba94
GS		 2053 if (first->op_type != type
2054 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2055 {
2056 return newLISTOP(type, 0, first, last);
2057 }
79072805 2058
a0d0e21e
LW		 2059 if (first->op_flags & OPf_KIDS)
2060 ((LISTOP*)first)->op_last->op_sibling = last;
2061 else {
2062 first->op_flags |= OPf_KIDS;
2063 ((LISTOP*)first)->op_first = last;
2064 }
2065 ((LISTOP*)first)->op_last = last;
a0d0e21e 2066 return first;
79072805
LW		 2067}
2068
2069OP *
864dbfa3 2070Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2071{
2072 if (!first)
2073 return (OP*)last;
8990e307
LW		 2074
2075 if (!last)
79072805 2076 return (OP*)first;
8990e307
LW		 2077
2078 if (first->op_type != type)
79072805 2079 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW		 2080
2081 if (last->op_type != type)
79072805
LW		 2082 return append_elem(type, (OP*)first, (OP*)last);
2083
2084 first->op_last->op_sibling = last->op_first;
2085 first->op_last = last->op_last;
117dada2 2086 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2087
238a4c30
NIS		 2088 FreeOp(last);
2089
79072805
LW		 2090 return (OP*)first;
2091}
2092
2093OP *
864dbfa3 2094Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2095{
2096 if (!first)
2097 return last;
8990e307
LW		 2098
2099 if (!last)
79072805 2100 return first;
8990e307
LW		 2101
2102 if (last->op_type == type) {
2103 if (type == OP_LIST) { /* already a PUSHMARK there */
2104 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2105 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2106 if (!(first->op_flags & OPf_PARENS))
2107 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2108 }
2109 else {
2110 if (!(last->op_flags & OPf_KIDS)) {
2111 ((LISTOP*)last)->op_last = first;
2112 last->op_flags |= OPf_KIDS;
2113 }
2114 first->op_sibling = ((LISTOP*)last)->op_first;
2115 ((LISTOP*)last)->op_first = first;
79072805 2116 }
117dada2 2117 last->op_flags |= OPf_KIDS;
79072805
LW		 2118 return last;
2119 }
2120
2121 return newLISTOP(type, 0, first, last);
2122}
2123
2124/* Constructors */
2125
2126OP *
864dbfa3 2127Perl_newNULLLIST(pTHX)
79072805 2128{
8990e307
LW		 2129 return newOP(OP_STUB, 0);
2130}
2131
2132OP *
864dbfa3 2133Perl_force_list(pTHX_ OP *o)
8990e307 2134{
11343788
MB		 2135 if (!o || o->op_type != OP_LIST)
2136 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2137 op_null(o);
11343788 2138 return o;
79072805
LW		 2139}
2140
2141OP *
864dbfa3 2142Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2143{
2144 LISTOP *listop;
2145
b7dc083c 2146 NewOp(1101, listop, 1, LISTOP);
79072805 2147
eb160463 2148 listop->op_type = (OPCODE)type;
22c35a8c 2149 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2150 if (first || last)
2151 flags |= OPf_KIDS;
eb160463 2152 listop->op_flags = (U8)flags;
79072805
LW		 2153
2154 if (!last && first)
2155 last = first;
2156 else if (!first && last)
2157 first = last;
8990e307
LW		 2158 else if (first)
2159 first->op_sibling = last;
79072805
LW		 2160 listop->op_first = first;
2161 listop->op_last = last;
8990e307
LW		 2162 if (type == OP_LIST) {
2163 OP* pushop;
2164 pushop = newOP(OP_PUSHMARK, 0);
2165 pushop->op_sibling = first;
2166 listop->op_first = pushop;
2167 listop->op_flags |= OPf_KIDS;
2168 if (!last)
2169 listop->op_last = pushop;
2170 }
79072805
LW		 2171
2172 return (OP*)listop;
2173}
2174
2175OP *
864dbfa3 2176Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2177{
11343788 2178 OP *o;
b7dc083c 2179 NewOp(1101, o, 1, OP);
eb160463 2180 o->op_type = (OPCODE)type;
22c35a8c 2181 o->op_ppaddr = PL_ppaddr[type];
eb160463 2182 o->op_flags = (U8)flags;
79072805 2183
11343788 2184 o->op_next = o;
eb160463 2185 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2186 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2187 scalar(o);
22c35a8c 2188 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2189 o->op_targ = pad_alloc(type, SVs_PADTMP);
2190 return CHECKOP(type, o);
79072805
LW		 2191}
2192
2193OP *
864dbfa3 2194Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW		 2195{
2196 UNOP *unop;
2197
93a17b20 2198 if (!first)
aeea060c 2199 first = newOP(OP_STUB, 0);
22c35a8c 2200 if (PL_opargs[type] & OA_MARK)
8990e307 2201 first = force_list(first);
93a17b20 2202
b7dc083c 2203 NewOp(1101, unop, 1, UNOP);
eb160463 2204 unop->op_type = (OPCODE)type;
22c35a8c 2205 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2206 unop->op_first = first;
2207 unop->op_flags = flags | OPf_KIDS;
eb160463 2208 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2209 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2210 if (unop->op_next)
2211 return (OP*)unop;
2212
a0d0e21e 2213 return fold_constants((OP *) unop);
79072805
LW		 2214}
2215
2216OP *
864dbfa3 2217Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2218{
2219 BINOP *binop;
b7dc083c 2220 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2221
2222 if (!first)
2223 first = newOP(OP_NULL, 0);
2224
eb160463 2225 binop->op_type = (OPCODE)type;
22c35a8c 2226 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2227 binop->op_first = first;
2228 binop->op_flags = flags | OPf_KIDS;
2229 if (!last) {
2230 last = first;
eb160463 2231 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2232 }
2233 else {
eb160463 2234 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2235 first->op_sibling = last;
2236 }
2237
e50aee73 2238 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2239 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2240 return (OP*)binop;
2241
7284ab6f 2242 binop->op_last = binop->op_first->op_sibling;
79072805 2243
a0d0e21e 2244 return fold_constants((OP *)binop);
79072805
LW		 2245}
2246
a0ed51b3 2247static int
2b9d42f0
NIS		 2248uvcompare(const void *a, const void *b)
2249{
2250 if (*((UV *)a) < (*(UV *)b))
2251 return -1;
2252 if (*((UV *)a) > (*(UV *)b))
2253 return 1;
2254 if (*((UV *)a+1) < (*(UV *)b+1))
2255 return -1;
2256 if (*((UV *)a+1) > (*(UV *)b+1))
2257 return 1;
a0ed51b3
LW		 2258 return 0;
2259}
2260
79072805 2261OP *
864dbfa3 2262Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2263{
79072805
LW		 2264 SV *tstr = ((SVOP*)expr)->op_sv;
2265 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2266 STRLEN tlen;
2267 STRLEN rlen;
9b877dbb
IH		 2268 U8 *t = (U8*)SvPV(tstr, tlen);
2269 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW		 2270 register I32 i;
2271 register I32 j;
a0ed51b3 2272 I32 del;
79072805 2273 I32 complement;
5d06d08e 2274 I32 squash;
9b877dbb 2275 I32 grows = 0;
79072805
LW		 2276 register short *tbl;
2277
800b4dc4 2278 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2279 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2280 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2281 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2282
036b4402
GS		 2283 if (SvUTF8(tstr))
2284 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2285
2286 if (SvUTF8(rstr))
036b4402 2287 o->op_private |= OPpTRANS_TO_UTF;
79072805 2288
a0ed51b3 2289 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2290 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW		 2291 SV* transv = 0;
2292 U8* tend = t + tlen;
2293 U8* rend = r + rlen;
ba210ebe 2294 STRLEN ulen;
a0ed51b3
LW		 2295 U32 tfirst = 1;
2296 U32 tlast = 0;
2297 I32 tdiff;
2298 U32 rfirst = 1;
2299 U32 rlast = 0;
2300 I32 rdiff;
2301 I32 diff;
2302 I32 none = 0;
2303 U32 max = 0;
2304 I32 bits;
a0ed51b3 2305 I32 havefinal = 0;
9c5ffd7c 2306 U32 final = 0;
a0ed51b3
LW		 2307 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2308 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2309 U8* tsave = NULL;
2310 U8* rsave = NULL;
2311
2312 if (!from_utf) {
2313 STRLEN len = tlen;
2314 tsave = t = bytes_to_utf8(t, &len);
2315 tend = t + len;
2316 }
2317 if (!to_utf && rlen) {
2318 STRLEN len = rlen;
2319 rsave = r = bytes_to_utf8(r, &len);
2320 rend = r + len;
2321 }
a0ed51b3 2322
2b9d42f0
NIS		 2323/* There are several snags with this code on EBCDIC:
2324 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2325 2. scan_const() in toke.c has encoded chars in native encoding which makes
2326 ranges at least in EBCDIC 0..255 range the bottom odd.
2327*/
2328
a0ed51b3 2329 if (complement) {
ad391ad9 2330 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2331 UV *cp;
a0ed51b3 2332 UV nextmin = 0;
2b9d42f0 2333 New(1109, cp, 2*tlen, UV);
a0ed51b3 2334 i = 0;
79cb57f6 2335 transv = newSVpvn("",0);
a0ed51b3 2336 while (t < tend) {
2b9d42f0
NIS		 2337 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2338 t += ulen;
2339 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2340 t++;
2b9d42f0
NIS		 2341 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2342 t += ulen;
a0ed51b3 2343 }
2b9d42f0
NIS		 2344 else {
2345 cp[2*i+1] = cp[2*i];
2346 }
2347 i++;
a0ed51b3 2348 }
2b9d42f0 2349 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2350 for (j = 0; j < i; j++) {
2b9d42f0 2351 UV val = cp[2*j];
a0ed51b3
LW		 2352 diff = val - nextmin;
2353 if (diff > 0) {
9041c2e3 2354 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2355 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2356 if (diff > 1) {
2b9d42f0 2357 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2358 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2359 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2360 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2361 }
2362 }
2b9d42f0 2363 val = cp[2*j+1];
a0ed51b3
LW		 2364 if (val >= nextmin)
2365 nextmin = val + 1;
2366 }
9041c2e3 2367 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2368 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2369 {
2370 U8 range_mark = UTF_TO_NATIVE(0xff);
2371 sv_catpvn(transv, (char *)&range_mark, 1);
2372 }
b851fbc1
JH		 2373 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2374 UNICODE_ALLOW_SUPER);
dfe13c55
GS		 2375 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2376 t = (U8*)SvPVX(transv);
a0ed51b3
LW		 2377 tlen = SvCUR(transv);
2378 tend = t + tlen;
455d824a 2379 Safefree(cp);
a0ed51b3
LW		 2380 }
2381 else if (!rlen && !del) {
2382 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2383 }
2384 if (!squash) {
05d340b8 2385 if ((!rlen && !del) || t == r ||
12ae5dfc 2386 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2387 {
4757a243 2388 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2389 }
a0ed51b3
LW		 2390 }
2391
2392 while (t < tend || tfirst <= tlast) {
2393 /* see if we need more "t" chars */
2394 if (tfirst > tlast) {
9041c2e3 2395 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2396 t += ulen;
2b9d42f0 2397 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2398 t++;
9041c2e3 2399 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2400 t += ulen;
2401 }
2402 else
2403 tlast = tfirst;
2404 }
2405
2406 /* now see if we need more "r" chars */
2407 if (rfirst > rlast) {
2408 if (r < rend) {
9041c2e3 2409 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2410 r += ulen;
2b9d42f0 2411 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2412 r++;
9041c2e3 2413 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2414 r += ulen;
2415 }
2416 else
2417 rlast = rfirst;
2418 }
2419 else {
2420 if (!havefinal++)
2421 final = rlast;
2422 rfirst = rlast = 0xffffffff;
2423 }
2424 }
2425
2426 /* now see which range will peter our first, if either. */
2427 tdiff = tlast - tfirst;
2428 rdiff = rlast - rfirst;
2429
2430 if (tdiff <= rdiff)
2431 diff = tdiff;
2432 else
2433 diff = rdiff;
2434
2435 if (rfirst == 0xffffffff) {
2436 diff = tdiff; /* oops, pretend rdiff is infinite */
2437 if (diff > 0)
894356b3
GS		 2438 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2439 (long)tfirst, (long)tlast);
a0ed51b3 2440 else
894356b3 2441 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2442 }
2443 else {
2444 if (diff > 0)
894356b3
GS		 2445 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2446 (long)tfirst, (long)(tfirst + diff),
2447 (long)rfirst);
a0ed51b3 2448 else
894356b3
GS		 2449 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2450 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2451
2452 if (rfirst + diff > max)
2453 max = rfirst + diff;
9b877dbb 2454 if (!grows)
45005bfb
JH		 2455 grows = (tfirst < rfirst &&
2456 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2457 rfirst += diff + 1;
a0ed51b3
LW		 2458 }
2459 tfirst += diff + 1;
2460 }
2461
2462 none = ++max;
2463 if (del)
2464 del = ++max;
2465
2466 if (max > 0xffff)
2467 bits = 32;
2468 else if (max > 0xff)
2469 bits = 16;
2470 else
2471 bits = 8;
2472
455d824a 2473 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2474 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2475 SvREFCNT_dec(listsv);
2476 if (transv)
2477 SvREFCNT_dec(transv);
2478
45005bfb 2479 if (!del && havefinal && rlen)
b448e4fe
JH		 2480 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2481 newSVuv((UV)final), 0);
a0ed51b3 2482
9b877dbb 2483 if (grows)
a0ed51b3
LW		 2484 o->op_private |= OPpTRANS_GROWS;
2485
9b877dbb
IH		 2486 if (tsave)
2487 Safefree(tsave);
2488 if (rsave)
2489 Safefree(rsave);
2490
a0ed51b3
LW		 2491 op_free(expr);
2492 op_free(repl);
2493 return o;
2494 }
2495
2496 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2497 if (complement) {
2498 Zero(tbl, 256, short);
eb160463 2499 for (i = 0; i < (I32)tlen; i++)
ec49126f 2500 tbl[t[i]] = -1;
79072805
LW		 2501 for (i = 0, j = 0; i < 256; i++) {
2502 if (!tbl[i]) {
eb160463 2503 if (j >= (I32)rlen) {
a0ed51b3 2504 if (del)
79072805
LW		 2505 tbl[i] = -2;
2506 else if (rlen)
ec49126f 2507 tbl[i] = r[j-1];
79072805 2508 else
eb160463 2509 tbl[i] = (short)i;
79072805 2510 }
9b877dbb
IH		 2511 else {
2512 if (i < 128 && r[j] >= 128)
2513 grows = 1;
ec49126f 2514 tbl[i] = r[j++];
9b877dbb 2515 }
79072805
LW		 2516 }
2517 }
05d340b8
JH		 2518 if (!del) {
2519 if (!rlen) {
2520 j = rlen;
2521 if (!squash)
2522 o->op_private |= OPpTRANS_IDENTICAL;
2523 }
eb160463 2524 else if (j >= (I32)rlen)
05d340b8
JH		 2525 j = rlen - 1;
2526 else
2527 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79 2528 tbl[0x100] = rlen - j;
eb160463 2529 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 2530 tbl[0x101+i] = r[j+i];
2531 }
79072805
LW		 2532 }
2533 else {
a0ed51b3 2534 if (!rlen && !del) {
79072805 2535 r = t; rlen = tlen;
5d06d08e 2536 if (!squash)
4757a243 2537 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2538 }
94bfe852
RGS		 2539 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2540 o->op_private |= OPpTRANS_IDENTICAL;
2541 }
79072805
LW		 2542 for (i = 0; i < 256; i++)
2543 tbl[i] = -1;
eb160463
GS		 2544 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2545 if (j >= (I32)rlen) {
a0ed51b3 2546 if (del) {
ec49126f 2547 if (tbl[t[i]] == -1)
2548 tbl[t[i]] = -2;
79072805
LW		 2549 continue;
2550 }
2551 --j;
2552 }
9b877dbb
IH		 2553 if (tbl[t[i]] == -1) {
2554 if (t[i] < 128 && r[j] >= 128)
2555 grows = 1;
ec49126f 2556 tbl[t[i]] = r[j];
9b877dbb 2557 }
79072805
LW		 2558 }
2559 }
9b877dbb
IH		 2560 if (grows)
2561 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 2562 op_free(expr);
2563 op_free(repl);
2564
11343788 2565 return o;
79072805
LW		 2566}
2567
2568OP *
864dbfa3 2569Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 2570{
2571 PMOP *pmop;
2572
b7dc083c 2573 NewOp(1101, pmop, 1, PMOP);
eb160463 2574 pmop->op_type = (OPCODE)type;
22c35a8c 2575 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 2576 pmop->op_flags = (U8)flags;
2577 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2578
3280af22 2579 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2580 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2581 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 2582 pmop->op_pmpermflags |= PMf_LOCALE;
2583 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2584
debc9467 2585#ifdef USE_ITHREADS
13137afc
AB		 2586 {
2587 SV* repointer;
2588 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2589 repointer = av_pop((AV*)PL_regex_pad[0]);
2590 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2591 SvREPADTMP_off(repointer);
13137afc 2592 sv_setiv(repointer,0);
1eb1540c 2593 } else {
13137afc
AB		 2594 repointer = newSViv(0);
2595 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2596 pmop->op_pmoffset = av_len(PL_regex_padav);
2597 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2598 }
13137afc 2599 }
debc9467 2600#endif
1eb1540c 2601
1fcf4c12 2602 /* link into pm list */
3280af22
NIS		 2603 if (type != OP_TRANS && PL_curstash) {
2604 pmop->op_pmnext = HvPMROOT(PL_curstash);
2605 HvPMROOT(PL_curstash) = pmop;
cb55de95 2606 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 2607 }
2608
2609 return (OP*)pmop;
2610}
2611
2612OP *
864dbfa3 2613Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 2614{
2615 PMOP *pm;
2616 LOGOP *rcop;
ce862d02 2617 I32 repl_has_vars = 0;
79072805 2618
11343788
MB		 2619 if (o->op_type == OP_TRANS)
2620 return pmtrans(o, expr, repl);
79072805 2621
3280af22 2622 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2623 pm = (PMOP*)o;
79072805
LW		 2624
2625 if (expr->op_type == OP_CONST) {
463ee0b2 2626 STRLEN plen;
79072805 2627 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2628 char *p = SvPV(pat, plen);
11343788 2629 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 2630 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2631 p = SvPV(pat, plen);
79072805
LW		 2632 pm->op_pmflags |= PMf_SKIPWHITE;
2633 }
5b71a6a7 2634 if (DO_UTF8(pat))
a5961de5 2635 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS		 2636 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2637 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2638 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 2639 op_free(expr);
2640 }
2641 else {
3280af22 2642 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2643 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2644 ? OP_REGCRESET
2645 : OP_REGCMAYBE),0,expr);
463ee0b2 2646
b7dc083c 2647 NewOp(1101, rcop, 1, LOGOP);
79072805 2648 rcop->op_type = OP_REGCOMP;
22c35a8c 2649 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2650 rcop->op_first = scalar(expr);
1c846c1f 2651 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2652 ? (OPf_SPECIAL | OPf_KIDS)
2653 : OPf_KIDS);
79072805 2654 rcop->op_private = 1;
11343788 2655 rcop->op_other = o;
b5c19bd7
DM		 2656 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2657 PL_cv_has_eval = 1;
79072805
LW		 2658
2659 /* establish postfix order */
3280af22 2660 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 2661 LINKLIST(expr);
2662 rcop->op_next = expr;
2663 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2664 }
2665 else {
2666 rcop->op_next = LINKLIST(expr);
2667 expr->op_next = (OP*)rcop;
2668 }
79072805 2669
11343788 2670 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 2671 }
2672
2673 if (repl) {
748a9306 2674 OP *curop;
0244c3a4 2675 if (pm->op_pmflags & PMf_EVAL) {
748a9306 2676 curop = 0;
57843af0 2677 if (CopLINE(PL_curcop) < PL_multi_end)
eb160463 2678 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2679 }
748a9306
LW		 2680 else if (repl->op_type == OP_CONST)
2681 curop = repl;
79072805 2682 else {
79072805
LW		 2683 OP *lastop = 0;
2684 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 2685 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 2686 if (curop->op_type == OP_GV) {
638eceb6 2687 GV *gv = cGVOPx_gv(curop);
ce862d02 2688 repl_has_vars = 1;
f702bf4a 2689 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 2690 break;
2691 }
2692 else if (curop->op_type == OP_RV2CV)
2693 break;
2694 else if (curop->op_type == OP_RV2SV ||
2695 curop->op_type == OP_RV2AV ||
2696 curop->op_type == OP_RV2HV ||
2697 curop->op_type == OP_RV2GV) {
2698 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2699 break;
2700 }
748a9306
LW		 2701 else if (curop->op_type == OP_PADSV ||
2702 curop->op_type == OP_PADAV ||
2703 curop->op_type == OP_PADHV ||
554b3eca 2704 curop->op_type == OP_PADANY) {
ce862d02 2705 repl_has_vars = 1;
748a9306 2706 }
1167e5da
SM		 2707 else if (curop->op_type == OP_PUSHRE)
2708 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 2709 else
2710 break;
2711 }
2712 lastop = curop;
2713 }
748a9306 2714 }
ce862d02 2715 if (curop == repl
1c846c1f 2716 && !(repl_has_vars
aaa362c4
RS		 2717 && (!PM_GETRE(pm)
2718 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2719 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2720 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2721 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 2722 }
2723 else {
aaa362c4 2724 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 2725 pm->op_pmflags |= PMf_MAYBE_CONST;
2726 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2727 }
b7dc083c 2728 NewOp(1101, rcop, 1, LOGOP);
748a9306 2729 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2730 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 2731 rcop->op_first = scalar(repl);
2732 rcop->op_flags |= OPf_KIDS;
2733 rcop->op_private = 1;
11343788 2734 rcop->op_other = o;
748a9306
LW		 2735
2736 /* establish postfix order */
2737 rcop->op_next = LINKLIST(repl);
2738 repl->op_next = (OP*)rcop;
2739
2740 pm->op_pmreplroot = scalar((OP*)rcop);
2741 pm->op_pmreplstart = LINKLIST(rcop);
2742 rcop->op_next = 0;
79072805
LW		 2743 }
2744 }
2745
2746 return (OP*)pm;
2747}
2748
2749OP *
864dbfa3 2750Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 2751{
2752 SVOP *svop;
b7dc083c 2753 NewOp(1101, svop, 1, SVOP);
eb160463 2754 svop->op_type = (OPCODE)type;
22c35a8c 2755 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2756 svop->op_sv = sv;
2757 svop->op_next = (OP*)svop;
eb160463 2758 svop->op_flags = (U8)flags;
22c35a8c 2759 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2760 scalar((OP*)svop);
22c35a8c 2761 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2762 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2763 return CHECKOP(type, svop);
79072805
LW		 2764}
2765
2766OP *
350de78d
GS		 2767Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2768{
2769 PADOP *padop;
2770 NewOp(1101, padop, 1, PADOP);
eb160463 2771 padop->op_type = (OPCODE)type;
350de78d
GS		 2772 padop->op_ppaddr = PL_ppaddr[type];
2773 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 2774 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2775 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS		 2776 if (sv)
2777 SvPADTMP_on(sv);
350de78d 2778 padop->op_next = (OP*)padop;
eb160463 2779 padop->op_flags = (U8)flags;
350de78d
GS		 2780 if (PL_opargs[type] & OA_RETSCALAR)
2781 scalar((OP*)padop);
2782 if (PL_opargs[type] & OA_TARGET)
2783 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2784 return CHECKOP(type, padop);
2785}
2786
2787OP *
864dbfa3 2788Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 2789{
350de78d 2790#ifdef USE_ITHREADS
ce50c033
AMS		 2791 if (gv)
2792 GvIN_PAD_on(gv);
350de78d
GS		 2793 return newPADOP(type, flags, SvREFCNT_inc(gv));
2794#else
7934575e 2795 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 2796#endif
79072805
LW		 2797}
2798
2799OP *
864dbfa3 2800Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 2801{
2802 PVOP *pvop;
b7dc083c 2803 NewOp(1101, pvop, 1, PVOP);
eb160463 2804 pvop->op_type = (OPCODE)type;
22c35a8c 2805 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2806 pvop->op_pv = pv;
2807 pvop->op_next = (OP*)pvop;
eb160463 2808 pvop->op_flags = (U8)flags;
22c35a8c 2809 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2810 scalar((OP*)pvop);
22c35a8c 2811 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2812 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2813 return CHECKOP(type, pvop);
79072805
LW		 2814}
2815
79072805 2816void
864dbfa3 2817Perl_package(pTHX_ OP *o)
79072805 2818{
de11ba31
AMS		 2819 char *name;
2820 STRLEN len;
79072805 2821
3280af22
NIS		 2822 save_hptr(&PL_curstash);
2823 save_item(PL_curstname);
de11ba31
AMS		 2824
2825 name = SvPV(cSVOPo->op_sv, len);
2826 PL_curstash = gv_stashpvn(name, len, TRUE);
2827 sv_setpvn(PL_curstname, name, len);
2828 op_free(o);
2829
7ad382f4 2830 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 2831 PL_copline = NOLINE;
2832 PL_expect = XSTATE;
79072805
LW		 2833}
2834
85e6fe83 2835void
88d95a4d 2836Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 2837{
a0d0e21e 2838 OP *pack;
a0d0e21e 2839 OP *imop;
b1cb66bf 2840 OP *veop;
85e6fe83 2841
88d95a4d 2842 if (idop->op_type != OP_CONST)
cea2e8a9 2843 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 2844
b1cb66bf 2845 veop = Nullop;
2846
0f79a09d 2847 if (version != Nullop) {
b1cb66bf 2848 SV *vesv = ((SVOP*)version)->op_sv;
2849
44dcb63b 2850 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 2851 arg = version;
2852 }
2853 else {
2854 OP *pack;
0f79a09d 2855 SV *meth;
b1cb66bf 2856
44dcb63b 2857 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 2858 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 2859
88d95a4d
JH		 2860 /* Make copy of idop so we don't free it twice */
2861 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 2862
2863 /* Fake up a method call to VERSION */
0f79a09d
GS		 2864 meth = newSVpvn("VERSION",7);
2865 sv_upgrade(meth, SVt_PVIV);
155aba94 2866 (void)SvIOK_on(meth);
5afd6d42 2867 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 2868 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2869 append_elem(OP_LIST,
0f79a09d
GS		 2870 prepend_elem(OP_LIST, pack, list(version)),
2871 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 2872 }
2873 }
aeea060c 2874
a0d0e21e 2875 /* Fake up an import/unimport */
4633a7c4
LW		 2876 if (arg && arg->op_type == OP_STUB)
2877 imop = arg; /* no import on explicit () */
88d95a4d 2878 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
b1cb66bf 2879 imop = Nullop; /* use 5.0; */
2880 }
4633a7c4 2881 else {
0f79a09d
GS		 2882 SV *meth;
2883
88d95a4d
JH		 2884 /* Make copy of idop so we don't free it twice */
2885 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 2886
2887 /* Fake up a method call to import/unimport */
b47cad08 2888 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
ad4c42df 2889 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 2890 (void)SvIOK_on(meth);
5afd6d42 2891 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 2892 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 2893 append_elem(OP_LIST,
2894 prepend_elem(OP_LIST, pack, list(arg)),
2895 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 2896 }
2897
a0d0e21e 2898 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 2899 newATTRSUB(floor,
79cb57f6 2900 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 2901 Nullop,
09bef843 2902 Nullop,
a0d0e21e 2903 append_elem(OP_LINESEQ,
b1cb66bf 2904 append_elem(OP_LINESEQ,
88d95a4d 2905 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
b1cb66bf 2906 newSTATEOP(0, Nullch, veop)),
a0d0e21e 2907 newSTATEOP(0, Nullch, imop) ));
85e6fe83 2908
70f5e4ed
JH		 2909 /* The "did you use incorrect case?" warning used to be here.
2910 * The problem is that on case-insensitive filesystems one
2911 * might get false positives for "use" (and "require"):
2912 * "use Strict" or "require CARP" will work. This causes
2913 * portability problems for the script: in case-strict
2914 * filesystems the script will stop working.
2915 *
2916 * The "incorrect case" warning checked whether "use Foo"
2917 * imported "Foo" to your namespace, but that is wrong, too:
2918 * there is no requirement nor promise in the language that
2919 * a Foo.pm should or would contain anything in package "Foo".
2920 *
2921 * There is very little Configure-wise that can be done, either:
2922 * the case-sensitivity of the build filesystem of Perl does not
2923 * help in guessing the case-sensitivity of the runtime environment.
2924 */
18fc9488 2925
c305c6a0 2926 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 2927 PL_copline = NOLINE;
2928 PL_expect = XSTATE;
85e6fe83
LW		 2929}
2930
7d3fb230 2931/*
ccfc67b7
JH		 2932=head1 Embedding Functions
2933
7d3fb230
BS		 2934=for apidoc load_module
2935
2936Loads the module whose name is pointed to by the string part of name.
2937Note that the actual module name, not its filename, should be given.
2938Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2939PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2940(or 0 for no flags). ver, if specified, provides version semantics
2941similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2942arguments can be used to specify arguments to the module's import()
2943method, similar to C<use Foo::Bar VERSION LIST>.
2944
2945=cut */
2946
e4783991
GS		 2947void
2948Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2949{
2950 va_list args;
2951 va_start(args, ver);
2952 vload_module(flags, name, ver, &args);
2953 va_end(args);
2954}
2955
2956#ifdef PERL_IMPLICIT_CONTEXT
2957void
2958Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2959{
2960 dTHX;
2961 va_list args;
2962 va_start(args, ver);
2963 vload_module(flags, name, ver, &args);
2964 va_end(args);
2965}
2966#endif
2967
2968void
2969Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2970{
2971 OP *modname, *veop, *imop;
2972
2973 modname = newSVOP(OP_CONST, 0, name);
2974 modname->op_private |= OPpCONST_BARE;
2975 if (ver) {
2976 veop = newSVOP(OP_CONST, 0, ver);
2977 }
2978 else
2979 veop = Nullop;
2980 if (flags & PERL_LOADMOD_NOIMPORT) {
2981 imop = sawparens(newNULLLIST());
2982 }
2983 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2984 imop = va_arg(*args, OP*);
2985 }
2986 else {
2987 SV *sv;
2988 imop = Nullop;
2989 sv = va_arg(*args, SV*);
2990 while (sv) {
2991 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2992 sv = va_arg(*args, SV*);
2993 }
2994 }
81885997
GS		 2995 {
2996 line_t ocopline = PL_copline;
834a3ffa 2997 COP *ocurcop = PL_curcop;
81885997
GS		 2998 int oexpect = PL_expect;
2999
3000 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3001 veop, modname, imop);
3002 PL_expect = oexpect;
3003 PL_copline = ocopline;
834a3ffa 3004 PL_curcop = ocurcop;
81885997 3005 }
e4783991
GS		 3006}
3007
79072805 3008OP *
864dbfa3 3009Perl_dofile(pTHX_ OP *term)
78ca652e
GS		 3010{
3011 OP *doop;
3012 GV *gv;
3013
3014 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3015 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS		 3016 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3017
b9f751c0 3018 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3019 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3020 append_elem(OP_LIST, term,
3021 scalar(newUNOP(OP_RV2CV, 0,
3022 newGVOP(OP_GV, 0,
3023 gv))))));
3024 }
3025 else {
3026 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3027 }
3028 return doop;
3029}
3030
3031OP *
864dbfa3 3032Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3033{
3034 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3035 list(force_list(subscript)),
3036 list(force_list(listval)) );
79072805
LW		 3037}
3038
76e3520e 3039STATIC I32
cea2e8a9 3040S_list_assignment(pTHX_ register OP *o)
79072805 3041{
11343788 3042 if (!o)
79072805
LW		 3043 return TRUE;
3044
11343788
MB		 3045 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3046 o = cUNOPo->op_first;
79072805 3047
11343788 3048 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM		 3049 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3050 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3051
3052 if (t && f)
3053 return TRUE;
3054 if (t || f)
3055 yyerror("Assignment to both a list and a scalar");
3056 return FALSE;
3057 }
3058
95f0a2f1
SB		 3059 if (o->op_type == OP_LIST &&
3060 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3061 o->op_private & OPpLVAL_INTRO)
3062 return FALSE;
3063
11343788
MB		 3064 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3065 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3066 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3067 return TRUE;
3068
11343788 3069 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3070 return TRUE;
3071
11343788 3072 if (o->op_type == OP_RV2SV)
79072805
LW		 3073 return FALSE;
3074
3075 return FALSE;
3076}
3077
3078OP *
864dbfa3 3079Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3080{
11343788 3081 OP *o;
79072805 3082
a0d0e21e 3083 if (optype) {
c963b151 3084 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 3085 return newLOGOP(optype, 0,
3086 mod(scalar(left), optype),
3087 newUNOP(OP_SASSIGN, 0, scalar(right)));
3088 }
3089 else {
3090 return newBINOP(optype, OPf_STACKED,
3091 mod(scalar(left), optype), scalar(right));
3092 }
3093 }
3094
79072805 3095 if (list_assignment(left)) {
10c8fecd
GS		 3096 OP *curop;
3097
3280af22
NIS		 3098 PL_modcount = 0;
3099 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3100 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3101 if (PL_eval_start)
3102 PL_eval_start = 0;
748a9306 3103 else {
a0d0e21e
LW		 3104 op_free(left);
3105 op_free(right);
3106 return Nullop;
3107 }
10c8fecd
GS		 3108 curop = list(force_list(left));
3109 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3110 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM		 3111
3112 /* PL_generation sorcery:
3113 * an assignment like ($a,$b) = ($c,$d) is easier than
3114 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3115 * To detect whether there are common vars, the global var
3116 * PL_generation is incremented for each assign op we compile.
3117 * Then, while compiling the assign op, we run through all the
3118 * variables on both sides of the assignment, setting a spare slot
3119 * in each of them to PL_generation. If any of them already have
3120 * that value, we know we've got commonality. We could use a
3121 * single bit marker, but then we'd have to make 2 passes, first
3122 * to clear the flag, then to test and set it. To find somewhere
3123 * to store these values, evil chicanery is done with SvCUR().
3124 */
3125
a0d0e21e 3126 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3127 OP *lastop = o;
3280af22 3128 PL_generation++;
11343788 3129 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3130 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3131 if (curop->op_type == OP_GV) {
638eceb6 3132 GV *gv = cGVOPx_gv(curop);
eb160463 3133 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
79072805 3134 break;
3280af22 3135 SvCUR(gv) = PL_generation;
79072805 3136 }
748a9306
LW		 3137 else if (curop->op_type == OP_PADSV ||
3138 curop->op_type == OP_PADAV ||
3139 curop->op_type == OP_PADHV ||
dd2155a4
DM		 3140 curop->op_type == OP_PADANY)
3141 {
3142 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3143 == (STRLEN)PL_generation)
748a9306 3144 break;
dd2155a4
DM		 3145 PAD_COMPNAME_GEN(curop->op_targ)
3146 = PL_generation;
3147
748a9306 3148 }
79072805
LW		 3149 else if (curop->op_type == OP_RV2CV)
3150 break;
3151 else if (curop->op_type == OP_RV2SV ||
3152 curop->op_type == OP_RV2AV ||
3153 curop->op_type == OP_RV2HV ||
3154 curop->op_type == OP_RV2GV) {
3155 if (lastop->op_type != OP_GV) /* funny deref? */
3156 break;
3157 }
1167e5da
SM		 3158 else if (curop->op_type == OP_PUSHRE) {
3159 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3160#ifdef USE_ITHREADS
dd2155a4
DM		 3161 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3162 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3163#else
1167e5da 3164 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3165#endif
eb160463 3166 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
1167e5da 3167 break;
3280af22 3168 SvCUR(gv) = PL_generation;
b2ffa427 3169 }
1167e5da 3170 }
79072805
LW		 3171 else
3172 break;
3173 }
3174 lastop = curop;
3175 }
11343788 3176 if (curop != o)
10c8fecd 3177 o->op_private |= OPpASSIGN_COMMON;
79072805 3178 }
c07a80fd 3179 if (right && right->op_type == OP_SPLIT) {
3180 OP* tmpop;
3181 if ((tmpop = ((LISTOP*)right)->op_first) &&
3182 tmpop->op_type == OP_PUSHRE)
3183 {
3184 PMOP *pm = (PMOP*)tmpop;
3185 if (left->op_type == OP_RV2AV &&
3186 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3187 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3188 {
3189 tmpop = ((UNOP*)left)->op_first;
3190 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3191#ifdef USE_ITHREADS
ba89bb6e 3192 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3193 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3194#else
3195 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3196 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3197#endif
c07a80fd 3198 pm->op_pmflags |= PMf_ONCE;
11343788 3199 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3200 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3201 tmpop->op_sibling = Nullop; /* don't free split */
3202 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3203 op_free(o); /* blow off assign */
54310121 3204 right->op_flags &= ~OPf_WANT;
a5f75d66 3205 /* "I don't know and I don't care." */
c07a80fd 3206 return right;
3207 }
3208 }
3209 else {
e6438c1a 3210 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3211 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3212 {
3213 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3214 if (SvIVX(sv) == 0)
3280af22 3215 sv_setiv(sv, PL_modcount+1);
c07a80fd 3216 }
3217 }
3218 }
3219 }
11343788 3220 return o;
79072805
LW		 3221 }
3222 if (!right)
3223 right = newOP(OP_UNDEF, 0);
3224 if (right->op_type == OP_READLINE) {
3225 right->op_flags |= OPf_STACKED;
463ee0b2 3226 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3227 }
a0d0e21e 3228 else {
3280af22 3229 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3230 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3231 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3232 if (PL_eval_start)
3233 PL_eval_start = 0;
748a9306 3234 else {
11343788 3235 op_free(o);
a0d0e21e
LW		 3236 return Nullop;
3237 }
3238 }
11343788 3239 return o;
79072805
LW		 3240}
3241
3242OP *
864dbfa3 3243Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3244{
bbce6d69 3245 U32 seq = intro_my();
79072805
LW		 3246 register COP *cop;
3247
b7dc083c 3248 NewOp(1101, cop, 1, COP);
57843af0 3249 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3250 cop->op_type = OP_DBSTATE;
22c35a8c 3251 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3252 }
3253 else {
3254 cop->op_type = OP_NEXTSTATE;
22c35a8c 3255 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3256 }
eb160463
GS		 3257 cop->op_flags = (U8)flags;
3258 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3259#ifdef NATIVE_HINTS
3260 cop->op_private |= NATIVE_HINTS;
3261#endif
e24b16f9 3262 PL_compiling.op_private = cop->op_private;
79072805
LW		 3263 cop->op_next = (OP*)cop;
3264
463ee0b2
LW		 3265 if (label) {
3266 cop->cop_label = label;
3280af22 3267 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3268 }
bbce6d69 3269 cop->cop_seq = seq;
3280af22 3270 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3271 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3272 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3273 else
599cee73 3274 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3275 if (specialCopIO(PL_curcop->cop_io))
3276 cop->cop_io = PL_curcop->cop_io;
3277 else
3278 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3279
79072805 3280
3280af22 3281 if (PL_copline == NOLINE)
57843af0 3282 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3283 else {
57843af0 3284 CopLINE_set(cop, PL_copline);
3280af22 3285 PL_copline = NOLINE;
79072805 3286 }
57843af0 3287#ifdef USE_ITHREADS
f4dd75d9 3288 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3289#else
f4dd75d9 3290 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3291#endif
11faa288 3292 CopSTASH_set(cop, PL_curstash);
79072805 3293
3280af22 3294 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3295 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3296 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3297 (void)SvIOK_on(*svp);
57b2e452 3298 SvIVX(*svp) = PTR2IV(cop);
1eb1540c 3299 }
93a17b20
LW		 3300 }
3301
11343788 3302 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3303}
3304
bbce6d69 3305
79072805 3306OP *
864dbfa3 3307Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3308{
883ffac3
CS		 3309 return new_logop(type, flags, &first, &other);
3310}
3311
3bd495df 3312STATIC OP *
cea2e8a9 3313S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3314{
79072805 3315 LOGOP *logop;
11343788 3316 OP *o;
883ffac3
CS		 3317 OP *first = *firstp;
3318 OP *other = *otherp;
79072805 3319
a0d0e21e
LW		 3320 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3321 return newBINOP(type, flags, scalar(first), scalar(other));
3322
8990e307 3323 scalarboolean(first);
79072805
LW		 3324 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3325 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3326 if (type == OP_AND || type == OP_OR) {
3327 if (type == OP_AND)
3328 type = OP_OR;
3329 else
3330 type = OP_AND;
11343788 3331 o = first;
883ffac3 3332 first = *firstp = cUNOPo->op_first;
11343788
MB		 3333 if (o->op_next)
3334 first->op_next = o->op_next;
3335 cUNOPo->op_first = Nullop;
3336 op_free(o);
79072805
LW		 3337 }
3338 }
3339 if (first->op_type == OP_CONST) {
989dfb19 3340 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
6d5637c3 3341 if (first->op_private & OPpCONST_STRICT)
989dfb19
K		 3342 no_bareword_allowed(first);
3343 else
3344 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3345 }
79072805
LW		 3346 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3347 op_free(first);
883ffac3 3348 *firstp = Nullop;
79072805
LW		 3349 return other;
3350 }
3351 else {
3352 op_free(other);
883ffac3 3353 *otherp = Nullop;
79072805
LW		 3354 return first;
3355 }
3356 }
e476b1b5 3357 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
a6006777 3358 OP *k1 = ((UNOP*)first)->op_first;
3359 OP *k2 = k1->op_sibling;
3360 OPCODE warnop = 0;
3361 switch (first->op_type)
3362 {
3363 case OP_NULL:
3364 if (k2 && k2->op_type == OP_READLINE
3365 && (k2->op_flags & OPf_STACKED)
1c846c1f 3366 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3367 {
a6006777 3368 warnop = k2->op_type;
72b16652 3369 }
a6006777 3370 break;
3371
3372 case OP_SASSIGN:
68dc0745 3373 if (k1->op_type == OP_READDIR
3374 || k1->op_type == OP_GLOB
72b16652 3375 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3376 || k1->op_type == OP_EACH)
72b16652
GS		 3377 {
3378 warnop = ((k1->op_type == OP_NULL)
eb160463 3379 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 3380 }
a6006777 3381 break;
3382 }
8ebc5c01 3383 if (warnop) {
57843af0
GS		 3384 line_t oldline = CopLINE(PL_curcop);
3385 CopLINE_set(PL_curcop, PL_copline);
9014280d 3386 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 3387 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3388 PL_op_desc[warnop],
68dc0745 3389 ((warnop == OP_READLINE || warnop == OP_GLOB)
3390 ? " construct" : "() operator"));
57843af0 3391 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3392 }
a6006777 3393 }
79072805
LW		 3394
3395 if (!other)
3396 return first;
3397
c963b151 3398 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 3399 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3400
b7dc083c 3401 NewOp(1101, logop, 1, LOGOP);
79072805 3402
eb160463 3403 logop->op_type = (OPCODE)type;
22c35a8c 3404 logop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3405 logop->op_first = first;
3406 logop->op_flags = flags | OPf_KIDS;
3407 logop->op_other = LINKLIST(other);
eb160463 3408 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3409
3410 /* establish postfix order */
3411 logop->op_next = LINKLIST(first);
3412 first->op_next = (OP*)logop;
3413 first->op_sibling = other;
3414
11343788
MB		 3415 o = newUNOP(OP_NULL, 0, (OP*)logop);
3416 other->op_next = o;
79072805 3417
11343788 3418 return o;
79072805
LW		 3419}
3420
3421OP *
864dbfa3 3422Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3423{
1a67a97c
SM		 3424 LOGOP *logop;
3425 OP *start;
11343788 3426 OP *o;
79072805 3427
b1cb66bf 3428 if (!falseop)
3429 return newLOGOP(OP_AND, 0, first, trueop);
3430 if (!trueop)
3431 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3432
8990e307 3433 scalarboolean(first);
79072805 3434 if (first->op_type == OP_CONST) {
2bc6235c
K		 3435 if (first->op_private & OPpCONST_BARE &&
3436 first->op_private & OPpCONST_STRICT) {
3437 no_bareword_allowed(first);
3438 }
79072805
LW		 3439 if (SvTRUE(((SVOP*)first)->op_sv)) {
3440 op_free(first);
b1cb66bf 3441 op_free(falseop);
3442 return trueop;
79072805
LW		 3443 }
3444 else {
3445 op_free(first);
b1cb66bf 3446 op_free(trueop);
3447 return falseop;
79072805
LW		 3448 }
3449 }
1a67a97c
SM		 3450 NewOp(1101, logop, 1, LOGOP);
3451 logop->op_type = OP_COND_EXPR;
3452 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3453 logop->op_first = first;
3454 logop->op_flags = flags | OPf_KIDS;
eb160463 3455 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 3456 logop->op_other = LINKLIST(trueop);
3457 logop->op_next = LINKLIST(falseop);
79072805 3458
79072805
LW		 3459
3460 /* establish postfix order */
1a67a97c
SM		 3461 start = LINKLIST(first);
3462 first->op_next = (OP*)logop;
79072805 3463
b1cb66bf 3464 first->op_sibling = trueop;
3465 trueop->op_sibling = falseop;
1a67a97c 3466 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 3467
1a67a97c 3468 trueop->op_next = falseop->op_next = o;
79072805 3469
1a67a97c 3470 o->op_next = start;
11343788 3471 return o;
79072805
LW		 3472}
3473
3474OP *
864dbfa3 3475Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 3476{
1a67a97c 3477 LOGOP *range;
79072805
LW		 3478 OP *flip;
3479 OP *flop;
1a67a97c 3480 OP *leftstart;
11343788 3481 OP *o;
79072805 3482
1a67a97c 3483 NewOp(1101, range, 1, LOGOP);
79072805 3484
1a67a97c
SM		 3485 range->op_type = OP_RANGE;
3486 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3487 range->op_first = left;
3488 range->op_flags = OPf_KIDS;
3489 leftstart = LINKLIST(left);
3490 range->op_other = LINKLIST(right);
eb160463 3491 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3492
3493 left->op_sibling = right;
3494
1a67a97c
SM		 3495 range->op_next = (OP*)range;
3496 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 3497 flop = newUNOP(OP_FLOP, 0, flip);
11343788 3498 o = newUNOP(OP_NULL, 0, flop);
79072805 3499 linklist(flop);
1a67a97c 3500 range->op_next = leftstart;
79072805
LW		 3501
3502 left->op_next = flip;
3503 right->op_next = flop;
3504
1a67a97c
SM		 3505 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3506 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 3507 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 3508 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3509
3510 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3511 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3512
11343788 3513 flip->op_next = o;
79072805 3514 if (!flip->op_private || !flop->op_private)
11343788 3515 linklist(o); /* blow off optimizer unless constant */
79072805 3516
11343788 3517 return o;
79072805
LW		 3518}
3519
3520OP *
864dbfa3 3521Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 3522{
463ee0b2 3523 OP* listop;
11343788 3524 OP* o;
463ee0b2 3525 int once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 3526 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
93a17b20 3527
463ee0b2
LW		 3528 if (expr) {
3529 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3530 return block; /* do {} while 0 does once */
fb73857a 3531 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3532 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 3533 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3534 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3535 } else if (expr->op_flags & OPf_KIDS) {
3536 OP *k1 = ((UNOP*)expr)->op_first;
3537 OP *k2 = (k1) ? k1->op_sibling : NULL;
3538 switch (expr->op_type) {
1c846c1f 3539 case OP_NULL:
55d729e4
GS		 3540 if (k2 && k2->op_type == OP_READLINE
3541 && (k2->op_flags & OPf_STACKED)
1c846c1f 3542 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3543 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3544 break;
55d729e4
GS		 3545
3546 case OP_SASSIGN:
3547 if (k1->op_type == OP_READDIR
3548 || k1->op_type == OP_GLOB
6531c3e6 3549 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3550 || k1->op_type == OP_EACH)
3551 expr = newUNOP(OP_DEFINED, 0, expr);
3552 break;
3553 }
774d564b 3554 }
463ee0b2 3555 }
93a17b20 3556
8990e307 3557 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 3558 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 3559
883ffac3
CS		 3560 if (listop)
3561 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 3562
11343788
MB		 3563 if (once && o != listop)
3564 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 3565
11343788
MB		 3566 if (o == listop)
3567 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 3568
11343788
MB		 3569 o->op_flags |= flags;
3570 o = scope(o);
3571 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3572 return o;
79072805
LW		 3573}
3574
3575OP *
864dbfa3 3576Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
79072805
LW		 3577{
3578 OP *redo;
3579 OP *next = 0;
3580 OP *listop;
11343788 3581 OP *o;
1ba6ee2b 3582 U8 loopflags = 0;
79072805 3583
fb73857a 3584 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3585 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
748a9306 3586 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3587 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3588 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3589 OP *k1 = ((UNOP*)expr)->op_first;
3590 OP *k2 = (k1) ? k1->op_sibling : NULL;
3591 switch (expr->op_type) {
1c846c1f 3592 case OP_NULL:
55d729e4
GS		 3593 if (k2 && k2->op_type == OP_READLINE
3594 && (k2->op_flags & OPf_STACKED)
1c846c1f 3595 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3596 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3597 break;
55d729e4
GS		 3598
3599 case OP_SASSIGN:
3600 if (k1->op_type == OP_READDIR
3601 || k1->op_type == OP_GLOB
72b16652 3602 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3603 || k1->op_type == OP_EACH)
3604 expr = newUNOP(OP_DEFINED, 0, expr);
3605 break;
3606 }
748a9306 3607 }
79072805
LW		 3608
3609 if (!block)
3610 block = newOP(OP_NULL, 0);
87246558
GS		 3611 else if (cont) {
3612 block = scope(block);
3613 }
79072805 3614
1ba6ee2b 3615 if (cont) {
79072805 3616 next = LINKLIST(cont);
1ba6ee2b 3617 }
fb73857a 3618 if (expr) {
85538317
GS		 3619 OP *unstack = newOP(OP_UNSTACK, 0);
3620 if (!next)
3621 next = unstack;
3622 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 3623 }
79072805 3624
463ee0b2 3625 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 3626 redo = LINKLIST(listop);
3627
3628 if (expr) {
eb160463 3629 PL_copline = (line_t)whileline;
883ffac3
CS		 3630 scalar(listop);
3631 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 3632 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 3633 op_free(expr); /* oops, it's a while (0) */
463ee0b2 3634 op_free((OP*)loop);
883ffac3 3635 return Nullop; /* listop already freed by new_logop */
463ee0b2 3636 }
883ffac3 3637 if (listop)
497b47a8 3638 ((LISTOP*)listop)->op_last->op_next =
883ffac3 3639 (o == listop ? redo : LINKLIST(o));
79072805
LW		 3640 }
3641 else
11343788 3642 o = listop;
79072805
LW		 3643
3644 if (!loop) {
b7dc083c 3645 NewOp(1101,loop,1,LOOP);
79072805 3646 loop->op_type = OP_ENTERLOOP;
22c35a8c 3647 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 3648 loop->op_private = 0;
3649 loop->op_next = (OP*)loop;
3650 }
3651
11343788 3652 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 3653
3654 loop->op_redoop = redo;
11343788 3655 loop->op_lastop = o;
1ba6ee2b 3656 o->op_private |= loopflags;
79072805
LW		 3657
3658 if (next)
3659 loop->op_nextop = next;
3660 else
11343788 3661 loop->op_nextop = o;
79072805 3662
11343788
MB		 3663 o->op_flags |= flags;
3664 o->op_private |= (flags >> 8);
3665 return o;
79072805
LW		 3666}
3667
3668OP *
864dbfa3 3669Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
79072805
LW		 3670{
3671 LOOP *loop;
fb73857a 3672 OP *wop;
4bbc6d12 3673 PADOFFSET padoff = 0;
4633a7c4 3674 I32 iterflags = 0;
241416b8 3675 I32 iterpflags = 0;
79072805 3676
79072805 3677 if (sv) {
85e6fe83 3678 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 3679 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 3680 sv->op_type = OP_RV2GV;
22c35a8c 3681 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
79072805 3682 }
85e6fe83 3683 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 3684 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 3685 padoff = sv->op_targ;
743e66e6 3686 sv->op_targ = 0;
85e6fe83
LW		 3687 op_free(sv);
3688 sv = Nullop;
3689 }
54b9620d
MB		 3690 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3691 padoff = sv->op_targ;
743e66e6 3692 sv->op_targ = 0;
54b9620d
MB		 3693 iterflags |= OPf_SPECIAL;
3694 op_free(sv);
3695 sv = Nullop;
3696 }
79072805 3697 else
cea2e8a9 3698 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
79072805
LW		 3699 }
3700 else {
3280af22 3701 sv = newGVOP(OP_GV, 0, PL_defgv);
79072805 3702 }
5f05dabc 3703 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 3704 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 3705 iterflags |= OPf_STACKED;
3706 }
89ea2908
GA		 3707 else if (expr->op_type == OP_NULL &&
3708 (expr->op_flags & OPf_KIDS) &&
3709 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3710 {
3711 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3712 * set the STACKED flag to indicate that these values are to be
3713 * treated as min/max values by 'pp_iterinit'.
3714 */
3715 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
1a67a97c 3716 LOGOP* range = (LOGOP*) flip->op_first;
89ea2908
GA		 3717 OP* left = range->op_first;
3718 OP* right = left->op_sibling;
5152d7c7 3719 LISTOP* listop;
89ea2908
GA		 3720
3721 range->op_flags &= ~OPf_KIDS;
3722 range->op_first = Nullop;
3723
5152d7c7 3724 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 3725 listop->op_first->op_next = range->op_next;
3726 left->op_next = range->op_other;
5152d7c7
GS		 3727 right->op_next = (OP*)listop;
3728 listop->op_next = listop->op_first;
89ea2908
GA		 3729
3730 op_free(expr);
5152d7c7 3731 expr = (OP*)(listop);
93c66552 3732 op_null(expr);
89ea2908
GA		 3733 iterflags |= OPf_STACKED;
3734 }
3735 else {
3736 expr = mod(force_list(expr), OP_GREPSTART);
3737 }
3738
3739
4633a7c4 3740 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 3741 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 3742 assert(!loop->op_next);
241416b8
DM		 3743 /* for my $x () sets OPpLVAL_INTRO;
3744 * for our $x () sets OPpOUR_INTRO; both only used by Deparse.pm */
3745 loop->op_private = iterpflags;
b7dc083c 3746#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 3747 {
3748 LOOP *tmp;
3749 NewOp(1234,tmp,1,LOOP);
3750 Copy(loop,tmp,1,LOOP);
238a4c30 3751 FreeOp(loop);
155aba94
GS		 3752 loop = tmp;
3753 }
b7dc083c 3754#else
85e6fe83 3755 Renew(loop, 1, LOOP);
1c846c1f 3756#endif
85e6fe83 3757 loop->op_targ = padoff;
fb73857a 3758 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3280af22 3759 PL_copline = forline;
fb73857a 3760 return newSTATEOP(0, label, wop);
79072805
LW		 3761}
3762
8990e307 3763OP*
864dbfa3 3764Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 3765{
11343788 3766 OP *o;
2d8e6c8d
GS		 3767 STRLEN n_a;
3768
8990e307 3769 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 3770 /* "last()" means "last" */
3771 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3772 o = newOP(type, OPf_SPECIAL);
3773 else {
3774 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
2d8e6c8d 3775 ? SvPVx(((SVOP*)label)->op_sv, n_a)
cdaebead
MB		 3776 : ""));
3777 }
8990e307
LW		 3778 op_free(label);
3779 }
3780 else {
a0d0e21e
LW		 3781 if (label->op_type == OP_ENTERSUB)
3782 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 3783 o = newUNOP(type, OPf_STACKED, label);
8990e307 3784 }
3280af22 3785 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3786 return o;
8990e307
LW		 3787}
3788
7dafbf52
DM		 3789/*
3790=for apidoc cv_undef
3791
3792Clear out all the active components of a CV. This can happen either
3793by an explicit C<undef &foo>, or by the reference count going to zero.
3794In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3795children can still follow the full lexical scope chain.
3796
3797=cut
3798*/
3799
79072805 3800void
864dbfa3 3801Perl_cv_undef(pTHX_ CV *cv)
79072805 3802{
a636914a
RH		 3803#ifdef USE_ITHREADS
3804 if (CvFILE(cv) && !CvXSUB(cv)) {
f3e31eb5 3805 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 3806 Safefree(CvFILE(cv));
a636914a 3807 }
f3e31eb5 3808 CvFILE(cv) = 0;
a636914a
RH		 3809#endif
3810
a0d0e21e
LW		 3811 if (!CvXSUB(cv) && CvROOT(cv)) {
3812 if (CvDEPTH(cv))
cea2e8a9 3813 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 3814 ENTER;
a0d0e21e 3815
f3548bdc 3816 PAD_SAVE_SETNULLPAD();
a0d0e21e 3817
282f25c9 3818 op_free(CvROOT(cv));
79072805 3819 CvROOT(cv) = Nullop;
8990e307 3820 LEAVE;
79072805 3821 }
1d5db326 3822 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 3823 CvGV(cv) = Nullgv;
a3985cdc
DM		 3824
3825 pad_undef(cv);
3826
7dafbf52
DM		 3827 /* remove CvOUTSIDE unless this is an undef rather than a free */
3828 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3829 if (!CvWEAKOUTSIDE(cv))
3830 SvREFCNT_dec(CvOUTSIDE(cv));
3831 CvOUTSIDE(cv) = Nullcv;
3832 }
beab0874
JT		 3833 if (CvCONST(cv)) {
3834 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3835 CvCONST_off(cv);
3836 }
50762d59
DM		 3837 if (CvXSUB(cv)) {
3838 CvXSUB(cv) = 0;
3839 }
7dafbf52
DM		 3840 /* delete all flags except WEAKOUTSIDE */
3841 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 3842}
3843
3fe9a6f1 3844void
864dbfa3 3845Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 3846{
e476b1b5 3847 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 3848 SV* msg = sv_newmortal();
3fe9a6f1 3849 SV* name = Nullsv;
3850
3851 if (gv)
46fc3d4c 3852 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3853 sv_setpv(msg, "Prototype mismatch:");
3854 if (name)
894356b3 3855 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 3856 if (SvPOK(cv))
35c1215d 3857 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
46fc3d4c 3858 sv_catpv(msg, " vs ");
3859 if (p)
cea2e8a9 3860 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 3861 else
3862 sv_catpv(msg, "none");
9014280d 3863 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3fe9a6f1 3864 }
3865}
3866
acfe0abc 3867static void const_sv_xsub(pTHX_ CV* cv);
beab0874
JT		 3868
3869/*
ccfc67b7
JH		 3870
3871=head1 Optree Manipulation Functions
3872
beab0874
JT		 3873=for apidoc cv_const_sv
3874
3875If C<cv> is a constant sub eligible for inlining. returns the constant
3876value returned by the sub. Otherwise, returns NULL.
3877
3878Constant subs can be created with C<newCONSTSUB> or as described in
3879L<perlsub/"Constant Functions">.
3880
3881=cut
3882*/
760ac839 3883SV *
864dbfa3 3884Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 3885{
beab0874 3886 if (!cv || !CvCONST(cv))
54310121 3887 return Nullsv;
beab0874 3888 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 3889}
760ac839 3890
b5c19bd7
DM		 3891/* op_const_sv: examine an optree to determine whether it's in-lineable.
3892 * Can be called in 3 ways:
3893 *
3894 * !cv
3895 * look for a single OP_CONST with attached value: return the value
3896 *
3897 * cv && CvCLONE(cv) && !CvCONST(cv)
3898 *
3899 * examine the clone prototype, and if contains only a single
3900 * OP_CONST referencing a pad const, or a single PADSV referencing
3901 * an outer lexical, return a non-zero value to indicate the CV is
3902 * a candidate for "constizing" at clone time
3903 *
3904 * cv && CvCONST(cv)
3905 *
3906 * We have just cloned an anon prototype that was marked as a const
3907 * candidiate. Try to grab the current value, and in the case of
3908 * PADSV, ignore it if it has multiple references. Return the value.
3909 */
3910
fe5e78ed 3911SV *
864dbfa3 3912Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 3913{
3914 SV *sv = Nullsv;
3915
0f79a09d 3916 if (!o)
fe5e78ed 3917 return Nullsv;
1c846c1f
NIS		 3918
3919 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 3920 o = cLISTOPo->op_first->op_sibling;
3921
3922 for (; o; o = o->op_next) {
54310121 3923 OPCODE type = o->op_type;
fe5e78ed 3924
1c846c1f 3925 if (sv && o->op_next == o)
fe5e78ed 3926 return sv;
e576b457
JT		 3927 if (o->op_next != o) {
3928 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3929 continue;
3930 if (type == OP_DBSTATE)
3931 continue;
3932 }
54310121 3933 if (type == OP_LEAVESUB || type == OP_RETURN)
3934 break;
3935 if (sv)
3936 return Nullsv;
7766f137 3937 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 3938 sv = cSVOPo->op_sv;
b5c19bd7 3939 else if (cv && type == OP_CONST) {
dd2155a4 3940 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874
JT		 3941 if (!sv)
3942 return Nullsv;
b5c19bd7
DM		 3943 }
3944 else if (cv && type == OP_PADSV) {
3945 if (CvCONST(cv)) { /* newly cloned anon */
3946 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3947 /* the candidate should have 1 ref from this pad and 1 ref
3948 * from the parent */
3949 if (!sv || SvREFCNT(sv) != 2)
3950 return Nullsv;
beab0874 3951 sv = newSVsv(sv);
b5c19bd7
DM		 3952 SvREADONLY_on(sv);
3953 return sv;
3954 }
3955 else {
3956 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3957 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 3958 }
760ac839 3959 }
b5c19bd7 3960 else {
54310121 3961 return Nullsv;
b5c19bd7 3962 }
760ac839
LW		 3963 }
3964 return sv;
3965}
3966
09bef843
SB		 3967void
3968Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3969{
3970 if (o)
3971 SAVEFREEOP(o);
3972 if (proto)
3973 SAVEFREEOP(proto);
3974 if (attrs)
3975 SAVEFREEOP(attrs);
3976 if (block)
3977 SAVEFREEOP(block);
3978 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3979}
3980
748a9306 3981CV *
864dbfa3 3982Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 3983{
09bef843
SB		 3984 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3985}
3986
3987CV *
3988Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3989{
2d8e6c8d 3990 STRLEN n_a;
83ee9e09
GS		 3991 char *name;
3992 char *aname;
3993 GV *gv;
2d8e6c8d 3994 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 3995 register CV *cv=0;
beab0874 3996 SV *const_sv;
79072805 3997
83ee9e09
GS		 3998 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3999 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4000 SV *sv = sv_newmortal();
c99da370
JH		 4001 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4002 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09
GS		 4003 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4004 aname = SvPVX(sv);
4005 }
4006 else
4007 aname = Nullch;
c99da370
JH		 4008 gv = gv_fetchpv(name ? name : (aname ? aname :
4009 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
83ee9e09
GS		 4010 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4011 SVt_PVCV);
4012
11343788 4013 if (o)
5dc0d613 4014 SAVEFREEOP(o);
3fe9a6f1 4015 if (proto)
4016 SAVEFREEOP(proto);
09bef843
SB		 4017 if (attrs)
4018 SAVEFREEOP(attrs);
3fe9a6f1 4019
09bef843 4020 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4021 maximum a prototype before. */
4022 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4023 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4024 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4025 {
9014280d 4026 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 4027 }
55d729e4
GS		 4028 cv_ckproto((CV*)gv, NULL, ps);
4029 }
4030 if (ps)
4031 sv_setpv((SV*)gv, ps);
4032 else
4033 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4034 SvREFCNT_dec(PL_compcv);
4035 cv = PL_compcv = NULL;
4036 PL_sub_generation++;
beab0874 4037 goto done;
55d729e4
GS		 4038 }
4039
beab0874
JT		 4040 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4041
7fb37951
AMS		 4042#ifdef GV_UNIQUE_CHECK
4043 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4044 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4045 }
4046#endif
4047
beab0874
JT		 4048 if (!block || !ps || *ps || attrs)
4049 const_sv = Nullsv;
4050 else
4051 const_sv = op_const_sv(block, Nullcv);
4052
4053 if (cv) {
60ed1d8c 4054 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4055
7fb37951
AMS		 4056#ifdef GV_UNIQUE_CHECK
4057 if (exists && GvUNIQUE(gv)) {
4058 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4059 }
4060#endif
4061
60ed1d8c
GS		 4062 /* if the subroutine doesn't exist and wasn't pre-declared
4063 * with a prototype, assume it will be AUTOLOADed,
4064 * skipping the prototype check
4065 */
4066 if (exists || SvPOK(cv))
01ec43d0 4067 cv_ckproto(cv, gv, ps);
68dc0745 4068 /* already defined (or promised)? */
60ed1d8c 4069 if (exists || GvASSUMECV(gv)) {
09bef843 4070 if (!block && !attrs) {
d3cea301
SB		 4071 if (CvFLAGS(PL_compcv)) {
4072 /* might have had built-in attrs applied */
4073 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4074 }
aa689395 4075 /* just a "sub foo;" when &foo is already defined */
3280af22 4076 SAVEFREESV(PL_compcv);
aa689395 4077 goto done;
4078 }
7bac28a0 4079 /* ahem, death to those who redefine active sort subs */
3280af22 4080 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4081 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4082 if (block) {
4083 if (ckWARN(WARN_REDEFINE)
4084 || (CvCONST(cv)
4085 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4086 {
4087 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4088 if (PL_copline != NOLINE)
4089 CopLINE_set(PL_curcop, PL_copline);
9014280d 4090 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4091 CvCONST(cv) ? "Constant subroutine %s redefined"
4092 : "Subroutine %s redefined", name);
4093 CopLINE_set(PL_curcop, oldline);
4094 }
4095 SvREFCNT_dec(cv);
4096 cv = Nullcv;
79072805 4097 }
79072805
LW		 4098 }
4099 }
beab0874
JT		 4100 if (const_sv) {
4101 SvREFCNT_inc(const_sv);
4102 if (cv) {
0768512c 4103 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4104 sv_setpv((SV*)cv, ""); /* prototype is "" */
4105 CvXSUBANY(cv).any_ptr = const_sv;
4106 CvXSUB(cv) = const_sv_xsub;
4107 CvCONST_on(cv);
beab0874
JT		 4108 }
4109 else {
4110 GvCV(gv) = Nullcv;
4111 cv = newCONSTSUB(NULL, name, const_sv);
4112 }
4113 op_free(block);
4114 SvREFCNT_dec(PL_compcv);
4115 PL_compcv = NULL;
4116 PL_sub_generation++;
4117 goto done;
4118 }
09bef843
SB		 4119 if (attrs) {
4120 HV *stash;
4121 SV *rcv;
4122
4123 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4124 * before we clobber PL_compcv.
4125 */
4126 if (cv && !block) {
4127 rcv = (SV*)cv;
020f0e03
SB		 4128 /* Might have had built-in attributes applied -- propagate them. */
4129 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4130 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4131 stash = GvSTASH(CvGV(cv));
a9164de8 4132 else if (CvSTASH(cv))
09bef843
SB		 4133 stash = CvSTASH(cv);
4134 else
4135 stash = PL_curstash;
4136 }
4137 else {
4138 /* possibly about to re-define existing subr -- ignore old cv */
4139 rcv = (SV*)PL_compcv;
a9164de8 4140 if (name && GvSTASH(gv))
09bef843
SB		 4141 stash = GvSTASH(gv);
4142 else
4143 stash = PL_curstash;
4144 }
95f0a2f1 4145 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4146 }
a0d0e21e 4147 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4148 if (!block) {
4149 /* got here with just attrs -- work done, so bug out */
4150 SAVEFREESV(PL_compcv);
4151 goto done;
4152 }
a3985cdc 4153 /* transfer PL_compcv to cv */
4633a7c4 4154 cv_undef(cv);
3280af22
NIS		 4155 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4156 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 4157 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 4158 CvOUTSIDE(PL_compcv) = 0;
4159 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4160 CvPADLIST(PL_compcv) = 0;
282f25c9 4161 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 4162 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 4163 /* ... before we throw it away */
3280af22 4164 SvREFCNT_dec(PL_compcv);
b5c19bd7 4165 PL_compcv = cv;
a933f601
IZ		 4166 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4167 ++PL_sub_generation;
a0d0e21e
LW		 4168 }
4169 else {
3280af22 4170 cv = PL_compcv;
44a8e56a 4171 if (name) {
4172 GvCV(gv) = cv;
4173 GvCVGEN(gv) = 0;
3280af22 4174 PL_sub_generation++;
44a8e56a 4175 }
a0d0e21e 4176 }
65c50114 4177 CvGV(cv) = gv;
a636914a 4178 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4179 CvSTASH(cv) = PL_curstash;
8990e307 4180
3fe9a6f1 4181 if (ps)
4182 sv_setpv((SV*)cv, ps);
4633a7c4 4183
3280af22 4184 if (PL_error_count) {
c07a80fd 4185 op_free(block);
4186 block = Nullop;
68dc0745 4187 if (name) {
4188 char *s = strrchr(name, ':');
4189 s = s ? s+1 : name;
6d4c2119
CS		 4190 if (strEQ(s, "BEGIN")) {
4191 char *not_safe =
4192 "BEGIN not safe after errors--compilation aborted";
faef0170 4193 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4194 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4195 else {
4196 /* force display of errors found but not reported */
38a03e6e 4197 sv_catpv(ERRSV, not_safe);
35c1215d 4198 Perl_croak(aTHX_ "%"SVf, ERRSV);
6d4c2119
CS		 4199 }
4200 }
68dc0745 4201 }
c07a80fd 4202 }
beab0874
JT		 4203 if (!block)
4204 goto done;
a0d0e21e 4205
7766f137 4206 if (CvLVALUE(cv)) {
78f9721b
SM		 4207 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4208 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4209 }
4210 else {
4211 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4212 }
4213 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4214 OpREFCNT_set(CvROOT(cv), 1);
4215 CvSTART(cv) = LINKLIST(CvROOT(cv));
4216 CvROOT(cv)->op_next = 0;
a2efc822 4217 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4218
4219 /* now that optimizer has done its work, adjust pad values */
54310121 4220
dd2155a4
DM		 4221 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4222
4223 if (CvCLONE(cv)) {
beab0874
JT		 4224 assert(!CvCONST(cv));
4225 if (ps && !*ps && op_const_sv(block, cv))
4226 CvCONST_on(cv);
a0d0e21e 4227 }
79072805 4228
83ee9e09 4229 if (name || aname) {
44a8e56a 4230 char *s;
83ee9e09 4231 char *tname = (name ? name : aname);
44a8e56a 4232
3280af22 4233 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 4234 SV *sv = NEWSV(0,0);
44a8e56a 4235 SV *tmpstr = sv_newmortal();
549bb64a 4236 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 4237 CV *pcv;
44a8e56a 4238 HV *hv;
4239
ed094faf
GS		 4240 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4241 CopFILE(PL_curcop),
cc49e20b 4242 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4243 gv_efullname3(tmpstr, gv, Nullch);
3280af22 4244 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4245 hv = GvHVn(db_postponed);
9607fc9c 4246 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 4247 && (pcv = GvCV(db_postponed)))
4248 {
44a8e56a 4249 dSP;
924508f0 4250 PUSHMARK(SP);
44a8e56a 4251 XPUSHs(tmpstr);
4252 PUTBACK;
83ee9e09 4253 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 4254 }
4255 }
79072805 4256
83ee9e09 4257 if ((s = strrchr(tname,':')))
28757baa 4258 s++;
4259 else
83ee9e09 4260 s = tname;
ed094faf 4261
7d30b5c4 4262 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4263 goto done;
4264
7678c486 4265 if (strEQ(s, "BEGIN") && !PL_error_count) {
3280af22 4266 I32 oldscope = PL_scopestack_ix;
28757baa 4267 ENTER;
57843af0
GS		 4268 SAVECOPFILE(&PL_compiling);
4269 SAVECOPLINE(&PL_compiling);
28757baa 4270
3280af22
NIS		 4271 if (!PL_beginav)
4272 PL_beginav = newAV();
28757baa 4273 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4274 av_push(PL_beginav, (SV*)cv);
4275 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4276 call_list(oldscope, PL_beginav);
a6006777 4277
3280af22 4278 PL_curcop = &PL_compiling;
eb160463 4279 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
28757baa 4280 LEAVE;
4281 }
3280af22
NIS		 4282 else if (strEQ(s, "END") && !PL_error_count) {
4283 if (!PL_endav)
4284 PL_endav = newAV();
ed094faf 4285 DEBUG_x( dump_sub(gv) );
3280af22 4286 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4287 av_store(PL_endav, 0, (SV*)cv);
4288 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4289 }
7d30b5c4
GS		 4290 else if (strEQ(s, "CHECK") && !PL_error_count) {
4291 if (!PL_checkav)
4292 PL_checkav = newAV();
ed094faf 4293 DEBUG_x( dump_sub(gv) );
ddda08b7 4294 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4295 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4296 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4297 av_store(PL_checkav, 0, (SV*)cv);
4298 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4299 }
3280af22
NIS		 4300 else if (strEQ(s, "INIT") && !PL_error_count) {
4301 if (!PL_initav)
4302 PL_initav = newAV();
ed094faf 4303 DEBUG_x( dump_sub(gv) );
ddda08b7 4304 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4305 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4306 av_push(PL_initav, (SV*)cv);
4307 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4308 }
79072805 4309 }
a6006777 4310
aa689395 4311 done:
3280af22 4312 PL_copline = NOLINE;
8990e307 4313 LEAVE_SCOPE(floor);
a0d0e21e 4314 return cv;
79072805
LW		 4315}
4316
b099ddc0 4317/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4318/*
4319=for apidoc newCONSTSUB
4320
4321Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4322eligible for inlining at compile-time.
4323
4324=cut
4325*/
4326
beab0874 4327CV *
864dbfa3 4328Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 4329{
beab0874 4330 CV* cv;
5476c433 4331
11faa288 4332 ENTER;
11faa288 4333
f4dd75d9 4334 SAVECOPLINE(PL_curcop);
11faa288 4335 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4336
4337 SAVEHINTS();
3280af22 4338 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4339
4340 if (stash) {
4341 SAVESPTR(PL_curstash);
4342 SAVECOPSTASH(PL_curcop);
4343 PL_curstash = stash;
05ec9bb3 4344 CopSTASH_set(PL_curcop,stash);
11faa288 4345 }
5476c433 4346
91a15d0d 4347 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
beab0874
JT		 4348 CvXSUBANY(cv).any_ptr = sv;
4349 CvCONST_on(cv);
4350 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 4351
11faa288 4352 LEAVE;
beab0874
JT		 4353
4354 return cv;
5476c433
JD		 4355}
4356
954c1994
GS		 4357/*
4358=for apidoc U||newXS
4359
4360Used by C<xsubpp> to hook up XSUBs as Perl subs.
4361
4362=cut
4363*/
4364
57d3b86d 4365CV *
864dbfa3 4366Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 4367{
c99da370
JH		 4368 GV *gv = gv_fetchpv(name ? name :
4369 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4370 GV_ADDMULTI, SVt_PVCV);
79072805 4371 register CV *cv;
44a8e56a 4372
1ecdd9a8
HS		 4373 if (!subaddr)
4374 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4375
155aba94 4376 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4377 if (GvCVGEN(gv)) {
4378 /* just a cached method */
4379 SvREFCNT_dec(cv);
4380 cv = 0;
4381 }
4382 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4383 /* already defined (or promised) */
599cee73 4384 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4 4385 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 4386 line_t oldline = CopLINE(PL_curcop);
51f6edd3 4387 if (PL_copline != NOLINE)
57843af0 4388 CopLINE_set(PL_curcop, PL_copline);
9014280d 4389 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4390 CvCONST(cv) ? "Constant subroutine %s redefined"
4391 : "Subroutine %s redefined"
4392 ,name);
57843af0 4393 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 4394 }
4395 SvREFCNT_dec(cv);
4396 cv = 0;
79072805 4397 }
79072805 4398 }
44a8e56a 4399
4400 if (cv) /* must reuse cv if autoloaded */
4401 cv_undef(cv);
a0d0e21e
LW		 4402 else {
4403 cv = (CV*)NEWSV(1105,0);
4404 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 4405 if (name) {
4406 GvCV(gv) = cv;
4407 GvCVGEN(gv) = 0;
3280af22 4408 PL_sub_generation++;
44a8e56a 4409 }
a0d0e21e 4410 }
65c50114 4411 CvGV(cv) = gv;
b195d487 4412 (void)gv_fetchfile(filename);
57843af0
GS		 4413 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4414 an external constant string */
a0d0e21e 4415 CvXSUB(cv) = subaddr;
44a8e56a 4416
28757baa 4417 if (name) {
4418 char *s = strrchr(name,':');
4419 if (s)
4420 s++;
4421 else
4422 s = name;
ed094faf 4423
7d30b5c4 4424 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4425 goto done;
4426
28757baa 4427 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 4428 if (!PL_beginav)
4429 PL_beginav = newAV();
ea2f84a3
GS		 4430 av_push(PL_beginav, (SV*)cv);
4431 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4432 }
4433 else if (strEQ(s, "END")) {
3280af22
NIS		 4434 if (!PL_endav)
4435 PL_endav = newAV();
4436 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4437 av_store(PL_endav, 0, (SV*)cv);
4438 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4439 }
7d30b5c4
GS		 4440 else if (strEQ(s, "CHECK")) {
4441 if (!PL_checkav)
4442 PL_checkav = newAV();
ddda08b7 4443 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4444 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4445 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4446 av_store(PL_checkav, 0, (SV*)cv);
4447 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4448 }
7d07dbc2 4449 else if (strEQ(s, "INIT")) {
3280af22
NIS		 4450 if (!PL_initav)
4451 PL_initav = newAV();
ddda08b7 4452 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4453 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4454 av_push(PL_initav, (SV*)cv);
4455 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4456 }
28757baa 4457 }
8990e307 4458 else
a5f75d66 4459 CvANON_on(cv);
44a8e56a 4460
ed094faf 4461done:
a0d0e21e 4462 return cv;
79072805
LW		 4463}
4464
4465void
864dbfa3 4466Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 4467{
4468 register CV *cv;
4469 char *name;
4470 GV *gv;
2d8e6c8d 4471 STRLEN n_a;
79072805 4472
11343788 4473 if (o)
2d8e6c8d 4474 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 4475 else
4476 name = "STDOUT";
85e6fe83 4477 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
7fb37951
AMS		 4478#ifdef GV_UNIQUE_CHECK
4479 if (GvUNIQUE(gv)) {
4480 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 4481 }
4482#endif
a5f75d66 4483 GvMULTI_on(gv);
155aba94 4484 if ((cv = GvFORM(gv))) {
599cee73 4485 if (ckWARN(WARN_REDEFINE)) {
57843af0 4486 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4487 if (PL_copline != NOLINE)
4488 CopLINE_set(PL_curcop, PL_copline);
9014280d 4489 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
57843af0 4490 CopLINE_set(PL_curcop, oldline);
79072805 4491 }
8990e307 4492 SvREFCNT_dec(cv);
79072805 4493 }
3280af22 4494 cv = PL_compcv;
79072805 4495 GvFORM(gv) = cv;
65c50114 4496 CvGV(cv) = gv;
a636914a 4497 CvFILE_set_from_cop(cv, PL_curcop);
79072805 4498
a0d0e21e 4499
dd2155a4 4500 pad_tidy(padtidy_FORMAT);
79072805 4501 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 4502 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4503 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 4504 CvSTART(cv) = LINKLIST(CvROOT(cv));
4505 CvROOT(cv)->op_next = 0;
a2efc822 4506 CALL_PEEP(CvSTART(cv));
11343788 4507 op_free(o);
3280af22 4508 PL_copline = NOLINE;
8990e307 4509 LEAVE_SCOPE(floor);
79072805
LW		 4510}
4511
4512OP *
864dbfa3 4513Perl_newANONLIST(pTHX_ OP *o)
79072805 4514{
93a17b20 4515 return newUNOP(OP_REFGEN, 0,
11343788 4516 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 4517}
4518
4519OP *
864dbfa3 4520Perl_newANONHASH(pTHX_ OP *o)
79072805 4521{
93a17b20 4522 return newUNOP(OP_REFGEN, 0,
11343788 4523 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 4524}
4525
4526OP *
864dbfa3 4527Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 4528{
09bef843
SB		 4529 return newANONATTRSUB(floor, proto, Nullop, block);
4530}
4531
4532OP *
4533Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4534{
a0d0e21e 4535 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 4536 newSVOP(OP_ANONCODE, 0,
4537 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 4538}
4539
4540OP *
864dbfa3 4541Perl_oopsAV(pTHX_ OP *o)
79072805 4542{
ed6116ce
LW		 4543 switch (o->op_type) {
4544 case OP_PADSV:
4545 o->op_type = OP_PADAV;
22c35a8c 4546 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 4547 return ref(o, OP_RV2AV);
b2ffa427 4548
ed6116ce 4549 case OP_RV2SV:
79072805 4550 o->op_type = OP_RV2AV;
22c35a8c 4551 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 4552 ref(o, OP_RV2AV);
ed6116ce
LW		 4553 break;
4554
4555 default:
0453d815 4556 if (ckWARN_d(WARN_INTERNAL))
9014280d 4557 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 4558 break;
4559 }
79072805
LW		 4560 return o;
4561}
4562
4563OP *
864dbfa3 4564Perl_oopsHV(pTHX_ OP *o)
79072805 4565{
ed6116ce
LW		 4566 switch (o->op_type) {
4567 case OP_PADSV:
4568 case OP_PADAV:
4569 o->op_type = OP_PADHV;
22c35a8c 4570 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 4571 return ref(o, OP_RV2HV);
ed6116ce
LW		 4572
4573 case OP_RV2SV:
4574 case OP_RV2AV:
79072805 4575 o->op_type = OP_RV2HV;
22c35a8c 4576 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 4577 ref(o, OP_RV2HV);
ed6116ce
LW		 4578 break;
4579
4580 default:
0453d815 4581 if (ckWARN_d(WARN_INTERNAL))
9014280d 4582 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 4583 break;
4584 }
79072805
LW		 4585 return o;
4586}
4587
4588OP *
864dbfa3 4589Perl_newAVREF(pTHX_ OP *o)
79072805 4590{
ed6116ce
LW		 4591 if (o->op_type == OP_PADANY) {
4592 o->op_type = OP_PADAV;
22c35a8c 4593 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 4594 return o;
ed6116ce 4595 }
a1063b2d 4596 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 4597 && ckWARN(WARN_DEPRECATED)) {
4598 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4599 "Using an array as a reference is deprecated");
4600 }
79072805
LW		 4601 return newUNOP(OP_RV2AV, 0, scalar(o));
4602}
4603
4604OP *
864dbfa3 4605Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 4606{
82092f1d 4607 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 4608 return newUNOP(OP_NULL, 0, o);
748a9306 4609 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 4610}
4611
4612OP *
864dbfa3 4613Perl_newHVREF(pTHX_ OP *o)
79072805 4614{
ed6116ce
LW		 4615 if (o->op_type == OP_PADANY) {
4616 o->op_type = OP_PADHV;
22c35a8c 4617 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 4618 return o;
ed6116ce 4619 }
a1063b2d 4620 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 4621 && ckWARN(WARN_DEPRECATED)) {
4622 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4623 "Using a hash as a reference is deprecated");
4624 }
79072805
LW		 4625 return newUNOP(OP_RV2HV, 0, scalar(o));
4626}
4627
4628OP *
864dbfa3 4629Perl_oopsCV(pTHX_ OP *o)
79072805 4630{
cea2e8a9 4631 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 4632 /* STUB */
4633 return o;
4634}
4635
4636OP *
864dbfa3 4637Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 4638{
c07a80fd 4639 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 4640}
4641
4642OP *
864dbfa3 4643Perl_newSVREF(pTHX_ OP *o)
79072805 4644{
ed6116ce
LW		 4645 if (o->op_type == OP_PADANY) {
4646 o->op_type = OP_PADSV;
22c35a8c 4647 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 4648 return o;
ed6116ce 4649 }
224a4551
MB		 4650 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4651 o->op_flags |= OPpDONE_SVREF;
a863c7d1 4652 return o;
224a4551 4653 }
79072805
LW		 4654 return newUNOP(OP_RV2SV, 0, scalar(o));
4655}
4656
4657/* Check routines. */
4658
4659OP *
cea2e8a9 4660Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 4661{
dd2155a4 4662 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5dc0d613 4663 cSVOPo->op_sv = Nullsv;
5dc0d613 4664 return o;
5f05dabc 4665}
4666
4667OP *
cea2e8a9 4668Perl_ck_bitop(pTHX_ OP *o)
55497cff 4669{
276b2a0c
RGS		 4670#define OP_IS_NUMCOMPARE(op) \
4671 ((op) == OP_LT || (op) == OP_I_LT || \
4672 (op) == OP_GT || (op) == OP_I_GT || \
4673 (op) == OP_LE || (op) == OP_I_LE || \
4674 (op) == OP_GE || (op) == OP_I_GE || \
4675 (op) == OP_EQ || (op) == OP_I_EQ || \
4676 (op) == OP_NE || (op) == OP_I_NE || \
4677 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 4678 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
276b2a0c
RGS		 4679 if (o->op_type == OP_BIT_OR
4680 || o->op_type == OP_BIT_AND
4681 || o->op_type == OP_BIT_XOR)
4682 {
96a925ab
YST		 4683 OP * left = cBINOPo->op_first;
4684 OP * right = left->op_sibling;
4685 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4686 (left->op_flags & OPf_PARENS) == 0) ||
4687 (OP_IS_NUMCOMPARE(right->op_type) &&
4688 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 4689 if (ckWARN(WARN_PRECEDENCE))
4690 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4691 "Possible precedence problem on bitwise %c operator",
4692 o->op_type == OP_BIT_OR ? '|'
4693 : o->op_type == OP_BIT_AND ? '&' : '^'
4694 );
4695 }
5dc0d613 4696 return o;
55497cff 4697}
4698
4699OP *
cea2e8a9 4700Perl_ck_concat(pTHX_ OP *o)
79072805 4701{
11343788
MB		 4702 if (cUNOPo->op_first->op_type == OP_CONCAT)
4703 o->op_flags |= OPf_STACKED;
4704 return o;
79072805
LW		 4705}
4706
4707OP *
cea2e8a9 4708Perl_ck_spair(pTHX_ OP *o)
79072805 4709{
11343788 4710 if (o->op_flags & OPf_KIDS) {
79072805 4711 OP* newop;
a0d0e21e 4712 OP* kid;
5dc0d613
MB		 4713 OPCODE type = o->op_type;
4714 o = modkids(ck_fun(o), type);
11343788 4715 kid = cUNOPo->op_first;
a0d0e21e
LW		 4716 newop = kUNOP->op_first->op_sibling;
4717 if (newop &&
4718 (newop->op_sibling ||
22c35a8c 4719 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 4720 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4721 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 4722
11343788 4723 return o;
a0d0e21e
LW		 4724 }
4725 op_free(kUNOP->op_first);
4726 kUNOP->op_first = newop;
4727 }
22c35a8c 4728 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 4729 return ck_fun(o);
a0d0e21e
LW		 4730}
4731
4732OP *
cea2e8a9 4733Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 4734{
11343788 4735 o = ck_fun(o);
5dc0d613 4736 o->op_private = 0;
11343788
MB		 4737 if (o->op_flags & OPf_KIDS) {
4738 OP *kid = cUNOPo->op_first;
01020589
GS		 4739 switch (kid->op_type) {
4740 case OP_ASLICE:
4741 o->op_flags |= OPf_SPECIAL;
4742 /* FALL THROUGH */
4743 case OP_HSLICE:
5dc0d613 4744 o->op_private |= OPpSLICE;
01020589
GS		 4745 break;
4746 case OP_AELEM:
4747 o->op_flags |= OPf_SPECIAL;
4748 /* FALL THROUGH */
4749 case OP_HELEM:
4750 break;
4751 default:
4752 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 4753 OP_DESC(o));
01020589 4754 }
93c66552 4755 op_null(kid);
79072805 4756 }
11343788 4757 return o;
79072805
LW		 4758}
4759
4760OP *
96e176bf
CL		 4761Perl_ck_die(pTHX_ OP *o)
4762{
4763#ifdef VMS
4764 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4765#endif
4766 return ck_fun(o);
4767}
4768
4769OP *
cea2e8a9 4770Perl_ck_eof(pTHX_ OP *o)
79072805 4771{
11343788 4772 I32 type = o->op_type;
79072805 4773
11343788
MB		 4774 if (o->op_flags & OPf_KIDS) {
4775 if (cLISTOPo->op_first->op_type == OP_STUB) {
4776 op_free(o);
8fde6460 4777 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8990e307 4778 }
11343788 4779 return ck_fun(o);
79072805 4780 }
11343788 4781 return o;
79072805
LW		 4782}
4783
4784OP *
cea2e8a9 4785Perl_ck_eval(pTHX_ OP *o)
79072805 4786{
3280af22 4787 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 4788 if (o->op_flags & OPf_KIDS) {
4789 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 4790
93a17b20 4791 if (!kid) {
11343788 4792 o->op_flags &= ~OPf_KIDS;
93c66552 4793 op_null(o);
79072805 4794 }
b14574b4 4795 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 4796 LOGOP *enter;
4797
11343788
MB		 4798 cUNOPo->op_first = 0;
4799 op_free(o);
79072805 4800
b7dc083c 4801 NewOp(1101, enter, 1, LOGOP);
79072805 4802 enter->op_type = OP_ENTERTRY;
22c35a8c 4803 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 4804 enter->op_private = 0;
4805
4806 /* establish postfix order */
4807 enter->op_next = (OP*)enter;
4808
11343788
MB		 4809 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4810 o->op_type = OP_LEAVETRY;
22c35a8c 4811 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 4812 enter->op_other = o;
4813 return o;
79072805 4814 }
b5c19bd7 4815 else {
473986ff 4816 scalar((OP*)kid);
b5c19bd7
DM		 4817 PL_cv_has_eval = 1;
4818 }
79072805
LW		 4819 }
4820 else {
11343788 4821 op_free(o);
54b9620d 4822 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 4823 }
3280af22 4824 o->op_targ = (PADOFFSET)PL_hints;
11343788 4825 return o;
79072805
LW		 4826}
4827
4828OP *
d98f61e7
GS		 4829Perl_ck_exit(pTHX_ OP *o)
4830{
4831#ifdef VMS
4832 HV *table = GvHV(PL_hintgv);
4833 if (table) {
4834 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4835 if (svp && *svp && SvTRUE(*svp))
4836 o->op_private |= OPpEXIT_VMSISH;
4837 }
96e176bf 4838 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 4839#endif
4840 return ck_fun(o);
4841}
4842
4843OP *
cea2e8a9 4844Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 4845{
4846 OP *kid;
11343788
MB		 4847 if (o->op_flags & OPf_STACKED) {
4848 o = ck_fun(o);
4849 kid = cUNOPo->op_first->op_sibling;
8990e307 4850 if (kid->op_type == OP_RV2GV)
93c66552 4851 op_null(kid);
79072805 4852 }
463ee0b2 4853 else
11343788
MB		 4854 o = listkids(o);
4855 return o;
79072805
LW		 4856}
4857
4858OP *
cea2e8a9 4859Perl_ck_exists(pTHX_ OP *o)
5f05dabc 4860{
5196be3e
MB		 4861 o = ck_fun(o);
4862 if (o->op_flags & OPf_KIDS) {
4863 OP *kid = cUNOPo->op_first;
afebc493
GS		 4864 if (kid->op_type == OP_ENTERSUB) {
4865 (void) ref(kid, o->op_type);
4866 if (kid->op_type != OP_RV2CV && !PL_error_count)
4867 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 4868 OP_DESC(o));
afebc493
GS		 4869 o->op_private |= OPpEXISTS_SUB;
4870 }
4871 else if (kid->op_type == OP_AELEM)
01020589
GS		 4872 o->op_flags |= OPf_SPECIAL;
4873 else if (kid->op_type != OP_HELEM)
4874 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 4875 OP_DESC(o));
93c66552 4876 op_null(kid);
5f05dabc 4877 }
5196be3e 4878 return o;
5f05dabc 4879}
4880
22c35a8c 4881#if 0
5f05dabc 4882OP *
cea2e8a9 4883Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 4884{
4885 o = fold_constants(o);
4886 if (o->op_type == OP_CONST)
4887 o->op_type = OP_GV;
4888 return o;
4889}
22c35a8c 4890#endif
79072805
LW		 4891
4892OP *
cea2e8a9 4893Perl_ck_rvconst(pTHX_ register OP *o)
79072805 4894{
11343788 4895 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 4896
3280af22 4897 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 4898 if (kid->op_type == OP_CONST) {
44a8e56a 4899 char *name;
4900 int iscv;
4901 GV *gv;
779c5bc9 4902 SV *kidsv = kid->op_sv;
2d8e6c8d 4903 STRLEN n_a;
44a8e56a 4904
779c5bc9
GS		 4905 /* Is it a constant from cv_const_sv()? */
4906 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4907 SV *rsv = SvRV(kidsv);
4908 int svtype = SvTYPE(rsv);
4909 char *badtype = Nullch;
4910
4911 switch (o->op_type) {
4912 case OP_RV2SV:
4913 if (svtype > SVt_PVMG)
4914 badtype = "a SCALAR";
4915 break;
4916 case OP_RV2AV:
4917 if (svtype != SVt_PVAV)
4918 badtype = "an ARRAY";
4919 break;
4920 case OP_RV2HV:
6d822dc4 4921 if (svtype != SVt_PVHV)
779c5bc9 4922 badtype = "a HASH";
779c5bc9
GS		 4923 break;
4924 case OP_RV2CV:
4925 if (svtype != SVt_PVCV)
4926 badtype = "a CODE";
4927 break;
4928 }
4929 if (badtype)
cea2e8a9 4930 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 4931 return o;
4932 }
2d8e6c8d 4933 name = SvPV(kidsv, n_a);
3280af22 4934 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 4935 char *badthing = Nullch;
5dc0d613 4936 switch (o->op_type) {
44a8e56a 4937 case OP_RV2SV:
4938 badthing = "a SCALAR";
4939 break;
4940 case OP_RV2AV:
4941 badthing = "an ARRAY";
4942 break;
4943 case OP_RV2HV:
4944 badthing = "a HASH";
4945 break;
4946 }
4947 if (badthing)
1c846c1f 4948 Perl_croak(aTHX_
44a8e56a 4949 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4950 name, badthing);
4951 }
93233ece
CS		 4952 /*
4953 * This is a little tricky. We only want to add the symbol if we
4954 * didn't add it in the lexer. Otherwise we get duplicate strict
4955 * warnings. But if we didn't add it in the lexer, we must at
4956 * least pretend like we wanted to add it even if it existed before,
4957 * or we get possible typo warnings. OPpCONST_ENTERED says
4958 * whether the lexer already added THIS instance of this symbol.
4959 */
5196be3e 4960 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 4961 do {
44a8e56a 4962 gv = gv_fetchpv(name,
748a9306 4963 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 4964 iscv
4965 ? SVt_PVCV
11343788 4966 : o->op_type == OP_RV2SV
a0d0e21e 4967 ? SVt_PV
11343788 4968 : o->op_type == OP_RV2AV
a0d0e21e 4969 ? SVt_PVAV
11343788 4970 : o->op_type == OP_RV2HV
a0d0e21e
LW		 4971 ? SVt_PVHV
4972 : SVt_PVGV);
93233ece
CS		 4973 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4974 if (gv) {
4975 kid->op_type = OP_GV;
4976 SvREFCNT_dec(kid->op_sv);
350de78d 4977#ifdef USE_ITHREADS
638eceb6 4978 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 4979 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 4980 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 4981 GvIN_PAD_on(gv);
dd2155a4 4982 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
350de78d 4983#else
93233ece 4984 kid->op_sv = SvREFCNT_inc(gv);
350de78d 4985#endif
23f1ca44 4986 kid->op_private = 0;
76cd736e 4987 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 4988 }
79072805 4989 }
11343788 4990 return o;
79072805
LW		 4991}
4992
4993OP *
cea2e8a9 4994Perl_ck_ftst(pTHX_ OP *o)
79072805 4995{
11343788 4996 I32 type = o->op_type;
79072805 4997
d0dca557
JD		 4998 if (o->op_flags & OPf_REF) {
4999 /* nothing */
5000 }
5001 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5002 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5003
5004 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5005 STRLEN n_a;
a0d0e21e 5006 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5007 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5008 op_free(o);
d0dca557 5009 o = newop;
79072805 5010 }
1af34c76
JH		 5011 else {
5012 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5013 OP_IS_FILETEST_ACCESS(o))
5014 o->op_private |= OPpFT_ACCESS;
5015 }
79072805
LW		 5016 }
5017 else {
11343788 5018 op_free(o);
79072805 5019 if (type == OP_FTTTY)
8fde6460 5020 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5021 else
d0dca557 5022 o = newUNOP(type, 0, newDEFSVOP());
79072805 5023 }
11343788 5024 return o;
79072805
LW		 5025}
5026
5027OP *
cea2e8a9 5028Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5029{
5030 register OP *kid;
5031 OP **tokid;
5032 OP *sibl;
5033 I32 numargs = 0;
11343788 5034 int type = o->op_type;
22c35a8c 5035 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5036
11343788 5037 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5038 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5039 oa &= ~OA_OPTIONAL;
5040 else
11343788 5041 return no_fh_allowed(o);
79072805
LW		 5042 }
5043
11343788 5044 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5045 STRLEN n_a;
11343788
MB		 5046 tokid = &cLISTOPo->op_first;
5047 kid = cLISTOPo->op_first;
8990e307 5048 if (kid->op_type == OP_PUSHMARK ||
155aba94 5049 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5050 {
79072805
LW		 5051 tokid = &kid->op_sibling;
5052 kid = kid->op_sibling;
5053 }
22c35a8c 5054 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5055 *tokid = kid = newDEFSVOP();
79072805
LW		 5056
5057 while (oa && kid) {
5058 numargs++;
5059 sibl = kid->op_sibling;
5060 switch (oa & 7) {
5061 case OA_SCALAR:
62c18ce2
GS		 5062 /* list seen where single (scalar) arg expected? */
5063 if (numargs == 1 && !(oa >> 4)
5064 && kid->op_type == OP_LIST && type != OP_SCALAR)
5065 {
5066 return too_many_arguments(o,PL_op_desc[type]);
5067 }
79072805
LW		 5068 scalar(kid);
5069 break;
5070 case OA_LIST:
5071 if (oa < 16) {
5072 kid = 0;
5073 continue;
5074 }
5075 else
5076 list(kid);
5077 break;
5078 case OA_AVREF:
936edb8b 5079 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5080 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5081 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5082 "Useless use of %s with no values",
936edb8b 5083 PL_op_desc[type]);
b2ffa427 5084
79072805 5085 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5086 (kid->op_private & OPpCONST_BARE))
5087 {
2d8e6c8d 5088 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5089 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5090 gv_fetchpv(name, TRUE, SVt_PVAV) ));
12bcd1a6
PM		 5091 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5092 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5093 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5094 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5095 op_free(kid);
5096 kid = newop;
5097 kid->op_sibling = sibl;
5098 *tokid = kid;
5099 }
8990e307 5100 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5101 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5102 mod(kid, type);
79072805
LW		 5103 break;
5104 case OA_HVREF:
5105 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5106 (kid->op_private & OPpCONST_BARE))
5107 {
2d8e6c8d 5108 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5109 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5110 gv_fetchpv(name, TRUE, SVt_PVHV) ));
12bcd1a6
PM		 5111 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5112 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5113 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5114 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5115 op_free(kid);
5116 kid = newop;
5117 kid->op_sibling = sibl;
5118 *tokid = kid;
5119 }
8990e307 5120 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5121 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5122 mod(kid, type);
79072805
LW		 5123 break;
5124 case OA_CVREF:
5125 {
a0d0e21e 5126 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5127 kid->op_sibling = 0;
5128 linklist(kid);
5129 newop->op_next = newop;
5130 kid = newop;
5131 kid->op_sibling = sibl;
5132 *tokid = kid;
5133 }
5134 break;
5135 case OA_FILEREF:
c340be78 5136 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5137 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5138 (kid->op_private & OPpCONST_BARE))
5139 {
79072805 5140 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5141 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5142 SVt_PVIO) );
afbdacea 5143 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5144 kid == cLISTOPo->op_last)
364daeac 5145 cLISTOPo->op_last = newop;
79072805
LW		 5146 op_free(kid);
5147 kid = newop;
5148 }
1ea32a52
GS		 5149 else if (kid->op_type == OP_READLINE) {
5150 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5151 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5152 }
79072805 5153 else {
35cd451c 5154 I32 flags = OPf_SPECIAL;
a6c40364 5155 I32 priv = 0;
2c8ac474
GS		 5156 PADOFFSET targ = 0;
5157
35cd451c 5158 /* is this op a FH constructor? */
853846ea 5159 if (is_handle_constructor(o,numargs)) {
2c8ac474 5160 char *name = Nullch;
dd2155a4 5161 STRLEN len = 0;
2c8ac474
GS		 5162
5163 flags = 0;
5164 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5165 * need to "prove" flag does not mean something
5166 * else already - NI-S 1999/05/07
2c8ac474
GS		 5167 */
5168 priv = OPpDEREF;
5169 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 5170 name = PAD_COMPNAME_PV(kid->op_targ);
5171 /* SvCUR of a pad namesv can't be trusted
5172 * (see PL_generation), so calc its length
5173 * manually */
5174 if (name)
5175 len = strlen(name);
5176
2c8ac474
GS		 5177 }
5178 else if (kid->op_type == OP_RV2SV
5179 && kUNOP->op_first->op_type == OP_GV)
5180 {
5181 GV *gv = cGVOPx_gv(kUNOP->op_first);
5182 name = GvNAME(gv);
5183 len = GvNAMELEN(gv);
5184 }
afd1915d
GS		 5185 else if (kid->op_type == OP_AELEM
5186 || kid->op_type == OP_HELEM)
5187 {
0c4b0a3f
JH		 5188 OP *op;
5189
5190 name = 0;
5191 if ((op = ((BINOP*)kid)->op_first)) {
5192 SV *tmpstr = Nullsv;
5193 char *a =
5194 kid->op_type == OP_AELEM ?
5195 "[]" : "{}";
5196 if (((op->op_type == OP_RV2AV) ||
5197 (op->op_type == OP_RV2HV)) &&
5198 (op = ((UNOP*)op)->op_first) &&
5199 (op->op_type == OP_GV)) {
5200 /* packagevar $a[] or $h{} */
5201 GV *gv = cGVOPx_gv(op);
5202 if (gv)
5203 tmpstr =
5204 Perl_newSVpvf(aTHX_
5205 "%s%c...%c",
5206 GvNAME(gv),
5207 a[0], a[1]);
5208 }
5209 else if (op->op_type == OP_PADAV
5210 || op->op_type == OP_PADHV) {
5211 /* lexicalvar $a[] or $h{} */
5212 char *padname =
5213 PAD_COMPNAME_PV(op->op_targ);
5214 if (padname)
5215 tmpstr =
5216 Perl_newSVpvf(aTHX_
5217 "%s%c...%c",
5218 padname + 1,
5219 a[0], a[1]);
5220
5221 }
5222 if (tmpstr) {
5223 name = savepv(SvPVX(tmpstr));
5224 len = strlen(name);
5225 sv_2mortal(tmpstr);
5226 }
5227 }
5228 if (!name) {
5229 name = "__ANONIO__";
5230 len = 10;
5231 }
5232 mod(kid, type);
afd1915d 5233 }
2c8ac474
GS		 5234 if (name) {
5235 SV *namesv;
5236 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 5237 namesv = PAD_SVl(targ);
155aba94 5238 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5239 if (*name != '$')
5240 sv_setpvn(namesv, "$", 1);
5241 sv_catpvn(namesv, name, len);
5242 }
853846ea 5243 }
79072805 5244 kid->op_sibling = 0;
35cd451c 5245 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5246 kid->op_targ = targ;
5247 kid->op_private |= priv;
79072805
LW		 5248 }
5249 kid->op_sibling = sibl;
5250 *tokid = kid;
5251 }
5252 scalar(kid);
5253 break;
5254 case OA_SCALARREF:
a0d0e21e 5255 mod(scalar(kid), type);
79072805
LW		 5256 break;
5257 }
5258 oa >>= 4;
5259 tokid = &kid->op_sibling;
5260 kid = kid->op_sibling;
5261 }
11343788 5262 o->op_private |= numargs;
79072805 5263 if (kid)
53e06cf0 5264 return too_many_arguments(o,OP_DESC(o));
11343788 5265 listkids(o);
79072805 5266 }
22c35a8c 5267 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5268 op_free(o);
54b9620d 5269 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5270 }
5271
79072805
LW		 5272 if (oa) {
5273 while (oa & OA_OPTIONAL)
5274 oa >>= 4;
5275 if (oa && oa != OA_LIST)
53e06cf0 5276 return too_few_arguments(o,OP_DESC(o));
79072805 5277 }
11343788 5278 return o;
79072805
LW		 5279}
5280
5281OP *
cea2e8a9 5282Perl_ck_glob(pTHX_ OP *o)
79072805 5283{
fb73857a 5284 GV *gv;
5285
649da076 5286 o = ck_fun(o);
1f2bfc8a 5287 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5288 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5289
b9f751c0
GS		 5290 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5291 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5292 {
fb73857a 5293 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b9f751c0 5294 }
b1cb66bf 5295
52bb0670 5296#if !defined(PERL_EXTERNAL_GLOB)
72b16652
GS		 5297 /* XXX this can be tightened up and made more failsafe. */
5298 if (!gv) {
7d3fb230 5299 GV *glob_gv;
72b16652 5300 ENTER;
00ca71c1
NIS		 5301 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5302 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
72b16652 5303 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5304 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5305 GvCV(gv) = GvCV(glob_gv);
445266f0 5306 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5307 GvIMPORTED_CV_on(gv);
72b16652
GS		 5308 LEAVE;
5309 }
52bb0670 5310#endif /* PERL_EXTERNAL_GLOB */
72b16652 5311
b9f751c0 5312 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5313 append_elem(OP_GLOB, o,
80252599 5314 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5315 o->op_type = OP_LIST;
22c35a8c 5316 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5317 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5318 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
1f2bfc8a 5319 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5320 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5321 scalar(newUNOP(OP_RV2CV, 0,
5322 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5323 o = newUNOP(OP_NULL, 0, ck_subr(o));
5324 o->op_targ = OP_GLOB; /* hint at what it used to be */
5325 return o;
b1cb66bf 5326 }
5327 gv = newGVgen("main");
a0d0e21e 5328 gv_IOadd(gv);
11343788
MB		 5329 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5330 scalarkids(o);
649da076 5331 return o;
79072805
LW		 5332}
5333
5334OP *
cea2e8a9 5335Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 5336{
5337 LOGOP *gwop;
5338 OP *kid;
11343788 5339 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 5340
22c35a8c 5341 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5342 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5343
11343788 5344 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5345 OP* k;
11343788
MB		 5346 o = ck_sort(o);
5347 kid = cLISTOPo->op_first->op_sibling;
5348 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 5349 kid = k;
5350 }
5351 kid->op_next = (OP*)gwop;
11343788 5352 o->op_flags &= ~OPf_STACKED;
93a17b20 5353 }
11343788 5354 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5355 if (type == OP_MAPWHILE)
5356 list(kid);
5357 else
5358 scalar(kid);
11343788 5359 o = ck_fun(o);
3280af22 5360 if (PL_error_count)
11343788 5361 return o;
aeea060c 5362 kid = cLISTOPo->op_first->op_sibling;
79072805 5363 if (kid->op_type != OP_NULL)
cea2e8a9 5364 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5365 kid = kUNOP->op_first;
5366
a0d0e21e 5367 gwop->op_type = type;
22c35a8c 5368 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5369 gwop->op_first = listkids(o);
79072805
LW		 5370 gwop->op_flags |= OPf_KIDS;
5371 gwop->op_private = 1;
5372 gwop->op_other = LINKLIST(kid);
a0d0e21e 5373 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 5374 kid->op_next = (OP*)gwop;
5375
11343788 5376 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5377 if (!kid || !kid->op_sibling)
53e06cf0 5378 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5379 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5380 mod(kid, OP_GREPSTART);
5381
79072805
LW		 5382 return (OP*)gwop;
5383}
5384
5385OP *
cea2e8a9 5386Perl_ck_index(pTHX_ OP *o)
79072805 5387{
11343788
MB		 5388 if (o->op_flags & OPf_KIDS) {
5389 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5390 if (kid)
5391 kid = kid->op_sibling; /* get past "big" */
79072805 5392 if (kid && kid->op_type == OP_CONST)
2779dcf1 5393 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5394 }
11343788 5395 return ck_fun(o);
79072805
LW		 5396}
5397
5398OP *
cea2e8a9 5399Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5400{
5401 /* XXX length optimization goes here */
11343788 5402 return ck_fun(o);
79072805
LW		 5403}
5404
5405OP *
cea2e8a9 5406Perl_ck_lfun(pTHX_ OP *o)
79072805 5407{
5dc0d613
MB		 5408 OPCODE type = o->op_type;
5409 return modkids(ck_fun(o), type);
79072805
LW		 5410}
5411
5412OP *
cea2e8a9 5413Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5414{
12bcd1a6 5415 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5416 switch (cUNOPo->op_first->op_type) {
5417 case OP_RV2AV:
a8739d98
JH		 5418 /* This is needed for
5419 if (defined %stash::)
5420 to work. Do not break Tk.
5421 */
1c846c1f 5422 break; /* Globals via GV can be undef */
d0334bed
GS		 5423 case OP_PADAV:
5424 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5425 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5426 "defined(@array) is deprecated");
12bcd1a6 5427 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5428 "\t(Maybe you should just omit the defined()?)\n");
69794302 5429 break;
d0334bed 5430 case OP_RV2HV:
a8739d98
JH		 5431 /* This is needed for
5432 if (defined %stash::)
5433 to work. Do not break Tk.
5434 */
1c846c1f 5435 break; /* Globals via GV can be undef */
d0334bed 5436 case OP_PADHV:
12bcd1a6 5437 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5438 "defined(%%hash) is deprecated");
12bcd1a6 5439 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5440 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5441 break;
5442 default:
5443 /* no warning */
5444 break;
5445 }
69794302
MJD		 5446 }
5447 return ck_rfun(o);
5448}
5449
5450OP *
cea2e8a9 5451Perl_ck_rfun(pTHX_ OP *o)
8990e307 5452{
5dc0d613
MB		 5453 OPCODE type = o->op_type;
5454 return refkids(ck_fun(o), type);
8990e307
LW		 5455}
5456
5457OP *
cea2e8a9 5458Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5459{
5460 register OP *kid;
aeea060c 5461
11343788 5462 kid = cLISTOPo->op_first;
79072805 5463 if (!kid) {
11343788
MB		 5464 o = force_list(o);
5465 kid = cLISTOPo->op_first;
79072805
LW		 5466 }
5467 if (kid->op_type == OP_PUSHMARK)
5468 kid = kid->op_sibling;
11343788 5469 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 5470 kid = kid->op_sibling;
5471 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5472 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 5473 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 5474 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 5475 cLISTOPo->op_first->op_sibling = kid;
5476 cLISTOPo->op_last = kid;
79072805
LW		 5477 kid = kid->op_sibling;
5478 }
5479 }
b2ffa427 5480
79072805 5481 if (!kid)
54b9620d 5482 append_elem(o->op_type, o, newDEFSVOP());
79072805 5483
2de3dbcc 5484 return listkids(o);
bbce6d69 5485}
5486
5487OP *
b162f9ea
IZ		 5488Perl_ck_sassign(pTHX_ OP *o)
5489{
5490 OP *kid = cLISTOPo->op_first;
5491 /* has a disposable target? */
5492 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 5493 && !(kid->op_flags & OPf_STACKED)
5494 /* Cannot steal the second time! */
5495 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 5496 {
5497 OP *kkid = kid->op_sibling;
5498
5499 /* Can just relocate the target. */
2c2d71f5
JH		 5500 if (kkid && kkid->op_type == OP_PADSV
5501 && !(kkid->op_private & OPpLVAL_INTRO))
5502 {
b162f9ea 5503 kid->op_targ = kkid->op_targ;
743e66e6 5504 kkid->op_targ = 0;
b162f9ea
IZ		 5505 /* Now we do not need PADSV and SASSIGN. */
5506 kid->op_sibling = o->op_sibling; /* NULL */
5507 cLISTOPo->op_first = NULL;
5508 op_free(o);
5509 op_free(kkid);
5510 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5511 return kid;
5512 }
5513 }
5514 return o;
5515}
5516
5517OP *
cea2e8a9 5518Perl_ck_match(pTHX_ OP *o)
79072805 5519{
5dc0d613 5520 o->op_private |= OPpRUNTIME;
11343788 5521 return o;
79072805
LW		 5522}
5523
5524OP *
f5d5a27c
CS		 5525Perl_ck_method(pTHX_ OP *o)
5526{
5527 OP *kid = cUNOPo->op_first;
5528 if (kid->op_type == OP_CONST) {
5529 SV* sv = kSVOP->op_sv;
5530 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5531 OP *cmop;
1c846c1f
NIS		 5532 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5533 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5534 }
5535 else {
5536 kSVOP->op_sv = Nullsv;
5537 }
f5d5a27c 5538 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 5539 op_free(o);
5540 return cmop;
5541 }
5542 }
5543 return o;
5544}
5545
5546OP *
cea2e8a9 5547Perl_ck_null(pTHX_ OP *o)
79072805 5548{
11343788 5549 return o;
79072805
LW		 5550}
5551
5552OP *
16fe6d59
GS		 5553Perl_ck_open(pTHX_ OP *o)
5554{
5555 HV *table = GvHV(PL_hintgv);
5556 if (table) {
5557 SV **svp;
5558 I32 mode;
5559 svp = hv_fetch(table, "open_IN", 7, FALSE);
5560 if (svp && *svp) {
5561 mode = mode_from_discipline(*svp);
5562 if (mode & O_BINARY)
5563 o->op_private |= OPpOPEN_IN_RAW;
5564 else if (mode & O_TEXT)
5565 o->op_private |= OPpOPEN_IN_CRLF;
5566 }
5567
5568 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5569 if (svp && *svp) {
5570 mode = mode_from_discipline(*svp);
5571 if (mode & O_BINARY)
5572 o->op_private |= OPpOPEN_OUT_RAW;
5573 else if (mode & O_TEXT)
5574 o->op_private |= OPpOPEN_OUT_CRLF;
5575 }
5576 }
5577 if (o->op_type == OP_BACKTICK)
5578 return o;
3b82e551
JH		 5579 {
5580 /* In case of three-arg dup open remove strictness
5581 * from the last arg if it is a bareword. */
5582 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5583 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5584 OP *oa;
5585 char *mode;
5586
5587 if ((last->op_type == OP_CONST) && /* The bareword. */
5588 (last->op_private & OPpCONST_BARE) &&
5589 (last->op_private & OPpCONST_STRICT) &&
5590 (oa = first->op_sibling) && /* The fh. */
5591 (oa = oa->op_sibling) && /* The mode. */
5592 SvPOK(((SVOP*)oa)->op_sv) &&
5593 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5594 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5595 (last == oa->op_sibling)) /* The bareword. */
5596 last->op_private &= ~OPpCONST_STRICT;
5597 }
16fe6d59
GS		 5598 return ck_fun(o);
5599}
5600
5601OP *
cea2e8a9 5602Perl_ck_repeat(pTHX_ OP *o)
79072805 5603{
11343788
MB		 5604 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5605 o->op_private |= OPpREPEAT_DOLIST;
5606 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 5607 }
5608 else
11343788
MB		 5609 scalar(o);
5610 return o;
79072805
LW		 5611}
5612
5613OP *
cea2e8a9 5614Perl_ck_require(pTHX_ OP *o)
8990e307 5615{
ec4ab249
GA		 5616 GV* gv;
5617
11343788
MB		 5618 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5619 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 5620
5621 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 5622 char *s;
a0d0e21e
LW		 5623 for (s = SvPVX(kid->op_sv); *s; s++) {
5624 if (*s == ':' && s[1] == ':') {
5625 *s = '/';
1aef975c 5626 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 5627 --SvCUR(kid->op_sv);
5628 }
8990e307 5629 }
ce3b816e
GS		 5630 if (SvREADONLY(kid->op_sv)) {
5631 SvREADONLY_off(kid->op_sv);
5632 sv_catpvn(kid->op_sv, ".pm", 3);
5633 SvREADONLY_on(kid->op_sv);
5634 }
5635 else
5636 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 5637 }
5638 }
ec4ab249
GA		 5639
5640 /* handle override, if any */
5641 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
b9f751c0 5642 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
ec4ab249
GA		 5643 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5644
b9f751c0 5645 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
ec4ab249
GA		 5646 OP *kid = cUNOPo->op_first;
5647 cUNOPo->op_first = 0;
5648 op_free(o);
5649 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5650 append_elem(OP_LIST, kid,
5651 scalar(newUNOP(OP_RV2CV, 0,
5652 newGVOP(OP_GV, 0,
5653 gv))))));
5654 }
5655
11343788 5656 return ck_fun(o);
8990e307
LW		 5657}
5658
78f9721b
SM		 5659OP *
5660Perl_ck_return(pTHX_ OP *o)
5661{
5662 OP *kid;
5663 if (CvLVALUE(PL_compcv)) {
5664 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5665 mod(kid, OP_LEAVESUBLV);
5666 }
5667 return o;
5668}
5669
22c35a8c 5670#if 0
8990e307 5671OP *
cea2e8a9 5672Perl_ck_retarget(pTHX_ OP *o)
79072805 5673{
cea2e8a9 5674 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 5675 /* STUB */
11343788 5676 return o;
79072805 5677}
22c35a8c 5678#endif
79072805
LW		 5679
5680OP *
cea2e8a9 5681Perl_ck_select(pTHX_ OP *o)
79072805 5682{
c07a80fd 5683 OP* kid;
11343788
MB		 5684 if (o->op_flags & OPf_KIDS) {
5685 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 5686 if (kid && kid->op_sibling) {
11343788 5687 o->op_type = OP_SSELECT;
22c35a8c 5688 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 5689 o = ck_fun(o);
5690 return fold_constants(o);
79072805
LW		 5691 }
5692 }
11343788
MB		 5693 o = ck_fun(o);
5694 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 5695 if (kid && kid->op_type == OP_RV2GV)
5696 kid->op_private &= ~HINT_STRICT_REFS;
11343788 5697 return o;
79072805
LW		 5698}
5699
5700OP *
cea2e8a9 5701Perl_ck_shift(pTHX_ OP *o)
79072805 5702{
11343788 5703 I32 type = o->op_type;
79072805 5704
11343788 5705 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 5706 OP *argop;
b2ffa427 5707
11343788 5708 op_free(o);
6d4ff0d2 5709 argop = newUNOP(OP_RV2AV, 0,
8fde6460 5710 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6d4ff0d2 5711 return newUNOP(type, 0, scalar(argop));
79072805 5712 }
11343788 5713 return scalar(modkids(ck_fun(o), type));
79072805
LW		 5714}
5715
5716OP *
cea2e8a9 5717Perl_ck_sort(pTHX_ OP *o)
79072805 5718{
8e3f9bdf 5719 OP *firstkid;
bbce6d69 5720
9ea6e965 5721 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 5722 simplify_sort(o);
8e3f9bdf
GS		 5723 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5724 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 5725 OP *k = NULL;
8e3f9bdf 5726 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 5727
463ee0b2 5728 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 5729 linklist(kid);
463ee0b2
LW		 5730 if (kid->op_type == OP_SCOPE) {
5731 k = kid->op_next;
5732 kid->op_next = 0;
79072805 5733 }
463ee0b2 5734 else if (kid->op_type == OP_LEAVE) {
11343788 5735 if (o->op_type == OP_SORT) {
93c66552 5736 op_null(kid); /* wipe out leave */
748a9306 5737 kid->op_next = kid;
463ee0b2 5738
748a9306
LW		 5739 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5740 if (k->op_next == kid)
5741 k->op_next = 0;
71a29c3c
GS		 5742 /* don't descend into loops */
5743 else if (k->op_type == OP_ENTERLOOP
5744 || k->op_type == OP_ENTERITER)
5745 {
5746 k = cLOOPx(k)->op_lastop;
5747 }
748a9306 5748 }
463ee0b2 5749 }
748a9306
LW		 5750 else
5751 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 5752 k = kLISTOP->op_first;
463ee0b2 5753 }
a2efc822 5754 CALL_PEEP(k);
a0d0e21e 5755
8e3f9bdf
GS		 5756 kid = firstkid;
5757 if (o->op_type == OP_SORT) {
5758 /* provide scalar context for comparison function/block */
5759 kid = scalar(kid);
a0d0e21e 5760 kid->op_next = kid;
8e3f9bdf 5761 }
a0d0e21e
LW		 5762 else
5763 kid->op_next = k;
11343788 5764 o->op_flags |= OPf_SPECIAL;
79072805 5765 }
c6e96bcb 5766 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 5767 op_null(firstkid);
8e3f9bdf
GS		 5768
5769 firstkid = firstkid->op_sibling;
79072805 5770 }
bbce6d69 5771
8e3f9bdf
GS		 5772 /* provide list context for arguments */
5773 if (o->op_type == OP_SORT)
5774 list(firstkid);
5775
11343788 5776 return o;
79072805 5777}
bda4119b
GS		 5778
5779STATIC void
cea2e8a9 5780S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 5781{
5782 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5783 OP *k;
5784 int reversed;
350de78d 5785 GV *gv;
9c007264
JH		 5786 if (!(o->op_flags & OPf_STACKED))
5787 return;
1c846c1f
NIS		 5788 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5789 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 5790 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 5791 if (kid->op_type != OP_SCOPE)
5792 return;
5793 kid = kLISTOP->op_last; /* get past scope */
5794 switch(kid->op_type) {
5795 case OP_NCMP:
5796 case OP_I_NCMP:
5797 case OP_SCMP:
5798 break;
5799 default:
5800 return;
5801 }
5802 k = kid; /* remember this node*/
5803 if (kBINOP->op_first->op_type != OP_RV2SV)
5804 return;
5805 kid = kBINOP->op_first; /* get past cmp */
5806 if (kUNOP->op_first->op_type != OP_GV)
5807 return;
5808 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5809 gv = kGVOP_gv;
350de78d 5810 if (GvSTASH(gv) != PL_curstash)
9c007264 5811 return;
350de78d 5812 if (strEQ(GvNAME(gv), "a"))
9c007264 5813 reversed = 0;
0f79a09d 5814 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 5815 reversed = 1;
5816 else
5817 return;
5818 kid = k; /* back to cmp */
5819 if (kBINOP->op_last->op_type != OP_RV2SV)
5820 return;
5821 kid = kBINOP->op_last; /* down to 2nd arg */
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 || ( reversed
350de78d
GS		 5828 ? strNE(GvNAME(gv), "a")
5829 : strNE(GvNAME(gv), "b")))
9c007264
JH		 5830 return;
5831 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5832 if (reversed)
5833 o->op_private |= OPpSORT_REVERSE;
5834 if (k->op_type == OP_NCMP)
5835 o->op_private |= OPpSORT_NUMERIC;
5836 if (k->op_type == OP_I_NCMP)
5837 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 5838 kid = cLISTOPo->op_first->op_sibling;
5839 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5840 op_free(kid); /* then delete it */
9c007264 5841}
79072805
LW		 5842
5843OP *
cea2e8a9 5844Perl_ck_split(pTHX_ OP *o)
79072805
LW		 5845{
5846 register OP *kid;
aeea060c 5847
11343788
MB		 5848 if (o->op_flags & OPf_STACKED)
5849 return no_fh_allowed(o);
79072805 5850
11343788 5851 kid = cLISTOPo->op_first;
8990e307 5852 if (kid->op_type != OP_NULL)
cea2e8a9 5853 Perl_croak(aTHX_ "panic: ck_split");
8990e307 5854 kid = kid->op_sibling;
11343788
MB		 5855 op_free(cLISTOPo->op_first);
5856 cLISTOPo->op_first = kid;
85e6fe83 5857 if (!kid) {
79cb57f6 5858 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 5859 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 5860 }
79072805 5861
de4bf5b3 5862 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 5863 OP *sibl = kid->op_sibling;
463ee0b2 5864 kid->op_sibling = 0;
79072805 5865 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 5866 if (cLISTOPo->op_first == cLISTOPo->op_last)
5867 cLISTOPo->op_last = kid;
5868 cLISTOPo->op_first = kid;
79072805
LW		 5869 kid->op_sibling = sibl;
5870 }
5871
5872 kid->op_type = OP_PUSHRE;
22c35a8c 5873 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 5874 scalar(kid);
f34840d8
MJD		 5875 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5876 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5877 "Use of /g modifier is meaningless in split");
5878 }
79072805
LW		 5879
5880 if (!kid->op_sibling)
54b9620d 5881 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 5882
5883 kid = kid->op_sibling;
5884 scalar(kid);
5885
5886 if (!kid->op_sibling)
11343788 5887 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 5888
5889 kid = kid->op_sibling;
5890 scalar(kid);
5891
5892 if (kid->op_sibling)
53e06cf0 5893 return too_many_arguments(o,OP_DESC(o));
79072805 5894
11343788 5895 return o;
79072805
LW		 5896}
5897
5898OP *
1c846c1f 5899Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 5900{
5901 if (ckWARN(WARN_SYNTAX)) {
5902 OP *kid = cLISTOPo->op_first->op_sibling;
5903 if (kid && kid->op_type == OP_MATCH) {
5904 char *pmstr = "STRING";
aaa362c4
RS		 5905 if (PM_GETRE(kPMOP))
5906 pmstr = PM_GETRE(kPMOP)->precomp;
9014280d 5907 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 5908 "/%s/ should probably be written as \"%s\"",
5909 pmstr, pmstr);
5910 }
5911 }
5912 return ck_fun(o);
5913}
5914
5915OP *
cea2e8a9 5916Perl_ck_subr(pTHX_ OP *o)
79072805 5917{
11343788
MB		 5918 OP *prev = ((cUNOPo->op_first->op_sibling)
5919 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5920 OP *o2 = prev->op_sibling;
4633a7c4
LW		 5921 OP *cvop;
5922 char *proto = 0;
5923 CV *cv = 0;
46fc3d4c 5924 GV *namegv = 0;
4633a7c4
LW		 5925 int optional = 0;
5926 I32 arg = 0;
5b794e05 5927 I32 contextclass = 0;
90b7f708 5928 char *e = 0;
2d8e6c8d 5929 STRLEN n_a;
06492da6 5930 bool delete=0;
4633a7c4 5931
d3011074 5932 o->op_private |= OPpENTERSUB_HASTARG;
11343788 5933 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 5934 if (cvop->op_type == OP_RV2CV) {
5935 SVOP* tmpop;
11343788 5936 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 5937 op_null(cvop); /* disable rv2cv */
4633a7c4 5938 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 5939 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 5940 GV *gv = cGVOPx_gv(tmpop);
350de78d 5941 cv = GvCVu(gv);
76cd736e
GS		 5942 if (!cv)
5943 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 5944 else {
5945 if (SvPOK(cv)) {
5946 namegv = CvANON(cv) ? gv : CvGV(cv);
5947 proto = SvPV((SV*)cv, n_a);
5948 }
5949 if (CvASSERTION(cv)) {
5950 if (PL_hints & HINT_ASSERTING) {
5951 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5952 o->op_private |= OPpENTERSUB_DB;
5953 }
8fa7688f
SF		 5954 else {
5955 delete=1;
5956 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5957 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5958 "Impossible to activate assertion call");
5959 }
5960 }
06492da6 5961 }
46fc3d4c 5962 }
4633a7c4
LW		 5963 }
5964 }
f5d5a27c 5965 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 5966 if (o2->op_type == OP_CONST)
5967 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 5968 else if (o2->op_type == OP_LIST) {
5969 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5970 if (o && o->op_type == OP_CONST)
5971 o->op_private &= ~OPpCONST_STRICT;
5972 }
7a52d87a 5973 }
3280af22
NIS		 5974 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5975 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 5976 o->op_private |= OPpENTERSUB_DB;
5977 while (o2 != cvop) {
4633a7c4
LW		 5978 if (proto) {
5979 switch (*proto) {
5980 case '\0':
5dc0d613 5981 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 5982 case ';':
5983 optional = 1;
5984 proto++;
5985 continue;
5986 case '$':
5987 proto++;
5988 arg++;
11343788 5989 scalar(o2);
4633a7c4
LW		 5990 break;
5991 case '%':
5992 case '@':
11343788 5993 list(o2);
4633a7c4
LW		 5994 arg++;
5995 break;
5996 case '&':
5997 proto++;
5998 arg++;
11343788 5999 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6000 bad_type(arg,
6001 arg == 1 ? "block or sub {}" : "sub {}",
6002 gv_ename(namegv), o2);
4633a7c4
LW		 6003 break;
6004 case '*':
2ba6ecf4 6005 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6006 proto++;
6007 arg++;
11343788 6008 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6009 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6010 else if (o2->op_type == OP_CONST)
6011 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6012 else if (o2->op_type == OP_ENTERSUB) {
6013 /* accidental subroutine, revert to bareword */
6014 OP *gvop = ((UNOP*)o2)->op_first;
6015 if (gvop && gvop->op_type == OP_NULL) {
6016 gvop = ((UNOP*)gvop)->op_first;
6017 if (gvop) {
6018 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6019 ;
6020 if (gvop &&
6021 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6022 (gvop = ((UNOP*)gvop)->op_first) &&
6023 gvop->op_type == OP_GV)
6024 {
638eceb6 6025 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6026 OP *sibling = o2->op_sibling;
2692f720 6027 SV *n = newSVpvn("",0);
9675f7ac 6028 op_free(o2);
2692f720
GS		 6029 gv_fullname3(n, gv, "");
6030 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6031 sv_chop(n, SvPVX(n)+6);
6032 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6033 prev->op_sibling = o2;
6034 o2->op_sibling = sibling;
6035 }
6036 }
6037 }
6038 }
2ba6ecf4
GS		 6039 scalar(o2);
6040 break;
5b794e05
JH		 6041 case '[': case ']':
6042 goto oops;
6043 break;
4633a7c4
LW		 6044 case '\\':
6045 proto++;
6046 arg++;
5b794e05 6047 again:
4633a7c4 6048 switch (*proto++) {
5b794e05
JH		 6049 case '[':
6050 if (contextclass++ == 0) {
841d93c8 6051 e = strchr(proto, ']');
5b794e05
JH		 6052 if (!e || e == proto)
6053 goto oops;
6054 }
6055 else
6056 goto oops;
6057 goto again;
6058 break;
6059 case ']':
466bafcd
RGS		 6060 if (contextclass) {
6061 char *p = proto;
6062 char s = *p;
6063 contextclass = 0;
6064 *p = '\0';
6065 while (*--p != '[');
1eb1540c 6066 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6067 gv_ename(namegv), o2);
6068 *proto = s;
6069 } else
5b794e05
JH		 6070 goto oops;
6071 break;
4633a7c4 6072 case '*':
5b794e05
JH		 6073 if (o2->op_type == OP_RV2GV)
6074 goto wrapref;
6075 if (!contextclass)
6076 bad_type(arg, "symbol", gv_ename(namegv), o2);
6077 break;
4633a7c4 6078 case '&':
5b794e05
JH		 6079 if (o2->op_type == OP_ENTERSUB)
6080 goto wrapref;
6081 if (!contextclass)
6082 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6083 break;
4633a7c4 6084 case '$':
5b794e05
JH		 6085 if (o2->op_type == OP_RV2SV ||
6086 o2->op_type == OP_PADSV ||
6087 o2->op_type == OP_HELEM ||
6088 o2->op_type == OP_AELEM ||
6089 o2->op_type == OP_THREADSV)
6090 goto wrapref;
6091 if (!contextclass)
5dc0d613 6092 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6093 break;
4633a7c4 6094 case '@':
5b794e05
JH		 6095 if (o2->op_type == OP_RV2AV ||
6096 o2->op_type == OP_PADAV)
6097 goto wrapref;
6098 if (!contextclass)
5dc0d613 6099 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6100 break;
4633a7c4 6101 case '%':
5b794e05
JH		 6102 if (o2->op_type == OP_RV2HV ||
6103 o2->op_type == OP_PADHV)
6104 goto wrapref;
6105 if (!contextclass)
6106 bad_type(arg, "hash", gv_ename(namegv), o2);
6107 break;
6108 wrapref:
4633a7c4 6109 {
11343788 6110 OP* kid = o2;
6fa846a0 6111 OP* sib = kid->op_sibling;
4633a7c4 6112 kid->op_sibling = 0;
6fa846a0
GS		 6113 o2 = newUNOP(OP_REFGEN, 0, kid);
6114 o2->op_sibling = sib;
e858de61 6115 prev->op_sibling = o2;
4633a7c4 6116 }
841d93c8 6117 if (contextclass && e) {
5b794e05
JH		 6118 proto = e + 1;
6119 contextclass = 0;
6120 }
4633a7c4
LW		 6121 break;
6122 default: goto oops;
6123 }
5b794e05
JH		 6124 if (contextclass)
6125 goto again;
4633a7c4 6126 break;
b1cb66bf 6127 case ' ':
6128 proto++;
6129 continue;
4633a7c4
LW		 6130 default:
6131 oops:
35c1215d
NC		 6132 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6133 gv_ename(namegv), cv);
4633a7c4
LW		 6134 }
6135 }
6136 else
11343788
MB		 6137 list(o2);
6138 mod(o2, OP_ENTERSUB);
6139 prev = o2;
6140 o2 = o2->op_sibling;
4633a7c4 6141 }
fb73857a 6142 if (proto && !optional &&
6143 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6144 return too_few_arguments(o, gv_ename(namegv));
06492da6
SF		 6145 if(delete) {
6146 op_free(o);
6147 o=newSVOP(OP_CONST, 0, newSViv(0));
6148 }
11343788 6149 return o;
79072805
LW		 6150}
6151
6152OP *
cea2e8a9 6153Perl_ck_svconst(pTHX_ OP *o)
8990e307 6154{
11343788
MB		 6155 SvREADONLY_on(cSVOPo->op_sv);
6156 return o;
8990e307
LW		 6157}
6158
6159OP *
cea2e8a9 6160Perl_ck_trunc(pTHX_ OP *o)
79072805 6161{
11343788
MB		 6162 if (o->op_flags & OPf_KIDS) {
6163 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6164
a0d0e21e
LW		 6165 if (kid->op_type == OP_NULL)
6166 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6167 if (kid && kid->op_type == OP_CONST &&
6168 (kid->op_private & OPpCONST_BARE))
6169 {
11343788 6170 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6171 kid->op_private &= ~OPpCONST_STRICT;
6172 }
79072805 6173 }
11343788 6174 return ck_fun(o);
79072805
LW		 6175}
6176
35fba0d9
RG		 6177OP *
6178Perl_ck_substr(pTHX_ OP *o)
6179{
6180 o = ck_fun(o);
6181 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6182 OP *kid = cLISTOPo->op_first;
6183
6184 if (kid->op_type == OP_NULL)
6185 kid = kid->op_sibling;
6186 if (kid)
6187 kid->op_flags |= OPf_MOD;
6188
6189 }
6190 return o;
6191}
6192
463ee0b2
LW		 6193/* A peephole optimizer. We visit the ops in the order they're to execute. */
6194
79072805 6195void
864dbfa3 6196Perl_peep(pTHX_ register OP *o)
79072805
LW		 6197{
6198 register OP* oldop = 0;
2d8e6c8d 6199
a0d0e21e 6200 if (!o || o->op_seq)
79072805 6201 return;
a0d0e21e 6202 ENTER;
462e5cf6 6203 SAVEOP();
7766f137 6204 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6205 for (; o; o = o->op_next) {
6206 if (o->op_seq)
6207 break;
cfa2c302
PJ		 6208 /* The special value -1 is used by the B::C compiler backend to indicate
6209 * that an op is statically defined and should not be freed */
6210 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6211 PL_op_seqmax = 1;
533c011a 6212 PL_op = o;
a0d0e21e 6213 switch (o->op_type) {
acb36ea4 6214 case OP_SETSTATE:
a0d0e21e
LW		 6215 case OP_NEXTSTATE:
6216 case OP_DBSTATE:
3280af22
NIS		 6217 PL_curcop = ((COP*)o); /* for warnings */
6218 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6219 break;
6220
a0d0e21e 6221 case OP_CONST:
7a52d87a
GS		 6222 if (cSVOPo->op_private & OPpCONST_STRICT)
6223 no_bareword_allowed(o);
7766f137 6224#ifdef USE_ITHREADS
3848b962 6225 case OP_METHOD_NAMED:
7766f137
GS		 6226 /* Relocate sv to the pad for thread safety.
6227 * Despite being a "constant", the SV is written to,
6228 * for reference counts, sv_upgrade() etc. */
6229 if (cSVOP->op_sv) {
6230 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 6231 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6232 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6233 * some pad, so make a copy. */
dd2155a4
DM		 6234 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6235 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6236 SvREFCNT_dec(cSVOPo->op_sv);
6237 }
6238 else {
dd2155a4 6239 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6240 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 6241 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6242 /* XXX I don't know how this isn't readonly already. */
dd2155a4 6243 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6244 }
7766f137
GS		 6245 cSVOPo->op_sv = Nullsv;
6246 o->op_targ = ix;
6247 }
6248#endif
07447971
GS		 6249 o->op_seq = PL_op_seqmax++;
6250 break;
6251
ed7ab888 6252 case OP_CONCAT:
b162f9ea
IZ		 6253 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6254 if (o->op_next->op_private & OPpTARGET_MY) {
69b47968 6255 if (o->op_flags & OPf_STACKED) /* chained concats */
b162f9ea 6256 goto ignore_optimization;
cd06dffe 6257 else {
07447971 6258 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
b162f9ea 6259 o->op_targ = o->op_next->op_targ;
743e66e6 6260 o->op_next->op_targ = 0;
2c2d71f5 6261 o->op_private |= OPpTARGET_MY;
b162f9ea
IZ		 6262 }
6263 }
93c66552 6264 op_null(o->op_next);
b162f9ea
IZ		 6265 }
6266 ignore_optimization:
3280af22 6267 o->op_seq = PL_op_seqmax++;
a0d0e21e 6268 break;
8990e307 6269 case OP_STUB:
54310121 6270 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 6271 o->op_seq = PL_op_seqmax++;
54310121 6272 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6273 }
748a9306 6274 goto nothin;
79072805 6275 case OP_NULL:
acb36ea4
GS		 6276 if (o->op_targ == OP_NEXTSTATE
6277 || o->op_targ == OP_DBSTATE
6278 || o->op_targ == OP_SETSTATE)
6279 {
3280af22 6280 PL_curcop = ((COP*)o);
acb36ea4 6281 }
dad75012
AMS		 6282 /* XXX: We avoid setting op_seq here to prevent later calls
6283 to peep() from mistakenly concluding that optimisation
6284 has already occurred. This doesn't fix the real problem,
6285 though (See 20010220.007). AMS 20010719 */
6286 if (oldop && o->op_next) {
6287 oldop->op_next = o->op_next;
6288 continue;
6289 }
6290 break;
79072805 6291 case OP_SCALAR:
93a17b20 6292 case OP_LINESEQ:
463ee0b2 6293 case OP_SCOPE:
748a9306 6294 nothin:
a0d0e21e
LW		 6295 if (oldop && o->op_next) {
6296 oldop->op_next = o->op_next;
79072805
LW		 6297 continue;
6298 }
3280af22 6299 o->op_seq = PL_op_seqmax++;
79072805
LW		 6300 break;
6301
6302 case OP_GV:
a0d0e21e 6303 if (o->op_next->op_type == OP_RV2SV) {
64aac5a9 6304 if (!(o->op_next->op_private & OPpDEREF)) {
93c66552 6305 op_null(o->op_next);
64aac5a9
GS		 6306 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6307 | OPpOUR_INTRO);
a0d0e21e
LW		 6308 o->op_next = o->op_next->op_next;
6309 o->op_type = OP_GVSV;
22c35a8c 6310 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307
LW		 6311 }
6312 }
a0d0e21e
LW		 6313 else if (o->op_next->op_type == OP_RV2AV) {
6314 OP* pop = o->op_next->op_next;
6315 IV i;
f9dc862f 6316 if (pop && pop->op_type == OP_CONST &&
533c011a 6317 (PL_op = pop->op_next) &&
8990e307 6318 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6319 !(pop->op_next->op_private &
78f9721b 6320 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6321 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6322 <= 255 &&
8990e307
LW		 6323 i >= 0)
6324 {
350de78d 6325 GV *gv;
93c66552
DM		 6326 op_null(o->op_next);
6327 op_null(pop->op_next);
6328 op_null(pop);
a0d0e21e
LW		 6329 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6330 o->op_next = pop->op_next->op_next;
6331 o->op_type = OP_AELEMFAST;
22c35a8c 6332 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6333 o->op_private = (U8)i;
638eceb6 6334 gv = cGVOPo_gv;
350de78d 6335 GvAVn(gv);
8990e307 6336 }
79072805 6337 }
e476b1b5 6338 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 6339 GV *gv = cGVOPo_gv;
76cd736e
GS		 6340 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6341 /* XXX could check prototype here instead of just carping */
6342 SV *sv = sv_newmortal();
6343 gv_efullname3(sv, gv, Nullch);
9014280d 6344 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d
NC		 6345 "%"SVf"() called too early to check prototype",
6346 sv);
76cd736e
GS		 6347 }
6348 }
89de2904
AMS		 6349 else if (o->op_next->op_type == OP_READLINE
6350 && o->op_next->op_next->op_type == OP_CONCAT
6351 && (o->op_next->op_next->op_flags & OPf_STACKED))
6352 {
d2c45030
AMS		 6353 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6354 o->op_type = OP_RCATLINE;
6355 o->op_flags |= OPf_STACKED;
6356 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6357 op_null(o->op_next->op_next);
d2c45030 6358 op_null(o->op_next);
89de2904 6359 }
76cd736e 6360
3280af22 6361 o->op_seq = PL_op_seqmax++;
79072805
LW		 6362 break;
6363
a0d0e21e 6364 case OP_MAPWHILE:
79072805
LW		 6365 case OP_GREPWHILE:
6366 case OP_AND:
6367 case OP_OR:
c963b151 6368 case OP_DOR:
2c2d71f5
JH		 6369 case OP_ANDASSIGN:
6370 case OP_ORASSIGN:
c963b151 6371 case OP_DORASSIGN:
1a67a97c
SM		 6372 case OP_COND_EXPR:
6373 case OP_RANGE:
3280af22 6374 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 6375 while (cLOGOP->op_other->op_type == OP_NULL)
6376 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 6377 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 6378 break;
6379
79072805 6380 case OP_ENTERLOOP:
9c2ca71a 6381 case OP_ENTERITER:
3280af22 6382 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 6383 while (cLOOP->op_redoop->op_type == OP_NULL)
6384 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6385 peep(cLOOP->op_redoop);
58cccf98
SM		 6386 while (cLOOP->op_nextop->op_type == OP_NULL)
6387 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6388 peep(cLOOP->op_nextop);
58cccf98
SM		 6389 while (cLOOP->op_lastop->op_type == OP_NULL)
6390 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6391 peep(cLOOP->op_lastop);
6392 break;
6393
8782bef2 6394 case OP_QR:
79072805
LW		 6395 case OP_MATCH:
6396 case OP_SUBST:
3280af22 6397 o->op_seq = PL_op_seqmax++;
9041c2e3 6398 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6399 cPMOP->op_pmreplstart->op_type == OP_NULL)
6400 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6401 peep(cPMOP->op_pmreplstart);
79072805
LW		 6402 break;
6403
a0d0e21e 6404 case OP_EXEC:
3280af22 6405 o->op_seq = PL_op_seqmax++;
1c846c1f 6406 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 6407 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 6408 if (o->op_next->op_sibling &&
20408e3c
GS		 6409 o->op_next->op_sibling->op_type != OP_EXIT &&
6410 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6411 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 6412 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 6413
57843af0 6414 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 6415 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 6416 "Statement unlikely to be reached");
9014280d 6417 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 6418 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 6419 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 6420 }
6421 }
6422 break;
b2ffa427 6423
c750a3ec 6424 case OP_HELEM: {
6d822dc4
MS		 6425 SV *lexname;
6426 SV **svp, *sv;
1c846c1f 6427 char *key = NULL;
c750a3ec 6428 STRLEN keylen;
b2ffa427 6429
9615e741 6430 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 6431
6432 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6433 break;
1c846c1f
NIS		 6434
6435 /* Make the CONST have a shared SV */
6436 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6437 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 6438 key = SvPV(sv, keylen);
25716404
GS		 6439 lexname = newSVpvn_share(key,
6440 SvUTF8(sv) ? -(I32)keylen : keylen,
6441 0);
1c846c1f
NIS		 6442 SvREFCNT_dec(sv);
6443 *svp = lexname;
6444 }
6d822dc4
MS		 6445 break;
6446 }
c750a3ec 6447
79072805 6448 default:
3280af22 6449 o->op_seq = PL_op_seqmax++;
79072805
LW		 6450 break;
6451 }
a0d0e21e 6452 oldop = o;
79072805 6453 }
a0d0e21e 6454 LEAVE;
79072805 6455}
beab0874 6456
19e8ce8e
AB		 6457
6458
6459char* Perl_custom_op_name(pTHX_ OP* o)
53e06cf0
SC		 6460{
6461 IV index = PTR2IV(o->op_ppaddr);
6462 SV* keysv;
6463 HE* he;
6464
6465 if (!PL_custom_op_names) /* This probably shouldn't happen */
6466 return PL_op_name[OP_CUSTOM];
6467
6468 keysv = sv_2mortal(newSViv(index));
6469
6470 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6471 if (!he)
6472 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6473
6474 return SvPV_nolen(HeVAL(he));
6475}
6476
19e8ce8e 6477char* Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0
SC		 6478{
6479 IV index = PTR2IV(o->op_ppaddr);
6480 SV* keysv;
6481 HE* he;
6482
6483 if (!PL_custom_op_descs)
6484 return PL_op_desc[OP_CUSTOM];
6485
6486 keysv = sv_2mortal(newSViv(index));
6487
6488 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6489 if (!he)
6490 return PL_op_desc[OP_CUSTOM];
6491
6492 return SvPV_nolen(HeVAL(he));
6493}
19e8ce8e 6494
53e06cf0 6495
beab0874
JT		 6496#include "XSUB.h"
6497
6498/* Efficient sub that returns a constant scalar value. */
6499static void
acfe0abc 6500const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 6501{
6502 dXSARGS;
9cbac4c7
DM		 6503 if (items != 0) {
6504#if 0
6505 Perl_croak(aTHX_ "usage: %s::%s()",
6506 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6507#endif
6508 }
9a049f1c 6509 EXTEND(sp, 1);
0768512c 6510 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 6511 XSRETURN(1);
6512}
de72a0a2
JH		 6513
6514PerlIO*
6515Perl_my_tmpfp(pTHX)
6516{
de72a0a2
JH		 6517 PerlIO *f = NULL;
6518 int fd = -1;
6519#ifdef PERL_EXTERNAL_GLOB
6520 /* File::Temp pulls in Fcntl, which may not be available with
6521 * e.g. miniperl, use mkstemp() or stdio tmpfile() instead. */
96d9c003
JH		 6522# if defined(WIN32) || !defined(HAS_MKSTEMP)
6523 FILE *stdio = PerlSIO_tmpfile();
6524 if (stdio) {
6525 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)),
6526 &PerlIO_stdio, "w+", Nullsv))) {
6527 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
6528 s->stdio = stdio;
6529 }
6530 }
6531# else /* !WIN32 && HAS_MKSTEMP */
de72a0a2
JH		 6532 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
6533 fd = mkstemp(SvPVX(sv));
6534 if (fd >= 0) {
6535 f = PerlIO_fdopen(fd, "w+");
6536 if (f) {
6537 PerlLIO_unlink(SvPVX(sv));
6538 SvREFCNT_dec(sv);
6539 }
6540 }
96d9c003 6541# endif /* WIN32 || !HAS_MKSTEMP */
de72a0a2
JH		 6542#else
6543 /* We have internal glob, which probably also means that we
6544 * can also use File::Temp (which uses Fcntl) with impunity. */
6545 GV *gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV);
6546
6547 if (!gv) {
6548 ENTER;
6549 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6550 newSVpvn("File::Temp", 10), Nullsv, Nullsv, Nullsv);
6551 gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV);
6552 GvIMPORTED_CV_on(gv);
6553 LEAVE;
6554 }
6555 if (gv && GvCV(gv)) {
6556 dSP;
6557 ENTER;
6558 SAVETMPS;
6559 PUSHMARK(SP);
6560 PUTBACK;
6561 if (call_sv((SV*)GvCV(gv), G_SCALAR)) {
6562 GV *gv = (GV*)SvRV(newSVsv(*PL_stack_sp--));
6563 IO *io = gv ? GvIO(gv) : 0;
6564 fd = io ? PerlIO_fileno(IoIFP(io)) : -1;
6565 }
6566 SPAGAIN;
6567 PUTBACK;
6568 FREETMPS;
6569 LEAVE;
6570 }
6571 if (fd >= 0)
6572 f = PerlIO_fdopen(fd, "w+");
6573#endif
6574
6575 return f;
6576}
6577
Unnamed repository; edit this file 'description' to name the repository.