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
unifold is really an op test since it requires
[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 }
1eb1540c 871#endif
13137afc 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 3092 sv_setiv(repointer,0);
1eb1540c 3093 } else {
13137afc
AB		 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
1eb1540c 3101
1fcf4c12 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 }
5b71a6a7 3134 if (DO_UTF8(pat))
a5961de5 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 {
3280af22 3142 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3143 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3144 ? OP_REGCRESET
3145 : OP_REGCMAYBE),0,expr);
463ee0b2 3146
b7dc083c 3147 NewOp(1101, rcop, 1, LOGOP);
79072805 3148 rcop->op_type = OP_REGCOMP;
22c35a8c 3149 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3150 rcop->op_first = scalar(expr);
1c846c1f 3151 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3152 ? (OPf_SPECIAL | OPf_KIDS)
3153 : OPf_KIDS);
79072805 3154 rcop->op_private = 1;
11343788 3155 rcop->op_other = o;
79072805
LW		 3156
3157 /* establish postfix order */
3280af22 3158 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3159 LINKLIST(expr);
3160 rcop->op_next = expr;
3161 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3162 }
3163 else {
3164 rcop->op_next = LINKLIST(expr);
3165 expr->op_next = (OP*)rcop;
3166 }
79072805 3167
11343788 3168 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3169 }
3170
3171 if (repl) {
748a9306 3172 OP *curop;
0244c3a4 3173 if (pm->op_pmflags & PMf_EVAL) {
748a9306 3174 curop = 0;
57843af0
GS		 3175 if (CopLINE(PL_curcop) < PL_multi_end)
3176 CopLINE_set(PL_curcop, PL_multi_end);
0244c3a4 3177 }
4d1ff10f 3178#ifdef USE_5005THREADS
2faa37cc 3179 else if (repl->op_type == OP_THREADSV
554b3eca 3180 && strchr("&`'123456789+",
533c011a 3181 PL_threadsv_names[repl->op_targ]))
554b3eca
MB		 3182 {
3183 curop = 0;
3184 }
4d1ff10f 3185#endif /* USE_5005THREADS */
748a9306
LW		 3186 else if (repl->op_type == OP_CONST)
3187 curop = repl;
79072805 3188 else {
79072805
LW		 3189 OP *lastop = 0;
3190 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3191 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4d1ff10f 3192#ifdef USE_5005THREADS
ce862d02
IZ		 3193 if (curop->op_type == OP_THREADSV) {
3194 repl_has_vars = 1;
be949f6f 3195 if (strchr("&`'123456789+", curop->op_private))
ce862d02 3196 break;
554b3eca
MB		 3197 }
3198#else
79072805 3199 if (curop->op_type == OP_GV) {
638eceb6 3200 GV *gv = cGVOPx_gv(curop);
ce862d02 3201 repl_has_vars = 1;
93a17b20 3202 if (strchr("&`'123456789+", *GvENAME(gv)))
79072805
LW		 3203 break;
3204 }
4d1ff10f 3205#endif /* USE_5005THREADS */
79072805
LW		 3206 else if (curop->op_type == OP_RV2CV)
3207 break;
3208 else if (curop->op_type == OP_RV2SV ||
3209 curop->op_type == OP_RV2AV ||
3210 curop->op_type == OP_RV2HV ||
3211 curop->op_type == OP_RV2GV) {
3212 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3213 break;
3214 }
748a9306
LW		 3215 else if (curop->op_type == OP_PADSV ||
3216 curop->op_type == OP_PADAV ||
3217 curop->op_type == OP_PADHV ||
554b3eca 3218 curop->op_type == OP_PADANY) {
ce862d02 3219 repl_has_vars = 1;
748a9306 3220 }
1167e5da
SM		 3221 else if (curop->op_type == OP_PUSHRE)
3222 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3223 else
3224 break;
3225 }
3226 lastop = curop;
3227 }
748a9306 3228 }
ce862d02 3229 if (curop == repl
1c846c1f 3230 && !(repl_has_vars
aaa362c4
RS		 3231 && (!PM_GETRE(pm)
3232 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3233 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3234 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3235 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3236 }
3237 else {
aaa362c4 3238 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 3239 pm->op_pmflags |= PMf_MAYBE_CONST;
3240 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3241 }
b7dc083c 3242 NewOp(1101, rcop, 1, LOGOP);
748a9306 3243 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3244 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3245 rcop->op_first = scalar(repl);
3246 rcop->op_flags |= OPf_KIDS;
3247 rcop->op_private = 1;
11343788 3248 rcop->op_other = o;
748a9306
LW		 3249
3250 /* establish postfix order */
3251 rcop->op_next = LINKLIST(repl);
3252 repl->op_next = (OP*)rcop;
3253
3254 pm->op_pmreplroot = scalar((OP*)rcop);
3255 pm->op_pmreplstart = LINKLIST(rcop);
3256 rcop->op_next = 0;
79072805
LW		 3257 }
3258 }
3259
3260 return (OP*)pm;
3261}
3262
3263OP *
864dbfa3 3264Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 3265{
3266 SVOP *svop;
b7dc083c 3267 NewOp(1101, svop, 1, SVOP);
79072805 3268 svop->op_type = type;
22c35a8c 3269 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3270 svop->op_sv = sv;
3271 svop->op_next = (OP*)svop;
3272 svop->op_flags = flags;
22c35a8c 3273 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3274 scalar((OP*)svop);
22c35a8c 3275 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3276 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3277 return CHECKOP(type, svop);
79072805
LW		 3278}
3279
3280OP *
350de78d
GS		 3281Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3282{
3283 PADOP *padop;
3284 NewOp(1101, padop, 1, PADOP);
3285 padop->op_type = type;
3286 padop->op_ppaddr = PL_ppaddr[type];
3287 padop->op_padix = pad_alloc(type, SVs_PADTMP);
7766f137 3288 SvREFCNT_dec(PL_curpad[padop->op_padix]);
350de78d 3289 PL_curpad[padop->op_padix] = sv;
7766f137 3290 SvPADTMP_on(sv);
350de78d
GS		 3291 padop->op_next = (OP*)padop;
3292 padop->op_flags = flags;
3293 if (PL_opargs[type] & OA_RETSCALAR)
3294 scalar((OP*)padop);
3295 if (PL_opargs[type] & OA_TARGET)
3296 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3297 return CHECKOP(type, padop);
3298}
3299
3300OP *
864dbfa3 3301Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3302{
350de78d 3303#ifdef USE_ITHREADS
743e66e6 3304 GvIN_PAD_on(gv);
350de78d
GS		 3305 return newPADOP(type, flags, SvREFCNT_inc(gv));
3306#else
7934575e 3307 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3308#endif
79072805
LW		 3309}
3310
3311OP *
864dbfa3 3312Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 3313{
3314 PVOP *pvop;
b7dc083c 3315 NewOp(1101, pvop, 1, PVOP);
79072805 3316 pvop->op_type = type;
22c35a8c 3317 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3318 pvop->op_pv = pv;
3319 pvop->op_next = (OP*)pvop;
3320 pvop->op_flags = flags;
22c35a8c 3321 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3322 scalar((OP*)pvop);
22c35a8c 3323 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3324 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3325 return CHECKOP(type, pvop);
79072805
LW		 3326}
3327
79072805 3328void
864dbfa3 3329Perl_package(pTHX_ OP *o)
79072805 3330{
93a17b20 3331 SV *sv;
79072805 3332
3280af22
NIS		 3333 save_hptr(&PL_curstash);
3334 save_item(PL_curstname);
11343788 3335 if (o) {
463ee0b2
LW		 3336 STRLEN len;
3337 char *name;
11343788 3338 sv = cSVOPo->op_sv;
463ee0b2 3339 name = SvPV(sv, len);
3280af22
NIS		 3340 PL_curstash = gv_stashpvn(name,len,TRUE);
3341 sv_setpvn(PL_curstname, name, len);
11343788 3342 op_free(o);
93a17b20
LW		 3343 }
3344 else {
f2c0fa37 3345 deprecate("\"package\" with no arguments");
3280af22
NIS		 3346 sv_setpv(PL_curstname,"<none>");
3347 PL_curstash = Nullhv;
93a17b20 3348 }
7ad382f4 3349 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3350 PL_copline = NOLINE;
3351 PL_expect = XSTATE;
79072805
LW		 3352}
3353
85e6fe83 3354void
864dbfa3 3355Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
85e6fe83 3356{
a0d0e21e 3357 OP *pack;
a0d0e21e 3358 OP *imop;
b1cb66bf 3359 OP *veop;
18fc9488 3360 char *packname = Nullch;
c4e33207 3361 STRLEN packlen = 0;
18fc9488 3362 SV *packsv;
85e6fe83 3363
a0d0e21e 3364 if (id->op_type != OP_CONST)
cea2e8a9 3365 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3366
b1cb66bf 3367 veop = Nullop;
3368
0f79a09d 3369 if (version != Nullop) {
b1cb66bf 3370 SV *vesv = ((SVOP*)version)->op_sv;
3371
44dcb63b 3372 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 3373 arg = version;
3374 }
3375 else {
3376 OP *pack;
0f79a09d 3377 SV *meth;
b1cb66bf 3378
44dcb63b 3379 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3380 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3381
3382 /* Make copy of id so we don't free it twice */
3383 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3384
3385 /* Fake up a method call to VERSION */
0f79a09d
GS		 3386 meth = newSVpvn("VERSION",7);
3387 sv_upgrade(meth, SVt_PVIV);
155aba94 3388 (void)SvIOK_on(meth);
0f79a09d 3389 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 3390 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3391 append_elem(OP_LIST,
0f79a09d
GS		 3392 prepend_elem(OP_LIST, pack, list(version)),
3393 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3394 }
3395 }
aeea060c 3396
a0d0e21e 3397 /* Fake up an import/unimport */
4633a7c4
LW		 3398 if (arg && arg->op_type == OP_STUB)
3399 imop = arg; /* no import on explicit () */
44dcb63b 3400 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
b1cb66bf 3401 imop = Nullop; /* use 5.0; */
3402 }
4633a7c4 3403 else {
0f79a09d
GS		 3404 SV *meth;
3405
4633a7c4
LW		 3406 /* Make copy of id so we don't free it twice */
3407 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
0f79a09d
GS		 3408
3409 /* Fake up a method call to import/unimport */
3410 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
ad4c42df 3411 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 3412 (void)SvIOK_on(meth);
0f79a09d 3413 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 3414 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3415 append_elem(OP_LIST,
3416 prepend_elem(OP_LIST, pack, list(arg)),
3417 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3418 }
3419
d04f2e46
DM		 3420 if (ckWARN(WARN_MISC) &&
3421 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3422 SvPOK(packsv = ((SVOP*)id)->op_sv))
3423 {
18fc9488
DM		 3424 /* BEGIN will free the ops, so we need to make a copy */
3425 packlen = SvCUR(packsv);
3426 packname = savepvn(SvPVX(packsv), packlen);
3427 }
3428
a0d0e21e 3429 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3430 newATTRSUB(floor,
79cb57f6 3431 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3432 Nullop,
09bef843 3433 Nullop,
a0d0e21e 3434 append_elem(OP_LINESEQ,
b1cb66bf 3435 append_elem(OP_LINESEQ,
ec4ab249 3436 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
b1cb66bf 3437 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3438 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3439
18fc9488
DM		 3440 if (packname) {
3441 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3442 Perl_warner(aTHX_ WARN_MISC,
3443 "Package `%s' not found "
3444 "(did you use the incorrect case?)", packname);
3445 }
3446 safefree(packname);
3447 }
3448
c305c6a0 3449 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3450 PL_copline = NOLINE;
3451 PL_expect = XSTATE;
85e6fe83
LW		 3452}
3453
7d3fb230 3454/*
ccfc67b7
JH		 3455=head1 Embedding Functions
3456
7d3fb230
BS		 3457=for apidoc load_module
3458
3459Loads the module whose name is pointed to by the string part of name.
3460Note that the actual module name, not its filename, should be given.
3461Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3462PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3463(or 0 for no flags). ver, if specified, provides version semantics
3464similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3465arguments can be used to specify arguments to the module's import()
3466method, similar to C<use Foo::Bar VERSION LIST>.
3467
3468=cut */
3469
e4783991
GS		 3470void
3471Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3472{
3473 va_list args;
3474 va_start(args, ver);
3475 vload_module(flags, name, ver, &args);
3476 va_end(args);
3477}
3478
3479#ifdef PERL_IMPLICIT_CONTEXT
3480void
3481Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3482{
3483 dTHX;
3484 va_list args;
3485 va_start(args, ver);
3486 vload_module(flags, name, ver, &args);
3487 va_end(args);
3488}
3489#endif
3490
3491void
3492Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3493{
3494 OP *modname, *veop, *imop;
3495
3496 modname = newSVOP(OP_CONST, 0, name);
3497 modname->op_private |= OPpCONST_BARE;
3498 if (ver) {
3499 veop = newSVOP(OP_CONST, 0, ver);
3500 }
3501 else
3502 veop = Nullop;
3503 if (flags & PERL_LOADMOD_NOIMPORT) {
3504 imop = sawparens(newNULLLIST());
3505 }
3506 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3507 imop = va_arg(*args, OP*);
3508 }
3509 else {
3510 SV *sv;
3511 imop = Nullop;
3512 sv = va_arg(*args, SV*);
3513 while (sv) {
3514 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3515 sv = va_arg(*args, SV*);
3516 }
3517 }
81885997
GS		 3518 {
3519 line_t ocopline = PL_copline;
3520 int oexpect = PL_expect;
3521
3522 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3523 veop, modname, imop);
3524 PL_expect = oexpect;
3525 PL_copline = ocopline;
3526 }
e4783991
GS		 3527}
3528
79072805 3529OP *
864dbfa3 3530Perl_dofile(pTHX_ OP *term)
78ca652e
GS		 3531{
3532 OP *doop;
3533 GV *gv;
3534
3535 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3536 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS		 3537 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3538
b9f751c0 3539 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3540 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3541 append_elem(OP_LIST, term,
3542 scalar(newUNOP(OP_RV2CV, 0,
3543 newGVOP(OP_GV, 0,
3544 gv))))));
3545 }
3546 else {
3547 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3548 }
3549 return doop;
3550}
3551
3552OP *
864dbfa3 3553Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3554{
3555 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3556 list(force_list(subscript)),
3557 list(force_list(listval)) );
79072805
LW		 3558}
3559
76e3520e 3560STATIC I32
cea2e8a9 3561S_list_assignment(pTHX_ register OP *o)
79072805 3562{
11343788 3563 if (!o)
79072805
LW		 3564 return TRUE;
3565
11343788
MB		 3566 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3567 o = cUNOPo->op_first;
79072805 3568
11343788 3569 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM		 3570 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3571 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3572
3573 if (t && f)
3574 return TRUE;
3575 if (t || f)
3576 yyerror("Assignment to both a list and a scalar");
3577 return FALSE;
3578 }
3579
95f0a2f1
SB		 3580 if (o->op_type == OP_LIST &&
3581 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3582 o->op_private & OPpLVAL_INTRO)
3583 return FALSE;
3584
11343788
MB		 3585 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3586 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3587 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3588 return TRUE;
3589
11343788 3590 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3591 return TRUE;
3592
11343788 3593 if (o->op_type == OP_RV2SV)
79072805
LW		 3594 return FALSE;
3595
3596 return FALSE;
3597}
3598
3599OP *
864dbfa3 3600Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3601{
11343788 3602 OP *o;
79072805 3603
a0d0e21e
LW		 3604 if (optype) {
3605 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3606 return newLOGOP(optype, 0,
3607 mod(scalar(left), optype),
3608 newUNOP(OP_SASSIGN, 0, scalar(right)));
3609 }
3610 else {
3611 return newBINOP(optype, OPf_STACKED,
3612 mod(scalar(left), optype), scalar(right));
3613 }
3614 }
3615
79072805 3616 if (list_assignment(left)) {
10c8fecd
GS		 3617 OP *curop;
3618
3280af22
NIS		 3619 PL_modcount = 0;
3620 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3621 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3622 if (PL_eval_start)
3623 PL_eval_start = 0;
748a9306 3624 else {
a0d0e21e
LW		 3625 op_free(left);
3626 op_free(right);
3627 return Nullop;
3628 }
10c8fecd
GS		 3629 curop = list(force_list(left));
3630 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
11343788 3631 o->op_private = 0 | (flags >> 8);
10c8fecd
GS		 3632 for (curop = ((LISTOP*)curop)->op_first;
3633 curop; curop = curop->op_sibling)
3634 {
3635 if (curop->op_type == OP_RV2HV &&
3636 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3637 o->op_private |= OPpASSIGN_HASH;
3638 break;
3639 }
3640 }
a0d0e21e 3641 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3642 OP *lastop = o;
3280af22 3643 PL_generation++;
11343788 3644 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3645 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3646 if (curop->op_type == OP_GV) {
638eceb6 3647 GV *gv = cGVOPx_gv(curop);
3280af22 3648 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
79072805 3649 break;
3280af22 3650 SvCUR(gv) = PL_generation;
79072805 3651 }
748a9306
LW		 3652 else if (curop->op_type == OP_PADSV ||
3653 curop->op_type == OP_PADAV ||
3654 curop->op_type == OP_PADHV ||
3655 curop->op_type == OP_PADANY) {
3280af22 3656 SV **svp = AvARRAY(PL_comppad_name);
8e07c86e 3657 SV *sv = svp[curop->op_targ];
3280af22 3658 if (SvCUR(sv) == PL_generation)
748a9306 3659 break;
3280af22 3660 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
748a9306 3661 }
79072805
LW		 3662 else if (curop->op_type == OP_RV2CV)
3663 break;
3664 else if (curop->op_type == OP_RV2SV ||
3665 curop->op_type == OP_RV2AV ||
3666 curop->op_type == OP_RV2HV ||
3667 curop->op_type == OP_RV2GV) {
3668 if (lastop->op_type != OP_GV) /* funny deref? */
3669 break;
3670 }
1167e5da
SM		 3671 else if (curop->op_type == OP_PUSHRE) {
3672 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3673#ifdef USE_ITHREADS
ba89bb6e 3674 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
b3f5893f 3675#else
1167e5da 3676 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3677#endif
3280af22 3678 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
1167e5da 3679 break;
3280af22 3680 SvCUR(gv) = PL_generation;
1167e5da
SM		 3681 }
3682 }
79072805
LW		 3683 else
3684 break;
3685 }
3686 lastop = curop;
3687 }
11343788 3688 if (curop != o)
10c8fecd 3689 o->op_private |= OPpASSIGN_COMMON;
79072805 3690 }
c07a80fd 3691 if (right && right->op_type == OP_SPLIT) {
3692 OP* tmpop;
3693 if ((tmpop = ((LISTOP*)right)->op_first) &&
3694 tmpop->op_type == OP_PUSHRE)
3695 {
3696 PMOP *pm = (PMOP*)tmpop;
3697 if (left->op_type == OP_RV2AV &&
3698 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3699 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3700 {
3701 tmpop = ((UNOP*)left)->op_first;
3702 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3703#ifdef USE_ITHREADS
ba89bb6e 3704 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3705 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3706#else
3707 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3708 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3709#endif
c07a80fd 3710 pm->op_pmflags |= PMf_ONCE;
11343788 3711 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3712 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3713 tmpop->op_sibling = Nullop; /* don't free split */
3714 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3715 op_free(o); /* blow off assign */
54310121 3716 right->op_flags &= ~OPf_WANT;
a5f75d66 3717 /* "I don't know and I don't care." */
c07a80fd 3718 return right;
3719 }
3720 }
3721 else {
e6438c1a 3722 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3723 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3724 {
3725 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3726 if (SvIVX(sv) == 0)
3280af22 3727 sv_setiv(sv, PL_modcount+1);
c07a80fd 3728 }
3729 }
3730 }
3731 }
11343788 3732 return o;
79072805
LW		 3733 }
3734 if (!right)
3735 right = newOP(OP_UNDEF, 0);
3736 if (right->op_type == OP_READLINE) {
3737 right->op_flags |= OPf_STACKED;
463ee0b2 3738 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3739 }
a0d0e21e 3740 else {
3280af22 3741 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3742 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3743 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3744 if (PL_eval_start)
3745 PL_eval_start = 0;
748a9306 3746 else {
11343788 3747 op_free(o);
a0d0e21e
LW		 3748 return Nullop;
3749 }
3750 }
11343788 3751 return o;
79072805
LW		 3752}
3753
3754OP *
864dbfa3 3755Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3756{
bbce6d69 3757 U32 seq = intro_my();
79072805
LW		 3758 register COP *cop;
3759
b7dc083c 3760 NewOp(1101, cop, 1, COP);
57843af0 3761 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3762 cop->op_type = OP_DBSTATE;
22c35a8c 3763 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3764 }
3765 else {
3766 cop->op_type = OP_NEXTSTATE;
22c35a8c 3767 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3768 }
79072805 3769 cop->op_flags = flags;
9d43a755 3770 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3771#ifdef NATIVE_HINTS
3772 cop->op_private |= NATIVE_HINTS;
3773#endif
e24b16f9 3774 PL_compiling.op_private = cop->op_private;
79072805
LW		 3775 cop->op_next = (OP*)cop;
3776
463ee0b2
LW		 3777 if (label) {
3778 cop->cop_label = label;
3280af22 3779 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3780 }
bbce6d69 3781 cop->cop_seq = seq;
3280af22 3782 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3783 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3784 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3785 else
599cee73 3786 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3787 if (specialCopIO(PL_curcop->cop_io))
3788 cop->cop_io = PL_curcop->cop_io;
3789 else
3790 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3791
79072805 3792
3280af22 3793 if (PL_copline == NOLINE)
57843af0 3794 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3795 else {
57843af0 3796 CopLINE_set(cop, PL_copline);
3280af22 3797 PL_copline = NOLINE;
79072805 3798 }
57843af0 3799#ifdef USE_ITHREADS
f4dd75d9 3800 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3801#else
f4dd75d9 3802 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3803#endif
11faa288 3804 CopSTASH_set(cop, PL_curstash);
79072805 3805
3280af22 3806 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3807 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3808 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3809 (void)SvIOK_on(*svp);
57b2e452 3810 SvIVX(*svp) = PTR2IV(cop);
1eb1540c 3811 }
93a17b20
LW		 3812 }
3813
11343788 3814 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3815}
3816
bbce6d69 3817/* "Introduce" my variables to visible status. */
3818U32
864dbfa3 3819Perl_intro_my(pTHX)
bbce6d69 3820{
3821 SV **svp;
3822 SV *sv;
3823 I32 i;
3824
3280af22
NIS		 3825 if (! PL_min_intro_pending)
3826 return PL_cop_seqmax;
bbce6d69 3827
3280af22
NIS		 3828 svp = AvARRAY(PL_comppad_name);
3829 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3830 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
c53d7c7d 3831 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
65202027 3832 SvNVX(sv) = (NV)PL_cop_seqmax;
bbce6d69 3833 }
3834 }
3280af22
NIS		 3835 PL_min_intro_pending = 0;
3836 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3837 return PL_cop_seqmax++;
bbce6d69 3838}
3839
79072805 3840OP *
864dbfa3 3841Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3842{
883ffac3
CS		 3843 return new_logop(type, flags, &first, &other);
3844}
3845
3bd495df 3846STATIC OP *
cea2e8a9 3847S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3848{
79072805 3849 LOGOP *logop;
11343788 3850 OP *o;
883ffac3
CS		 3851 OP *first = *firstp;
3852 OP *other = *otherp;
79072805 3853
a0d0e21e
LW		 3854 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3855 return newBINOP(type, flags, scalar(first), scalar(other));
3856
8990e307 3857 scalarboolean(first);
79072805
LW		 3858 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3859 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3860 if (type == OP_AND || type == OP_OR) {
3861 if (type == OP_AND)
3862 type = OP_OR;
3863 else
3864 type = OP_AND;
11343788 3865 o = first;
883ffac3 3866 first = *firstp = cUNOPo->op_first;
11343788
MB		 3867 if (o->op_next)
3868 first->op_next = o->op_next;
3869 cUNOPo->op_first = Nullop;
3870 op_free(o);
79072805
LW		 3871 }
3872 }
3873 if (first->op_type == OP_CONST) {
4673fc70 3874 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
1c846c1f 3875 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
79072805
LW		 3876 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3877 op_free(first);
883ffac3 3878 *firstp = Nullop;
79072805
LW		 3879 return other;
3880 }
3881 else {
3882 op_free(other);
883ffac3 3883 *otherp = Nullop;
79072805
LW		 3884 return first;
3885 }
3886 }
3887 else if (first->op_type == OP_WANTARRAY) {
3888 if (type == OP_AND)
3889 list(other);
3890 else
3891 scalar(other);
3892 }
e476b1b5 3893 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
a6006777 3894 OP *k1 = ((UNOP*)first)->op_first;
3895 OP *k2 = k1->op_sibling;
3896 OPCODE warnop = 0;
3897 switch (first->op_type)
3898 {
3899 case OP_NULL:
3900 if (k2 && k2->op_type == OP_READLINE
3901 && (k2->op_flags & OPf_STACKED)
1c846c1f 3902 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3903 {
a6006777 3904 warnop = k2->op_type;
72b16652 3905 }
a6006777 3906 break;
3907
3908 case OP_SASSIGN:
68dc0745 3909 if (k1->op_type == OP_READDIR
3910 || k1->op_type == OP_GLOB
72b16652 3911 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3912 || k1->op_type == OP_EACH)
72b16652
GS		 3913 {
3914 warnop = ((k1->op_type == OP_NULL)
3915 ? k1->op_targ : k1->op_type);
3916 }
a6006777 3917 break;
3918 }
8ebc5c01 3919 if (warnop) {
57843af0
GS		 3920 line_t oldline = CopLINE(PL_curcop);
3921 CopLINE_set(PL_curcop, PL_copline);
e476b1b5 3922 Perl_warner(aTHX_ WARN_MISC,
599cee73 3923 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3924 PL_op_desc[warnop],
68dc0745 3925 ((warnop == OP_READLINE || warnop == OP_GLOB)
3926 ? " construct" : "() operator"));
57843af0 3927 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3928 }
a6006777 3929 }
79072805
LW		 3930
3931 if (!other)
3932 return first;
3933
a0d0e21e
LW		 3934 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3935 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3936
b7dc083c 3937 NewOp(1101, logop, 1, LOGOP);
79072805
LW		 3938
3939 logop->op_type = type;
22c35a8c 3940 logop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3941 logop->op_first = first;
3942 logop->op_flags = flags | OPf_KIDS;
3943 logop->op_other = LINKLIST(other);
c07a80fd 3944 logop->op_private = 1 | (flags >> 8);
79072805
LW		 3945
3946 /* establish postfix order */
3947 logop->op_next = LINKLIST(first);
3948 first->op_next = (OP*)logop;
3949 first->op_sibling = other;
3950
11343788
MB		 3951 o = newUNOP(OP_NULL, 0, (OP*)logop);
3952 other->op_next = o;
79072805 3953
11343788 3954 return o;
79072805
LW		 3955}
3956
3957OP *
864dbfa3 3958Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3959{
1a67a97c
SM		 3960 LOGOP *logop;
3961 OP *start;
11343788 3962 OP *o;
79072805 3963
b1cb66bf 3964 if (!falseop)
3965 return newLOGOP(OP_AND, 0, first, trueop);
3966 if (!trueop)
3967 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3968
8990e307 3969 scalarboolean(first);
79072805
LW		 3970 if (first->op_type == OP_CONST) {
3971 if (SvTRUE(((SVOP*)first)->op_sv)) {
3972 op_free(first);
b1cb66bf 3973 op_free(falseop);
3974 return trueop;
79072805
LW		 3975 }
3976 else {
3977 op_free(first);
b1cb66bf 3978 op_free(trueop);
3979 return falseop;
79072805
LW		 3980 }
3981 }
3982 else if (first->op_type == OP_WANTARRAY) {
b1cb66bf 3983 list(trueop);
3984 scalar(falseop);
79072805 3985 }
1a67a97c
SM		 3986 NewOp(1101, logop, 1, LOGOP);
3987 logop->op_type = OP_COND_EXPR;
3988 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3989 logop->op_first = first;
3990 logop->op_flags = flags | OPf_KIDS;
3991 logop->op_private = 1 | (flags >> 8);
3992 logop->op_other = LINKLIST(trueop);
3993 logop->op_next = LINKLIST(falseop);
79072805 3994
79072805
LW		 3995
3996 /* establish postfix order */
1a67a97c
SM		 3997 start = LINKLIST(first);
3998 first->op_next = (OP*)logop;
79072805 3999
b1cb66bf 4000 first->op_sibling = trueop;
4001 trueop->op_sibling = falseop;
1a67a97c 4002 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 4003
1a67a97c 4004 trueop->op_next = falseop->op_next = o;
79072805 4005
1a67a97c 4006 o->op_next = start;
11343788 4007 return o;
79072805
LW		 4008}
4009
4010OP *
864dbfa3 4011Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 4012{
1a67a97c 4013 LOGOP *range;
79072805
LW		 4014 OP *flip;
4015 OP *flop;
1a67a97c 4016 OP *leftstart;
11343788 4017 OP *o;
79072805 4018
1a67a97c 4019 NewOp(1101, range, 1, LOGOP);
79072805 4020
1a67a97c
SM		 4021 range->op_type = OP_RANGE;
4022 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4023 range->op_first = left;
4024 range->op_flags = OPf_KIDS;
4025 leftstart = LINKLIST(left);
4026 range->op_other = LINKLIST(right);
4027 range->op_private = 1 | (flags >> 8);
79072805
LW		 4028
4029 left->op_sibling = right;
4030
1a67a97c
SM		 4031 range->op_next = (OP*)range;
4032 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 4033 flop = newUNOP(OP_FLOP, 0, flip);
11343788 4034 o = newUNOP(OP_NULL, 0, flop);
79072805 4035 linklist(flop);
1a67a97c 4036 range->op_next = leftstart;
79072805
LW		 4037
4038 left->op_next = flip;
4039 right->op_next = flop;
4040
1a67a97c
SM		 4041 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4042 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 4043 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 4044 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4045
4046 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4047 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4048
11343788 4049 flip->op_next = o;
79072805 4050 if (!flip->op_private || !flop->op_private)
11343788 4051 linklist(o); /* blow off optimizer unless constant */
79072805 4052
11343788 4053 return o;
79072805
LW		 4054}
4055
4056OP *
864dbfa3 4057Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 4058{
463ee0b2 4059 OP* listop;
11343788 4060 OP* o;
463ee0b2 4061 int once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 4062 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
93a17b20 4063
463ee0b2
LW		 4064 if (expr) {
4065 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4066 return block; /* do {} while 0 does once */
fb73857a 4067 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4068 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 4069 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4070 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 4071 } else if (expr->op_flags & OPf_KIDS) {
4072 OP *k1 = ((UNOP*)expr)->op_first;
4073 OP *k2 = (k1) ? k1->op_sibling : NULL;
4074 switch (expr->op_type) {
1c846c1f 4075 case OP_NULL:
55d729e4
GS		 4076 if (k2 && k2->op_type == OP_READLINE
4077 && (k2->op_flags & OPf_STACKED)
1c846c1f 4078 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4079 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4080 break;
55d729e4
GS		 4081
4082 case OP_SASSIGN:
4083 if (k1->op_type == OP_READDIR
4084 || k1->op_type == OP_GLOB
6531c3e6 4085 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 4086 || k1->op_type == OP_EACH)
4087 expr = newUNOP(OP_DEFINED, 0, expr);
4088 break;
4089 }
774d564b 4090 }
463ee0b2 4091 }
93a17b20 4092
8990e307 4093 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 4094 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 4095
883ffac3
CS		 4096 if (listop)
4097 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 4098
11343788
MB		 4099 if (once && o != listop)
4100 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 4101
11343788
MB		 4102 if (o == listop)
4103 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 4104
11343788
MB		 4105 o->op_flags |= flags;
4106 o = scope(o);
4107 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4108 return o;
79072805
LW		 4109}
4110
4111OP *
864dbfa3 4112Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
79072805
LW		 4113{
4114 OP *redo;
4115 OP *next = 0;
4116 OP *listop;
11343788 4117 OP *o;
1ba6ee2b 4118 U8 loopflags = 0;
79072805 4119
fb73857a 4120 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4121 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
748a9306 4122 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4123 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 4124 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4125 OP *k1 = ((UNOP*)expr)->op_first;
4126 OP *k2 = (k1) ? k1->op_sibling : NULL;
4127 switch (expr->op_type) {
1c846c1f 4128 case OP_NULL:
55d729e4
GS		 4129 if (k2 && k2->op_type == OP_READLINE
4130 && (k2->op_flags & OPf_STACKED)
1c846c1f 4131 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4132 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4133 break;
55d729e4
GS		 4134
4135 case OP_SASSIGN:
4136 if (k1->op_type == OP_READDIR
4137 || k1->op_type == OP_GLOB
72b16652 4138 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 4139 || k1->op_type == OP_EACH)
4140 expr = newUNOP(OP_DEFINED, 0, expr);
4141 break;
4142 }
748a9306 4143 }
79072805
LW		 4144
4145 if (!block)
4146 block = newOP(OP_NULL, 0);
87246558
GS		 4147 else if (cont) {
4148 block = scope(block);
4149 }
79072805 4150
1ba6ee2b 4151 if (cont) {
79072805 4152 next = LINKLIST(cont);
1ba6ee2b 4153 }
fb73857a 4154 if (expr) {
85538317
GS		 4155 OP *unstack = newOP(OP_UNSTACK, 0);
4156 if (!next)
4157 next = unstack;
4158 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 4159 if ((line_t)whileline != NOLINE) {
3280af22 4160 PL_copline = whileline;
fb73857a 4161 cont = append_elem(OP_LINESEQ, cont,
4162 newSTATEOP(0, Nullch, Nullop));
4163 }
4164 }
79072805 4165
463ee0b2 4166 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 4167 redo = LINKLIST(listop);
4168
4169 if (expr) {
3280af22 4170 PL_copline = whileline;
883ffac3
CS		 4171 scalar(listop);
4172 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 4173 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 4174 op_free(expr); /* oops, it's a while (0) */
463ee0b2 4175 op_free((OP*)loop);
883ffac3 4176 return Nullop; /* listop already freed by new_logop */
463ee0b2 4177 }
883ffac3 4178 if (listop)
497b47a8 4179 ((LISTOP*)listop)->op_last->op_next =
883ffac3 4180 (o == listop ? redo : LINKLIST(o));
79072805
LW		 4181 }
4182 else
11343788 4183 o = listop;
79072805
LW		 4184
4185 if (!loop) {
b7dc083c 4186 NewOp(1101,loop,1,LOOP);
79072805 4187 loop->op_type = OP_ENTERLOOP;
22c35a8c 4188 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 4189 loop->op_private = 0;
4190 loop->op_next = (OP*)loop;
4191 }
4192
11343788 4193 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 4194
4195 loop->op_redoop = redo;
11343788 4196 loop->op_lastop = o;
1ba6ee2b 4197 o->op_private |= loopflags;
79072805
LW		 4198
4199 if (next)
4200 loop->op_nextop = next;
4201 else
11343788 4202 loop->op_nextop = o;
79072805 4203
11343788
MB		 4204 o->op_flags |= flags;
4205 o->op_private |= (flags >> 8);
4206 return o;
79072805
LW		 4207}
4208
4209OP *
864dbfa3 4210Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
79072805
LW		 4211{
4212 LOOP *loop;
fb73857a 4213 OP *wop;
85e6fe83 4214 int padoff = 0;
4633a7c4 4215 I32 iterflags = 0;
79072805 4216
79072805 4217 if (sv) {
85e6fe83 4218 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
748a9306 4219 sv->op_type = OP_RV2GV;
22c35a8c 4220 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
79072805 4221 }
85e6fe83
LW		 4222 else if (sv->op_type == OP_PADSV) { /* private variable */
4223 padoff = sv->op_targ;
743e66e6 4224 sv->op_targ = 0;
85e6fe83
LW		 4225 op_free(sv);
4226 sv = Nullop;
4227 }
54b9620d
MB		 4228 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4229 padoff = sv->op_targ;
743e66e6 4230 sv->op_targ = 0;
54b9620d
MB		 4231 iterflags |= OPf_SPECIAL;
4232 op_free(sv);
4233 sv = Nullop;
4234 }
79072805 4235 else
cea2e8a9 4236 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
79072805
LW		 4237 }
4238 else {
4d1ff10f 4239#ifdef USE_5005THREADS
54b9620d
MB		 4240 padoff = find_threadsv("_");
4241 iterflags |= OPf_SPECIAL;
4242#else
3280af22 4243 sv = newGVOP(OP_GV, 0, PL_defgv);
54b9620d 4244#endif
79072805 4245 }
5f05dabc 4246 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 4247 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 4248 iterflags |= OPf_STACKED;
4249 }
89ea2908
GA		 4250 else if (expr->op_type == OP_NULL &&
4251 (expr->op_flags & OPf_KIDS) &&
4252 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4253 {
4254 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4255 * set the STACKED flag to indicate that these values are to be
4256 * treated as min/max values by 'pp_iterinit'.
4257 */
4258 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
1a67a97c 4259 LOGOP* range = (LOGOP*) flip->op_first;
89ea2908
GA		 4260 OP* left = range->op_first;
4261 OP* right = left->op_sibling;
5152d7c7 4262 LISTOP* listop;
89ea2908
GA		 4263
4264 range->op_flags &= ~OPf_KIDS;
4265 range->op_first = Nullop;
4266
5152d7c7 4267 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 4268 listop->op_first->op_next = range->op_next;
4269 left->op_next = range->op_other;
5152d7c7
GS		 4270 right->op_next = (OP*)listop;
4271 listop->op_next = listop->op_first;
89ea2908
GA		 4272
4273 op_free(expr);
5152d7c7 4274 expr = (OP*)(listop);
93c66552 4275 op_null(expr);
89ea2908
GA		 4276 iterflags |= OPf_STACKED;
4277 }
4278 else {
4279 expr = mod(force_list(expr), OP_GREPSTART);
4280 }
4281
4282
4633a7c4 4283 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 4284 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 4285 assert(!loop->op_next);
b7dc083c 4286#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 4287 {
4288 LOOP *tmp;
4289 NewOp(1234,tmp,1,LOOP);
4290 Copy(loop,tmp,1,LOOP);
4291 loop = tmp;
4292 }
b7dc083c 4293#else
85e6fe83 4294 Renew(loop, 1, LOOP);
1c846c1f 4295#endif
85e6fe83 4296 loop->op_targ = padoff;
fb73857a 4297 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3280af22 4298 PL_copline = forline;
fb73857a 4299 return newSTATEOP(0, label, wop);
79072805
LW		 4300}
4301
8990e307 4302OP*
864dbfa3 4303Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 4304{
11343788 4305 OP *o;
2d8e6c8d
GS		 4306 STRLEN n_a;
4307
8990e307 4308 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 4309 /* "last()" means "last" */
4310 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4311 o = newOP(type, OPf_SPECIAL);
4312 else {
4313 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
2d8e6c8d 4314 ? SvPVx(((SVOP*)label)->op_sv, n_a)
cdaebead
MB		 4315 : ""));
4316 }
8990e307
LW		 4317 op_free(label);
4318 }
4319 else {
a0d0e21e
LW		 4320 if (label->op_type == OP_ENTERSUB)
4321 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 4322 o = newUNOP(type, OPf_STACKED, label);
8990e307 4323 }
3280af22 4324 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4325 return o;
8990e307
LW		 4326}
4327
79072805 4328void
864dbfa3 4329Perl_cv_undef(pTHX_ CV *cv)
79072805 4330{
4d1ff10f 4331#ifdef USE_5005THREADS
e858de61
MB		 4332 if (CvMUTEXP(cv)) {
4333 MUTEX_DESTROY(CvMUTEXP(cv));
4334 Safefree(CvMUTEXP(cv));
4335 CvMUTEXP(cv) = 0;
4336 }
4d1ff10f 4337#endif /* USE_5005THREADS */
11343788 4338
a636914a
RH		 4339#ifdef USE_ITHREADS
4340 if (CvFILE(cv) && !CvXSUB(cv)) {
f3e31eb5 4341 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 4342 Safefree(CvFILE(cv));
a636914a 4343 }
f3e31eb5 4344 CvFILE(cv) = 0;
a636914a
RH		 4345#endif
4346
a0d0e21e 4347 if (!CvXSUB(cv) && CvROOT(cv)) {
4d1ff10f 4348#ifdef USE_5005THREADS
11343788 4349 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
cea2e8a9 4350 Perl_croak(aTHX_ "Can't undef active subroutine");
11343788 4351#else
a0d0e21e 4352 if (CvDEPTH(cv))
cea2e8a9 4353 Perl_croak(aTHX_ "Can't undef active subroutine");
4d1ff10f 4354#endif /* USE_5005THREADS */
8990e307 4355 ENTER;
a0d0e21e 4356
7766f137 4357 SAVEVPTR(PL_curpad);
3280af22 4358 PL_curpad = 0;
a0d0e21e 4359
282f25c9 4360 op_free(CvROOT(cv));
79072805 4361 CvROOT(cv) = Nullop;
8990e307 4362 LEAVE;
79072805 4363 }
1d5db326 4364 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 4365 CvGV(cv) = Nullgv;
282f25c9
JH		 4366 /* Since closure prototypes have the same lifetime as the containing
4367 * CV, they don't hold a refcount on the outside CV. This avoids
4368 * the refcount loop between the outer CV (which keeps a refcount to
4369 * the closure prototype in the pad entry for pp_anoncode()) and the
afa38808
JH		 4370 * closure prototype, and the ensuing memory leak. --GSAR */
4371 if (!CvANON(cv) || CvCLONED(cv))
e12d8556 4372 SvREFCNT_dec(CvOUTSIDE(cv));
8e07c86e 4373 CvOUTSIDE(cv) = Nullcv;
beab0874
JT		 4374 if (CvCONST(cv)) {
4375 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4376 CvCONST_off(cv);
4377 }
8e07c86e 4378 if (CvPADLIST(cv)) {
8ebc5c01 4379 /* may be during global destruction */
4380 if (SvREFCNT(CvPADLIST(cv))) {
e12d8556
JH		 4381 I32 i = AvFILLp(CvPADLIST(cv));
4382 while (i >= 0) {
4383 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4384 SV* sv = svp ? *svp : Nullsv;
46fc3d4c 4385 if (!sv)
4386 continue;
3280af22
NIS		 4387 if (sv == (SV*)PL_comppad_name)
4388 PL_comppad_name = Nullav;
4389 else if (sv == (SV*)PL_comppad) {
4390 PL_comppad = Nullav;
4391 PL_curpad = Null(SV**);
46fc3d4c 4392 }
4393 SvREFCNT_dec(sv);
8ebc5c01 4394 }
4395 SvREFCNT_dec((SV*)CvPADLIST(cv));
8e07c86e 4396 }
8e07c86e
AD		 4397 CvPADLIST(cv) = Nullav;
4398 }
50762d59
DM		 4399 if (CvXSUB(cv)) {
4400 CvXSUB(cv) = 0;
4401 }
a2c090b3 4402 CvFLAGS(cv) = 0;
79072805
LW		 4403}
4404
9cbac4c7 4405#ifdef DEBUG_CLOSURES
76e3520e 4406STATIC void
743e66e6 4407S_cv_dump(pTHX_ CV *cv)
5f05dabc 4408{
62fde642 4409#ifdef DEBUGGING
5f05dabc 4410 CV *outside = CvOUTSIDE(cv);
4411 AV* padlist = CvPADLIST(cv);
4fdae800 4412 AV* pad_name;
4413 AV* pad;
4414 SV** pname;
4415 SV** ppad;
5f05dabc 4416 I32 ix;
4417
b900a521
JH		 4418 PerlIO_printf(Perl_debug_log,
4419 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4420 PTR2UV(cv),
ab50184a 4421 (CvANON(cv) ? "ANON"
6b88bc9c 4422 : (cv == PL_main_cv) ? "MAIN"
33b8ce05 4423 : CvUNIQUE(cv) ? "UNIQUE"
44a8e56a 4424 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
b900a521 4425 PTR2UV(outside),
ab50184a
CS		 4426 (!outside ? "null"
4427 : CvANON(outside) ? "ANON"
6b88bc9c 4428 : (outside == PL_main_cv) ? "MAIN"
07055b4c 4429 : CvUNIQUE(outside) ? "UNIQUE"
44a8e56a 4430 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
5f05dabc 4431
4fdae800 4432 if (!padlist)
4433 return;
4434
4435 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4436 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4437 pname = AvARRAY(pad_name);
4438 ppad = AvARRAY(pad);
4439
93965878 4440 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
5f05dabc 4441 if (SvPOK(pname[ix]))
b900a521
JH		 4442 PerlIO_printf(Perl_debug_log,
4443 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
894356b3 4444 (int)ix, PTR2UV(ppad[ix]),
4fdae800 4445 SvFAKE(pname[ix]) ? "FAKE " : "",
4446 SvPVX(pname[ix]),
b900a521
JH		 4447 (IV)I_32(SvNVX(pname[ix])),
4448 SvIVX(pname[ix]));
5f05dabc 4449 }
743e66e6 4450#endif /* DEBUGGING */
62fde642 4451}
9cbac4c7 4452#endif /* DEBUG_CLOSURES */
5f05dabc 4453
76e3520e 4454STATIC CV *
cea2e8a9 4455S_cv_clone2(pTHX_ CV *proto, CV *outside)
748a9306
LW		 4456{
4457 AV* av;
4458 I32 ix;
4459 AV* protopadlist = CvPADLIST(proto);
4460 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4461 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
5f05dabc 4462 SV** pname = AvARRAY(protopad_name);
4463 SV** ppad = AvARRAY(protopad);
93965878
NIS		 4464 I32 fname = AvFILLp(protopad_name);
4465 I32 fpad = AvFILLp(protopad);
748a9306
LW		 4466 AV* comppadlist;
4467 CV* cv;
4468
07055b4c
CS		 4469 assert(!CvUNIQUE(proto));
4470
748a9306 4471 ENTER;
354992b1 4472 SAVECOMPPAD();
3280af22
NIS		 4473 SAVESPTR(PL_comppad_name);
4474 SAVESPTR(PL_compcv);
748a9306 4475
3280af22 4476 cv = PL_compcv = (CV*)NEWSV(1104,0);
fa83b5b6 4477 sv_upgrade((SV *)cv, SvTYPE(proto));
a57ec3bd 4478 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
a5f75d66 4479 CvCLONED_on(cv);
748a9306 4480
4d1ff10f 4481#ifdef USE_5005THREADS
12ca11f6 4482 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 4483 MUTEX_INIT(CvMUTEXP(cv));
11343788 4484 CvOWNER(cv) = 0;
4d1ff10f 4485#endif /* USE_5005THREADS */
a636914a
RH		 4486#ifdef USE_ITHREADS
4487 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4488 : savepv(CvFILE(proto));
4489#else
57843af0 4490 CvFILE(cv) = CvFILE(proto);
a636914a 4491#endif
65c50114 4492 CvGV(cv) = CvGV(proto);
748a9306 4493 CvSTASH(cv) = CvSTASH(proto);
282f25c9 4494 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
748a9306 4495 CvSTART(cv) = CvSTART(proto);
5f05dabc 4496 if (outside)
4497 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
748a9306 4498
68dc0745 4499 if (SvPOK(proto))
4500 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4501
3280af22 4502 PL_comppad_name = newAV();
46fc3d4c 4503 for (ix = fname; ix >= 0; ix--)
3280af22 4504 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
748a9306 4505
3280af22 4506 PL_comppad = newAV();
748a9306
LW		 4507
4508 comppadlist = newAV();
4509 AvREAL_off(comppadlist);
3280af22
NIS		 4510 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4511 av_store(comppadlist, 1, (SV*)PL_comppad);
748a9306 4512 CvPADLIST(cv) = comppadlist;
3280af22
NIS		 4513 av_fill(PL_comppad, AvFILLp(protopad));
4514 PL_curpad = AvARRAY(PL_comppad);
748a9306
LW		 4515
4516 av = newAV(); /* will be @_ */
4517 av_extend(av, 0);
3280af22 4518 av_store(PL_comppad, 0, (SV*)av);
748a9306
LW		 4519 AvFLAGS(av) = AVf_REIFY;
4520
9607fc9c 4521 for (ix = fpad; ix > 0; ix--) {
4522 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
3280af22 4523 if (namesv && namesv != &PL_sv_undef) {
aa689395 4524 char *name = SvPVX(namesv); /* XXX */
4525 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4526 I32 off = pad_findlex(name, ix, SvIVX(namesv),
2680586e 4527 CvOUTSIDE(cv), cxstack_ix, 0, 0);
5f05dabc 4528 if (!off)
3280af22 4529 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
5f05dabc 4530 else if (off != ix)
cea2e8a9 4531 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
748a9306
LW		 4532 }
4533 else { /* our own lexical */
aa689395 4534 SV* sv;
5f05dabc 4535 if (*name == '&') {
4536 /* anon code -- we'll come back for it */
4537 sv = SvREFCNT_inc(ppad[ix]);
4538 }
4539 else if (*name == '@')
4540 sv = (SV*)newAV();
748a9306 4541 else if (*name == '%')
5f05dabc 4542 sv = (SV*)newHV();
748a9306 4543 else
5f05dabc 4544 sv = NEWSV(0,0);
4545 if (!SvPADBUSY(sv))
4546 SvPADMY_on(sv);
3280af22 4547 PL_curpad[ix] = sv;
748a9306
LW		 4548 }
4549 }
7766f137 4550 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
743e66e6
GS		 4551 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4552 }
748a9306 4553 else {
aa689395 4554 SV* sv = NEWSV(0,0);
748a9306 4555 SvPADTMP_on(sv);
3280af22 4556 PL_curpad[ix] = sv;
748a9306
LW		 4557 }
4558 }
4559
5f05dabc 4560 /* Now that vars are all in place, clone nested closures. */
4561
9607fc9c 4562 for (ix = fpad; ix > 0; ix--) {
4563 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
aa689395 4564 if (namesv
3280af22 4565 && namesv != &PL_sv_undef
aa689395 4566 && !(SvFLAGS(namesv) & SVf_FAKE)
4567 && *SvPVX(namesv) == '&'
5f05dabc 4568 && CvCLONE(ppad[ix]))
4569 {
4570 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4571 SvREFCNT_dec(ppad[ix]);
4572 CvCLONE_on(kid);
4573 SvPADMY_on(kid);
3280af22 4574 PL_curpad[ix] = (SV*)kid;
748a9306
LW		 4575 }
4576 }
4577
5f05dabc 4578#ifdef DEBUG_CLOSURES
ab50184a
CS		 4579 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4580 cv_dump(outside);
4581 PerlIO_printf(Perl_debug_log, " from:\n");
5f05dabc 4582 cv_dump(proto);
ab50184a 4583 PerlIO_printf(Perl_debug_log, " to:\n");
5f05dabc 4584 cv_dump(cv);
4585#endif
4586
748a9306 4587 LEAVE;
beab0874
JT		 4588
4589 if (CvCONST(cv)) {
4590 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4591 assert(const_sv);
4592 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4593 SvREFCNT_dec(cv);
4594 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4595 }
4596
748a9306
LW		 4597 return cv;
4598}
4599
4600CV *
864dbfa3 4601Perl_cv_clone(pTHX_ CV *proto)
5f05dabc 4602{
b099ddc0 4603 CV *cv;
1feb2720 4604 LOCK_CRED_MUTEX; /* XXX create separate mutex */
b099ddc0 4605 cv = cv_clone2(proto, CvOUTSIDE(proto));
1feb2720 4606 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
b099ddc0 4607 return cv;
5f05dabc 4608}
4609
3fe9a6f1 4610void
864dbfa3 4611Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 4612{
e476b1b5 4613 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 4614 SV* msg = sv_newmortal();
3fe9a6f1 4615 SV* name = Nullsv;
4616
4617 if (gv)
46fc3d4c 4618 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4619 sv_setpv(msg, "Prototype mismatch:");
4620 if (name)
894356b3 4621 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 4622 if (SvPOK(cv))
cea2e8a9 4623 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
46fc3d4c 4624 sv_catpv(msg, " vs ");
4625 if (p)
cea2e8a9 4626 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 4627 else
4628 sv_catpv(msg, "none");
e476b1b5 4629 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
3fe9a6f1 4630 }
4631}
4632
acfe0abc 4633static void const_sv_xsub(pTHX_ CV* cv);
beab0874
JT		 4634
4635/*
ccfc67b7
JH		 4636
4637=head1 Optree Manipulation Functions
4638
beab0874
JT		 4639=for apidoc cv_const_sv
4640
4641If C<cv> is a constant sub eligible for inlining. returns the constant
4642value returned by the sub. Otherwise, returns NULL.
4643
4644Constant subs can be created with C<newCONSTSUB> or as described in
4645L<perlsub/"Constant Functions">.
4646
4647=cut
4648*/
760ac839 4649SV *
864dbfa3 4650Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 4651{
beab0874 4652 if (!cv || !CvCONST(cv))
54310121 4653 return Nullsv;
beab0874 4654 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 4655}
760ac839 4656
fe5e78ed 4657SV *
864dbfa3 4658Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 4659{
4660 SV *sv = Nullsv;
4661
0f79a09d 4662 if (!o)
fe5e78ed 4663 return Nullsv;
1c846c1f
NIS		 4664
4665 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 4666 o = cLISTOPo->op_first->op_sibling;
4667
4668 for (; o; o = o->op_next) {
54310121 4669 OPCODE type = o->op_type;
fe5e78ed 4670
1c846c1f 4671 if (sv && o->op_next == o)
fe5e78ed 4672 return sv;
e576b457
JT		 4673 if (o->op_next != o) {
4674 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4675 continue;
4676 if (type == OP_DBSTATE)
4677 continue;
4678 }
54310121 4679 if (type == OP_LEAVESUB || type == OP_RETURN)
4680 break;
4681 if (sv)
4682 return Nullsv;
7766f137 4683 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 4684 sv = cSVOPo->op_sv;
7766f137 4685 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
e858de61
MB		 4686 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4687 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
beab0874
JT		 4688 if (!sv)
4689 return Nullsv;
4690 if (CvCONST(cv)) {
4691 /* We get here only from cv_clone2() while creating a closure.
4692 Copy the const value here instead of in cv_clone2 so that
4693 SvREADONLY_on doesn't lead to problems when leaving
4694 scope.
4695 */
4696 sv = newSVsv(sv);
4697 }
4698 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
54310121 4699 return Nullsv;
760ac839 4700 }
54310121 4701 else
4702 return Nullsv;
760ac839 4703 }
5aabfad6 4704 if (sv)
4705 SvREADONLY_on(sv);
760ac839
LW		 4706 return sv;
4707}
4708
09bef843
SB		 4709void
4710Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4711{
4712 if (o)
4713 SAVEFREEOP(o);
4714 if (proto)
4715 SAVEFREEOP(proto);
4716 if (attrs)
4717 SAVEFREEOP(attrs);
4718 if (block)
4719 SAVEFREEOP(block);
4720 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4721}
4722
748a9306 4723CV *
864dbfa3 4724Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 4725{
09bef843
SB		 4726 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4727}
4728
4729CV *
4730Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4731{
2d8e6c8d 4732 STRLEN n_a;
83ee9e09
GS		 4733 char *name;
4734 char *aname;
4735 GV *gv;
2d8e6c8d 4736 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 4737 register CV *cv=0;
a0d0e21e 4738 I32 ix;
beab0874 4739 SV *const_sv;
79072805 4740
83ee9e09
GS		 4741 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4742 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4743 SV *sv = sv_newmortal();
4744 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4745 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4746 aname = SvPVX(sv);
4747 }
4748 else
4749 aname = Nullch;
4750 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4751 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4752 SVt_PVCV);
4753
11343788 4754 if (o)
5dc0d613 4755 SAVEFREEOP(o);
3fe9a6f1 4756 if (proto)
4757 SAVEFREEOP(proto);
09bef843
SB		 4758 if (attrs)
4759 SAVEFREEOP(attrs);
3fe9a6f1 4760
09bef843 4761 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4762 maximum a prototype before. */
4763 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4764 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4765 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4766 {
e476b1b5 4767 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
f248d071 4768 }
55d729e4
GS		 4769 cv_ckproto((CV*)gv, NULL, ps);
4770 }
4771 if (ps)
4772 sv_setpv((SV*)gv, ps);
4773 else
4774 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4775 SvREFCNT_dec(PL_compcv);
4776 cv = PL_compcv = NULL;
4777 PL_sub_generation++;
beab0874 4778 goto done;
55d729e4
GS		 4779 }
4780
beab0874
JT		 4781 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4782
7fb37951
AMS		 4783#ifdef GV_UNIQUE_CHECK
4784 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4785 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4786 }
4787#endif
4788
beab0874
JT		 4789 if (!block || !ps || *ps || attrs)
4790 const_sv = Nullsv;
4791 else
4792 const_sv = op_const_sv(block, Nullcv);
4793
4794 if (cv) {
60ed1d8c 4795 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4796
7fb37951
AMS		 4797#ifdef GV_UNIQUE_CHECK
4798 if (exists && GvUNIQUE(gv)) {
4799 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4800 }
4801#endif
4802
60ed1d8c
GS		 4803 /* if the subroutine doesn't exist and wasn't pre-declared
4804 * with a prototype, assume it will be AUTOLOADed,
4805 * skipping the prototype check
4806 */
4807 if (exists || SvPOK(cv))
01ec43d0 4808 cv_ckproto(cv, gv, ps);
68dc0745 4809 /* already defined (or promised)? */
60ed1d8c 4810 if (exists || GvASSUMECV(gv)) {
09bef843 4811 if (!block && !attrs) {
aa689395 4812 /* just a "sub foo;" when &foo is already defined */
3280af22 4813 SAVEFREESV(PL_compcv);
aa689395 4814 goto done;
4815 }
7bac28a0 4816 /* ahem, death to those who redefine active sort subs */
3280af22 4817 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4818 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4819 if (block) {
4820 if (ckWARN(WARN_REDEFINE)
4821 || (CvCONST(cv)
4822 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4823 {
4824 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4825 if (PL_copline != NOLINE)
4826 CopLINE_set(PL_curcop, PL_copline);
beab0874
JT		 4827 Perl_warner(aTHX_ WARN_REDEFINE,
4828 CvCONST(cv) ? "Constant subroutine %s redefined"
4829 : "Subroutine %s redefined", name);
4830 CopLINE_set(PL_curcop, oldline);
4831 }
4832 SvREFCNT_dec(cv);
4833 cv = Nullcv;
79072805 4834 }
79072805
LW		 4835 }
4836 }
beab0874
JT		 4837 if (const_sv) {
4838 SvREFCNT_inc(const_sv);
4839 if (cv) {
0768512c 4840 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4841 sv_setpv((SV*)cv, ""); /* prototype is "" */
4842 CvXSUBANY(cv).any_ptr = const_sv;
4843 CvXSUB(cv) = const_sv_xsub;
4844 CvCONST_on(cv);
beab0874
JT		 4845 }
4846 else {
4847 GvCV(gv) = Nullcv;
4848 cv = newCONSTSUB(NULL, name, const_sv);
4849 }
4850 op_free(block);
4851 SvREFCNT_dec(PL_compcv);
4852 PL_compcv = NULL;
4853 PL_sub_generation++;
4854 goto done;
4855 }
09bef843
SB		 4856 if (attrs) {
4857 HV *stash;
4858 SV *rcv;
4859
4860 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4861 * before we clobber PL_compcv.
4862 */
4863 if (cv && !block) {
4864 rcv = (SV*)cv;
a9164de8 4865 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4866 stash = GvSTASH(CvGV(cv));
a9164de8 4867 else if (CvSTASH(cv))
09bef843
SB		 4868 stash = CvSTASH(cv);
4869 else
4870 stash = PL_curstash;
4871 }
4872 else {
4873 /* possibly about to re-define existing subr -- ignore old cv */
4874 rcv = (SV*)PL_compcv;
a9164de8 4875 if (name && GvSTASH(gv))
09bef843
SB		 4876 stash = GvSTASH(gv);
4877 else
4878 stash = PL_curstash;
4879 }
95f0a2f1 4880 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4881 }
a0d0e21e 4882 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4883 if (!block) {
4884 /* got here with just attrs -- work done, so bug out */
4885 SAVEFREESV(PL_compcv);
4886 goto done;
4887 }
4633a7c4 4888 cv_undef(cv);
3280af22
NIS		 4889 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4890 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4891 CvOUTSIDE(PL_compcv) = 0;
4892 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4893 CvPADLIST(PL_compcv) = 0;
282f25c9
JH		 4894 /* inner references to PL_compcv must be fixed up ... */
4895 {
4896 AV *padlist = CvPADLIST(cv);
4897 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4898 AV *comppad = (AV*)AvARRAY(padlist)[1];
4899 SV **namepad = AvARRAY(comppad_name);
4900 SV **curpad = AvARRAY(comppad);
4901 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4902 SV *namesv = namepad[ix];
4903 if (namesv && namesv != &PL_sv_undef
4904 && *SvPVX(namesv) == '&')
4905 {
4906 CV *innercv = (CV*)curpad[ix];
4907 if (CvOUTSIDE(innercv) == PL_compcv) {
4908 CvOUTSIDE(innercv) = cv;
4909 if (!CvANON(innercv) || CvCLONED(innercv)) {
4910 (void)SvREFCNT_inc(cv);
4911 SvREFCNT_dec(PL_compcv);
4912 }
4913 }
4914 }
4915 }
4916 }
4917 /* ... before we throw it away */
3280af22 4918 SvREFCNT_dec(PL_compcv);
a933f601
IZ		 4919 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4920 ++PL_sub_generation;
a0d0e21e
LW		 4921 }
4922 else {
3280af22 4923 cv = PL_compcv;
44a8e56a 4924 if (name) {
4925 GvCV(gv) = cv;
4926 GvCVGEN(gv) = 0;
3280af22 4927 PL_sub_generation++;
44a8e56a 4928 }
a0d0e21e 4929 }
65c50114 4930 CvGV(cv) = gv;
a636914a 4931 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4932 CvSTASH(cv) = PL_curstash;
4d1ff10f 4933#ifdef USE_5005THREADS
11343788 4934 CvOWNER(cv) = 0;
1cfa4ec7 4935 if (!CvMUTEXP(cv)) {
f6aaf501 4936 New(666, CvMUTEXP(cv), 1, perl_mutex);
1cfa4ec7
GS		 4937 MUTEX_INIT(CvMUTEXP(cv));
4938 }
4d1ff10f 4939#endif /* USE_5005THREADS */
8990e307 4940
3fe9a6f1 4941 if (ps)
4942 sv_setpv((SV*)cv, ps);
4633a7c4 4943
3280af22 4944 if (PL_error_count) {
c07a80fd 4945 op_free(block);
4946 block = Nullop;
68dc0745 4947 if (name) {
4948 char *s = strrchr(name, ':');
4949 s = s ? s+1 : name;
6d4c2119
CS		 4950 if (strEQ(s, "BEGIN")) {
4951 char *not_safe =
4952 "BEGIN not safe after errors--compilation aborted";
faef0170 4953 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4954 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4955 else {
4956 /* force display of errors found but not reported */
38a03e6e 4957 sv_catpv(ERRSV, not_safe);
cea2e8a9 4958 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
6d4c2119
CS		 4959 }
4960 }
68dc0745 4961 }
c07a80fd 4962 }
beab0874
JT		 4963 if (!block)
4964 goto done;
a0d0e21e 4965
3280af22
NIS		 4966 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4967 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
a0d0e21e 4968
7766f137 4969 if (CvLVALUE(cv)) {
78f9721b
SM		 4970 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4971 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4972 }
4973 else {
4974 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4975 }
4976 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4977 OpREFCNT_set(CvROOT(cv), 1);
4978 CvSTART(cv) = LINKLIST(CvROOT(cv));
4979 CvROOT(cv)->op_next = 0;
a2efc822 4980 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4981
4982 /* now that optimizer has done its work, adjust pad values */
54310121 4983 if (CvCLONE(cv)) {
3280af22
NIS		 4984 SV **namep = AvARRAY(PL_comppad_name);
4985 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
54310121 4986 SV *namesv;
4987
7766f137 4988 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
54310121 4989 continue;
4990 /*
4991 * The only things that a clonable function needs in its
4992 * pad are references to outer lexicals and anonymous subs.
4993 * The rest are created anew during cloning.
4994 */
4995 if (!((namesv = namep[ix]) != Nullsv &&
3280af22 4996 namesv != &PL_sv_undef &&
54310121 4997 (SvFAKE(namesv) ||
4998 *SvPVX(namesv) == '&')))
4999 {
3280af22
NIS		 5000 SvREFCNT_dec(PL_curpad[ix]);
5001 PL_curpad[ix] = Nullsv;
54310121 5002 }
5003 }
beab0874
JT		 5004 assert(!CvCONST(cv));
5005 if (ps && !*ps && op_const_sv(block, cv))
5006 CvCONST_on(cv);
a0d0e21e 5007 }
54310121 5008 else {
5009 AV *av = newAV(); /* Will be @_ */
5010 av_extend(av, 0);
3280af22 5011 av_store(PL_comppad, 0, (SV*)av);
54310121 5012 AvFLAGS(av) = AVf_REIFY;
79072805 5013
3280af22 5014 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
7766f137 5015 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
54310121 5016 continue;
3280af22
NIS		 5017 if (!SvPADMY(PL_curpad[ix]))
5018 SvPADTMP_on(PL_curpad[ix]);
54310121 5019 }
5020 }
79072805 5021
afa38808 5022 /* If a potential closure prototype, don't keep a refcount on outer CV.
282f25c9
JH		 5023 * This is okay as the lifetime of the prototype is tied to the
5024 * lifetime of the outer CV. Avoids memory leak due to reference
5025 * loop. --GSAR */
afa38808 5026 if (!name)
282f25c9
JH		 5027 SvREFCNT_dec(CvOUTSIDE(cv));
5028
83ee9e09 5029 if (name || aname) {
44a8e56a 5030 char *s;
83ee9e09 5031 char *tname = (name ? name : aname);
44a8e56a 5032
3280af22 5033 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 5034 SV *sv = NEWSV(0,0);
44a8e56a 5035 SV *tmpstr = sv_newmortal();
549bb64a 5036 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 5037 CV *pcv;
44a8e56a 5038 HV *hv;
5039
ed094faf
GS		 5040 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5041 CopFILE(PL_curcop),
cc49e20b 5042 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 5043 gv_efullname3(tmpstr, gv, Nullch);
3280af22 5044 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 5045 hv = GvHVn(db_postponed);
9607fc9c 5046 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 5047 && (pcv = GvCV(db_postponed)))
5048 {
44a8e56a 5049 dSP;
924508f0 5050 PUSHMARK(SP);
44a8e56a 5051 XPUSHs(tmpstr);
5052 PUTBACK;
83ee9e09 5053 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 5054 }
5055 }
79072805 5056
83ee9e09 5057 if ((s = strrchr(tname,':')))
28757baa 5058 s++;
5059 else
83ee9e09 5060 s = tname;
ed094faf 5061
7d30b5c4 5062 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 5063 goto done;
5064
68dc0745 5065 if (strEQ(s, "BEGIN")) {
3280af22 5066 I32 oldscope = PL_scopestack_ix;
28757baa 5067 ENTER;
57843af0
GS		 5068 SAVECOPFILE(&PL_compiling);
5069 SAVECOPLINE(&PL_compiling);
28757baa 5070
3280af22
NIS		 5071 if (!PL_beginav)
5072 PL_beginav = newAV();
28757baa 5073 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 5074 av_push(PL_beginav, (SV*)cv);
5075 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 5076 call_list(oldscope, PL_beginav);
a6006777 5077
3280af22 5078 PL_curcop = &PL_compiling;
a0ed51b3 5079 PL_compiling.op_private = PL_hints;
28757baa 5080 LEAVE;
5081 }
3280af22
NIS		 5082 else if (strEQ(s, "END") && !PL_error_count) {
5083 if (!PL_endav)
5084 PL_endav = newAV();
ed094faf 5085 DEBUG_x( dump_sub(gv) );
3280af22 5086 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5087 av_store(PL_endav, 0, (SV*)cv);
5088 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5089 }
7d30b5c4
GS		 5090 else if (strEQ(s, "CHECK") && !PL_error_count) {
5091 if (!PL_checkav)
5092 PL_checkav = newAV();
ed094faf 5093 DEBUG_x( dump_sub(gv) );
ddda08b7
GS		 5094 if (PL_main_start && ckWARN(WARN_VOID))
5095 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
7d30b5c4 5096 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5097 av_store(PL_checkav, 0, (SV*)cv);
5098 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5099 }
3280af22
NIS		 5100 else if (strEQ(s, "INIT") && !PL_error_count) {
5101 if (!PL_initav)
5102 PL_initav = newAV();
ed094faf 5103 DEBUG_x( dump_sub(gv) );
ddda08b7
GS		 5104 if (PL_main_start && ckWARN(WARN_VOID))
5105 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
ea2f84a3
GS		 5106 av_push(PL_initav, (SV*)cv);
5107 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5108 }
79072805 5109 }
a6006777 5110
aa689395 5111 done:
3280af22 5112 PL_copline = NOLINE;
8990e307 5113 LEAVE_SCOPE(floor);
a0d0e21e 5114 return cv;
79072805
LW		 5115}
5116
b099ddc0 5117/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 5118/*
5119=for apidoc newCONSTSUB
5120
5121Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5122eligible for inlining at compile-time.
5123
5124=cut
5125*/
5126
beab0874 5127CV *
864dbfa3 5128Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 5129{
beab0874 5130 CV* cv;
5476c433 5131
11faa288 5132 ENTER;
11faa288 5133
f4dd75d9 5134 SAVECOPLINE(PL_curcop);
11faa288 5135 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 5136
5137 SAVEHINTS();
3280af22 5138 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 5139
5140 if (stash) {
5141 SAVESPTR(PL_curstash);
5142 SAVECOPSTASH(PL_curcop);
5143 PL_curstash = stash;
5144#ifdef USE_ITHREADS
5145 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5146#else
5147 CopSTASH(PL_curcop) = stash;
5148#endif
5149 }
5476c433 5150
beab0874
JT		 5151 cv = newXS(name, const_sv_xsub, __FILE__);
5152 CvXSUBANY(cv).any_ptr = sv;
5153 CvCONST_on(cv);
5154 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 5155
11faa288 5156 LEAVE;
beab0874
JT		 5157
5158 return cv;
5476c433
JD		 5159}
5160
954c1994
GS		 5161/*
5162=for apidoc U||newXS
5163
5164Used by C<xsubpp> to hook up XSUBs as Perl subs.
5165
5166=cut
5167*/
5168
57d3b86d 5169CV *
864dbfa3 5170Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 5171{
44a8e56a 5172 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
79072805 5173 register CV *cv;
44a8e56a 5174
155aba94 5175 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 5176 if (GvCVGEN(gv)) {
5177 /* just a cached method */
5178 SvREFCNT_dec(cv);
5179 cv = 0;
5180 }
5181 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5182 /* already defined (or promised) */
599cee73 5183 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4 5184 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 5185 line_t oldline = CopLINE(PL_curcop);
51f6edd3 5186 if (PL_copline != NOLINE)
57843af0 5187 CopLINE_set(PL_curcop, PL_copline);
beab0874
JT		 5188 Perl_warner(aTHX_ WARN_REDEFINE,
5189 CvCONST(cv) ? "Constant subroutine %s redefined"
5190 : "Subroutine %s redefined"
5191 ,name);
57843af0 5192 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 5193 }
5194 SvREFCNT_dec(cv);
5195 cv = 0;
79072805 5196 }
79072805 5197 }
44a8e56a 5198
5199 if (cv) /* must reuse cv if autoloaded */
5200 cv_undef(cv);
a0d0e21e
LW		 5201 else {
5202 cv = (CV*)NEWSV(1105,0);
5203 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 5204 if (name) {
5205 GvCV(gv) = cv;
5206 GvCVGEN(gv) = 0;
3280af22 5207 PL_sub_generation++;
44a8e56a 5208 }
a0d0e21e 5209 }
65c50114 5210 CvGV(cv) = gv;
4d1ff10f 5211#ifdef USE_5005THREADS
12ca11f6 5212 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 5213 MUTEX_INIT(CvMUTEXP(cv));
11343788 5214 CvOWNER(cv) = 0;
4d1ff10f 5215#endif /* USE_5005THREADS */
b195d487 5216 (void)gv_fetchfile(filename);
57843af0
GS		 5217 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5218 an external constant string */
a0d0e21e 5219 CvXSUB(cv) = subaddr;
44a8e56a 5220
28757baa 5221 if (name) {
5222 char *s = strrchr(name,':');
5223 if (s)
5224 s++;
5225 else
5226 s = name;
ed094faf 5227
7d30b5c4 5228 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 5229 goto done;
5230
28757baa 5231 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 5232 if (!PL_beginav)
5233 PL_beginav = newAV();
ea2f84a3
GS		 5234 av_push(PL_beginav, (SV*)cv);
5235 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5236 }
5237 else if (strEQ(s, "END")) {
3280af22
NIS		 5238 if (!PL_endav)
5239 PL_endav = newAV();
5240 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5241 av_store(PL_endav, 0, (SV*)cv);
5242 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5243 }
7d30b5c4
GS		 5244 else if (strEQ(s, "CHECK")) {
5245 if (!PL_checkav)
5246 PL_checkav = newAV();
ddda08b7
GS		 5247 if (PL_main_start && ckWARN(WARN_VOID))
5248 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
7d30b5c4 5249 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5250 av_store(PL_checkav, 0, (SV*)cv);
5251 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5252 }
7d07dbc2 5253 else if (strEQ(s, "INIT")) {
3280af22
NIS		 5254 if (!PL_initav)
5255 PL_initav = newAV();
ddda08b7
GS		 5256 if (PL_main_start && ckWARN(WARN_VOID))
5257 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
ea2f84a3
GS		 5258 av_push(PL_initav, (SV*)cv);
5259 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5260 }
28757baa 5261 }
8990e307 5262 else
a5f75d66 5263 CvANON_on(cv);
44a8e56a 5264
ed094faf 5265done:
a0d0e21e 5266 return cv;
79072805
LW		 5267}
5268
5269void
864dbfa3 5270Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 5271{
5272 register CV *cv;
5273 char *name;
5274 GV *gv;
a0d0e21e 5275 I32 ix;
2d8e6c8d 5276 STRLEN n_a;
79072805 5277
11343788 5278 if (o)
2d8e6c8d 5279 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 5280 else
5281 name = "STDOUT";
85e6fe83 5282 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
7fb37951
AMS		 5283#ifdef GV_UNIQUE_CHECK
5284 if (GvUNIQUE(gv)) {
5285 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 5286 }
5287#endif
a5f75d66 5288 GvMULTI_on(gv);
155aba94 5289 if ((cv = GvFORM(gv))) {
599cee73 5290 if (ckWARN(WARN_REDEFINE)) {
57843af0 5291 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 5292 if (PL_copline != NOLINE)
5293 CopLINE_set(PL_curcop, PL_copline);
cea2e8a9 5294 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
57843af0 5295 CopLINE_set(PL_curcop, oldline);
79072805 5296 }
8990e307 5297 SvREFCNT_dec(cv);
79072805 5298 }
3280af22 5299 cv = PL_compcv;
79072805 5300 GvFORM(gv) = cv;
65c50114 5301 CvGV(cv) = gv;
a636914a 5302 CvFILE_set_from_cop(cv, PL_curcop);
79072805 5303
3280af22
NIS		 5304 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5305 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5306 SvPADTMP_on(PL_curpad[ix]);
a0d0e21e
LW		 5307 }
5308
79072805 5309 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5310 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5311 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5312 CvSTART(cv) = LINKLIST(CvROOT(cv));
5313 CvROOT(cv)->op_next = 0;
a2efc822 5314 CALL_PEEP(CvSTART(cv));
11343788 5315 op_free(o);
3280af22 5316 PL_copline = NOLINE;
8990e307 5317 LEAVE_SCOPE(floor);
79072805
LW		 5318}
5319
5320OP *
864dbfa3 5321Perl_newANONLIST(pTHX_ OP *o)
79072805 5322{
93a17b20 5323 return newUNOP(OP_REFGEN, 0,
11343788 5324 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 5325}
5326
5327OP *
864dbfa3 5328Perl_newANONHASH(pTHX_ OP *o)
79072805 5329{
93a17b20 5330 return newUNOP(OP_REFGEN, 0,
11343788 5331 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 5332}
5333
5334OP *
864dbfa3 5335Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5336{
09bef843
SB		 5337 return newANONATTRSUB(floor, proto, Nullop, block);
5338}
5339
5340OP *
5341Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5342{
a0d0e21e 5343 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5344 newSVOP(OP_ANONCODE, 0,
5345 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5346}
5347
5348OP *
864dbfa3 5349Perl_oopsAV(pTHX_ OP *o)
79072805 5350{
ed6116ce
LW		 5351 switch (o->op_type) {
5352 case OP_PADSV:
5353 o->op_type = OP_PADAV;
22c35a8c 5354 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5355 return ref(o, OP_RV2AV);
ed6116ce
LW		 5356
5357 case OP_RV2SV:
79072805 5358 o->op_type = OP_RV2AV;
22c35a8c 5359 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 5360 ref(o, OP_RV2AV);
ed6116ce
LW		 5361 break;
5362
5363 default:
0453d815
PM		 5364 if (ckWARN_d(WARN_INTERNAL))
5365 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
ed6116ce
LW		 5366 break;
5367 }
79072805
LW		 5368 return o;
5369}
5370
5371OP *
864dbfa3 5372Perl_oopsHV(pTHX_ OP *o)
79072805 5373{
ed6116ce
LW		 5374 switch (o->op_type) {
5375 case OP_PADSV:
5376 case OP_PADAV:
5377 o->op_type = OP_PADHV;
22c35a8c 5378 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5379 return ref(o, OP_RV2HV);
ed6116ce
LW		 5380
5381 case OP_RV2SV:
5382 case OP_RV2AV:
79072805 5383 o->op_type = OP_RV2HV;
22c35a8c 5384 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5385 ref(o, OP_RV2HV);
ed6116ce
LW		 5386 break;
5387
5388 default:
0453d815
PM		 5389 if (ckWARN_d(WARN_INTERNAL))
5390 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
ed6116ce
LW		 5391 break;
5392 }
79072805
LW		 5393 return o;
5394}
5395
5396OP *
864dbfa3 5397Perl_newAVREF(pTHX_ OP *o)
79072805 5398{
ed6116ce
LW		 5399 if (o->op_type == OP_PADANY) {
5400 o->op_type = OP_PADAV;
22c35a8c 5401 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5402 return o;
ed6116ce 5403 }
a1063b2d
RH		 5404 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5405 && ckWARN(WARN_DEPRECATED)) {
5406 Perl_warner(aTHX_ WARN_DEPRECATED,
5407 "Using an array as a reference is deprecated");
5408 }
79072805
LW		 5409 return newUNOP(OP_RV2AV, 0, scalar(o));
5410}
5411
5412OP *
864dbfa3 5413Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 5414{
82092f1d 5415 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 5416 return newUNOP(OP_NULL, 0, o);
748a9306 5417 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 5418}
5419
5420OP *
864dbfa3 5421Perl_newHVREF(pTHX_ OP *o)
79072805 5422{
ed6116ce
LW		 5423 if (o->op_type == OP_PADANY) {
5424 o->op_type = OP_PADHV;
22c35a8c 5425 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 5426 return o;
ed6116ce 5427 }
a1063b2d
RH		 5428 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5429 && ckWARN(WARN_DEPRECATED)) {
5430 Perl_warner(aTHX_ WARN_DEPRECATED,
5431 "Using a hash as a reference is deprecated");
5432 }
79072805
LW		 5433 return newUNOP(OP_RV2HV, 0, scalar(o));
5434}
5435
5436OP *
864dbfa3 5437Perl_oopsCV(pTHX_ OP *o)
79072805 5438{
cea2e8a9 5439 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 5440 /* STUB */
5441 return o;
5442}
5443
5444OP *
864dbfa3 5445Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 5446{
c07a80fd 5447 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 5448}
5449
5450OP *
864dbfa3 5451Perl_newSVREF(pTHX_ OP *o)
79072805 5452{
ed6116ce
LW		 5453 if (o->op_type == OP_PADANY) {
5454 o->op_type = OP_PADSV;
22c35a8c 5455 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 5456 return o;
ed6116ce 5457 }
224a4551
MB		 5458 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5459 o->op_flags |= OPpDONE_SVREF;
a863c7d1 5460 return o;
224a4551 5461 }
79072805
LW		 5462 return newUNOP(OP_RV2SV, 0, scalar(o));
5463}
5464
5465/* Check routines. */
5466
5467OP *
cea2e8a9 5468Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 5469{
178c6305
CS		 5470 PADOFFSET ix;
5471 SV* name;
5472
5473 name = NEWSV(1106,0);
5474 sv_upgrade(name, SVt_PVNV);
5475 sv_setpvn(name, "&", 1);
5476 SvIVX(name) = -1;
5477 SvNVX(name) = 1;
5dc0d613 5478 ix = pad_alloc(o->op_type, SVs_PADMY);
3280af22
NIS		 5479 av_store(PL_comppad_name, ix, name);
5480 av_store(PL_comppad, ix, cSVOPo->op_sv);
5dc0d613
MB		 5481 SvPADMY_on(cSVOPo->op_sv);
5482 cSVOPo->op_sv = Nullsv;
5483 cSVOPo->op_targ = ix;
5484 return o;
5f05dabc 5485}
5486
5487OP *
cea2e8a9 5488Perl_ck_bitop(pTHX_ OP *o)
55497cff 5489{
3280af22 5490 o->op_private = PL_hints;
5dc0d613 5491 return o;
55497cff 5492}
5493
5494OP *
cea2e8a9 5495Perl_ck_concat(pTHX_ OP *o)
79072805 5496{
11343788
MB		 5497 if (cUNOPo->op_first->op_type == OP_CONCAT)
5498 o->op_flags |= OPf_STACKED;
5499 return o;
79072805
LW		 5500}
5501
5502OP *
cea2e8a9 5503Perl_ck_spair(pTHX_ OP *o)
79072805 5504{
11343788 5505 if (o->op_flags & OPf_KIDS) {
79072805 5506 OP* newop;
a0d0e21e 5507 OP* kid;
5dc0d613
MB		 5508 OPCODE type = o->op_type;
5509 o = modkids(ck_fun(o), type);
11343788 5510 kid = cUNOPo->op_first;
a0d0e21e
LW		 5511 newop = kUNOP->op_first->op_sibling;
5512 if (newop &&
5513 (newop->op_sibling ||
22c35a8c 5514 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 5515 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5516 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
aeea060c 5517
11343788 5518 return o;
a0d0e21e
LW		 5519 }
5520 op_free(kUNOP->op_first);
5521 kUNOP->op_first = newop;
5522 }
22c35a8c 5523 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5524 return ck_fun(o);
a0d0e21e
LW		 5525}
5526
5527OP *
cea2e8a9 5528Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5529{
11343788 5530 o = ck_fun(o);
5dc0d613 5531 o->op_private = 0;
11343788
MB		 5532 if (o->op_flags & OPf_KIDS) {
5533 OP *kid = cUNOPo->op_first;
01020589
GS		 5534 switch (kid->op_type) {
5535 case OP_ASLICE:
5536 o->op_flags |= OPf_SPECIAL;
5537 /* FALL THROUGH */
5538 case OP_HSLICE:
5dc0d613 5539 o->op_private |= OPpSLICE;
01020589
GS		 5540 break;
5541 case OP_AELEM:
5542 o->op_flags |= OPf_SPECIAL;
5543 /* FALL THROUGH */
5544 case OP_HELEM:
5545 break;
5546 default:
5547 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 5548 OP_DESC(o));
01020589 5549 }
93c66552 5550 op_null(kid);
79072805 5551 }
11343788 5552 return o;
79072805
LW		 5553}
5554
5555OP *
96e176bf
CL		 5556Perl_ck_die(pTHX_ OP *o)
5557{
5558#ifdef VMS
5559 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5560#endif
5561 return ck_fun(o);
5562}
5563
5564OP *
cea2e8a9 5565Perl_ck_eof(pTHX_ OP *o)
79072805 5566{
11343788 5567 I32 type = o->op_type;
79072805 5568
11343788
MB		 5569 if (o->op_flags & OPf_KIDS) {
5570 if (cLISTOPo->op_first->op_type == OP_STUB) {
5571 op_free(o);
5572 o = newUNOP(type, OPf_SPECIAL,
d58bf5aa 5573 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
8990e307 5574 }
11343788 5575 return ck_fun(o);
79072805 5576 }
11343788 5577 return o;
79072805
LW		 5578}
5579
5580OP *
cea2e8a9 5581Perl_ck_eval(pTHX_ OP *o)
79072805 5582{
3280af22 5583 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 5584 if (o->op_flags & OPf_KIDS) {
5585 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 5586
93a17b20 5587 if (!kid) {
11343788 5588 o->op_flags &= ~OPf_KIDS;
93c66552 5589 op_null(o);
79072805
LW		 5590 }
5591 else if (kid->op_type == OP_LINESEQ) {
5592 LOGOP *enter;
5593
11343788
MB		 5594 kid->op_next = o->op_next;
5595 cUNOPo->op_first = 0;
5596 op_free(o);
79072805 5597
b7dc083c 5598 NewOp(1101, enter, 1, LOGOP);
79072805 5599 enter->op_type = OP_ENTERTRY;
22c35a8c 5600 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 5601 enter->op_private = 0;
5602
5603 /* establish postfix order */
5604 enter->op_next = (OP*)enter;
5605
11343788
MB		 5606 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5607 o->op_type = OP_LEAVETRY;
22c35a8c 5608 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 5609 enter->op_other = o;
5610 return o;
79072805 5611 }
c7cc6f1c 5612 else
473986ff 5613 scalar((OP*)kid);
79072805
LW		 5614 }
5615 else {
11343788 5616 op_free(o);
54b9620d 5617 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 5618 }
3280af22 5619 o->op_targ = (PADOFFSET)PL_hints;
11343788 5620 return o;
79072805
LW		 5621}
5622
5623OP *
d98f61e7
GS		 5624Perl_ck_exit(pTHX_ OP *o)
5625{
5626#ifdef VMS
5627 HV *table = GvHV(PL_hintgv);
5628 if (table) {
5629 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5630 if (svp && *svp && SvTRUE(*svp))
5631 o->op_private |= OPpEXIT_VMSISH;
5632 }
96e176bf 5633 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 5634#endif
5635 return ck_fun(o);
5636}
5637
5638OP *
cea2e8a9 5639Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 5640{
5641 OP *kid;
11343788
MB		 5642 if (o->op_flags & OPf_STACKED) {
5643 o = ck_fun(o);
5644 kid = cUNOPo->op_first->op_sibling;
8990e307 5645 if (kid->op_type == OP_RV2GV)
93c66552 5646 op_null(kid);
79072805 5647 }
463ee0b2 5648 else
11343788
MB		 5649 o = listkids(o);
5650 return o;
79072805
LW		 5651}
5652
5653OP *
cea2e8a9 5654Perl_ck_exists(pTHX_ OP *o)
5f05dabc 5655{
5196be3e
MB		 5656 o = ck_fun(o);
5657 if (o->op_flags & OPf_KIDS) {
5658 OP *kid = cUNOPo->op_first;
afebc493
GS		 5659 if (kid->op_type == OP_ENTERSUB) {
5660 (void) ref(kid, o->op_type);
5661 if (kid->op_type != OP_RV2CV && !PL_error_count)
5662 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 5663 OP_DESC(o));
afebc493
GS		 5664 o->op_private |= OPpEXISTS_SUB;
5665 }
5666 else if (kid->op_type == OP_AELEM)
01020589
GS		 5667 o->op_flags |= OPf_SPECIAL;
5668 else if (kid->op_type != OP_HELEM)
5669 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 5670 OP_DESC(o));
93c66552 5671 op_null(kid);
5f05dabc 5672 }
5196be3e 5673 return o;
5f05dabc 5674}
5675
22c35a8c 5676#if 0
5f05dabc 5677OP *
cea2e8a9 5678Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 5679{
5680 o = fold_constants(o);
5681 if (o->op_type == OP_CONST)
5682 o->op_type = OP_GV;
5683 return o;
5684}
22c35a8c 5685#endif
79072805
LW		 5686
5687OP *
cea2e8a9 5688Perl_ck_rvconst(pTHX_ register OP *o)
79072805 5689{
11343788 5690 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 5691
3280af22 5692 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 5693 if (kid->op_type == OP_CONST) {
44a8e56a 5694 char *name;
5695 int iscv;
5696 GV *gv;
779c5bc9 5697 SV *kidsv = kid->op_sv;
2d8e6c8d 5698 STRLEN n_a;
44a8e56a 5699
779c5bc9
GS		 5700 /* Is it a constant from cv_const_sv()? */
5701 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5702 SV *rsv = SvRV(kidsv);
5703 int svtype = SvTYPE(rsv);
5704 char *badtype = Nullch;
5705
5706 switch (o->op_type) {
5707 case OP_RV2SV:
5708 if (svtype > SVt_PVMG)
5709 badtype = "a SCALAR";
5710 break;
5711 case OP_RV2AV:
5712 if (svtype != SVt_PVAV)
5713 badtype = "an ARRAY";
5714 break;
5715 case OP_RV2HV:
5716 if (svtype != SVt_PVHV) {
5717 if (svtype == SVt_PVAV) { /* pseudohash? */
5718 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5719 if (ksv && SvROK(*ksv)
5720 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5721 {
5722 break;
5723 }
5724 }
5725 badtype = "a HASH";
5726 }
5727 break;
5728 case OP_RV2CV:
5729 if (svtype != SVt_PVCV)
5730 badtype = "a CODE";
5731 break;
5732 }
5733 if (badtype)
cea2e8a9 5734 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5735 return o;
5736 }
2d8e6c8d 5737 name = SvPV(kidsv, n_a);
3280af22 5738 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 5739 char *badthing = Nullch;
5dc0d613 5740 switch (o->op_type) {
44a8e56a 5741 case OP_RV2SV:
5742 badthing = "a SCALAR";
5743 break;
5744 case OP_RV2AV:
5745 badthing = "an ARRAY";
5746 break;
5747 case OP_RV2HV:
5748 badthing = "a HASH";
5749 break;
5750 }
5751 if (badthing)
1c846c1f 5752 Perl_croak(aTHX_
44a8e56a 5753 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5754 name, badthing);
5755 }
93233ece
CS		 5756 /*
5757 * This is a little tricky. We only want to add the symbol if we
5758 * didn't add it in the lexer. Otherwise we get duplicate strict
5759 * warnings. But if we didn't add it in the lexer, we must at
5760 * least pretend like we wanted to add it even if it existed before,
5761 * or we get possible typo warnings. OPpCONST_ENTERED says
5762 * whether the lexer already added THIS instance of this symbol.
5763 */
5196be3e 5764 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5765 do {
44a8e56a 5766 gv = gv_fetchpv(name,
748a9306 5767 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5768 iscv
5769 ? SVt_PVCV
11343788 5770 : o->op_type == OP_RV2SV
a0d0e21e 5771 ? SVt_PV
11343788 5772 : o->op_type == OP_RV2AV
a0d0e21e 5773 ? SVt_PVAV
11343788 5774 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5775 ? SVt_PVHV
5776 : SVt_PVGV);
93233ece
CS		 5777 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5778 if (gv) {
5779 kid->op_type = OP_GV;
5780 SvREFCNT_dec(kid->op_sv);
350de78d 5781#ifdef USE_ITHREADS
638eceb6 5782 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5783 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
63caf608 5784 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
743e66e6 5785 GvIN_PAD_on(gv);
350de78d
GS		 5786 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5787#else
93233ece 5788 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5789#endif
23f1ca44 5790 kid->op_private = 0;
76cd736e 5791 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5792 }
79072805 5793 }
11343788 5794 return o;
79072805
LW		 5795}
5796
5797OP *
cea2e8a9 5798Perl_ck_ftst(pTHX_ OP *o)
79072805 5799{
11343788 5800 I32 type = o->op_type;
79072805 5801
d0dca557
JD		 5802 if (o->op_flags & OPf_REF) {
5803 /* nothing */
5804 }
5805 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5806 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5807
5808 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5809 STRLEN n_a;
a0d0e21e 5810 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5811 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5812 op_free(o);
d0dca557 5813 o = newop;
79072805
LW		 5814 }
5815 }
5816 else {
11343788 5817 op_free(o);
79072805 5818 if (type == OP_FTTTY)
d0dca557 5819 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
85e6fe83 5820 SVt_PVIO));
79072805 5821 else
d0dca557 5822 o = newUNOP(type, 0, newDEFSVOP());
79072805 5823 }
11343788 5824 return o;
79072805
LW		 5825}
5826
5827OP *
cea2e8a9 5828Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5829{
5830 register OP *kid;
5831 OP **tokid;
5832 OP *sibl;
5833 I32 numargs = 0;
11343788 5834 int type = o->op_type;
22c35a8c 5835 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5836
11343788 5837 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5838 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5839 oa &= ~OA_OPTIONAL;
5840 else
11343788 5841 return no_fh_allowed(o);
79072805
LW		 5842 }
5843
11343788 5844 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5845 STRLEN n_a;
11343788
MB		 5846 tokid = &cLISTOPo->op_first;
5847 kid = cLISTOPo->op_first;
8990e307 5848 if (kid->op_type == OP_PUSHMARK ||
155aba94 5849 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5850 {
79072805
LW		 5851 tokid = &kid->op_sibling;
5852 kid = kid->op_sibling;
5853 }
22c35a8c 5854 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5855 *tokid = kid = newDEFSVOP();
79072805
LW		 5856
5857 while (oa && kid) {
5858 numargs++;
5859 sibl = kid->op_sibling;
5860 switch (oa & 7) {
5861 case OA_SCALAR:
62c18ce2
GS		 5862 /* list seen where single (scalar) arg expected? */
5863 if (numargs == 1 && !(oa >> 4)
5864 && kid->op_type == OP_LIST && type != OP_SCALAR)
5865 {
5866 return too_many_arguments(o,PL_op_desc[type]);
5867 }
79072805
LW		 5868 scalar(kid);
5869 break;
5870 case OA_LIST:
5871 if (oa < 16) {
5872 kid = 0;
5873 continue;
5874 }
5875 else
5876 list(kid);
5877 break;
5878 case OA_AVREF:
936edb8b 5879 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213
JH		 5880 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5881 Perl_warner(aTHX_ WARN_SYNTAX,
de4864e4 5882 "Useless use of %s with no values",
936edb8b 5883 PL_op_desc[type]);
1eb1540c 5884
79072805 5885 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5886 (kid->op_private & OPpCONST_BARE))
5887 {
2d8e6c8d 5888 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5889 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5890 gv_fetchpv(name, TRUE, SVt_PVAV) ));
e476b1b5
GS		 5891 if (ckWARN(WARN_DEPRECATED))
5892 Perl_warner(aTHX_ WARN_DEPRECATED,
57def98f 5893 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5894 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5895 op_free(kid);
5896 kid = newop;
5897 kid->op_sibling = sibl;
5898 *tokid = kid;
5899 }
8990e307 5900 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5901 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5902 mod(kid, type);
79072805
LW		 5903 break;
5904 case OA_HVREF:
5905 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5906 (kid->op_private & OPpCONST_BARE))
5907 {
2d8e6c8d 5908 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5909 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5910 gv_fetchpv(name, TRUE, SVt_PVHV) ));
e476b1b5
GS		 5911 if (ckWARN(WARN_DEPRECATED))
5912 Perl_warner(aTHX_ WARN_DEPRECATED,
57def98f 5913 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5914 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5915 op_free(kid);
5916 kid = newop;
5917 kid->op_sibling = sibl;
5918 *tokid = kid;
5919 }
8990e307 5920 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5921 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5922 mod(kid, type);
79072805
LW		 5923 break;
5924 case OA_CVREF:
5925 {
a0d0e21e 5926 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5927 kid->op_sibling = 0;
5928 linklist(kid);
5929 newop->op_next = newop;
5930 kid = newop;
5931 kid->op_sibling = sibl;
5932 *tokid = kid;
5933 }
5934 break;
5935 case OA_FILEREF:
c340be78 5936 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5937 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5938 (kid->op_private & OPpCONST_BARE))
5939 {
79072805 5940 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5941 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5942 SVt_PVIO) );
364daeac
AMS		 5943 if (kid == cLISTOPo->op_last)
5944 cLISTOPo->op_last = newop;
79072805
LW		 5945 op_free(kid);
5946 kid = newop;
5947 }
1ea32a52
GS		 5948 else if (kid->op_type == OP_READLINE) {
5949 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5950 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5951 }
79072805 5952 else {
35cd451c 5953 I32 flags = OPf_SPECIAL;
a6c40364 5954 I32 priv = 0;
2c8ac474
GS		 5955 PADOFFSET targ = 0;
5956
35cd451c 5957 /* is this op a FH constructor? */
853846ea 5958 if (is_handle_constructor(o,numargs)) {
2c8ac474
GS		 5959 char *name = Nullch;
5960 STRLEN len;
5961
5962 flags = 0;
5963 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5964 * need to "prove" flag does not mean something
5965 * else already - NI-S 1999/05/07
2c8ac474
GS		 5966 */
5967 priv = OPpDEREF;
5968 if (kid->op_type == OP_PADSV) {
5969 SV **namep = av_fetch(PL_comppad_name,
5970 kid->op_targ, 4);
5971 if (namep && *namep)
5972 name = SvPV(*namep, len);
5973 }
5974 else if (kid->op_type == OP_RV2SV
5975 && kUNOP->op_first->op_type == OP_GV)
5976 {
5977 GV *gv = cGVOPx_gv(kUNOP->op_first);
5978 name = GvNAME(gv);
5979 len = GvNAMELEN(gv);
5980 }
afd1915d
GS		 5981 else if (kid->op_type == OP_AELEM
5982 || kid->op_type == OP_HELEM)
5983 {
5984 name = "__ANONIO__";
5985 len = 10;
5986 mod(kid,type);
5987 }
2c8ac474
GS		 5988 if (name) {
5989 SV *namesv;
5990 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5991 namesv = PL_curpad[targ];
155aba94 5992 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5993 if (*name != '$')
5994 sv_setpvn(namesv, "$", 1);
5995 sv_catpvn(namesv, name, len);
5996 }
853846ea 5997 }
79072805 5998 kid->op_sibling = 0;
35cd451c 5999 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 6000 kid->op_targ = targ;
6001 kid->op_private |= priv;
79072805
LW		 6002 }
6003 kid->op_sibling = sibl;
6004 *tokid = kid;
6005 }
6006 scalar(kid);
6007 break;
6008 case OA_SCALARREF:
a0d0e21e 6009 mod(scalar(kid), type);
79072805
LW		 6010 break;
6011 }
6012 oa >>= 4;
6013 tokid = &kid->op_sibling;
6014 kid = kid->op_sibling;
6015 }
11343788 6016 o->op_private |= numargs;
79072805 6017 if (kid)
53e06cf0 6018 return too_many_arguments(o,OP_DESC(o));
11343788 6019 listkids(o);
79072805 6020 }
22c35a8c 6021 else if (PL_opargs[type] & OA_DEFGV) {
11343788 6022 op_free(o);
54b9620d 6023 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 6024 }
6025
79072805
LW		 6026 if (oa) {
6027 while (oa & OA_OPTIONAL)
6028 oa >>= 4;
6029 if (oa && oa != OA_LIST)
53e06cf0 6030 return too_few_arguments(o,OP_DESC(o));
79072805 6031 }
11343788 6032 return o;
79072805
LW		 6033}
6034
6035OP *
cea2e8a9 6036Perl_ck_glob(pTHX_ OP *o)
79072805 6037{
fb73857a 6038 GV *gv;
6039
649da076 6040 o = ck_fun(o);
1f2bfc8a 6041 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 6042 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 6043
b9f751c0
GS		 6044 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6045 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6046 {
fb73857a 6047 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b9f751c0 6048 }
b1cb66bf 6049
52bb0670 6050#if !defined(PERL_EXTERNAL_GLOB)
72b16652
GS		 6051 /* XXX this can be tightened up and made more failsafe. */
6052 if (!gv) {
7d3fb230 6053 GV *glob_gv;
72b16652 6054 ENTER;
7d3fb230
BS		 6055 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
6056 Nullsv, Nullsv);
72b16652 6057 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 6058 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6059 GvCV(gv) = GvCV(glob_gv);
445266f0 6060 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 6061 GvIMPORTED_CV_on(gv);
72b16652
GS		 6062 LEAVE;
6063 }
52bb0670 6064#endif /* PERL_EXTERNAL_GLOB */
72b16652 6065
b9f751c0 6066 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 6067 append_elem(OP_GLOB, o,
80252599 6068 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 6069 o->op_type = OP_LIST;
22c35a8c 6070 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 6071 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 6072 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
1f2bfc8a 6073 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 6074 append_elem(OP_LIST, o,
1f2bfc8a
MB		 6075 scalar(newUNOP(OP_RV2CV, 0,
6076 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 6077 o = newUNOP(OP_NULL, 0, ck_subr(o));
6078 o->op_targ = OP_GLOB; /* hint at what it used to be */
6079 return o;
b1cb66bf 6080 }
6081 gv = newGVgen("main");
a0d0e21e 6082 gv_IOadd(gv);
11343788
MB		 6083 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6084 scalarkids(o);
649da076 6085 return o;
79072805
LW		 6086}
6087
6088OP *
cea2e8a9 6089Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 6090{
6091 LOGOP *gwop;
6092 OP *kid;
11343788 6093 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 6094
22c35a8c 6095 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 6096 NewOp(1101, gwop, 1, LOGOP);
aeea060c 6097
11343788 6098 if (o->op_flags & OPf_STACKED) {
a0d0e21e 6099 OP* k;
11343788
MB		 6100 o = ck_sort(o);
6101 kid = cLISTOPo->op_first->op_sibling;
6102 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 6103 kid = k;
6104 }
6105 kid->op_next = (OP*)gwop;
11343788 6106 o->op_flags &= ~OPf_STACKED;
93a17b20 6107 }
11343788 6108 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 6109 if (type == OP_MAPWHILE)
6110 list(kid);
6111 else
6112 scalar(kid);
11343788 6113 o = ck_fun(o);
3280af22 6114 if (PL_error_count)
11343788 6115 return o;
aeea060c 6116 kid = cLISTOPo->op_first->op_sibling;
79072805 6117 if (kid->op_type != OP_NULL)
cea2e8a9 6118 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 6119 kid = kUNOP->op_first;
6120
a0d0e21e 6121 gwop->op_type = type;
22c35a8c 6122 gwop->op_ppaddr = PL_ppaddr[type];
11343788 6123 gwop->op_first = listkids(o);
79072805
LW		 6124 gwop->op_flags |= OPf_KIDS;
6125 gwop->op_private = 1;
6126 gwop->op_other = LINKLIST(kid);
a0d0e21e 6127 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 6128 kid->op_next = (OP*)gwop;
6129
11343788 6130 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 6131 if (!kid || !kid->op_sibling)
53e06cf0 6132 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 6133 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6134 mod(kid, OP_GREPSTART);
6135
79072805
LW		 6136 return (OP*)gwop;
6137}
6138
6139OP *
cea2e8a9 6140Perl_ck_index(pTHX_ OP *o)
79072805 6141{
11343788
MB		 6142 if (o->op_flags & OPf_KIDS) {
6143 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 6144 if (kid)
6145 kid = kid->op_sibling; /* get past "big" */
79072805 6146 if (kid && kid->op_type == OP_CONST)
2779dcf1 6147 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 6148 }
11343788 6149 return ck_fun(o);
79072805
LW		 6150}
6151
6152OP *
cea2e8a9 6153Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 6154{
6155 /* XXX length optimization goes here */
11343788 6156 return ck_fun(o);
79072805
LW		 6157}
6158
6159OP *
cea2e8a9 6160Perl_ck_lfun(pTHX_ OP *o)
79072805 6161{
5dc0d613
MB		 6162 OPCODE type = o->op_type;
6163 return modkids(ck_fun(o), type);
79072805
LW		 6164}
6165
6166OP *
cea2e8a9 6167Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 6168{
d0334bed
GS		 6169 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6170 switch (cUNOPo->op_first->op_type) {
6171 case OP_RV2AV:
a8739d98
JH		 6172 /* This is needed for
6173 if (defined %stash::)
6174 to work. Do not break Tk.
6175 */
1c846c1f 6176 break; /* Globals via GV can be undef */
d0334bed
GS		 6177 case OP_PADAV:
6178 case OP_AASSIGN: /* Is this a good idea? */
6179 Perl_warner(aTHX_ WARN_DEPRECATED,
f10b0346 6180 "defined(@array) is deprecated");
d0334bed 6181 Perl_warner(aTHX_ WARN_DEPRECATED,
cc507455 6182 "\t(Maybe you should just omit the defined()?)\n");
69794302 6183 break;
d0334bed 6184 case OP_RV2HV:
a8739d98
JH		 6185 /* This is needed for
6186 if (defined %stash::)
6187 to work. Do not break Tk.
6188 */
1c846c1f 6189 break; /* Globals via GV can be undef */
d0334bed
GS		 6190 case OP_PADHV:
6191 Perl_warner(aTHX_ WARN_DEPRECATED,
894356b3 6192 "defined(%%hash) is deprecated");
d0334bed 6193 Perl_warner(aTHX_ WARN_DEPRECATED,
cc507455 6194 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 6195 break;
6196 default:
6197 /* no warning */
6198 break;
6199 }
69794302
MJD		 6200 }
6201 return ck_rfun(o);
6202}
6203
6204OP *
cea2e8a9 6205Perl_ck_rfun(pTHX_ OP *o)
8990e307 6206{
5dc0d613
MB		 6207 OPCODE type = o->op_type;
6208 return refkids(ck_fun(o), type);
8990e307
LW		 6209}
6210
6211OP *
cea2e8a9 6212Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 6213{
6214 register OP *kid;
aeea060c 6215
11343788 6216 kid = cLISTOPo->op_first;
79072805 6217 if (!kid) {
11343788
MB		 6218 o = force_list(o);
6219 kid = cLISTOPo->op_first;
79072805
LW		 6220 }
6221 if (kid->op_type == OP_PUSHMARK)
6222 kid = kid->op_sibling;
11343788 6223 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 6224 kid = kid->op_sibling;
6225 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6226 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 6227 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 6228 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 6229 cLISTOPo->op_first->op_sibling = kid;
6230 cLISTOPo->op_last = kid;
79072805
LW		 6231 kid = kid->op_sibling;
6232 }
6233 }
6234
6235 if (!kid)
54b9620d 6236 append_elem(o->op_type, o, newDEFSVOP());
79072805 6237
2de3dbcc 6238 return listkids(o);
bbce6d69 6239}
6240
6241OP *
b162f9ea
IZ		 6242Perl_ck_sassign(pTHX_ OP *o)
6243{
6244 OP *kid = cLISTOPo->op_first;
6245 /* has a disposable target? */
6246 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 6247 && !(kid->op_flags & OPf_STACKED)
6248 /* Cannot steal the second time! */
6249 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 6250 {
6251 OP *kkid = kid->op_sibling;
6252
6253 /* Can just relocate the target. */
2c2d71f5
JH		 6254 if (kkid && kkid->op_type == OP_PADSV
6255 && !(kkid->op_private & OPpLVAL_INTRO))
6256 {
b162f9ea 6257 kid->op_targ = kkid->op_targ;
743e66e6 6258 kkid->op_targ = 0;
b162f9ea
IZ		 6259 /* Now we do not need PADSV and SASSIGN. */
6260 kid->op_sibling = o->op_sibling; /* NULL */
6261 cLISTOPo->op_first = NULL;
6262 op_free(o);
6263 op_free(kkid);
6264 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6265 return kid;
6266 }
6267 }
6268 return o;
6269}
6270
6271OP *
cea2e8a9 6272Perl_ck_match(pTHX_ OP *o)
79072805 6273{
5dc0d613 6274 o->op_private |= OPpRUNTIME;
11343788 6275 return o;
79072805
LW		 6276}
6277
6278OP *
f5d5a27c
CS		 6279Perl_ck_method(pTHX_ OP *o)
6280{
6281 OP *kid = cUNOPo->op_first;
6282 if (kid->op_type == OP_CONST) {
6283 SV* sv = kSVOP->op_sv;
6284 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6285 OP *cmop;
1c846c1f
NIS		 6286 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6287 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6288 }
6289 else {
6290 kSVOP->op_sv = Nullsv;
6291 }
f5d5a27c 6292 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 6293 op_free(o);
6294 return cmop;
6295 }
6296 }
6297 return o;
6298}
6299
6300OP *
cea2e8a9 6301Perl_ck_null(pTHX_ OP *o)
79072805 6302{
11343788 6303 return o;
79072805
LW		 6304}
6305
6306OP *
16fe6d59
GS		 6307Perl_ck_open(pTHX_ OP *o)
6308{
6309 HV *table = GvHV(PL_hintgv);
6310 if (table) {
6311 SV **svp;
6312 I32 mode;
6313 svp = hv_fetch(table, "open_IN", 7, FALSE);
6314 if (svp && *svp) {
6315 mode = mode_from_discipline(*svp);
6316 if (mode & O_BINARY)
6317 o->op_private |= OPpOPEN_IN_RAW;
6318 else if (mode & O_TEXT)
6319 o->op_private |= OPpOPEN_IN_CRLF;
6320 }
6321
6322 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6323 if (svp && *svp) {
6324 mode = mode_from_discipline(*svp);
6325 if (mode & O_BINARY)
6326 o->op_private |= OPpOPEN_OUT_RAW;
6327 else if (mode & O_TEXT)
6328 o->op_private |= OPpOPEN_OUT_CRLF;
6329 }
6330 }
6331 if (o->op_type == OP_BACKTICK)
6332 return o;
6333 return ck_fun(o);
6334}
6335
6336OP *
cea2e8a9 6337Perl_ck_repeat(pTHX_ OP *o)
79072805 6338{
11343788
MB		 6339 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6340 o->op_private |= OPpREPEAT_DOLIST;
6341 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 6342 }
6343 else
11343788
MB		 6344 scalar(o);
6345 return o;
79072805
LW		 6346}
6347
6348OP *
cea2e8a9 6349Perl_ck_require(pTHX_ OP *o)
8990e307 6350{
ec4ab249
GA		 6351 GV* gv;
6352
11343788
MB		 6353 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6354 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 6355
6356 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 6357 char *s;
a0d0e21e
LW		 6358 for (s = SvPVX(kid->op_sv); *s; s++) {
6359 if (*s == ':' && s[1] == ':') {
6360 *s = '/';
1aef975c 6361 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 6362 --SvCUR(kid->op_sv);
6363 }
8990e307 6364 }
ce3b816e
GS		 6365 if (SvREADONLY(kid->op_sv)) {
6366 SvREADONLY_off(kid->op_sv);
6367 sv_catpvn(kid->op_sv, ".pm", 3);
6368 SvREADONLY_on(kid->op_sv);
6369 }
6370 else
6371 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 6372 }
6373 }
ec4ab249
GA		 6374
6375 /* handle override, if any */
6376 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
b9f751c0 6377 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
ec4ab249
GA		 6378 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6379
b9f751c0 6380 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
ec4ab249
GA		 6381 OP *kid = cUNOPo->op_first;
6382 cUNOPo->op_first = 0;
6383 op_free(o);
6384 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6385 append_elem(OP_LIST, kid,
6386 scalar(newUNOP(OP_RV2CV, 0,
6387 newGVOP(OP_GV, 0,
6388 gv))))));
6389 }
6390
11343788 6391 return ck_fun(o);
8990e307
LW		 6392}
6393
78f9721b
SM		 6394OP *
6395Perl_ck_return(pTHX_ OP *o)
6396{
6397 OP *kid;
6398 if (CvLVALUE(PL_compcv)) {
6399 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6400 mod(kid, OP_LEAVESUBLV);
6401 }
6402 return o;
6403}
6404
22c35a8c 6405#if 0
8990e307 6406OP *
cea2e8a9 6407Perl_ck_retarget(pTHX_ OP *o)
79072805 6408{
cea2e8a9 6409 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 6410 /* STUB */
11343788 6411 return o;
79072805 6412}
22c35a8c 6413#endif
79072805
LW		 6414
6415OP *
cea2e8a9 6416Perl_ck_select(pTHX_ OP *o)
79072805 6417{
c07a80fd 6418 OP* kid;
11343788
MB		 6419 if (o->op_flags & OPf_KIDS) {
6420 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 6421 if (kid && kid->op_sibling) {
11343788 6422 o->op_type = OP_SSELECT;
22c35a8c 6423 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 6424 o = ck_fun(o);
6425 return fold_constants(o);
79072805
LW		 6426 }
6427 }
11343788
MB		 6428 o = ck_fun(o);
6429 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 6430 if (kid && kid->op_type == OP_RV2GV)
6431 kid->op_private &= ~HINT_STRICT_REFS;
11343788 6432 return o;
79072805
LW		 6433}
6434
6435OP *
cea2e8a9 6436Perl_ck_shift(pTHX_ OP *o)
79072805 6437{
11343788 6438 I32 type = o->op_type;
79072805 6439
11343788 6440 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2
MB		 6441 OP *argop;
6442
11343788 6443 op_free(o);
4d1ff10f 6444#ifdef USE_5005THREADS
533c011a 6445 if (!CvUNIQUE(PL_compcv)) {
6d4ff0d2 6446 argop = newOP(OP_PADAV, OPf_REF);
6b88bc9c 6447 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6d4ff0d2
MB		 6448 }
6449 else {
6450 argop = newUNOP(OP_RV2AV, 0,
6451 scalar(newGVOP(OP_GV, 0,
6452 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6453 }
6454#else
6455 argop = newUNOP(OP_RV2AV, 0,
3280af22
NIS		 6456 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6457 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
4d1ff10f 6458#endif /* USE_5005THREADS */
6d4ff0d2 6459 return newUNOP(type, 0, scalar(argop));
79072805 6460 }
11343788 6461 return scalar(modkids(ck_fun(o), type));
79072805
LW		 6462}
6463
6464OP *
cea2e8a9 6465Perl_ck_sort(pTHX_ OP *o)
79072805 6466{
8e3f9bdf 6467 OP *firstkid;
bbce6d69 6468
9ea6e965 6469 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 6470 simplify_sort(o);
8e3f9bdf
GS		 6471 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6472 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 6473 OP *k = NULL;
8e3f9bdf 6474 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 6475
463ee0b2 6476 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 6477 linklist(kid);
463ee0b2
LW		 6478 if (kid->op_type == OP_SCOPE) {
6479 k = kid->op_next;
6480 kid->op_next = 0;
79072805 6481 }
463ee0b2 6482 else if (kid->op_type == OP_LEAVE) {
11343788 6483 if (o->op_type == OP_SORT) {
93c66552 6484 op_null(kid); /* wipe out leave */
748a9306 6485 kid->op_next = kid;
463ee0b2 6486
748a9306
LW		 6487 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6488 if (k->op_next == kid)
6489 k->op_next = 0;
71a29c3c
GS		 6490 /* don't descend into loops */
6491 else if (k->op_type == OP_ENTERLOOP
6492 || k->op_type == OP_ENTERITER)
6493 {
6494 k = cLOOPx(k)->op_lastop;
6495 }
748a9306 6496 }
463ee0b2 6497 }
748a9306
LW		 6498 else
6499 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 6500 k = kLISTOP->op_first;
463ee0b2 6501 }
a2efc822 6502 CALL_PEEP(k);
a0d0e21e 6503
8e3f9bdf
GS		 6504 kid = firstkid;
6505 if (o->op_type == OP_SORT) {
6506 /* provide scalar context for comparison function/block */
6507 kid = scalar(kid);
a0d0e21e 6508 kid->op_next = kid;
8e3f9bdf 6509 }
a0d0e21e
LW		 6510 else
6511 kid->op_next = k;
11343788 6512 o->op_flags |= OPf_SPECIAL;
79072805 6513 }
c6e96bcb 6514 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 6515 op_null(firstkid);
8e3f9bdf
GS		 6516
6517 firstkid = firstkid->op_sibling;
79072805 6518 }
bbce6d69 6519
8e3f9bdf
GS		 6520 /* provide list context for arguments */
6521 if (o->op_type == OP_SORT)
6522 list(firstkid);
6523
11343788 6524 return o;
79072805 6525}
bda4119b
GS		 6526
6527STATIC void
cea2e8a9 6528S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 6529{
6530 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6531 OP *k;
6532 int reversed;
350de78d 6533 GV *gv;
9c007264
JH		 6534 if (!(o->op_flags & OPf_STACKED))
6535 return;
1c846c1f
NIS		 6536 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6537 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 6538 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 6539 if (kid->op_type != OP_SCOPE)
6540 return;
6541 kid = kLISTOP->op_last; /* get past scope */
6542 switch(kid->op_type) {
6543 case OP_NCMP:
6544 case OP_I_NCMP:
6545 case OP_SCMP:
6546 break;
6547 default:
6548 return;
6549 }
6550 k = kid; /* remember this node*/
6551 if (kBINOP->op_first->op_type != OP_RV2SV)
6552 return;
6553 kid = kBINOP->op_first; /* get past cmp */
6554 if (kUNOP->op_first->op_type != OP_GV)
6555 return;
6556 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6557 gv = kGVOP_gv;
350de78d 6558 if (GvSTASH(gv) != PL_curstash)
9c007264 6559 return;
350de78d 6560 if (strEQ(GvNAME(gv), "a"))
9c007264 6561 reversed = 0;
0f79a09d 6562 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 6563 reversed = 1;
6564 else
6565 return;
6566 kid = k; /* back to cmp */
6567 if (kBINOP->op_last->op_type != OP_RV2SV)
6568 return;
6569 kid = kBINOP->op_last; /* down to 2nd arg */
6570 if (kUNOP->op_first->op_type != OP_GV)
6571 return;
6572 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6573 gv = kGVOP_gv;
350de78d 6574 if (GvSTASH(gv) != PL_curstash
9c007264 6575 || ( reversed
350de78d
GS		 6576 ? strNE(GvNAME(gv), "a")
6577 : strNE(GvNAME(gv), "b")))
9c007264
JH		 6578 return;
6579 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6580 if (reversed)
6581 o->op_private |= OPpSORT_REVERSE;
6582 if (k->op_type == OP_NCMP)
6583 o->op_private |= OPpSORT_NUMERIC;
6584 if (k->op_type == OP_I_NCMP)
6585 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 6586 kid = cLISTOPo->op_first->op_sibling;
6587 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6588 op_free(kid); /* then delete it */
9c007264 6589}
79072805
LW		 6590
6591OP *
cea2e8a9 6592Perl_ck_split(pTHX_ OP *o)
79072805
LW		 6593{
6594 register OP *kid;
aeea060c 6595
11343788
MB		 6596 if (o->op_flags & OPf_STACKED)
6597 return no_fh_allowed(o);
79072805 6598
11343788 6599 kid = cLISTOPo->op_first;
8990e307 6600 if (kid->op_type != OP_NULL)
cea2e8a9 6601 Perl_croak(aTHX_ "panic: ck_split");
8990e307 6602 kid = kid->op_sibling;
11343788
MB		 6603 op_free(cLISTOPo->op_first);
6604 cLISTOPo->op_first = kid;
85e6fe83 6605 if (!kid) {
79cb57f6 6606 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 6607 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 6608 }
79072805 6609
de4bf5b3 6610 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 6611 OP *sibl = kid->op_sibling;
463ee0b2 6612 kid->op_sibling = 0;
79072805 6613 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 6614 if (cLISTOPo->op_first == cLISTOPo->op_last)
6615 cLISTOPo->op_last = kid;
6616 cLISTOPo->op_first = kid;
79072805
LW		 6617 kid->op_sibling = sibl;
6618 }
6619
6620 kid->op_type = OP_PUSHRE;
22c35a8c 6621 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805
LW		 6622 scalar(kid);
6623
6624 if (!kid->op_sibling)
54b9620d 6625 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 6626
6627 kid = kid->op_sibling;
6628 scalar(kid);
6629
6630 if (!kid->op_sibling)
11343788 6631 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 6632
6633 kid = kid->op_sibling;
6634 scalar(kid);
6635
6636 if (kid->op_sibling)
53e06cf0 6637 return too_many_arguments(o,OP_DESC(o));
79072805 6638
11343788 6639 return o;
79072805
LW		 6640}
6641
6642OP *
1c846c1f 6643Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 6644{
6645 if (ckWARN(WARN_SYNTAX)) {
6646 OP *kid = cLISTOPo->op_first->op_sibling;
6647 if (kid && kid->op_type == OP_MATCH) {
6648 char *pmstr = "STRING";
aaa362c4
RS		 6649 if (PM_GETRE(kPMOP))
6650 pmstr = PM_GETRE(kPMOP)->precomp;
eb6e2d6f
GS		 6651 Perl_warner(aTHX_ WARN_SYNTAX,
6652 "/%s/ should probably be written as \"%s\"",
6653 pmstr, pmstr);
6654 }
6655 }
6656 return ck_fun(o);
6657}
6658
6659OP *
cea2e8a9 6660Perl_ck_subr(pTHX_ OP *o)
79072805 6661{
11343788
MB		 6662 OP *prev = ((cUNOPo->op_first->op_sibling)
6663 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6664 OP *o2 = prev->op_sibling;
4633a7c4
LW		 6665 OP *cvop;
6666 char *proto = 0;
6667 CV *cv = 0;
46fc3d4c 6668 GV *namegv = 0;
4633a7c4
LW		 6669 int optional = 0;
6670 I32 arg = 0;
5b794e05 6671 I32 contextclass = 0;
90b7f708 6672 char *e = 0;
2d8e6c8d 6673 STRLEN n_a;
4633a7c4 6674
d3011074 6675 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6676 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6677 if (cvop->op_type == OP_RV2CV) {
6678 SVOP* tmpop;
11343788 6679 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6680 op_null(cvop); /* disable rv2cv */
4633a7c4 6681 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6682 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6683 GV *gv = cGVOPx_gv(tmpop);
350de78d 6684 cv = GvCVu(gv);
76cd736e
GS		 6685 if (!cv)
6686 tmpop->op_private |= OPpEARLY_CV;
6687 else if (SvPOK(cv)) {
350de78d 6688 namegv = CvANON(cv) ? gv : CvGV(cv);
2d8e6c8d 6689 proto = SvPV((SV*)cv, n_a);
46fc3d4c 6690 }
4633a7c4
LW		 6691 }
6692 }
f5d5a27c 6693 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6694 if (o2->op_type == OP_CONST)
6695 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 6696 else if (o2->op_type == OP_LIST) {
6697 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6698 if (o && o->op_type == OP_CONST)
6699 o->op_private &= ~OPpCONST_STRICT;
6700 }
7a52d87a 6701 }
3280af22
NIS		 6702 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6703 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6704 o->op_private |= OPpENTERSUB_DB;
6705 while (o2 != cvop) {
4633a7c4
LW		 6706 if (proto) {
6707 switch (*proto) {
6708 case '\0':
5dc0d613 6709 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 6710 case ';':
6711 optional = 1;
6712 proto++;
6713 continue;
6714 case '$':
6715 proto++;
6716 arg++;
11343788 6717 scalar(o2);
4633a7c4
LW		 6718 break;
6719 case '%':
6720 case '@':
11343788 6721 list(o2);
4633a7c4
LW		 6722 arg++;
6723 break;
6724 case '&':
6725 proto++;
6726 arg++;
11343788 6727 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6728 bad_type(arg,
6729 arg == 1 ? "block or sub {}" : "sub {}",
6730 gv_ename(namegv), o2);
4633a7c4
LW		 6731 break;
6732 case '*':
2ba6ecf4 6733 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6734 proto++;
6735 arg++;
11343788 6736 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6737 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6738 else if (o2->op_type == OP_CONST)
6739 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6740 else if (o2->op_type == OP_ENTERSUB) {
6741 /* accidental subroutine, revert to bareword */
6742 OP *gvop = ((UNOP*)o2)->op_first;
6743 if (gvop && gvop->op_type == OP_NULL) {
6744 gvop = ((UNOP*)gvop)->op_first;
6745 if (gvop) {
6746 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6747 ;
6748 if (gvop &&
6749 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6750 (gvop = ((UNOP*)gvop)->op_first) &&
6751 gvop->op_type == OP_GV)
6752 {
638eceb6 6753 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6754 OP *sibling = o2->op_sibling;
2692f720 6755 SV *n = newSVpvn("",0);
9675f7ac 6756 op_free(o2);
2692f720
GS		 6757 gv_fullname3(n, gv, "");
6758 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6759 sv_chop(n, SvPVX(n)+6);
6760 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6761 prev->op_sibling = o2;
6762 o2->op_sibling = sibling;
6763 }
6764 }
6765 }
6766 }
2ba6ecf4
GS		 6767 scalar(o2);
6768 break;
5b794e05
JH		 6769 case '[': case ']':
6770 goto oops;
6771 break;
4633a7c4
LW		 6772 case '\\':
6773 proto++;
6774 arg++;
5b794e05 6775 again:
4633a7c4 6776 switch (*proto++) {
5b794e05
JH		 6777 case '[':
6778 if (contextclass++ == 0) {
841d93c8 6779 e = strchr(proto, ']');
5b794e05
JH		 6780 if (!e || e == proto)
6781 goto oops;
6782 }
6783 else
6784 goto oops;
6785 goto again;
6786 break;
6787 case ']':
466bafcd
RGS		 6788 if (contextclass) {
6789 char *p = proto;
6790 char s = *p;
6791 contextclass = 0;
6792 *p = '\0';
6793 while (*--p != '[');
1eb1540c 6794 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6795 gv_ename(namegv), o2);
6796 *proto = s;
6797 } else
5b794e05
JH		 6798 goto oops;
6799 break;
4633a7c4 6800 case '*':
5b794e05
JH		 6801 if (o2->op_type == OP_RV2GV)
6802 goto wrapref;
6803 if (!contextclass)
6804 bad_type(arg, "symbol", gv_ename(namegv), o2);
6805 break;
4633a7c4 6806 case '&':
5b794e05
JH		 6807 if (o2->op_type == OP_ENTERSUB)
6808 goto wrapref;
6809 if (!contextclass)
6810 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6811 break;
4633a7c4 6812 case '$':
5b794e05
JH		 6813 if (o2->op_type == OP_RV2SV ||
6814 o2->op_type == OP_PADSV ||
6815 o2->op_type == OP_HELEM ||
6816 o2->op_type == OP_AELEM ||
6817 o2->op_type == OP_THREADSV)
6818 goto wrapref;
6819 if (!contextclass)
5dc0d613 6820 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6821 break;
4633a7c4 6822 case '@':
5b794e05
JH		 6823 if (o2->op_type == OP_RV2AV ||
6824 o2->op_type == OP_PADAV)
6825 goto wrapref;
6826 if (!contextclass)
5dc0d613 6827 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6828 break;
4633a7c4 6829 case '%':
5b794e05
JH		 6830 if (o2->op_type == OP_RV2HV ||
6831 o2->op_type == OP_PADHV)
6832 goto wrapref;
6833 if (!contextclass)
6834 bad_type(arg, "hash", gv_ename(namegv), o2);
6835 break;
6836 wrapref:
4633a7c4 6837 {
11343788 6838 OP* kid = o2;
6fa846a0 6839 OP* sib = kid->op_sibling;
4633a7c4 6840 kid->op_sibling = 0;
6fa846a0
GS		 6841 o2 = newUNOP(OP_REFGEN, 0, kid);
6842 o2->op_sibling = sib;
e858de61 6843 prev->op_sibling = o2;
4633a7c4 6844 }
841d93c8 6845 if (contextclass && e) {
5b794e05
JH		 6846 proto = e + 1;
6847 contextclass = 0;
6848 }
4633a7c4
LW		 6849 break;
6850 default: goto oops;
6851 }
5b794e05
JH		 6852 if (contextclass)
6853 goto again;
4633a7c4 6854 break;
b1cb66bf 6855 case ' ':
6856 proto++;
6857 continue;
4633a7c4
LW		 6858 default:
6859 oops:
cea2e8a9 6860 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
5b794e05 6861 gv_ename(namegv), SvPV((SV*)cv, n_a));
4633a7c4
LW		 6862 }
6863 }
6864 else
11343788
MB		 6865 list(o2);
6866 mod(o2, OP_ENTERSUB);
6867 prev = o2;
6868 o2 = o2->op_sibling;
4633a7c4 6869 }
fb73857a 6870 if (proto && !optional &&
6871 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6872 return too_few_arguments(o, gv_ename(namegv));
11343788 6873 return o;
79072805
LW		 6874}
6875
6876OP *
cea2e8a9 6877Perl_ck_svconst(pTHX_ OP *o)
8990e307 6878{
11343788
MB		 6879 SvREADONLY_on(cSVOPo->op_sv);
6880 return o;
8990e307
LW		 6881}
6882
6883OP *
cea2e8a9 6884Perl_ck_trunc(pTHX_ OP *o)
79072805 6885{
11343788
MB		 6886 if (o->op_flags & OPf_KIDS) {
6887 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6888
a0d0e21e
LW		 6889 if (kid->op_type == OP_NULL)
6890 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6891 if (kid && kid->op_type == OP_CONST &&
6892 (kid->op_private & OPpCONST_BARE))
6893 {
11343788 6894 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6895 kid->op_private &= ~OPpCONST_STRICT;
6896 }
79072805 6897 }
11343788 6898 return ck_fun(o);
79072805
LW		 6899}
6900
35fba0d9
RG		 6901OP *
6902Perl_ck_substr(pTHX_ OP *o)
6903{
6904 o = ck_fun(o);
6905 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6906 OP *kid = cLISTOPo->op_first;
6907
6908 if (kid->op_type == OP_NULL)
6909 kid = kid->op_sibling;
6910 if (kid)
6911 kid->op_flags |= OPf_MOD;
6912
6913 }
6914 return o;
6915}
6916
463ee0b2
LW		 6917/* A peephole optimizer. We visit the ops in the order they're to execute. */
6918
79072805 6919void
864dbfa3 6920Perl_peep(pTHX_ register OP *o)
79072805
LW		 6921{
6922 register OP* oldop = 0;
2d8e6c8d
GS		 6923 STRLEN n_a;
6924
a0d0e21e 6925 if (!o || o->op_seq)
79072805 6926 return;
a0d0e21e 6927 ENTER;
462e5cf6 6928 SAVEOP();
7766f137 6929 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6930 for (; o; o = o->op_next) {
6931 if (o->op_seq)
6932 break;
3280af22
NIS		 6933 if (!PL_op_seqmax)
6934 PL_op_seqmax++;
533c011a 6935 PL_op = o;
a0d0e21e 6936 switch (o->op_type) {
acb36ea4 6937 case OP_SETSTATE:
a0d0e21e
LW		 6938 case OP_NEXTSTATE:
6939 case OP_DBSTATE:
3280af22
NIS		 6940 PL_curcop = ((COP*)o); /* for warnings */
6941 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6942 break;
6943
a0d0e21e 6944 case OP_CONST:
7a52d87a
GS		 6945 if (cSVOPo->op_private & OPpCONST_STRICT)
6946 no_bareword_allowed(o);
7766f137
GS		 6947#ifdef USE_ITHREADS
6948 /* Relocate sv to the pad for thread safety.
6949 * Despite being a "constant", the SV is written to,
6950 * for reference counts, sv_upgrade() etc. */
6951 if (cSVOP->op_sv) {
6952 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6a7129a1
GS		 6953 if (SvPADTMP(cSVOPo->op_sv)) {
6954 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6955 * some pad, so make a copy. */
6a7129a1
GS		 6956 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6957 SvREADONLY_on(PL_curpad[ix]);
6958 SvREFCNT_dec(cSVOPo->op_sv);
6959 }
6960 else {
6961 SvREFCNT_dec(PL_curpad[ix]);
6962 SvPADTMP_on(cSVOPo->op_sv);
6963 PL_curpad[ix] = cSVOPo->op_sv;
9a049f1c
JT		 6964 /* XXX I don't know how this isn't readonly already. */
6965 SvREADONLY_on(PL_curpad[ix]);
6a7129a1 6966 }
7766f137
GS		 6967 cSVOPo->op_sv = Nullsv;
6968 o->op_targ = ix;
6969 }
6970#endif
07447971
GS		 6971 o->op_seq = PL_op_seqmax++;
6972 break;
6973
ed7ab888 6974 case OP_CONCAT:
b162f9ea
IZ		 6975 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6976 if (o->op_next->op_private & OPpTARGET_MY) {
69b47968 6977 if (o->op_flags & OPf_STACKED) /* chained concats */
b162f9ea 6978 goto ignore_optimization;
cd06dffe 6979 else {
07447971 6980 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
b162f9ea 6981 o->op_targ = o->op_next->op_targ;
743e66e6 6982 o->op_next->op_targ = 0;
2c2d71f5 6983 o->op_private |= OPpTARGET_MY;
b162f9ea
IZ		 6984 }
6985 }
93c66552 6986 op_null(o->op_next);
b162f9ea
IZ		 6987 }
6988 ignore_optimization:
3280af22 6989 o->op_seq = PL_op_seqmax++;
a0d0e21e 6990 break;
8990e307 6991 case OP_STUB:
54310121 6992 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 6993 o->op_seq = PL_op_seqmax++;
54310121 6994 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6995 }
748a9306 6996 goto nothin;
79072805 6997 case OP_NULL:
acb36ea4
GS		 6998 if (o->op_targ == OP_NEXTSTATE
6999 || o->op_targ == OP_DBSTATE
7000 || o->op_targ == OP_SETSTATE)
7001 {
3280af22 7002 PL_curcop = ((COP*)o);
acb36ea4 7003 }
dad75012
AMS		 7004 /* XXX: We avoid setting op_seq here to prevent later calls
7005 to peep() from mistakenly concluding that optimisation
7006 has already occurred. This doesn't fix the real problem,
7007 though (See 20010220.007). AMS 20010719 */
7008 if (oldop && o->op_next) {
7009 oldop->op_next = o->op_next;
7010 continue;
7011 }
7012 break;
79072805 7013 case OP_SCALAR:
93a17b20 7014 case OP_LINESEQ:
463ee0b2 7015 case OP_SCOPE:
748a9306 7016 nothin:
a0d0e21e
LW		 7017 if (oldop && o->op_next) {
7018 oldop->op_next = o->op_next;
79072805
LW		 7019 continue;
7020 }
3280af22 7021 o->op_seq = PL_op_seqmax++;
79072805
LW		 7022 break;
7023
7024 case OP_GV:
a0d0e21e 7025 if (o->op_next->op_type == OP_RV2SV) {
64aac5a9 7026 if (!(o->op_next->op_private & OPpDEREF)) {
93c66552 7027 op_null(o->op_next);
64aac5a9
GS		 7028 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7029 | OPpOUR_INTRO);
a0d0e21e
LW		 7030 o->op_next = o->op_next->op_next;
7031 o->op_type = OP_GVSV;
22c35a8c 7032 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307
LW		 7033 }
7034 }
a0d0e21e
LW		 7035 else if (o->op_next->op_type == OP_RV2AV) {
7036 OP* pop = o->op_next->op_next;
7037 IV i;
8990e307 7038 if (pop->op_type == OP_CONST &&
533c011a 7039 (PL_op = pop->op_next) &&
8990e307 7040 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 7041 !(pop->op_next->op_private &
78f9721b 7042 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 7043 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 7044 <= 255 &&
8990e307
LW		 7045 i >= 0)
7046 {
350de78d 7047 GV *gv;
93c66552
DM		 7048 op_null(o->op_next);
7049 op_null(pop->op_next);
7050 op_null(pop);
a0d0e21e
LW		 7051 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7052 o->op_next = pop->op_next->op_next;
7053 o->op_type = OP_AELEMFAST;
22c35a8c 7054 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 7055 o->op_private = (U8)i;
638eceb6 7056 gv = cGVOPo_gv;
350de78d 7057 GvAVn(gv);
8990e307 7058 }
79072805 7059 }
e476b1b5 7060 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 7061 GV *gv = cGVOPo_gv;
76cd736e
GS		 7062 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7063 /* XXX could check prototype here instead of just carping */
7064 SV *sv = sv_newmortal();
7065 gv_efullname3(sv, gv, Nullch);
e476b1b5 7066 Perl_warner(aTHX_ WARN_PROTOTYPE,
76cd736e
GS		 7067 "%s() called too early to check prototype",
7068 SvPV_nolen(sv));
7069 }
7070 }
89de2904
AMS		 7071 else if (o->op_next->op_type == OP_READLINE
7072 && o->op_next->op_next->op_type == OP_CONCAT
7073 && (o->op_next->op_next->op_flags & OPf_STACKED))
7074 {
d2c45030
AMS		 7075 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7076 o->op_type = OP_RCATLINE;
7077 o->op_flags |= OPf_STACKED;
7078 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 7079 op_null(o->op_next->op_next);
d2c45030 7080 op_null(o->op_next);
89de2904 7081 }
76cd736e 7082
3280af22 7083 o->op_seq = PL_op_seqmax++;
79072805
LW		 7084 break;
7085
a0d0e21e 7086 case OP_MAPWHILE:
79072805
LW		 7087 case OP_GREPWHILE:
7088 case OP_AND:
7089 case OP_OR:
2c2d71f5
JH		 7090 case OP_ANDASSIGN:
7091 case OP_ORASSIGN:
1a67a97c
SM		 7092 case OP_COND_EXPR:
7093 case OP_RANGE:
3280af22 7094 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 7095 while (cLOGOP->op_other->op_type == OP_NULL)
7096 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 7097 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 7098 break;
7099
79072805 7100 case OP_ENTERLOOP:
9c2ca71a 7101 case OP_ENTERITER:
3280af22 7102 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 7103 while (cLOOP->op_redoop->op_type == OP_NULL)
7104 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 7105 peep(cLOOP->op_redoop);
58cccf98
SM		 7106 while (cLOOP->op_nextop->op_type == OP_NULL)
7107 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 7108 peep(cLOOP->op_nextop);
58cccf98
SM		 7109 while (cLOOP->op_lastop->op_type == OP_NULL)
7110 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 7111 peep(cLOOP->op_lastop);
7112 break;
7113
8782bef2 7114 case OP_QR:
79072805
LW		 7115 case OP_MATCH:
7116 case OP_SUBST:
3280af22 7117 o->op_seq = PL_op_seqmax++;
9041c2e3 7118 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 7119 cPMOP->op_pmreplstart->op_type == OP_NULL)
7120 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 7121 peep(cPMOP->op_pmreplstart);
79072805
LW		 7122 break;
7123
a0d0e21e 7124 case OP_EXEC:
3280af22 7125 o->op_seq = PL_op_seqmax++;
1c846c1f 7126 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 7127 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 7128 if (o->op_next->op_sibling &&
20408e3c
GS		 7129 o->op_next->op_sibling->op_type != OP_EXIT &&
7130 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 7131 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 7132 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 7133
57843af0 7134 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
eeb6a2c9
GS		 7135 Perl_warner(aTHX_ WARN_EXEC,
7136 "Statement unlikely to be reached");
7137 Perl_warner(aTHX_ WARN_EXEC,
cc507455 7138 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 7139 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 7140 }
7141 }
7142 break;
aeea060c 7143
c750a3ec
MB		 7144 case OP_HELEM: {
7145 UNOP *rop;
7146 SV *lexname;
7147 GV **fields;
9615e741 7148 SV **svp, **indsvp, *sv;
c750a3ec 7149 I32 ind;
1c846c1f 7150 char *key = NULL;
c750a3ec 7151 STRLEN keylen;
aeea060c 7152
9615e741 7153 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 7154
7155 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 7156 break;
1c846c1f
NIS		 7157
7158 /* Make the CONST have a shared SV */
7159 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 7160 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 7161 key = SvPV(sv, keylen);
25716404
GS		 7162 lexname = newSVpvn_share(key,
7163 SvUTF8(sv) ? -(I32)keylen : keylen,
7164 0);
1c846c1f
NIS		 7165 SvREFCNT_dec(sv);
7166 *svp = lexname;
7167 }
7168
7169 if ((o->op_private & (OPpLVAL_INTRO)))
7170 break;
7171
c750a3ec
MB		 7172 rop = (UNOP*)((BINOP*)o)->op_first;
7173 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7174 break;
3280af22 7175 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
524189f1 7176 if (!(SvFLAGS(lexname) & SVpad_TYPED))
c750a3ec 7177 break;
5196be3e 7178 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
c750a3ec
MB		 7179 if (!fields || !GvHV(*fields))
7180 break;
c750a3ec 7181 key = SvPV(*svp, keylen);
25716404
GS		 7182 indsvp = hv_fetch(GvHV(*fields), key,
7183 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
c750a3ec 7184 if (!indsvp) {
88e9b055 7185 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
2d8e6c8d 7186 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
c750a3ec
MB		 7187 }
7188 ind = SvIV(*indsvp);
7189 if (ind < 1)
cea2e8a9 7190 Perl_croak(aTHX_ "Bad index while coercing array into hash");
c750a3ec 7191 rop->op_type = OP_RV2AV;
22c35a8c 7192 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
c750a3ec 7193 o->op_type = OP_AELEM;
22c35a8c 7194 o->op_ppaddr = PL_ppaddr[OP_AELEM];
9615e741
GS		 7195 sv = newSViv(ind);
7196 if (SvREADONLY(*svp))
7197 SvREADONLY_on(sv);
7198 SvFLAGS(sv) |= (SvFLAGS(*svp)
7199 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
c750a3ec 7200 SvREFCNT_dec(*svp);
9615e741 7201 *svp = sv;
c750a3ec
MB		 7202 break;
7203 }
345599ca
GS		 7204
7205 case OP_HSLICE: {
7206 UNOP *rop;
7207 SV *lexname;
7208 GV **fields;
9615e741 7209 SV **svp, **indsvp, *sv;
345599ca
GS		 7210 I32 ind;
7211 char *key;
7212 STRLEN keylen;
7213 SVOP *first_key_op, *key_op;
9615e741
GS		 7214
7215 o->op_seq = PL_op_seqmax++;
345599ca
GS		 7216 if ((o->op_private & (OPpLVAL_INTRO))
7217 /* I bet there's always a pushmark... */
7218 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7219 /* hmmm, no optimization if list contains only one key. */
7220 break;
7221 rop = (UNOP*)((LISTOP*)o)->op_last;
7222 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7223 break;
7224 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
524189f1 7225 if (!(SvFLAGS(lexname) & SVpad_TYPED))
345599ca
GS		 7226 break;
7227 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7228 if (!fields || !GvHV(*fields))
7229 break;
7230 /* Again guessing that the pushmark can be jumped over.... */
7231 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7232 ->op_first->op_sibling;
7233 /* Check that the key list contains only constants. */
7234 for (key_op = first_key_op; key_op;
7235 key_op = (SVOP*)key_op->op_sibling)
7236 if (key_op->op_type != OP_CONST)
7237 break;
7238 if (key_op)
7239 break;
7240 rop->op_type = OP_RV2AV;
7241 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7242 o->op_type = OP_ASLICE;
7243 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7244 for (key_op = first_key_op; key_op;
7245 key_op = (SVOP*)key_op->op_sibling) {
7246 svp = cSVOPx_svp(key_op);
7247 key = SvPV(*svp, keylen);
25716404
GS		 7248 indsvp = hv_fetch(GvHV(*fields), key,
7249 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
345599ca 7250 if (!indsvp) {
9615e741
GS		 7251 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7252 "in variable %s of type %s",
345599ca
GS		 7253 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7254 }
7255 ind = SvIV(*indsvp);
7256 if (ind < 1)
7257 Perl_croak(aTHX_ "Bad index while coercing array into hash");
9615e741
GS		 7258 sv = newSViv(ind);
7259 if (SvREADONLY(*svp))
7260 SvREADONLY_on(sv);
7261 SvFLAGS(sv) |= (SvFLAGS(*svp)
7262 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
345599ca 7263 SvREFCNT_dec(*svp);
9615e741 7264 *svp = sv;
345599ca
GS		 7265 }
7266 break;
7267 }
c750a3ec 7268
79072805 7269 default:
3280af22 7270 o->op_seq = PL_op_seqmax++;
79072805
LW		 7271 break;
7272 }
a0d0e21e 7273 oldop = o;
79072805 7274 }
a0d0e21e 7275 LEAVE;
79072805 7276}
beab0874 7277
19e8ce8e
AB		 7278
7279
7280char* Perl_custom_op_name(pTHX_ OP* o)
53e06cf0
SC		 7281{
7282 IV index = PTR2IV(o->op_ppaddr);
7283 SV* keysv;
7284 HE* he;
7285
7286 if (!PL_custom_op_names) /* This probably shouldn't happen */
7287 return PL_op_name[OP_CUSTOM];
7288
7289 keysv = sv_2mortal(newSViv(index));
7290
7291 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7292 if (!he)
7293 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7294
7295 return SvPV_nolen(HeVAL(he));
7296}
7297
19e8ce8e 7298char* Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0
SC		 7299{
7300 IV index = PTR2IV(o->op_ppaddr);
7301 SV* keysv;
7302 HE* he;
7303
7304 if (!PL_custom_op_descs)
7305 return PL_op_desc[OP_CUSTOM];
7306
7307 keysv = sv_2mortal(newSViv(index));
7308
7309 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7310 if (!he)
7311 return PL_op_desc[OP_CUSTOM];
7312
7313 return SvPV_nolen(HeVAL(he));
7314}
19e8ce8e 7315
53e06cf0 7316
beab0874
JT		 7317#include "XSUB.h"
7318
7319/* Efficient sub that returns a constant scalar value. */
7320static void
acfe0abc 7321const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 7322{
7323 dXSARGS;
9cbac4c7
DM		 7324 if (items != 0) {
7325#if 0
7326 Perl_croak(aTHX_ "usage: %s::%s()",
7327 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7328#endif
7329 }
9a049f1c 7330 EXTEND(sp, 1);
0768512c 7331 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 7332 XSRETURN(1);
7333}
2b9d42f0 7334
Unnamed repository; edit this file 'description' to name the repository.