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