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