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