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