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