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