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