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