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