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