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