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
fixup t/op/append.t for UTF-EBCDIC
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
bc89e66f 3 * Copyright (c) 1991-2001, Larry Wall
79072805
LW		 4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e
LW		 8 */
9
10/*
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW		 16 */
17
18#include "EXTERN.h"
864dbfa3 19#define PERL_IN_OP_C
79072805 20#include "perl.h"
77ca0c92 21#include "keywords.h"
79072805 22
b7dc083c 23/* #define PL_OP_SLAB_ALLOC */
7934575e 24
1c846c1f 25#ifdef PL_OP_SLAB_ALLOC
b7dc083c
NIS		 26#define SLAB_SIZE 8192
27static char *PL_OpPtr = NULL;
28static int PL_OpSpace = 0;
29#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
30 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
31 else \
32 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
33 } while (0)
34
1c846c1f 35STATIC void *
cea2e8a9 36S_Slab_Alloc(pTHX_ int m, size_t sz)
1c846c1f 37{
b7dc083c
NIS		 38 Newz(m,PL_OpPtr,SLAB_SIZE,char);
39 PL_OpSpace = SLAB_SIZE - sz;
40 return PL_OpPtr += PL_OpSpace;
41}
76e3520e 42
1c846c1f 43#else
b7dc083c
NIS		 44#define NewOp(m, var, c, type) Newz(m, var, c, type)
45#endif
e50aee73 46/*
5dc0d613 47 * In the following definition, the ", Nullop" is just to make the compiler
a5f75d66 48 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 49 */
11343788 50#define CHECKOP(type,o) \
3280af22 51 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 52 ? ( op_free((OP*)o), \
cea2e8a9 53 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
28757baa 54 Nullop ) \
fc0dc3b3 55 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 56
c53d7c7d 57#define PAD_MAX 999999999
e6438c1a 58#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 59
76e3520e 60STATIC char*
cea2e8a9 61S_gv_ename(pTHX_ GV *gv)
4633a7c4 62{
2d8e6c8d 63 STRLEN n_a;
4633a7c4 64 SV* tmpsv = sv_newmortal();
46fc3d4c 65 gv_efullname3(tmpsv, gv, Nullch);
2d8e6c8d 66 return SvPV(tmpsv,n_a);
4633a7c4
LW		 67}
68
76e3520e 69STATIC OP *
cea2e8a9 70S_no_fh_allowed(pTHX_ OP *o)
79072805 71{
cea2e8a9 72 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
22c35a8c 73 PL_op_desc[o->op_type]));
11343788 74 return o;
79072805
LW		 75}
76
76e3520e 77STATIC OP *
cea2e8a9 78S_too_few_arguments(pTHX_ OP *o, char *name)
79072805 79{
cea2e8a9 80 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 81 return o;
79072805
LW		 82}
83
76e3520e 84STATIC OP *
cea2e8a9 85S_too_many_arguments(pTHX_ OP *o, char *name)
79072805 86{
cea2e8a9 87 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 88 return o;
79072805
LW		 89}
90
76e3520e 91STATIC void
cea2e8a9 92S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
8990e307 93{
cea2e8a9 94 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
22c35a8c 95 (int)n, name, t, PL_op_desc[kid->op_type]));
8990e307
LW		 96}
97
7a52d87a 98STATIC void
cea2e8a9 99S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 100{
5a844595
GS		 101 qerror(Perl_mess(aTHX_
102 "Bareword \"%s\" not allowed while \"strict subs\" in use",
7766f137 103 SvPV_nolen(cSVOPo_sv)));
7a52d87a
GS		 104}
105
79072805
LW		 106/* "register" allocation */
107
108PADOFFSET
864dbfa3 109Perl_pad_allocmy(pTHX_ char *name)
93a17b20 110{
a0d0e21e
LW		 111 PADOFFSET off;
112 SV *sv;
113
155aba94
GS		 114 if (!(PL_in_my == KEY_our ||
115 isALPHA(name[1]) ||
fd400ab9 116 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
155aba94 117 (name[1] == '_' && (int)strlen(name) > 2)))
834a4ddd 118 {
c4d0567e 119 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
2b92dfce
GS		 120 /* 1999-02-27 mjd@plover.com */
121 char *p;
122 p = strchr(name, '\0');
123 /* The next block assumes the buffer is at least 205 chars
124 long. At present, it's always at least 256 chars. */
125 if (p-name > 200) {
126 strcpy(name+200, "...");
127 p = name+199;
128 }
129 else {
130 p[1] = '\0';
131 }
132 /* Move everything else down one character */
133 for (; p-name > 2; p--)
134 *p = *(p-1);
46fc3d4c 135 name[2] = toCTRL(name[1]);
136 name[1] = '^';
137 }
cea2e8a9 138 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 139 }
e476b1b5 140 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
3280af22 141 SV **svp = AvARRAY(PL_comppad_name);
33633739
GS		 142 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
143 PADOFFSET top = AvFILLp(PL_comppad_name);
144 for (off = top; off > PL_comppad_name_floor; off--) {
b1cb66bf 145 if ((sv = svp[off])
3280af22 146 && sv != &PL_sv_undef
c53d7c7d 147 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
33633739
GS		 148 && (PL_in_my != KEY_our
149 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
b1cb66bf 150 && strEQ(name, SvPVX(sv)))
151 {
e476b1b5 152 Perl_warner(aTHX_ WARN_MISC,
1c846c1f 153 "\"%s\" variable %s masks earlier declaration in same %s",
33633739
GS		 154 (PL_in_my == KEY_our ? "our" : "my"),
155 name,
156 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
157 --off;
158 break;
159 }
160 }
161 if (PL_in_my == KEY_our) {
635bab04 162 do {
33633739
GS		 163 if ((sv = svp[off])
164 && sv != &PL_sv_undef
5ce0178e 165 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
33633739
GS		 166 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
167 && strEQ(name, SvPVX(sv)))
f472eb5c 168 {
e476b1b5 169 Perl_warner(aTHX_ WARN_MISC,
33633739 170 "\"our\" variable %s redeclared", name);
e476b1b5 171 Perl_warner(aTHX_ WARN_MISC,
cc507455 172 "\t(Did you mean \"local\" instead of \"our\"?)\n");
33633739 173 break;
f472eb5c 174 }
635bab04 175 } while ( off-- > 0 );
b1cb66bf 176 }
177 }
a0d0e21e
LW		 178 off = pad_alloc(OP_PADSV, SVs_PADMY);
179 sv = NEWSV(1102,0);
93a17b20
LW		 180 sv_upgrade(sv, SVt_PVNV);
181 sv_setpv(sv, name);
3280af22 182 if (PL_in_my_stash) {
c750a3ec 183 if (*name != '$')
eb64745e
GS		 184 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
185 name, PL_in_my == KEY_our ? "our" : "my"));
c750a3ec
MB		 186 SvOBJECT_on(sv);
187 (void)SvUPGRADE(sv, SVt_PVMG);
3280af22
NIS		 188 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
189 PL_sv_objcount++;
c750a3ec 190 }
f472eb5c
GS		 191 if (PL_in_my == KEY_our) {
192 (void)SvUPGRADE(sv, SVt_PVGV);
ef75a179 193 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
77ca0c92 194 SvFLAGS(sv) |= SVpad_OUR;
f472eb5c 195 }
3280af22 196 av_store(PL_comppad_name, off, sv);
65202027 197 SvNVX(sv) = (NV)PAD_MAX;
8990e307 198 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
3280af22
NIS		 199 if (!PL_min_intro_pending)
200 PL_min_intro_pending = off;
201 PL_max_intro_pending = off;
93a17b20 202 if (*name == '@')
3280af22 203 av_store(PL_comppad, off, (SV*)newAV());
93a17b20 204 else if (*name == '%')
3280af22
NIS		 205 av_store(PL_comppad, off, (SV*)newHV());
206 SvPADMY_on(PL_curpad[off]);
93a17b20
LW		 207 return off;
208}
209
94f23f41
GS		 210STATIC PADOFFSET
211S_pad_addlex(pTHX_ SV *proto_namesv)
212{
213 SV *namesv = NEWSV(1103,0);
214 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
215 sv_upgrade(namesv, SVt_PVNV);
216 sv_setpv(namesv, SvPVX(proto_namesv));
217 av_store(PL_comppad_name, newoff, namesv);
218 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
219 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
220 SvFAKE_on(namesv); /* A ref, not a real var */
221 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
222 SvFLAGS(namesv) |= SVpad_OUR;
223 (void)SvUPGRADE(namesv, SVt_PVGV);
224 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
225 }
226 if (SvOBJECT(proto_namesv)) { /* A typed var */
227 SvOBJECT_on(namesv);
228 (void)SvUPGRADE(namesv, SVt_PVMG);
229 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
230 PL_sv_objcount++;
231 }
232 return newoff;
233}
234
2680586e
GS		 235#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
236
76e3520e 237STATIC PADOFFSET
cea2e8a9 238S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
864dbfa3 239 I32 cx_ix, I32 saweval, U32 flags)
93a17b20 240{
748a9306 241 CV *cv;
93a17b20
LW		 242 I32 off;
243 SV *sv;
93a17b20 244 register I32 i;
c09156bb 245 register PERL_CONTEXT *cx;
93a17b20 246
748a9306 247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
4fdae800 248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
748a9306 250 AV *curname;
4fdae800 251
3280af22 252 if (!svp || *svp == &PL_sv_undef)
4633a7c4 253 continue;
748a9306
LW		 254 curname = (AV*)*svp;
255 svp = AvARRAY(curname);
93965878 256 for (off = AvFILLp(curname); off > 0; off--) {
748a9306 257 if ((sv = svp[off]) &&
3280af22 258 sv != &PL_sv_undef &&
748a9306 259 seq <= SvIVX(sv) &&
13826f2c 260 seq > I_32(SvNVX(sv)) &&
748a9306
LW		 261 strEQ(SvPVX(sv), name))
262 {
5f05dabc 263 I32 depth;
264 AV *oldpad;
265 SV *oldsv;
266
267 depth = CvDEPTH(cv);
268 if (!depth) {
9607fc9c 269 if (newoff) {
270 if (SvFAKE(sv))
271 continue;
4fdae800 272 return 0; /* don't clone from inactive stack frame */
9607fc9c 273 }
5f05dabc 274 depth = 1;
275 }
94f23f41 276 oldpad = (AV*)AvARRAY(curlist)[depth];
5f05dabc 277 oldsv = *av_fetch(oldpad, off, TRUE);
748a9306 278 if (!newoff) { /* Not a mere clone operation. */
94f23f41 279 newoff = pad_addlex(sv);
3280af22 280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
28757baa 281 /* "It's closures all the way down." */
3280af22 282 CvCLONE_on(PL_compcv);
54310121 283 if (cv == startcv) {
3280af22 284 if (CvANON(PL_compcv))
54310121 285 oldsv = Nullsv; /* no need to keep ref */
286 }
287 else {
28757baa 288 CV *bcv;
289 for (bcv = startcv;
290 bcv && bcv != cv && !CvCLONE(bcv);
6b35e009
GS		 291 bcv = CvOUTSIDE(bcv))
292 {
94f23f41
GS		 293 if (CvANON(bcv)) {
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
304 pad_addlex(sv);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
307 PL_curpad = ocurpad;
28757baa 308 CvCLONE_on(bcv);
94f23f41 309 }
28757baa 310 else {
6b35e009
GS		 311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
313 {
cea2e8a9 314 Perl_warner(aTHX_ WARN_CLOSURE,
44a8e56a 315 "Variable \"%s\" may be unavailable",
28757baa 316 name);
6b35e009 317 }
28757baa 318 break;
319 }
320 }
321 }
322 }
3280af22 323 else if (!CvUNIQUE(PL_compcv)) {
741b6338
GS		 324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
326 {
cea2e8a9 327 Perl_warner(aTHX_ WARN_CLOSURE,
599cee73 328 "Variable \"%s\" will not stay shared", name);
741b6338 329 }
5f05dabc 330 }
748a9306 331 }
3280af22 332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
748a9306
LW		 333 return newoff;
334 }
93a17b20
LW		 335 }
336 }
337
2680586e
GS		 338 if (flags & FINDLEX_NOSEARCH)
339 return 0;
340
93a17b20
LW		 341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
344 */
345
748a9306 346 for (i = cx_ix; i >= 0; i--) {
93a17b20 347 cx = &cxstack[i];
6b35e009 348 switch (CxTYPE(cx)) {
93a17b20 349 default:
748a9306
LW		 350 if (i == 0 && saweval) {
351 seq = cxstack[saweval].blk_oldcop->cop_seq;
2680586e 352 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
748a9306 353 }
93a17b20
LW		 354 break;
355 case CXt_EVAL:
44a8e56a 356 switch (cx->blk_eval.old_op_type) {
357 case OP_ENTEREVAL:
6b35e009
GS		 358 if (CxREALEVAL(cx))
359 saweval = i;
44a8e56a 360 break;
faa7e5bb 361 case OP_DOFILE:
44a8e56a 362 case OP_REQUIRE:
faa7e5bb 363 /* require/do must have their own scope */
44a8e56a 364 return 0;
365 }
93a17b20 366 break;
7766f137 367 case CXt_FORMAT:
93a17b20
LW		 368 case CXt_SUB:
369 if (!saweval)
370 return 0;
371 cv = cx->blk_sub.cv;
3280af22 372 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
748a9306 373 saweval = i; /* so we know where we were called from */
93a17b20 374 continue;
93a17b20 375 }
748a9306 376 seq = cxstack[saweval].blk_oldcop->cop_seq;
2680586e 377 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
93a17b20
LW		 378 }
379 }
380
748a9306
LW		 381 return 0;
382}
a0d0e21e 383
748a9306 384PADOFFSET
864dbfa3 385Perl_pad_findmy(pTHX_ char *name)
748a9306
LW		 386{
387 I32 off;
54310121 388 I32 pendoff = 0;
748a9306 389 SV *sv;
3280af22
NIS		 390 SV **svp = AvARRAY(PL_comppad_name);
391 U32 seq = PL_cop_seqmax;
6b35e009 392 PERL_CONTEXT *cx;
33b8ce05 393 CV *outside;
748a9306 394
11343788
MB		 395#ifdef USE_THREADS
396 /*
397 * Special case to get lexical (and hence per-thread) @_.
398 * XXX I need to find out how to tell at parse-time whether use
399 * of @_ should refer to a lexical (from a sub) or defgv (global
400 * scope and maybe weird sub-ish things like formats). See
401 * startsub in perly.y. It's possible that @_ could be lexical
402 * (at least from subs) even in non-threaded perl.
403 */
404 if (strEQ(name, "@_"))
405 return 0; /* success. (NOT_IN_PAD indicates failure) */
406#endif /* USE_THREADS */
407
748a9306 408 /* The one we're looking for is probably just before comppad_name_fill. */
3280af22 409 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
a0d0e21e 410 if ((sv = svp[off]) &&
3280af22 411 sv != &PL_sv_undef &&
54310121 412 (!SvIVX(sv) ||
413 (seq <= SvIVX(sv) &&
414 seq > I_32(SvNVX(sv)))) &&
a0d0e21e
LW		 415 strEQ(SvPVX(sv), name))
416 {
77ca0c92 417 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
54310121 418 return (PADOFFSET)off;
419 pendoff = off; /* this pending def. will override import */
a0d0e21e
LW		 420 }
421 }
748a9306 422
33b8ce05
GS		 423 outside = CvOUTSIDE(PL_compcv);
424
425 /* Check if if we're compiling an eval'', and adjust seq to be the
426 * eval's seq number. This depends on eval'' having a non-null
427 * CvOUTSIDE() while it is being compiled. The eval'' itself is
1aff0e91
GS		 428 * identified by CvEVAL being true and CvGV being null. */
429 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
6b35e009
GS		 430 cx = &cxstack[cxstack_ix];
431 if (CxREALEVAL(cx))
432 seq = cx->blk_oldcop->cop_seq;
433 }
434
748a9306 435 /* See if it's in a nested scope */
2680586e 436 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
54310121 437 if (off) {
438 /* If there is a pending local definition, this new alias must die */
439 if (pendoff)
3280af22 440 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
11343788 441 return off; /* pad_findlex returns 0 for failure...*/
54310121 442 }
11343788 443 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
93a17b20
LW		 444}
445
446void
864dbfa3 447Perl_pad_leavemy(pTHX_ I32 fill)
93a17b20
LW		 448{
449 I32 off;
3280af22 450 SV **svp = AvARRAY(PL_comppad_name);
93a17b20 451 SV *sv;
3280af22
NIS		 452 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
453 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
0453d815
PM		 454 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
455 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
8990e307
LW		 456 }
457 }
458 /* "Deintroduce" my variables that are leaving with this scope. */
3280af22 459 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
c53d7c7d 460 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
3280af22 461 SvIVX(sv) = PL_cop_seqmax;
93a17b20
LW		 462 }
463}
464
465PADOFFSET
864dbfa3 466Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
79072805
LW		 467{
468 SV *sv;
469 I32 retval;
470
3280af22 471 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 472 Perl_croak(aTHX_ "panic: pad_alloc");
3280af22 473 if (PL_pad_reset_pending)
a0d0e21e 474 pad_reset();
ed6116ce 475 if (tmptype & SVs_PADMY) {
79072805 476 do {
3280af22 477 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
ed6116ce 478 } while (SvPADBUSY(sv)); /* need a fresh one */
3280af22 479 retval = AvFILLp(PL_comppad);
79072805
LW		 480 }
481 else {
3280af22
NIS		 482 SV **names = AvARRAY(PL_comppad_name);
483 SSize_t names_fill = AvFILLp(PL_comppad_name);
bbce6d69 484 for (;;) {
485 /*
486 * "foreach" index vars temporarily become aliases to non-"my"
487 * values. Thus we must skip, not just pad values that are
488 * marked as current pad values, but also those with names.
489 */
3280af22
NIS		 490 if (++PL_padix <= names_fill &&
491 (sv = names[PL_padix]) && sv != &PL_sv_undef)
bbce6d69 492 continue;
3280af22 493 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
3049cdab
SB		 494 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
495 !IS_PADGV(sv) && !IS_PADCONST(sv))
bbce6d69 496 break;
497 }
3280af22 498 retval = PL_padix;
79072805 499 }
8990e307 500 SvFLAGS(sv) |= tmptype;
3280af22 501 PL_curpad = AvARRAY(PL_comppad);
11343788 502#ifdef USE_THREADS
b900a521
JH		 503 DEBUG_X(PerlIO_printf(Perl_debug_log,
504 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
505 PTR2UV(thr), PTR2UV(PL_curpad),
22c35a8c 506 (long) retval, PL_op_name[optype]));
11343788 507#else
b900a521
JH		 508 DEBUG_X(PerlIO_printf(Perl_debug_log,
509 "Pad 0x%"UVxf" alloc %ld for %s\n",
510 PTR2UV(PL_curpad),
22c35a8c 511 (long) retval, PL_op_name[optype]));
11343788 512#endif /* USE_THREADS */
79072805
LW		 513 return (PADOFFSET)retval;
514}
515
516SV *
864dbfa3 517Perl_pad_sv(pTHX_ PADOFFSET po)
79072805 518{
11343788 519#ifdef USE_THREADS
b900a521 520 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH		 521 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
522 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 523#else
79072805 524 if (!po)
cea2e8a9 525 Perl_croak(aTHX_ "panic: pad_sv po");
97835f67
JH		 526 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
527 PTR2UV(PL_curpad), (IV)po));
11343788 528#endif /* USE_THREADS */
3280af22 529 return PL_curpad[po]; /* eventually we'll turn this into a macro */
79072805
LW		 530}
531
532void
864dbfa3 533Perl_pad_free(pTHX_ PADOFFSET po)
79072805 534{
3280af22 535 if (!PL_curpad)
a0d0e21e 536 return;
3280af22 537 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 538 Perl_croak(aTHX_ "panic: pad_free curpad");
79072805 539 if (!po)
cea2e8a9 540 Perl_croak(aTHX_ "panic: pad_free po");
11343788 541#ifdef USE_THREADS
b900a521 542 DEBUG_X(PerlIO_printf(Perl_debug_log,
7766f137 543 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
f1dbda3d 544 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 545#else
97835f67
JH		 546 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
547 PTR2UV(PL_curpad), (IV)po));
11343788 548#endif /* USE_THREADS */
2aa1bedc 549 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
3280af22 550 SvPADTMP_off(PL_curpad[po]);
2aa1bedc
GS		 551#ifdef USE_ITHREADS
552 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
553#endif
554 }
3280af22
NIS		 555 if ((I32)po < PL_padix)
556 PL_padix = po - 1;
79072805
LW		 557}
558
559void
864dbfa3 560Perl_pad_swipe(pTHX_ PADOFFSET po)
79072805 561{
3280af22 562 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 563 Perl_croak(aTHX_ "panic: pad_swipe curpad");
79072805 564 if (!po)
cea2e8a9 565 Perl_croak(aTHX_ "panic: pad_swipe po");
11343788 566#ifdef USE_THREADS
b900a521 567 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH		 568 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
569 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 570#else
97835f67
JH		 571 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
572 PTR2UV(PL_curpad), (IV)po));
11343788 573#endif /* USE_THREADS */
3280af22
NIS		 574 SvPADTMP_off(PL_curpad[po]);
575 PL_curpad[po] = NEWSV(1107,0);
576 SvPADTMP_on(PL_curpad[po]);
577 if ((I32)po < PL_padix)
578 PL_padix = po - 1;
79072805
LW		 579}
580
d9bb4600
GS		 581/* XXX pad_reset() is currently disabled because it results in serious bugs.
582 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
583 * on the stack by OPs that use them, there are several ways to get an alias
584 * to a shared TARG. Such an alias will change randomly and unpredictably.
585 * We avoid doing this until we can think of a Better Way.
586 * GSAR 97-10-29 */
79072805 587void
864dbfa3 588Perl_pad_reset(pTHX)
79072805 589{
d9bb4600 590#ifdef USE_BROKEN_PAD_RESET
79072805
LW		 591 register I32 po;
592
6b88bc9c 593 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 594 Perl_croak(aTHX_ "panic: pad_reset curpad");
11343788 595#ifdef USE_THREADS
b900a521
JH		 596 DEBUG_X(PerlIO_printf(Perl_debug_log,
597 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
598 PTR2UV(thr), PTR2UV(PL_curpad)));
11343788 599#else
b900a521
JH		 600 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
601 PTR2UV(PL_curpad)));
11343788 602#endif /* USE_THREADS */
6b88bc9c
GS		 603 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
604 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
605 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
606 SvPADTMP_off(PL_curpad[po]);
748a9306 607 }
6b88bc9c 608 PL_padix = PL_padix_floor;
79072805 609 }
d9bb4600 610#endif
3280af22 611 PL_pad_reset_pending = FALSE;
79072805
LW		 612}
613
a863c7d1 614#ifdef USE_THREADS
54b9620d 615/* find_threadsv is not reentrant */
a863c7d1 616PADOFFSET
864dbfa3 617Perl_find_threadsv(pTHX_ const char *name)
a863c7d1 618{
a863c7d1
MB		 619 char *p;
620 PADOFFSET key;
554b3eca 621 SV **svp;
54b9620d 622 /* We currently only handle names of a single character */
533c011a 623 p = strchr(PL_threadsv_names, *name);
a863c7d1
MB		 624 if (!p)
625 return NOT_IN_PAD;
533c011a 626 key = p - PL_threadsv_names;
2d8e6c8d 627 MUTEX_LOCK(&thr->mutex);
54b9620d 628 svp = av_fetch(thr->threadsv, key, FALSE);
2d8e6c8d
GS		 629 if (svp)
630 MUTEX_UNLOCK(&thr->mutex);
631 else {
554b3eca 632 SV *sv = NEWSV(0, 0);
54b9620d 633 av_store(thr->threadsv, key, sv);
940cb80d 634 thr->threadsvp = AvARRAY(thr->threadsv);
2d8e6c8d 635 MUTEX_UNLOCK(&thr->mutex);
554b3eca
MB		 636 /*
637 * Some magic variables used to be automagically initialised
638 * in gv_fetchpv. Those which are now per-thread magicals get
639 * initialised here instead.
640 */
641 switch (*name) {
54b9620d
MB		 642 case '_':
643 break;
554b3eca
MB		 644 case ';':
645 sv_setpv(sv, "\034");
1c846c1f 646 sv_magic(sv, 0, 0, name, 1);
554b3eca 647 break;
c277df42
IZ		 648 case '&':
649 case '`':
650 case '\'':
533c011a 651 PL_sawampersand = TRUE;
a3f914c5
GS		 652 /* FALL THROUGH */
653 case '1':
654 case '2':
655 case '3':
656 case '4':
657 case '5':
658 case '6':
659 case '7':
660 case '8':
661 case '9':
c277df42 662 SvREADONLY_on(sv);
d8b5173a 663 /* FALL THROUGH */
067391ea
GS		 664
665 /* XXX %! tied to Errno.pm needs to be added here.
666 * See gv_fetchpv(). */
667 /* case '!': */
668
54b9620d 669 default:
1c846c1f 670 sv_magic(sv, 0, 0, name, 1);
554b3eca 671 }
bf49b057 672 DEBUG_S(PerlIO_printf(Perl_error_log,
54b9620d 673 "find_threadsv: new SV %p for $%s%c\n",
554b3eca
MB		 674 sv, (*name < 32) ? "^" : "",
675 (*name < 32) ? toCTRL(*name) : *name));
a863c7d1
MB		 676 }
677 return key;
678}
679#endif /* USE_THREADS */
680
79072805
LW		 681/* Destructor */
682
683void
864dbfa3 684Perl_op_free(pTHX_ OP *o)
79072805 685{
85e6fe83 686 register OP *kid, *nextkid;
acb36ea4 687 OPCODE type;
79072805 688
5dc0d613 689 if (!o || o->op_seq == (U16)-1)
79072805
LW		 690 return;
691
7934575e
GS		 692 if (o->op_private & OPpREFCOUNTED) {
693 switch (o->op_type) {
694 case OP_LEAVESUB:
695 case OP_LEAVESUBLV:
696 case OP_LEAVEEVAL:
697 case OP_LEAVE:
698 case OP_SCOPE:
699 case OP_LEAVEWRITE:
700 OP_REFCNT_LOCK;
701 if (OpREFCNT_dec(o)) {
702 OP_REFCNT_UNLOCK;
703 return;
704 }
705 OP_REFCNT_UNLOCK;
706 break;
707 default:
708 break;
709 }
710 }
711
11343788
MB		 712 if (o->op_flags & OPf_KIDS) {
713 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 714 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 715 op_free(kid);
85e6fe83 716 }
79072805 717 }
acb36ea4
GS		 718 type = o->op_type;
719 if (type == OP_NULL)
720 type = o->op_targ;
721
722 /* COP* is not cleared by op_clear() so that we may track line
723 * numbers etc even after null() */
724 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
725 cop_free((COP*)o);
726
727 op_clear(o);
728
729#ifdef PL_OP_SLAB_ALLOC
730 if ((char *) o == PL_OpPtr)
731 {
732 }
733#else
734 Safefree(o);
735#endif
736}
79072805 737
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 }
a2c090b3 4219 CvFLAGS(cv) = 0;
79072805
LW		 4220}
4221
9cbac4c7 4222#ifdef DEBUG_CLOSURES
76e3520e 4223STATIC void
743e66e6 4224S_cv_dump(pTHX_ CV *cv)
5f05dabc 4225{
62fde642 4226#ifdef DEBUGGING
5f05dabc 4227 CV *outside = CvOUTSIDE(cv);
4228 AV* padlist = CvPADLIST(cv);
4fdae800 4229 AV* pad_name;
4230 AV* pad;
4231 SV** pname;
4232 SV** ppad;
5f05dabc 4233 I32 ix;
4234
b900a521
JH		 4235 PerlIO_printf(Perl_debug_log,
4236 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4237 PTR2UV(cv),
ab50184a 4238 (CvANON(cv) ? "ANON"
6b88bc9c 4239 : (cv == PL_main_cv) ? "MAIN"
33b8ce05 4240 : CvUNIQUE(cv) ? "UNIQUE"
44a8e56a 4241 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
b900a521 4242 PTR2UV(outside),
ab50184a
CS		 4243 (!outside ? "null"
4244 : CvANON(outside) ? "ANON"
6b88bc9c 4245 : (outside == PL_main_cv) ? "MAIN"
07055b4c 4246 : CvUNIQUE(outside) ? "UNIQUE"
44a8e56a 4247 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
5f05dabc 4248
4fdae800 4249 if (!padlist)
4250 return;
4251
4252 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4253 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4254 pname = AvARRAY(pad_name);
4255 ppad = AvARRAY(pad);
4256
93965878 4257 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
5f05dabc 4258 if (SvPOK(pname[ix]))
b900a521
JH		 4259 PerlIO_printf(Perl_debug_log,
4260 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
894356b3 4261 (int)ix, PTR2UV(ppad[ix]),
4fdae800 4262 SvFAKE(pname[ix]) ? "FAKE " : "",
4263 SvPVX(pname[ix]),
b900a521
JH		 4264 (IV)I_32(SvNVX(pname[ix])),
4265 SvIVX(pname[ix]));
5f05dabc 4266 }
743e66e6 4267#endif /* DEBUGGING */
62fde642 4268}
9cbac4c7 4269#endif /* DEBUG_CLOSURES */
5f05dabc 4270
76e3520e 4271STATIC CV *
cea2e8a9 4272S_cv_clone2(pTHX_ CV *proto, CV *outside)
748a9306
LW		 4273{
4274 AV* av;
4275 I32 ix;
4276 AV* protopadlist = CvPADLIST(proto);
4277 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4278 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
5f05dabc 4279 SV** pname = AvARRAY(protopad_name);
4280 SV** ppad = AvARRAY(protopad);
93965878
NIS		 4281 I32 fname = AvFILLp(protopad_name);
4282 I32 fpad = AvFILLp(protopad);
748a9306
LW		 4283 AV* comppadlist;
4284 CV* cv;
4285
07055b4c
CS		 4286 assert(!CvUNIQUE(proto));
4287
748a9306 4288 ENTER;
354992b1 4289 SAVECOMPPAD();
3280af22
NIS		 4290 SAVESPTR(PL_comppad_name);
4291 SAVESPTR(PL_compcv);
748a9306 4292
3280af22 4293 cv = PL_compcv = (CV*)NEWSV(1104,0);
fa83b5b6 4294 sv_upgrade((SV *)cv, SvTYPE(proto));
a57ec3bd 4295 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
a5f75d66 4296 CvCLONED_on(cv);
748a9306 4297
11343788 4298#ifdef USE_THREADS
12ca11f6 4299 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 4300 MUTEX_INIT(CvMUTEXP(cv));
11343788
MB		 4301 CvOWNER(cv) = 0;
4302#endif /* USE_THREADS */
57843af0 4303 CvFILE(cv) = CvFILE(proto);
65c50114 4304 CvGV(cv) = CvGV(proto);
748a9306 4305 CvSTASH(cv) = CvSTASH(proto);
282f25c9 4306 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
748a9306 4307 CvSTART(cv) = CvSTART(proto);
5f05dabc 4308 if (outside)
4309 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
748a9306 4310
68dc0745 4311 if (SvPOK(proto))
4312 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4313
3280af22 4314 PL_comppad_name = newAV();
46fc3d4c 4315 for (ix = fname; ix >= 0; ix--)
3280af22 4316 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
748a9306 4317
3280af22 4318 PL_comppad = newAV();
748a9306
LW		 4319
4320 comppadlist = newAV();
4321 AvREAL_off(comppadlist);
3280af22
NIS		 4322 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4323 av_store(comppadlist, 1, (SV*)PL_comppad);
748a9306 4324 CvPADLIST(cv) = comppadlist;
3280af22
NIS		 4325 av_fill(PL_comppad, AvFILLp(protopad));
4326 PL_curpad = AvARRAY(PL_comppad);
748a9306
LW		 4327
4328 av = newAV(); /* will be @_ */
4329 av_extend(av, 0);
3280af22 4330 av_store(PL_comppad, 0, (SV*)av);
748a9306
LW		 4331 AvFLAGS(av) = AVf_REIFY;
4332
9607fc9c 4333 for (ix = fpad; ix > 0; ix--) {
4334 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
3280af22 4335 if (namesv && namesv != &PL_sv_undef) {
aa689395 4336 char *name = SvPVX(namesv); /* XXX */
4337 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4338 I32 off = pad_findlex(name, ix, SvIVX(namesv),
2680586e 4339 CvOUTSIDE(cv), cxstack_ix, 0, 0);
5f05dabc 4340 if (!off)
3280af22 4341 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
5f05dabc 4342 else if (off != ix)
cea2e8a9 4343 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
748a9306
LW		 4344 }
4345 else { /* our own lexical */
aa689395 4346 SV* sv;
5f05dabc 4347 if (*name == '&') {
4348 /* anon code -- we'll come back for it */
4349 sv = SvREFCNT_inc(ppad[ix]);
4350 }
4351 else if (*name == '@')
4352 sv = (SV*)newAV();
748a9306 4353 else if (*name == '%')
5f05dabc 4354 sv = (SV*)newHV();
748a9306 4355 else
5f05dabc 4356 sv = NEWSV(0,0);
4357 if (!SvPADBUSY(sv))
4358 SvPADMY_on(sv);
3280af22 4359 PL_curpad[ix] = sv;
748a9306
LW		 4360 }
4361 }
7766f137 4362 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
743e66e6
GS		 4363 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4364 }
748a9306 4365 else {
aa689395 4366 SV* sv = NEWSV(0,0);
748a9306 4367 SvPADTMP_on(sv);
3280af22 4368 PL_curpad[ix] = sv;
748a9306
LW		 4369 }
4370 }
4371
5f05dabc 4372 /* Now that vars are all in place, clone nested closures. */
4373
9607fc9c 4374 for (ix = fpad; ix > 0; ix--) {
4375 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
aa689395 4376 if (namesv
3280af22 4377 && namesv != &PL_sv_undef
aa689395 4378 && !(SvFLAGS(namesv) & SVf_FAKE)
4379 && *SvPVX(namesv) == '&'
5f05dabc 4380 && CvCLONE(ppad[ix]))
4381 {
4382 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4383 SvREFCNT_dec(ppad[ix]);
4384 CvCLONE_on(kid);
4385 SvPADMY_on(kid);
3280af22 4386 PL_curpad[ix] = (SV*)kid;
748a9306
LW		 4387 }
4388 }
4389
5f05dabc 4390#ifdef DEBUG_CLOSURES
ab50184a
CS		 4391 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4392 cv_dump(outside);
4393 PerlIO_printf(Perl_debug_log, " from:\n");
5f05dabc 4394 cv_dump(proto);
ab50184a 4395 PerlIO_printf(Perl_debug_log, " to:\n");
5f05dabc 4396 cv_dump(cv);
4397#endif
4398
748a9306 4399 LEAVE;
beab0874
JT		 4400
4401 if (CvCONST(cv)) {
4402 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4403 assert(const_sv);
4404 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4405 SvREFCNT_dec(cv);
4406 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4407 }
4408
748a9306
LW		 4409 return cv;
4410}
4411
4412CV *
864dbfa3 4413Perl_cv_clone(pTHX_ CV *proto)
5f05dabc 4414{
b099ddc0 4415 CV *cv;
1feb2720 4416 LOCK_CRED_MUTEX; /* XXX create separate mutex */
b099ddc0 4417 cv = cv_clone2(proto, CvOUTSIDE(proto));
1feb2720 4418 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
b099ddc0 4419 return cv;
5f05dabc 4420}
4421
3fe9a6f1 4422void
864dbfa3 4423Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 4424{
e476b1b5 4425 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 4426 SV* msg = sv_newmortal();
3fe9a6f1 4427 SV* name = Nullsv;
4428
4429 if (gv)
46fc3d4c 4430 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4431 sv_setpv(msg, "Prototype mismatch:");
4432 if (name)
894356b3 4433 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 4434 if (SvPOK(cv))
cea2e8a9 4435 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
46fc3d4c 4436 sv_catpv(msg, " vs ");
4437 if (p)
cea2e8a9 4438 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 4439 else
4440 sv_catpv(msg, "none");
e476b1b5 4441 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
3fe9a6f1 4442 }
4443}
4444
beab0874
JT		 4445static void const_sv_xsub(pTHXo_ CV* cv);
4446
4447/*
4448=for apidoc cv_const_sv
4449
4450If C<cv> is a constant sub eligible for inlining. returns the constant
4451value returned by the sub. Otherwise, returns NULL.
4452
4453Constant subs can be created with C<newCONSTSUB> or as described in
4454L<perlsub/"Constant Functions">.
4455
4456=cut
4457*/
760ac839 4458SV *
864dbfa3 4459Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 4460{
beab0874 4461 if (!cv || !CvCONST(cv))
54310121 4462 return Nullsv;
beab0874 4463 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 4464}
760ac839 4465
fe5e78ed 4466SV *
864dbfa3 4467Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 4468{
4469 SV *sv = Nullsv;
4470
0f79a09d 4471 if (!o)
fe5e78ed 4472 return Nullsv;
1c846c1f
NIS		 4473
4474 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 4475 o = cLISTOPo->op_first->op_sibling;
4476
4477 for (; o; o = o->op_next) {
54310121 4478 OPCODE type = o->op_type;
fe5e78ed 4479
1c846c1f 4480 if (sv && o->op_next == o)
fe5e78ed 4481 return sv;
e576b457
JT		 4482 if (o->op_next != o) {
4483 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4484 continue;
4485 if (type == OP_DBSTATE)
4486 continue;
4487 }
54310121 4488 if (type == OP_LEAVESUB || type == OP_RETURN)
4489 break;
4490 if (sv)
4491 return Nullsv;
7766f137 4492 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 4493 sv = cSVOPo->op_sv;
7766f137 4494 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
e858de61
MB		 4495 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4496 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
beab0874
JT		 4497 if (!sv)
4498 return Nullsv;
4499 if (CvCONST(cv)) {
4500 /* We get here only from cv_clone2() while creating a closure.
4501 Copy the const value here instead of in cv_clone2 so that
4502 SvREADONLY_on doesn't lead to problems when leaving
4503 scope.
4504 */
4505 sv = newSVsv(sv);
4506 }
4507 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
54310121 4508 return Nullsv;
760ac839 4509 }
54310121 4510 else
4511 return Nullsv;
760ac839 4512 }
5aabfad6 4513 if (sv)
4514 SvREADONLY_on(sv);
760ac839
LW		 4515 return sv;
4516}
4517
09bef843
SB		 4518void
4519Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4520{
4521 if (o)
4522 SAVEFREEOP(o);
4523 if (proto)
4524 SAVEFREEOP(proto);
4525 if (attrs)
4526 SAVEFREEOP(attrs);
4527 if (block)
4528 SAVEFREEOP(block);
4529 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4530}
4531
748a9306 4532CV *
864dbfa3 4533Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 4534{
09bef843
SB		 4535 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4536}
4537
4538CV *
4539Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4540{
2d8e6c8d 4541 STRLEN n_a;
83ee9e09
GS		 4542 char *name;
4543 char *aname;
4544 GV *gv;
2d8e6c8d 4545 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 4546 register CV *cv=0;
a0d0e21e 4547 I32 ix;
beab0874 4548 SV *const_sv;
79072805 4549
83ee9e09
GS		 4550 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4551 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4552 SV *sv = sv_newmortal();
4553 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4554 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4555 aname = SvPVX(sv);
4556 }
4557 else
4558 aname = Nullch;
4559 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4560 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4561 SVt_PVCV);
4562
11343788 4563 if (o)
5dc0d613 4564 SAVEFREEOP(o);
3fe9a6f1 4565 if (proto)
4566 SAVEFREEOP(proto);
09bef843
SB		 4567 if (attrs)
4568 SAVEFREEOP(attrs);
3fe9a6f1 4569
09bef843 4570 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4571 maximum a prototype before. */
4572 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4573 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4574 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4575 {
e476b1b5 4576 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
f248d071 4577 }
55d729e4
GS		 4578 cv_ckproto((CV*)gv, NULL, ps);
4579 }
4580 if (ps)
4581 sv_setpv((SV*)gv, ps);
4582 else
4583 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4584 SvREFCNT_dec(PL_compcv);
4585 cv = PL_compcv = NULL;
4586 PL_sub_generation++;
beab0874 4587 goto done;
55d729e4
GS		 4588 }
4589
beab0874
JT		 4590 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4591
5bd07a3d
DM		 4592#ifdef GV_SHARED_CHECK
4593 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4594 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4595 }
4596#endif
4597
beab0874
JT		 4598 if (!block || !ps || *ps || attrs)
4599 const_sv = Nullsv;
4600 else
4601 const_sv = op_const_sv(block, Nullcv);
4602
4603 if (cv) {
60ed1d8c 4604 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d
DM		 4605
4606#ifdef GV_SHARED_CHECK
4607 if (exists && GvSHARED(gv)) {
4608 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4609 }
4610#endif
4611
60ed1d8c
GS		 4612 /* if the subroutine doesn't exist and wasn't pre-declared
4613 * with a prototype, assume it will be AUTOLOADed,
4614 * skipping the prototype check
4615 */
4616 if (exists || SvPOK(cv))
01ec43d0 4617 cv_ckproto(cv, gv, ps);
68dc0745 4618 /* already defined (or promised)? */
60ed1d8c 4619 if (exists || GvASSUMECV(gv)) {
09bef843 4620 if (!block && !attrs) {
aa689395 4621 /* just a "sub foo;" when &foo is already defined */
3280af22 4622 SAVEFREESV(PL_compcv);
aa689395 4623 goto done;
4624 }
7bac28a0 4625 /* ahem, death to those who redefine active sort subs */
3280af22 4626 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4627 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4628 if (block) {
4629 if (ckWARN(WARN_REDEFINE)
4630 || (CvCONST(cv)
4631 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4632 {
4633 line_t oldline = CopLINE(PL_curcop);
4634 CopLINE_set(PL_curcop, PL_copline);
4635 Perl_warner(aTHX_ WARN_REDEFINE,
4636 CvCONST(cv) ? "Constant subroutine %s redefined"
4637 : "Subroutine %s redefined", name);
4638 CopLINE_set(PL_curcop, oldline);
4639 }
4640 SvREFCNT_dec(cv);
4641 cv = Nullcv;
79072805 4642 }
79072805
LW		 4643 }
4644 }
beab0874
JT		 4645 if (const_sv) {
4646 SvREFCNT_inc(const_sv);
4647 if (cv) {
0768512c 4648 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4649 sv_setpv((SV*)cv, ""); /* prototype is "" */
4650 CvXSUBANY(cv).any_ptr = const_sv;
4651 CvXSUB(cv) = const_sv_xsub;
4652 CvCONST_on(cv);
beab0874
JT		 4653 }
4654 else {
4655 GvCV(gv) = Nullcv;
4656 cv = newCONSTSUB(NULL, name, const_sv);
4657 }
4658 op_free(block);
4659 SvREFCNT_dec(PL_compcv);
4660 PL_compcv = NULL;
4661 PL_sub_generation++;
4662 goto done;
4663 }
09bef843
SB		 4664 if (attrs) {
4665 HV *stash;
4666 SV *rcv;
4667
4668 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4669 * before we clobber PL_compcv.
4670 */
4671 if (cv && !block) {
4672 rcv = (SV*)cv;
4673 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4674 stash = GvSTASH(CvGV(cv));
4675 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4676 stash = CvSTASH(cv);
4677 else
4678 stash = PL_curstash;
4679 }
4680 else {
4681 /* possibly about to re-define existing subr -- ignore old cv */
4682 rcv = (SV*)PL_compcv;
4683 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4684 stash = GvSTASH(gv);
4685 else
4686 stash = PL_curstash;
4687 }
4688 apply_attrs(stash, rcv, attrs);
4689 }
a0d0e21e 4690 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4691 if (!block) {
4692 /* got here with just attrs -- work done, so bug out */
4693 SAVEFREESV(PL_compcv);
4694 goto done;
4695 }
4633a7c4 4696 cv_undef(cv);
3280af22
NIS		 4697 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4698 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4699 CvOUTSIDE(PL_compcv) = 0;
4700 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4701 CvPADLIST(PL_compcv) = 0;
282f25c9
JH		 4702 /* inner references to PL_compcv must be fixed up ... */
4703 {
4704 AV *padlist = CvPADLIST(cv);
4705 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4706 AV *comppad = (AV*)AvARRAY(padlist)[1];
4707 SV **namepad = AvARRAY(comppad_name);
4708 SV **curpad = AvARRAY(comppad);
4709 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4710 SV *namesv = namepad[ix];
4711 if (namesv && namesv != &PL_sv_undef
4712 && *SvPVX(namesv) == '&')
4713 {
4714 CV *innercv = (CV*)curpad[ix];
4715 if (CvOUTSIDE(innercv) == PL_compcv) {
4716 CvOUTSIDE(innercv) = cv;
4717 if (!CvANON(innercv) || CvCLONED(innercv)) {
4718 (void)SvREFCNT_inc(cv);
4719 SvREFCNT_dec(PL_compcv);
4720 }
4721 }
4722 }
4723 }
4724 }
4725 /* ... before we throw it away */
3280af22 4726 SvREFCNT_dec(PL_compcv);
a0d0e21e
LW		 4727 }
4728 else {
3280af22 4729 cv = PL_compcv;
44a8e56a 4730 if (name) {
4731 GvCV(gv) = cv;
4732 GvCVGEN(gv) = 0;
3280af22 4733 PL_sub_generation++;
44a8e56a 4734 }
a0d0e21e 4735 }
65c50114 4736 CvGV(cv) = gv;
57843af0 4737 CvFILE(cv) = CopFILE(PL_curcop);
3280af22 4738 CvSTASH(cv) = PL_curstash;
11343788
MB		 4739#ifdef USE_THREADS
4740 CvOWNER(cv) = 0;
1cfa4ec7 4741 if (!CvMUTEXP(cv)) {
f6aaf501 4742 New(666, CvMUTEXP(cv), 1, perl_mutex);
1cfa4ec7
GS		 4743 MUTEX_INIT(CvMUTEXP(cv));
4744 }
11343788 4745#endif /* USE_THREADS */
8990e307 4746
3fe9a6f1 4747 if (ps)
4748 sv_setpv((SV*)cv, ps);
4633a7c4 4749
3280af22 4750 if (PL_error_count) {
c07a80fd 4751 op_free(block);
4752 block = Nullop;
68dc0745 4753 if (name) {
4754 char *s = strrchr(name, ':');
4755 s = s ? s+1 : name;
6d4c2119
CS		 4756 if (strEQ(s, "BEGIN")) {
4757 char *not_safe =
4758 "BEGIN not safe after errors--compilation aborted";
faef0170 4759 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4760 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4761 else {
4762 /* force display of errors found but not reported */
38a03e6e 4763 sv_catpv(ERRSV, not_safe);
cea2e8a9 4764 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
6d4c2119
CS		 4765 }
4766 }
68dc0745 4767 }
c07a80fd 4768 }
beab0874
JT		 4769 if (!block)
4770 goto done;
a0d0e21e 4771
3280af22
NIS		 4772 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4773 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
a0d0e21e 4774
7766f137 4775 if (CvLVALUE(cv)) {
78f9721b
SM		 4776 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4777 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4778 }
4779 else {
4780 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4781 }
4782 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4783 OpREFCNT_set(CvROOT(cv), 1);
4784 CvSTART(cv) = LINKLIST(CvROOT(cv));
4785 CvROOT(cv)->op_next = 0;
4786 peep(CvSTART(cv));
4787
4788 /* now that optimizer has done its work, adjust pad values */
54310121 4789 if (CvCLONE(cv)) {
3280af22
NIS		 4790 SV **namep = AvARRAY(PL_comppad_name);
4791 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
54310121 4792 SV *namesv;
4793
7766f137 4794 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
54310121 4795 continue;
4796 /*
4797 * The only things that a clonable function needs in its
4798 * pad are references to outer lexicals and anonymous subs.
4799 * The rest are created anew during cloning.
4800 */
4801 if (!((namesv = namep[ix]) != Nullsv &&
3280af22 4802 namesv != &PL_sv_undef &&
54310121 4803 (SvFAKE(namesv) ||
4804 *SvPVX(namesv) == '&')))
4805 {
3280af22
NIS		 4806 SvREFCNT_dec(PL_curpad[ix]);
4807 PL_curpad[ix] = Nullsv;
54310121 4808 }
4809 }
beab0874
JT		 4810 assert(!CvCONST(cv));
4811 if (ps && !*ps && op_const_sv(block, cv))
4812 CvCONST_on(cv);
a0d0e21e 4813 }
54310121 4814 else {
4815 AV *av = newAV(); /* Will be @_ */
4816 av_extend(av, 0);
3280af22 4817 av_store(PL_comppad, 0, (SV*)av);
54310121 4818 AvFLAGS(av) = AVf_REIFY;
79072805 4819
3280af22 4820 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
7766f137 4821 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
54310121 4822 continue;
3280af22
NIS		 4823 if (!SvPADMY(PL_curpad[ix]))
4824 SvPADTMP_on(PL_curpad[ix]);
54310121 4825 }
4826 }
79072805 4827
282f25c9
JH		 4828 /* If a potential closure prototype, don't keep a refcount on outer CV.
4829 * This is okay as the lifetime of the prototype is tied to the
4830 * lifetime of the outer CV. Avoids memory leak due to reference
4831 * loop. --GSAR */
4832 if (!name)
4833 SvREFCNT_dec(CvOUTSIDE(cv));
4834
83ee9e09 4835 if (name || aname) {
44a8e56a 4836 char *s;
83ee9e09 4837 char *tname = (name ? name : aname);
44a8e56a 4838
3280af22 4839 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 4840 SV *sv = NEWSV(0,0);
44a8e56a 4841 SV *tmpstr = sv_newmortal();
549bb64a 4842 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 4843 CV *pcv;
44a8e56a 4844 HV *hv;
4845
ed094faf
GS		 4846 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4847 CopFILE(PL_curcop),
cc49e20b 4848 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4849 gv_efullname3(tmpstr, gv, Nullch);
3280af22 4850 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4851 hv = GvHVn(db_postponed);
9607fc9c 4852 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 4853 && (pcv = GvCV(db_postponed)))
4854 {
44a8e56a 4855 dSP;
924508f0 4856 PUSHMARK(SP);
44a8e56a 4857 XPUSHs(tmpstr);
4858 PUTBACK;
83ee9e09 4859 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 4860 }
4861 }
79072805 4862
83ee9e09 4863 if ((s = strrchr(tname,':')))
28757baa 4864 s++;
4865 else
83ee9e09 4866 s = tname;
ed094faf 4867
7d30b5c4 4868 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4869 goto done;
4870
68dc0745 4871 if (strEQ(s, "BEGIN")) {
3280af22 4872 I32 oldscope = PL_scopestack_ix;
28757baa 4873 ENTER;
57843af0
GS		 4874 SAVECOPFILE(&PL_compiling);
4875 SAVECOPLINE(&PL_compiling);
3280af22
NIS		 4876 save_svref(&PL_rs);
4877 sv_setsv(PL_rs, PL_nrs);
28757baa 4878
3280af22
NIS		 4879 if (!PL_beginav)
4880 PL_beginav = newAV();
28757baa 4881 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4882 av_push(PL_beginav, (SV*)cv);
4883 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4884 call_list(oldscope, PL_beginav);
a6006777 4885
3280af22 4886 PL_curcop = &PL_compiling;
a0ed51b3 4887 PL_compiling.op_private = PL_hints;
28757baa 4888 LEAVE;
4889 }
3280af22
NIS		 4890 else if (strEQ(s, "END") && !PL_error_count) {
4891 if (!PL_endav)
4892 PL_endav = newAV();
ed094faf 4893 DEBUG_x( dump_sub(gv) );
3280af22 4894 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4895 av_store(PL_endav, 0, (SV*)cv);
4896 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4897 }
7d30b5c4
GS		 4898 else if (strEQ(s, "CHECK") && !PL_error_count) {
4899 if (!PL_checkav)
4900 PL_checkav = newAV();
ed094faf 4901 DEBUG_x( dump_sub(gv) );
ddda08b7
GS		 4902 if (PL_main_start && ckWARN(WARN_VOID))
4903 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
7d30b5c4 4904 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4905 av_store(PL_checkav, 0, (SV*)cv);
4906 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4907 }
3280af22
NIS		 4908 else if (strEQ(s, "INIT") && !PL_error_count) {
4909 if (!PL_initav)
4910 PL_initav = newAV();
ed094faf 4911 DEBUG_x( dump_sub(gv) );
ddda08b7
GS		 4912 if (PL_main_start && ckWARN(WARN_VOID))
4913 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
ea2f84a3
GS		 4914 av_push(PL_initav, (SV*)cv);
4915 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4916 }
79072805 4917 }
a6006777 4918
aa689395 4919 done:
3280af22 4920 PL_copline = NOLINE;
8990e307 4921 LEAVE_SCOPE(floor);
a0d0e21e 4922 return cv;
79072805
LW		 4923}
4924
b099ddc0 4925/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4926/*
4927=for apidoc newCONSTSUB
4928
4929Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4930eligible for inlining at compile-time.
4931
4932=cut
4933*/
4934
beab0874 4935CV *
864dbfa3 4936Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 4937{
beab0874 4938 CV* cv;
5476c433 4939
11faa288 4940 ENTER;
11faa288 4941
f4dd75d9 4942 SAVECOPLINE(PL_curcop);
11faa288 4943 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4944
4945 SAVEHINTS();
3280af22 4946 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4947
4948 if (stash) {
4949 SAVESPTR(PL_curstash);
4950 SAVECOPSTASH(PL_curcop);
4951 PL_curstash = stash;
4952#ifdef USE_ITHREADS
4953 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4954#else
4955 CopSTASH(PL_curcop) = stash;
4956#endif
4957 }
5476c433 4958
beab0874
JT		 4959 cv = newXS(name, const_sv_xsub, __FILE__);
4960 CvXSUBANY(cv).any_ptr = sv;
4961 CvCONST_on(cv);
4962 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 4963
11faa288 4964 LEAVE;
beab0874
JT		 4965
4966 return cv;
5476c433
JD		 4967}
4968
954c1994
GS		 4969/*
4970=for apidoc U||newXS
4971
4972Used by C<xsubpp> to hook up XSUBs as Perl subs.
4973
4974=cut
4975*/
4976
57d3b86d 4977CV *
864dbfa3 4978Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 4979{
44a8e56a 4980 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
79072805 4981 register CV *cv;
44a8e56a 4982
155aba94 4983 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4984 if (GvCVGEN(gv)) {
4985 /* just a cached method */
4986 SvREFCNT_dec(cv);
4987 cv = 0;
4988 }
4989 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4990 /* already defined (or promised) */
599cee73 4991 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4
IZ		 4992 && HvNAME(GvSTASH(CvGV(cv)))
4993 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 4994 line_t oldline = CopLINE(PL_curcop);
51f6edd3 4995 if (PL_copline != NOLINE)
57843af0 4996 CopLINE_set(PL_curcop, PL_copline);
beab0874
JT		 4997 Perl_warner(aTHX_ WARN_REDEFINE,
4998 CvCONST(cv) ? "Constant subroutine %s redefined"
4999 : "Subroutine %s redefined"
5000 ,name);
57843af0 5001 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 5002 }
5003 SvREFCNT_dec(cv);
5004 cv = 0;
79072805 5005 }
79072805 5006 }
44a8e56a 5007
5008 if (cv) /* must reuse cv if autoloaded */
5009 cv_undef(cv);
a0d0e21e
LW		 5010 else {
5011 cv = (CV*)NEWSV(1105,0);
5012 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 5013 if (name) {
5014 GvCV(gv) = cv;
5015 GvCVGEN(gv) = 0;
3280af22 5016 PL_sub_generation++;
44a8e56a 5017 }
a0d0e21e 5018 }
65c50114 5019 CvGV(cv) = gv;
11343788 5020#ifdef USE_THREADS
12ca11f6 5021 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 5022 MUTEX_INIT(CvMUTEXP(cv));
11343788
MB		 5023 CvOWNER(cv) = 0;
5024#endif /* USE_THREADS */
b195d487 5025 (void)gv_fetchfile(filename);
57843af0
GS		 5026 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5027 an external constant string */
a0d0e21e 5028 CvXSUB(cv) = subaddr;
44a8e56a 5029
28757baa 5030 if (name) {
5031 char *s = strrchr(name,':');
5032 if (s)
5033 s++;
5034 else
5035 s = name;
ed094faf 5036
7d30b5c4 5037 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 5038 goto done;
5039
28757baa 5040 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 5041 if (!PL_beginav)
5042 PL_beginav = newAV();
ea2f84a3
GS		 5043 av_push(PL_beginav, (SV*)cv);
5044 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5045 }
5046 else if (strEQ(s, "END")) {
3280af22
NIS		 5047 if (!PL_endav)
5048 PL_endav = newAV();
5049 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5050 av_store(PL_endav, 0, (SV*)cv);
5051 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5052 }
7d30b5c4
GS		 5053 else if (strEQ(s, "CHECK")) {
5054 if (!PL_checkav)
5055 PL_checkav = newAV();
ddda08b7
GS		 5056 if (PL_main_start && ckWARN(WARN_VOID))
5057 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
7d30b5c4 5058 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5059 av_store(PL_checkav, 0, (SV*)cv);
5060 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5061 }
7d07dbc2 5062 else if (strEQ(s, "INIT")) {
3280af22
NIS		 5063 if (!PL_initav)
5064 PL_initav = newAV();
ddda08b7
GS		 5065 if (PL_main_start && ckWARN(WARN_VOID))
5066 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
ea2f84a3
GS		 5067 av_push(PL_initav, (SV*)cv);
5068 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5069 }
28757baa 5070 }
8990e307 5071 else
a5f75d66 5072 CvANON_on(cv);
44a8e56a 5073
ed094faf 5074done:
a0d0e21e 5075 return cv;
79072805
LW		 5076}
5077
5078void
864dbfa3 5079Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 5080{
5081 register CV *cv;
5082 char *name;
5083 GV *gv;
a0d0e21e 5084 I32 ix;
2d8e6c8d 5085 STRLEN n_a;
79072805 5086
11343788 5087 if (o)
2d8e6c8d 5088 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 5089 else
5090 name = "STDOUT";
85e6fe83 5091 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5bd07a3d
DM		 5092#ifdef GV_SHARED_CHECK
5093 if (GvSHARED(gv)) {
5094 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5095 }
5096#endif
a5f75d66 5097 GvMULTI_on(gv);
155aba94 5098 if ((cv = GvFORM(gv))) {
599cee73 5099 if (ckWARN(WARN_REDEFINE)) {
57843af0 5100 line_t oldline = CopLINE(PL_curcop);
79072805 5101
57843af0 5102 CopLINE_set(PL_curcop, PL_copline);
cea2e8a9 5103 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
57843af0 5104 CopLINE_set(PL_curcop, oldline);
79072805 5105 }
8990e307 5106 SvREFCNT_dec(cv);
79072805 5107 }
3280af22 5108 cv = PL_compcv;
79072805 5109 GvFORM(gv) = cv;
65c50114 5110 CvGV(cv) = gv;
57843af0 5111 CvFILE(cv) = CopFILE(PL_curcop);
79072805 5112
3280af22
NIS		 5113 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5114 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5115 SvPADTMP_on(PL_curpad[ix]);
a0d0e21e
LW		 5116 }
5117
79072805 5118 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5119 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5120 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5121 CvSTART(cv) = LINKLIST(CvROOT(cv));
5122 CvROOT(cv)->op_next = 0;
5123 peep(CvSTART(cv));
11343788 5124 op_free(o);
3280af22 5125 PL_copline = NOLINE;
8990e307 5126 LEAVE_SCOPE(floor);
79072805
LW		 5127}
5128
5129OP *
864dbfa3 5130Perl_newANONLIST(pTHX_ OP *o)
79072805 5131{
93a17b20 5132 return newUNOP(OP_REFGEN, 0,
11343788 5133 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 5134}
5135
5136OP *
864dbfa3 5137Perl_newANONHASH(pTHX_ OP *o)
79072805 5138{
93a17b20 5139 return newUNOP(OP_REFGEN, 0,
11343788 5140 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 5141}
5142
5143OP *
864dbfa3 5144Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5145{
09bef843
SB		 5146 return newANONATTRSUB(floor, proto, Nullop, block);
5147}
5148
5149OP *
5150Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5151{
a0d0e21e 5152 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5153 newSVOP(OP_ANONCODE, 0,
5154 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5155}
5156
5157OP *
864dbfa3 5158Perl_oopsAV(pTHX_ OP *o)
79072805 5159{
ed6116ce
LW		 5160 switch (o->op_type) {
5161 case OP_PADSV:
5162 o->op_type = OP_PADAV;
22c35a8c 5163 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5164 return ref(o, OP_RV2AV);
ed6116ce
LW		 5165
5166 case OP_RV2SV:
79072805 5167 o->op_type = OP_RV2AV;
22c35a8c 5168 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 5169 ref(o, OP_RV2AV);
ed6116ce
LW		 5170 break;
5171
5172 default:
0453d815
PM		 5173 if (ckWARN_d(WARN_INTERNAL))
5174 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
ed6116ce
LW		 5175 break;
5176 }
79072805
LW		 5177 return o;
5178}
5179
5180OP *
864dbfa3 5181Perl_oopsHV(pTHX_ OP *o)
79072805 5182{
ed6116ce
LW		 5183 switch (o->op_type) {
5184 case OP_PADSV:
5185 case OP_PADAV:
5186 o->op_type = OP_PADHV;
22c35a8c 5187 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5188 return ref(o, OP_RV2HV);
ed6116ce
LW		 5189
5190 case OP_RV2SV:
5191 case OP_RV2AV:
79072805 5192 o->op_type = OP_RV2HV;
22c35a8c 5193 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5194 ref(o, OP_RV2HV);
ed6116ce
LW		 5195 break;
5196
5197 default:
0453d815
PM		 5198 if (ckWARN_d(WARN_INTERNAL))
5199 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
ed6116ce
LW		 5200 break;
5201 }
79072805
LW		 5202 return o;
5203}
5204
5205OP *
864dbfa3 5206Perl_newAVREF(pTHX_ OP *o)
79072805 5207{
ed6116ce
LW		 5208 if (o->op_type == OP_PADANY) {
5209 o->op_type = OP_PADAV;
22c35a8c 5210 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5211 return o;
ed6116ce 5212 }
a1063b2d
RH		 5213 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5214 && ckWARN(WARN_DEPRECATED)) {
5215 Perl_warner(aTHX_ WARN_DEPRECATED,
5216 "Using an array as a reference is deprecated");
5217 }
79072805
LW		 5218 return newUNOP(OP_RV2AV, 0, scalar(o));
5219}
5220
5221OP *
864dbfa3 5222Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 5223{
82092f1d 5224 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 5225 return newUNOP(OP_NULL, 0, o);
748a9306 5226 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 5227}
5228
5229OP *
864dbfa3 5230Perl_newHVREF(pTHX_ OP *o)
79072805 5231{
ed6116ce
LW		 5232 if (o->op_type == OP_PADANY) {
5233 o->op_type = OP_PADHV;
22c35a8c 5234 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 5235 return o;
ed6116ce 5236 }
a1063b2d
RH		 5237 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5238 && ckWARN(WARN_DEPRECATED)) {
5239 Perl_warner(aTHX_ WARN_DEPRECATED,
5240 "Using a hash as a reference is deprecated");
5241 }
79072805
LW		 5242 return newUNOP(OP_RV2HV, 0, scalar(o));
5243}
5244
5245OP *
864dbfa3 5246Perl_oopsCV(pTHX_ OP *o)
79072805 5247{
cea2e8a9 5248 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 5249 /* STUB */
5250 return o;
5251}
5252
5253OP *
864dbfa3 5254Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 5255{
c07a80fd 5256 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 5257}
5258
5259OP *
864dbfa3 5260Perl_newSVREF(pTHX_ OP *o)
79072805 5261{
ed6116ce
LW		 5262 if (o->op_type == OP_PADANY) {
5263 o->op_type = OP_PADSV;
22c35a8c 5264 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 5265 return o;
ed6116ce 5266 }
224a4551
MB		 5267 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5268 o->op_flags |= OPpDONE_SVREF;
a863c7d1 5269 return o;
224a4551 5270 }
79072805
LW		 5271 return newUNOP(OP_RV2SV, 0, scalar(o));
5272}
5273
5274/* Check routines. */
5275
5276OP *
cea2e8a9 5277Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 5278{
178c6305
CS		 5279 PADOFFSET ix;
5280 SV* name;
5281
5282 name = NEWSV(1106,0);
5283 sv_upgrade(name, SVt_PVNV);
5284 sv_setpvn(name, "&", 1);
5285 SvIVX(name) = -1;
5286 SvNVX(name) = 1;
5dc0d613 5287 ix = pad_alloc(o->op_type, SVs_PADMY);
3280af22
NIS		 5288 av_store(PL_comppad_name, ix, name);
5289 av_store(PL_comppad, ix, cSVOPo->op_sv);
5dc0d613
MB		 5290 SvPADMY_on(cSVOPo->op_sv);
5291 cSVOPo->op_sv = Nullsv;
5292 cSVOPo->op_targ = ix;
5293 return o;
5f05dabc 5294}
5295
5296OP *
cea2e8a9 5297Perl_ck_bitop(pTHX_ OP *o)
55497cff 5298{
3280af22 5299 o->op_private = PL_hints;
5dc0d613 5300 return o;
55497cff 5301}
5302
5303OP *
cea2e8a9 5304Perl_ck_concat(pTHX_ OP *o)
79072805 5305{
11343788
MB		 5306 if (cUNOPo->op_first->op_type == OP_CONCAT)
5307 o->op_flags |= OPf_STACKED;
5308 return o;
79072805
LW		 5309}
5310
5311OP *
cea2e8a9 5312Perl_ck_spair(pTHX_ OP *o)
79072805 5313{
11343788 5314 if (o->op_flags & OPf_KIDS) {
79072805 5315 OP* newop;
a0d0e21e 5316 OP* kid;
5dc0d613
MB		 5317 OPCODE type = o->op_type;
5318 o = modkids(ck_fun(o), type);
11343788 5319 kid = cUNOPo->op_first;
a0d0e21e
LW		 5320 newop = kUNOP->op_first->op_sibling;
5321 if (newop &&
5322 (newop->op_sibling ||
22c35a8c 5323 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 5324 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5325 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
aeea060c 5326
11343788 5327 return o;
a0d0e21e
LW		 5328 }
5329 op_free(kUNOP->op_first);
5330 kUNOP->op_first = newop;
5331 }
22c35a8c 5332 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5333 return ck_fun(o);
a0d0e21e
LW		 5334}
5335
5336OP *
cea2e8a9 5337Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5338{
11343788 5339 o = ck_fun(o);
5dc0d613 5340 o->op_private = 0;
11343788
MB		 5341 if (o->op_flags & OPf_KIDS) {
5342 OP *kid = cUNOPo->op_first;
01020589
GS		 5343 switch (kid->op_type) {
5344 case OP_ASLICE:
5345 o->op_flags |= OPf_SPECIAL;
5346 /* FALL THROUGH */
5347 case OP_HSLICE:
5dc0d613 5348 o->op_private |= OPpSLICE;
01020589
GS		 5349 break;
5350 case OP_AELEM:
5351 o->op_flags |= OPf_SPECIAL;
5352 /* FALL THROUGH */
5353 case OP_HELEM:
5354 break;
5355 default:
5356 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
22c35a8c 5357 PL_op_desc[o->op_type]);
01020589 5358 }
93c66552 5359 op_null(kid);
79072805 5360 }
11343788 5361 return o;
79072805
LW		 5362}
5363
5364OP *
cea2e8a9 5365Perl_ck_eof(pTHX_ OP *o)
79072805 5366{
11343788 5367 I32 type = o->op_type;
79072805 5368
11343788
MB		 5369 if (o->op_flags & OPf_KIDS) {
5370 if (cLISTOPo->op_first->op_type == OP_STUB) {
5371 op_free(o);
5372 o = newUNOP(type, OPf_SPECIAL,
d58bf5aa 5373 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
8990e307 5374 }
11343788 5375 return ck_fun(o);
79072805 5376 }
11343788 5377 return o;
79072805
LW		 5378}
5379
5380OP *
cea2e8a9 5381Perl_ck_eval(pTHX_ OP *o)
79072805 5382{
3280af22 5383 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 5384 if (o->op_flags & OPf_KIDS) {
5385 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 5386
93a17b20 5387 if (!kid) {
11343788 5388 o->op_flags &= ~OPf_KIDS;
93c66552 5389 op_null(o);
79072805
LW		 5390 }
5391 else if (kid->op_type == OP_LINESEQ) {
5392 LOGOP *enter;
5393
11343788
MB		 5394 kid->op_next = o->op_next;
5395 cUNOPo->op_first = 0;
5396 op_free(o);
79072805 5397
b7dc083c 5398 NewOp(1101, enter, 1, LOGOP);
79072805 5399 enter->op_type = OP_ENTERTRY;
22c35a8c 5400 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 5401 enter->op_private = 0;
5402
5403 /* establish postfix order */
5404 enter->op_next = (OP*)enter;
5405
11343788
MB		 5406 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5407 o->op_type = OP_LEAVETRY;
22c35a8c 5408 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 5409 enter->op_other = o;
5410 return o;
79072805 5411 }
c7cc6f1c 5412 else
473986ff 5413 scalar((OP*)kid);
79072805
LW		 5414 }
5415 else {
11343788 5416 op_free(o);
54b9620d 5417 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 5418 }
3280af22 5419 o->op_targ = (PADOFFSET)PL_hints;
11343788 5420 return o;
79072805
LW		 5421}
5422
5423OP *
d98f61e7
GS		 5424Perl_ck_exit(pTHX_ OP *o)
5425{
5426#ifdef VMS
5427 HV *table = GvHV(PL_hintgv);
5428 if (table) {
5429 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5430 if (svp && *svp && SvTRUE(*svp))
5431 o->op_private |= OPpEXIT_VMSISH;
5432 }
5433#endif
5434 return ck_fun(o);
5435}
5436
5437OP *
cea2e8a9 5438Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 5439{
5440 OP *kid;
11343788
MB		 5441 if (o->op_flags & OPf_STACKED) {
5442 o = ck_fun(o);
5443 kid = cUNOPo->op_first->op_sibling;
8990e307 5444 if (kid->op_type == OP_RV2GV)
93c66552 5445 op_null(kid);
79072805 5446 }
463ee0b2 5447 else
11343788
MB		 5448 o = listkids(o);
5449 return o;
79072805
LW		 5450}
5451
5452OP *
cea2e8a9 5453Perl_ck_exists(pTHX_ OP *o)
5f05dabc 5454{
5196be3e
MB		 5455 o = ck_fun(o);
5456 if (o->op_flags & OPf_KIDS) {
5457 OP *kid = cUNOPo->op_first;
afebc493
GS		 5458 if (kid->op_type == OP_ENTERSUB) {
5459 (void) ref(kid, o->op_type);
5460 if (kid->op_type != OP_RV2CV && !PL_error_count)
5461 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5462 PL_op_desc[o->op_type]);
5463 o->op_private |= OPpEXISTS_SUB;
5464 }
5465 else if (kid->op_type == OP_AELEM)
01020589
GS		 5466 o->op_flags |= OPf_SPECIAL;
5467 else if (kid->op_type != OP_HELEM)
5468 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5469 PL_op_desc[o->op_type]);
93c66552 5470 op_null(kid);
5f05dabc 5471 }
5196be3e 5472 return o;
5f05dabc 5473}
5474
22c35a8c 5475#if 0
5f05dabc 5476OP *
cea2e8a9 5477Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 5478{
5479 o = fold_constants(o);
5480 if (o->op_type == OP_CONST)
5481 o->op_type = OP_GV;
5482 return o;
5483}
22c35a8c 5484#endif
79072805
LW		 5485
5486OP *
cea2e8a9 5487Perl_ck_rvconst(pTHX_ register OP *o)
79072805 5488{
11343788 5489 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 5490
3280af22 5491 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 5492 if (kid->op_type == OP_CONST) {
44a8e56a 5493 char *name;
5494 int iscv;
5495 GV *gv;
779c5bc9 5496 SV *kidsv = kid->op_sv;
2d8e6c8d 5497 STRLEN n_a;
44a8e56a 5498
779c5bc9
GS		 5499 /* Is it a constant from cv_const_sv()? */
5500 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5501 SV *rsv = SvRV(kidsv);
5502 int svtype = SvTYPE(rsv);
5503 char *badtype = Nullch;
5504
5505 switch (o->op_type) {
5506 case OP_RV2SV:
5507 if (svtype > SVt_PVMG)
5508 badtype = "a SCALAR";
5509 break;
5510 case OP_RV2AV:
5511 if (svtype != SVt_PVAV)
5512 badtype = "an ARRAY";
5513 break;
5514 case OP_RV2HV:
5515 if (svtype != SVt_PVHV) {
5516 if (svtype == SVt_PVAV) { /* pseudohash? */
5517 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5518 if (ksv && SvROK(*ksv)
5519 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5520 {
5521 break;
5522 }
5523 }
5524 badtype = "a HASH";
5525 }
5526 break;
5527 case OP_RV2CV:
5528 if (svtype != SVt_PVCV)
5529 badtype = "a CODE";
5530 break;
5531 }
5532 if (badtype)
cea2e8a9 5533 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5534 return o;
5535 }
2d8e6c8d 5536 name = SvPV(kidsv, n_a);
3280af22 5537 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 5538 char *badthing = Nullch;
5dc0d613 5539 switch (o->op_type) {
44a8e56a 5540 case OP_RV2SV:
5541 badthing = "a SCALAR";
5542 break;
5543 case OP_RV2AV:
5544 badthing = "an ARRAY";
5545 break;
5546 case OP_RV2HV:
5547 badthing = "a HASH";
5548 break;
5549 }
5550 if (badthing)
1c846c1f 5551 Perl_croak(aTHX_
44a8e56a 5552 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5553 name, badthing);
5554 }
93233ece
CS		 5555 /*
5556 * This is a little tricky. We only want to add the symbol if we
5557 * didn't add it in the lexer. Otherwise we get duplicate strict
5558 * warnings. But if we didn't add it in the lexer, we must at
5559 * least pretend like we wanted to add it even if it existed before,
5560 * or we get possible typo warnings. OPpCONST_ENTERED says
5561 * whether the lexer already added THIS instance of this symbol.
5562 */
5196be3e 5563 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5564 do {
44a8e56a 5565 gv = gv_fetchpv(name,
748a9306 5566 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5567 iscv
5568 ? SVt_PVCV
11343788 5569 : o->op_type == OP_RV2SV
a0d0e21e 5570 ? SVt_PV
11343788 5571 : o->op_type == OP_RV2AV
a0d0e21e 5572 ? SVt_PVAV
11343788 5573 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5574 ? SVt_PVHV
5575 : SVt_PVGV);
93233ece
CS		 5576 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5577 if (gv) {
5578 kid->op_type = OP_GV;
5579 SvREFCNT_dec(kid->op_sv);
350de78d 5580#ifdef USE_ITHREADS
638eceb6 5581 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5582 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
63caf608 5583 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
743e66e6 5584 GvIN_PAD_on(gv);
350de78d
GS		 5585 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5586#else
93233ece 5587 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5588#endif
23f1ca44 5589 kid->op_private = 0;
76cd736e 5590 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5591 }
79072805 5592 }
11343788 5593 return o;
79072805
LW		 5594}
5595
5596OP *
cea2e8a9 5597Perl_ck_ftst(pTHX_ OP *o)
79072805 5598{
11343788 5599 I32 type = o->op_type;
79072805 5600
d0dca557
JD		 5601 if (o->op_flags & OPf_REF) {
5602 /* nothing */
5603 }
5604 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5605 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5606
5607 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5608 STRLEN n_a;
a0d0e21e 5609 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5610 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5611 op_free(o);
d0dca557 5612 o = newop;
79072805
LW		 5613 }
5614 }
5615 else {
11343788 5616 op_free(o);
79072805 5617 if (type == OP_FTTTY)
d0dca557 5618 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
85e6fe83 5619 SVt_PVIO));
79072805 5620 else
d0dca557 5621 o = newUNOP(type, 0, newDEFSVOP());
79072805 5622 }
d0dca557
JD		 5623#ifdef USE_LOCALE
5624 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5625 o->op_private = 0;
5626 if (PL_hints & HINT_LOCALE)
5627 o->op_private |= OPpLOCALE;
5628 }
5629#endif
11343788 5630 return o;
79072805
LW		 5631}
5632
5633OP *
cea2e8a9 5634Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5635{
5636 register OP *kid;
5637 OP **tokid;
5638 OP *sibl;
5639 I32 numargs = 0;
11343788 5640 int type = o->op_type;
22c35a8c 5641 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5642
11343788 5643 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5644 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5645 oa &= ~OA_OPTIONAL;
5646 else
11343788 5647 return no_fh_allowed(o);
79072805
LW		 5648 }
5649
11343788 5650 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5651 STRLEN n_a;
11343788
MB		 5652 tokid = &cLISTOPo->op_first;
5653 kid = cLISTOPo->op_first;
8990e307 5654 if (kid->op_type == OP_PUSHMARK ||
155aba94 5655 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5656 {
79072805
LW		 5657 tokid = &kid->op_sibling;
5658 kid = kid->op_sibling;
5659 }
22c35a8c 5660 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5661 *tokid = kid = newDEFSVOP();
79072805
LW		 5662
5663 while (oa && kid) {
5664 numargs++;
5665 sibl = kid->op_sibling;
5666 switch (oa & 7) {
5667 case OA_SCALAR:
62c18ce2
GS		 5668 /* list seen where single (scalar) arg expected? */
5669 if (numargs == 1 && !(oa >> 4)
5670 && kid->op_type == OP_LIST && type != OP_SCALAR)
5671 {
5672 return too_many_arguments(o,PL_op_desc[type]);
5673 }
79072805
LW		 5674 scalar(kid);
5675 break;
5676 case OA_LIST:
5677 if (oa < 16) {
5678 kid = 0;
5679 continue;
5680 }
5681 else
5682 list(kid);
5683 break;
5684 case OA_AVREF:
936edb8b 5685 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213
JH		 5686 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5687 Perl_warner(aTHX_ WARN_SYNTAX,
de4864e4 5688 "Useless use of %s with no values",
936edb8b
RH		 5689 PL_op_desc[type]);
5690
79072805 5691 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5692 (kid->op_private & OPpCONST_BARE))
5693 {
2d8e6c8d 5694 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5695 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5696 gv_fetchpv(name, TRUE, SVt_PVAV) ));
e476b1b5
GS		 5697 if (ckWARN(WARN_DEPRECATED))
5698 Perl_warner(aTHX_ WARN_DEPRECATED,
57def98f 5699 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5700 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5701 op_free(kid);
5702 kid = newop;
5703 kid->op_sibling = sibl;
5704 *tokid = kid;
5705 }
8990e307 5706 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5707 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5708 mod(kid, type);
79072805
LW		 5709 break;
5710 case OA_HVREF:
5711 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5712 (kid->op_private & OPpCONST_BARE))
5713 {
2d8e6c8d 5714 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5715 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5716 gv_fetchpv(name, TRUE, SVt_PVHV) ));
e476b1b5
GS		 5717 if (ckWARN(WARN_DEPRECATED))
5718 Perl_warner(aTHX_ WARN_DEPRECATED,
57def98f 5719 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5720 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5721 op_free(kid);
5722 kid = newop;
5723 kid->op_sibling = sibl;
5724 *tokid = kid;
5725 }
8990e307 5726 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5727 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5728 mod(kid, type);
79072805
LW		 5729 break;
5730 case OA_CVREF:
5731 {
a0d0e21e 5732 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5733 kid->op_sibling = 0;
5734 linklist(kid);
5735 newop->op_next = newop;
5736 kid = newop;
5737 kid->op_sibling = sibl;
5738 *tokid = kid;
5739 }
5740 break;
5741 case OA_FILEREF:
c340be78 5742 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5743 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5744 (kid->op_private & OPpCONST_BARE))
5745 {
79072805 5746 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5747 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5748 SVt_PVIO) );
79072805
LW		 5749 op_free(kid);
5750 kid = newop;
5751 }
1ea32a52
GS		 5752 else if (kid->op_type == OP_READLINE) {
5753 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5754 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5755 }
79072805 5756 else {
35cd451c 5757 I32 flags = OPf_SPECIAL;
a6c40364 5758 I32 priv = 0;
2c8ac474
GS		 5759 PADOFFSET targ = 0;
5760
35cd451c 5761 /* is this op a FH constructor? */
853846ea 5762 if (is_handle_constructor(o,numargs)) {
2c8ac474
GS		 5763 char *name = Nullch;
5764 STRLEN len;
5765
5766 flags = 0;
5767 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5768 * need to "prove" flag does not mean something
5769 * else already - NI-S 1999/05/07
2c8ac474
GS		 5770 */
5771 priv = OPpDEREF;
5772 if (kid->op_type == OP_PADSV) {
5773 SV **namep = av_fetch(PL_comppad_name,
5774 kid->op_targ, 4);
5775 if (namep && *namep)
5776 name = SvPV(*namep, len);
5777 }
5778 else if (kid->op_type == OP_RV2SV
5779 && kUNOP->op_first->op_type == OP_GV)
5780 {
5781 GV *gv = cGVOPx_gv(kUNOP->op_first);
5782 name = GvNAME(gv);
5783 len = GvNAMELEN(gv);
5784 }
afd1915d
GS		 5785 else if (kid->op_type == OP_AELEM
5786 || kid->op_type == OP_HELEM)
5787 {
5788 name = "__ANONIO__";
5789 len = 10;
5790 mod(kid,type);
5791 }
2c8ac474
GS		 5792 if (name) {
5793 SV *namesv;
5794 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5795 namesv = PL_curpad[targ];
155aba94 5796 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5797 if (*name != '$')
5798 sv_setpvn(namesv, "$", 1);
5799 sv_catpvn(namesv, name, len);
5800 }
853846ea 5801 }
79072805 5802 kid->op_sibling = 0;
35cd451c 5803 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5804 kid->op_targ = targ;
5805 kid->op_private |= priv;
79072805
LW		 5806 }
5807 kid->op_sibling = sibl;
5808 *tokid = kid;
5809 }
5810 scalar(kid);
5811 break;
5812 case OA_SCALARREF:
a0d0e21e 5813 mod(scalar(kid), type);
79072805
LW		 5814 break;
5815 }
5816 oa >>= 4;
5817 tokid = &kid->op_sibling;
5818 kid = kid->op_sibling;
5819 }
11343788 5820 o->op_private |= numargs;
79072805 5821 if (kid)
22c35a8c 5822 return too_many_arguments(o,PL_op_desc[o->op_type]);
11343788 5823 listkids(o);
79072805 5824 }
22c35a8c 5825 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5826 op_free(o);
54b9620d 5827 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5828 }
5829
79072805
LW		 5830 if (oa) {
5831 while (oa & OA_OPTIONAL)
5832 oa >>= 4;
5833 if (oa && oa != OA_LIST)
22c35a8c 5834 return too_few_arguments(o,PL_op_desc[o->op_type]);
79072805 5835 }
11343788 5836 return o;
79072805
LW		 5837}
5838
5839OP *
cea2e8a9 5840Perl_ck_glob(pTHX_ OP *o)
79072805 5841{
fb73857a 5842 GV *gv;
5843
649da076 5844 o = ck_fun(o);
1f2bfc8a 5845 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5846 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5847
5848 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5849 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b1cb66bf 5850
52bb0670 5851#if !defined(PERL_EXTERNAL_GLOB)
72b16652
GS		 5852 /* XXX this can be tightened up and made more failsafe. */
5853 if (!gv) {
7d3fb230 5854 GV *glob_gv;
72b16652 5855 ENTER;
7d3fb230
BS		 5856 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5857 Nullsv, Nullsv);
72b16652 5858 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5859 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5860 GvCV(gv) = GvCV(glob_gv);
445266f0 5861 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5862 GvIMPORTED_CV_on(gv);
72b16652
GS		 5863 LEAVE;
5864 }
52bb0670 5865#endif /* PERL_EXTERNAL_GLOB */
72b16652 5866
b1cb66bf 5867 if (gv && GvIMPORTED_CV(gv)) {
5196be3e 5868 append_elem(OP_GLOB, o,
80252599 5869 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5870 o->op_type = OP_LIST;
22c35a8c 5871 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5872 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5873 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
1f2bfc8a 5874 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5875 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5876 scalar(newUNOP(OP_RV2CV, 0,
5877 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5878 o = newUNOP(OP_NULL, 0, ck_subr(o));
5879 o->op_targ = OP_GLOB; /* hint at what it used to be */
5880 return o;
b1cb66bf 5881 }
5882 gv = newGVgen("main");
a0d0e21e 5883 gv_IOadd(gv);
11343788
MB		 5884 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5885 scalarkids(o);
649da076 5886 return o;
79072805
LW		 5887}
5888
5889OP *
cea2e8a9 5890Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 5891{
5892 LOGOP *gwop;
5893 OP *kid;
11343788 5894 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 5895
22c35a8c 5896 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5897 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5898
11343788 5899 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5900 OP* k;
11343788
MB		 5901 o = ck_sort(o);
5902 kid = cLISTOPo->op_first->op_sibling;
5903 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 5904 kid = k;
5905 }
5906 kid->op_next = (OP*)gwop;
11343788 5907 o->op_flags &= ~OPf_STACKED;
93a17b20 5908 }
11343788 5909 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5910 if (type == OP_MAPWHILE)
5911 list(kid);
5912 else
5913 scalar(kid);
11343788 5914 o = ck_fun(o);
3280af22 5915 if (PL_error_count)
11343788 5916 return o;
aeea060c 5917 kid = cLISTOPo->op_first->op_sibling;
79072805 5918 if (kid->op_type != OP_NULL)
cea2e8a9 5919 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5920 kid = kUNOP->op_first;
5921
a0d0e21e 5922 gwop->op_type = type;
22c35a8c 5923 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5924 gwop->op_first = listkids(o);
79072805
LW		 5925 gwop->op_flags |= OPf_KIDS;
5926 gwop->op_private = 1;
5927 gwop->op_other = LINKLIST(kid);
a0d0e21e 5928 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 5929 kid->op_next = (OP*)gwop;
5930
11343788 5931 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5932 if (!kid || !kid->op_sibling)
22c35a8c 5933 return too_few_arguments(o,PL_op_desc[o->op_type]);
a0d0e21e
LW		 5934 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5935 mod(kid, OP_GREPSTART);
5936
79072805
LW		 5937 return (OP*)gwop;
5938}
5939
5940OP *
cea2e8a9 5941Perl_ck_index(pTHX_ OP *o)
79072805 5942{
11343788
MB		 5943 if (o->op_flags & OPf_KIDS) {
5944 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5945 if (kid)
5946 kid = kid->op_sibling; /* get past "big" */
79072805 5947 if (kid && kid->op_type == OP_CONST)
2779dcf1 5948 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5949 }
11343788 5950 return ck_fun(o);
79072805
LW		 5951}
5952
5953OP *
cea2e8a9 5954Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5955{
5956 /* XXX length optimization goes here */
11343788 5957 return ck_fun(o);
79072805
LW		 5958}
5959
5960OP *
cea2e8a9 5961Perl_ck_lfun(pTHX_ OP *o)
79072805 5962{
5dc0d613
MB		 5963 OPCODE type = o->op_type;
5964 return modkids(ck_fun(o), type);
79072805
LW		 5965}
5966
5967OP *
cea2e8a9 5968Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5969{
d0334bed
GS		 5970 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5971 switch (cUNOPo->op_first->op_type) {
5972 case OP_RV2AV:
a8739d98
JH		 5973 /* This is needed for
5974 if (defined %stash::)
5975 to work. Do not break Tk.
5976 */
1c846c1f 5977 break; /* Globals via GV can be undef */
d0334bed
GS		 5978 case OP_PADAV:
5979 case OP_AASSIGN: /* Is this a good idea? */
5980 Perl_warner(aTHX_ WARN_DEPRECATED,
f10b0346 5981 "defined(@array) is deprecated");
d0334bed 5982 Perl_warner(aTHX_ WARN_DEPRECATED,
cc507455 5983 "\t(Maybe you should just omit the defined()?)\n");
69794302 5984 break;
d0334bed 5985 case OP_RV2HV:
a8739d98
JH		 5986 /* This is needed for
5987 if (defined %stash::)
5988 to work. Do not break Tk.
5989 */
1c846c1f 5990 break; /* Globals via GV can be undef */
d0334bed
GS		 5991 case OP_PADHV:
5992 Perl_warner(aTHX_ WARN_DEPRECATED,
894356b3 5993 "defined(%%hash) is deprecated");
d0334bed 5994 Perl_warner(aTHX_ WARN_DEPRECATED,
cc507455 5995 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5996 break;
5997 default:
5998 /* no warning */
5999 break;
6000 }
69794302
MJD		 6001 }
6002 return ck_rfun(o);
6003}
6004
6005OP *
cea2e8a9 6006Perl_ck_rfun(pTHX_ OP *o)
8990e307 6007{
5dc0d613
MB		 6008 OPCODE type = o->op_type;
6009 return refkids(ck_fun(o), type);
8990e307
LW		 6010}
6011
6012OP *
cea2e8a9 6013Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 6014{
6015 register OP *kid;
aeea060c 6016
11343788 6017 kid = cLISTOPo->op_first;
79072805 6018 if (!kid) {
11343788
MB		 6019 o = force_list(o);
6020 kid = cLISTOPo->op_first;
79072805
LW		 6021 }
6022 if (kid->op_type == OP_PUSHMARK)
6023 kid = kid->op_sibling;
11343788 6024 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 6025 kid = kid->op_sibling;
6026 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6027 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 6028 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 6029 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 6030 cLISTOPo->op_first->op_sibling = kid;
6031 cLISTOPo->op_last = kid;
79072805
LW		 6032 kid = kid->op_sibling;
6033 }
6034 }
6035
6036 if (!kid)
54b9620d 6037 append_elem(o->op_type, o, newDEFSVOP());
79072805 6038
5dc0d613 6039 o = listkids(o);
bbce6d69 6040
5dc0d613 6041 o->op_private = 0;
36477c24 6042#ifdef USE_LOCALE
3280af22 6043 if (PL_hints & HINT_LOCALE)
5dc0d613 6044 o->op_private |= OPpLOCALE;
bbce6d69 6045#endif
6046
5dc0d613 6047 return o;
bbce6d69 6048}
6049
6050OP *
cea2e8a9 6051Perl_ck_fun_locale(pTHX_ OP *o)
bbce6d69 6052{
5dc0d613 6053 o = ck_fun(o);
bbce6d69 6054
5dc0d613 6055 o->op_private = 0;
36477c24 6056#ifdef USE_LOCALE
3280af22 6057 if (PL_hints & HINT_LOCALE)
5dc0d613 6058 o->op_private |= OPpLOCALE;
bbce6d69 6059#endif
6060
5dc0d613 6061 return o;
bbce6d69 6062}
6063
6064OP *
b162f9ea
IZ		 6065Perl_ck_sassign(pTHX_ OP *o)
6066{
6067 OP *kid = cLISTOPo->op_first;
6068 /* has a disposable target? */
6069 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 6070 && !(kid->op_flags & OPf_STACKED)
6071 /* Cannot steal the second time! */
6072 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 6073 {
6074 OP *kkid = kid->op_sibling;
6075
6076 /* Can just relocate the target. */
2c2d71f5
JH		 6077 if (kkid && kkid->op_type == OP_PADSV
6078 && !(kkid->op_private & OPpLVAL_INTRO))
6079 {
b162f9ea 6080 kid->op_targ = kkid->op_targ;
743e66e6 6081 kkid->op_targ = 0;
b162f9ea
IZ		 6082 /* Now we do not need PADSV and SASSIGN. */
6083 kid->op_sibling = o->op_sibling; /* NULL */
6084 cLISTOPo->op_first = NULL;
6085 op_free(o);
6086 op_free(kkid);
6087 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6088 return kid;
6089 }
6090 }
6091 return o;
6092}
6093
6094OP *
cea2e8a9 6095Perl_ck_scmp(pTHX_ OP *o)
bbce6d69 6096{
5dc0d613 6097 o->op_private = 0;
36477c24 6098#ifdef USE_LOCALE
3280af22 6099 if (PL_hints & HINT_LOCALE)
5dc0d613 6100 o->op_private |= OPpLOCALE;
bbce6d69 6101#endif
36477c24 6102
5dc0d613 6103 return o;
79072805
LW		 6104}
6105
6106OP *
cea2e8a9 6107Perl_ck_match(pTHX_ OP *o)
79072805 6108{
5dc0d613 6109 o->op_private |= OPpRUNTIME;
11343788 6110 return o;
79072805
LW		 6111}
6112
6113OP *
f5d5a27c
CS		 6114Perl_ck_method(pTHX_ OP *o)
6115{
6116 OP *kid = cUNOPo->op_first;
6117 if (kid->op_type == OP_CONST) {
6118 SV* sv = kSVOP->op_sv;
6119 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6120 OP *cmop;
1c846c1f
NIS		 6121 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6122 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6123 }
6124 else {
6125 kSVOP->op_sv = Nullsv;
6126 }
f5d5a27c 6127 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 6128 op_free(o);
6129 return cmop;
6130 }
6131 }
6132 return o;
6133}
6134
6135OP *
cea2e8a9 6136Perl_ck_null(pTHX_ OP *o)
79072805 6137{
11343788 6138 return o;
79072805
LW		 6139}
6140
6141OP *
16fe6d59
GS		 6142Perl_ck_open(pTHX_ OP *o)
6143{
6144 HV *table = GvHV(PL_hintgv);
6145 if (table) {
6146 SV **svp;
6147 I32 mode;
6148 svp = hv_fetch(table, "open_IN", 7, FALSE);
6149 if (svp && *svp) {
6150 mode = mode_from_discipline(*svp);
6151 if (mode & O_BINARY)
6152 o->op_private |= OPpOPEN_IN_RAW;
6153 else if (mode & O_TEXT)
6154 o->op_private |= OPpOPEN_IN_CRLF;
6155 }
6156
6157 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6158 if (svp && *svp) {
6159 mode = mode_from_discipline(*svp);
6160 if (mode & O_BINARY)
6161 o->op_private |= OPpOPEN_OUT_RAW;
6162 else if (mode & O_TEXT)
6163 o->op_private |= OPpOPEN_OUT_CRLF;
6164 }
6165 }
6166 if (o->op_type == OP_BACKTICK)
6167 return o;
6168 return ck_fun(o);
6169}
6170
6171OP *
cea2e8a9 6172Perl_ck_repeat(pTHX_ OP *o)
79072805 6173{
11343788
MB		 6174 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6175 o->op_private |= OPpREPEAT_DOLIST;
6176 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 6177 }
6178 else
11343788
MB		 6179 scalar(o);
6180 return o;
79072805
LW		 6181}
6182
6183OP *
cea2e8a9 6184Perl_ck_require(pTHX_ OP *o)
8990e307 6185{
11343788
MB		 6186 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6187 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 6188
6189 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 6190 char *s;
a0d0e21e
LW		 6191 for (s = SvPVX(kid->op_sv); *s; s++) {
6192 if (*s == ':' && s[1] == ':') {
6193 *s = '/';
1aef975c 6194 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 6195 --SvCUR(kid->op_sv);
6196 }
8990e307 6197 }
ce3b816e
GS		 6198 if (SvREADONLY(kid->op_sv)) {
6199 SvREADONLY_off(kid->op_sv);
6200 sv_catpvn(kid->op_sv, ".pm", 3);
6201 SvREADONLY_on(kid->op_sv);
6202 }
6203 else
6204 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 6205 }
6206 }
11343788 6207 return ck_fun(o);
8990e307
LW		 6208}
6209
78f9721b
SM		 6210OP *
6211Perl_ck_return(pTHX_ OP *o)
6212{
6213 OP *kid;
6214 if (CvLVALUE(PL_compcv)) {
6215 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6216 mod(kid, OP_LEAVESUBLV);
6217 }
6218 return o;
6219}
6220
22c35a8c 6221#if 0
8990e307 6222OP *
cea2e8a9 6223Perl_ck_retarget(pTHX_ OP *o)
79072805 6224{
cea2e8a9 6225 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 6226 /* STUB */
11343788 6227 return o;
79072805 6228}
22c35a8c 6229#endif
79072805
LW		 6230
6231OP *
cea2e8a9 6232Perl_ck_select(pTHX_ OP *o)
79072805 6233{
c07a80fd 6234 OP* kid;
11343788
MB		 6235 if (o->op_flags & OPf_KIDS) {
6236 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 6237 if (kid && kid->op_sibling) {
11343788 6238 o->op_type = OP_SSELECT;
22c35a8c 6239 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 6240 o = ck_fun(o);
6241 return fold_constants(o);
79072805
LW		 6242 }
6243 }
11343788
MB		 6244 o = ck_fun(o);
6245 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 6246 if (kid && kid->op_type == OP_RV2GV)
6247 kid->op_private &= ~HINT_STRICT_REFS;
11343788 6248 return o;
79072805
LW		 6249}
6250
6251OP *
cea2e8a9 6252Perl_ck_shift(pTHX_ OP *o)
79072805 6253{
11343788 6254 I32 type = o->op_type;
79072805 6255
11343788 6256 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2
MB		 6257 OP *argop;
6258
11343788 6259 op_free(o);
6d4ff0d2 6260#ifdef USE_THREADS
533c011a 6261 if (!CvUNIQUE(PL_compcv)) {
6d4ff0d2 6262 argop = newOP(OP_PADAV, OPf_REF);
6b88bc9c 6263 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6d4ff0d2
MB		 6264 }
6265 else {
6266 argop = newUNOP(OP_RV2AV, 0,
6267 scalar(newGVOP(OP_GV, 0,
6268 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6269 }
6270#else
6271 argop = newUNOP(OP_RV2AV, 0,
3280af22
NIS		 6272 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6273 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6d4ff0d2
MB		 6274#endif /* USE_THREADS */
6275 return newUNOP(type, 0, scalar(argop));
79072805 6276 }
11343788 6277 return scalar(modkids(ck_fun(o), type));
79072805
LW		 6278}
6279
6280OP *
cea2e8a9 6281Perl_ck_sort(pTHX_ OP *o)
79072805 6282{
8e3f9bdf 6283 OP *firstkid;
5dc0d613 6284 o->op_private = 0;
36477c24 6285#ifdef USE_LOCALE
3280af22 6286 if (PL_hints & HINT_LOCALE)
5dc0d613 6287 o->op_private |= OPpLOCALE;
bbce6d69 6288#endif
6289
9ea6e965 6290 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 6291 simplify_sort(o);
8e3f9bdf
GS		 6292 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6293 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
463ee0b2 6294 OP *k;
8e3f9bdf 6295 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 6296
463ee0b2 6297 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 6298 linklist(kid);
463ee0b2
LW		 6299 if (kid->op_type == OP_SCOPE) {
6300 k = kid->op_next;
6301 kid->op_next = 0;
79072805 6302 }
463ee0b2 6303 else if (kid->op_type == OP_LEAVE) {
11343788 6304 if (o->op_type == OP_SORT) {
93c66552 6305 op_null(kid); /* wipe out leave */
748a9306 6306 kid->op_next = kid;
463ee0b2 6307
748a9306
LW		 6308 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6309 if (k->op_next == kid)
6310 k->op_next = 0;
71a29c3c
GS		 6311 /* don't descend into loops */
6312 else if (k->op_type == OP_ENTERLOOP
6313 || k->op_type == OP_ENTERITER)
6314 {
6315 k = cLOOPx(k)->op_lastop;
6316 }
748a9306 6317 }
463ee0b2 6318 }
748a9306
LW		 6319 else
6320 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 6321 k = kLISTOP->op_first;
463ee0b2 6322 }
a0d0e21e
LW		 6323 peep(k);
6324
8e3f9bdf
GS		 6325 kid = firstkid;
6326 if (o->op_type == OP_SORT) {
6327 /* provide scalar context for comparison function/block */
6328 kid = scalar(kid);
a0d0e21e 6329 kid->op_next = kid;
8e3f9bdf 6330 }
a0d0e21e
LW		 6331 else
6332 kid->op_next = k;
11343788 6333 o->op_flags |= OPf_SPECIAL;
79072805 6334 }
c6e96bcb 6335 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 6336 op_null(firstkid);
8e3f9bdf
GS		 6337
6338 firstkid = firstkid->op_sibling;
79072805 6339 }
bbce6d69 6340
8e3f9bdf
GS		 6341 /* provide list context for arguments */
6342 if (o->op_type == OP_SORT)
6343 list(firstkid);
6344
11343788 6345 return o;
79072805 6346}
bda4119b
GS		 6347
6348STATIC void
cea2e8a9 6349S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 6350{
6351 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6352 OP *k;
6353 int reversed;
350de78d 6354 GV *gv;
9c007264
JH		 6355 if (!(o->op_flags & OPf_STACKED))
6356 return;
1c846c1f
NIS		 6357 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6358 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 6359 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 6360 if (kid->op_type != OP_SCOPE)
6361 return;
6362 kid = kLISTOP->op_last; /* get past scope */
6363 switch(kid->op_type) {
6364 case OP_NCMP:
6365 case OP_I_NCMP:
6366 case OP_SCMP:
6367 break;
6368 default:
6369 return;
6370 }
6371 k = kid; /* remember this node*/
6372 if (kBINOP->op_first->op_type != OP_RV2SV)
6373 return;
6374 kid = kBINOP->op_first; /* get past cmp */
6375 if (kUNOP->op_first->op_type != OP_GV)
6376 return;
6377 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6378 gv = kGVOP_gv;
350de78d 6379 if (GvSTASH(gv) != PL_curstash)
9c007264 6380 return;
350de78d 6381 if (strEQ(GvNAME(gv), "a"))
9c007264 6382 reversed = 0;
0f79a09d 6383 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 6384 reversed = 1;
6385 else
6386 return;
6387 kid = k; /* back to cmp */
6388 if (kBINOP->op_last->op_type != OP_RV2SV)
6389 return;
6390 kid = kBINOP->op_last; /* down to 2nd arg */
6391 if (kUNOP->op_first->op_type != OP_GV)
6392 return;
6393 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6394 gv = kGVOP_gv;
350de78d 6395 if (GvSTASH(gv) != PL_curstash
9c007264 6396 || ( reversed
350de78d
GS		 6397 ? strNE(GvNAME(gv), "a")
6398 : strNE(GvNAME(gv), "b")))
9c007264
JH		 6399 return;
6400 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6401 if (reversed)
6402 o->op_private |= OPpSORT_REVERSE;
6403 if (k->op_type == OP_NCMP)
6404 o->op_private |= OPpSORT_NUMERIC;
6405 if (k->op_type == OP_I_NCMP)
6406 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 6407 kid = cLISTOPo->op_first->op_sibling;
6408 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6409 op_free(kid); /* then delete it */
9c007264 6410}
79072805
LW		 6411
6412OP *
cea2e8a9 6413Perl_ck_split(pTHX_ OP *o)
79072805
LW		 6414{
6415 register OP *kid;
aeea060c 6416
11343788
MB		 6417 if (o->op_flags & OPf_STACKED)
6418 return no_fh_allowed(o);
79072805 6419
11343788 6420 kid = cLISTOPo->op_first;
8990e307 6421 if (kid->op_type != OP_NULL)
cea2e8a9 6422 Perl_croak(aTHX_ "panic: ck_split");
8990e307 6423 kid = kid->op_sibling;
11343788
MB		 6424 op_free(cLISTOPo->op_first);
6425 cLISTOPo->op_first = kid;
85e6fe83 6426 if (!kid) {
79cb57f6 6427 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 6428 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 6429 }
79072805 6430
de4bf5b3 6431 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 6432 OP *sibl = kid->op_sibling;
463ee0b2 6433 kid->op_sibling = 0;
79072805 6434 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 6435 if (cLISTOPo->op_first == cLISTOPo->op_last)
6436 cLISTOPo->op_last = kid;
6437 cLISTOPo->op_first = kid;
79072805
LW		 6438 kid->op_sibling = sibl;
6439 }
6440
6441 kid->op_type = OP_PUSHRE;
22c35a8c 6442 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805
LW		 6443 scalar(kid);
6444
6445 if (!kid->op_sibling)
54b9620d 6446 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 6447
6448 kid = kid->op_sibling;
6449 scalar(kid);
6450
6451 if (!kid->op_sibling)
11343788 6452 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 6453
6454 kid = kid->op_sibling;
6455 scalar(kid);
6456
6457 if (kid->op_sibling)
22c35a8c 6458 return too_many_arguments(o,PL_op_desc[o->op_type]);
79072805 6459
11343788 6460 return o;
79072805
LW		 6461}
6462
6463OP *
1c846c1f 6464Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 6465{
6466 if (ckWARN(WARN_SYNTAX)) {
6467 OP *kid = cLISTOPo->op_first->op_sibling;
6468 if (kid && kid->op_type == OP_MATCH) {
6469 char *pmstr = "STRING";
6470 if (kPMOP->op_pmregexp)
6471 pmstr = kPMOP->op_pmregexp->precomp;
6472 Perl_warner(aTHX_ WARN_SYNTAX,
6473 "/%s/ should probably be written as \"%s\"",
6474 pmstr, pmstr);
6475 }
6476 }
6477 return ck_fun(o);
6478}
6479
6480OP *
cea2e8a9 6481Perl_ck_subr(pTHX_ OP *o)
79072805 6482{
11343788
MB		 6483 OP *prev = ((cUNOPo->op_first->op_sibling)
6484 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6485 OP *o2 = prev->op_sibling;
4633a7c4
LW		 6486 OP *cvop;
6487 char *proto = 0;
6488 CV *cv = 0;
46fc3d4c 6489 GV *namegv = 0;
4633a7c4
LW		 6490 int optional = 0;
6491 I32 arg = 0;
2d8e6c8d 6492 STRLEN n_a;
4633a7c4 6493
d3011074 6494 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6495 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6496 if (cvop->op_type == OP_RV2CV) {
6497 SVOP* tmpop;
11343788 6498 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6499 op_null(cvop); /* disable rv2cv */
4633a7c4 6500 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6501 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6502 GV *gv = cGVOPx_gv(tmpop);
350de78d 6503 cv = GvCVu(gv);
76cd736e
GS		 6504 if (!cv)
6505 tmpop->op_private |= OPpEARLY_CV;
6506 else if (SvPOK(cv)) {
350de78d 6507 namegv = CvANON(cv) ? gv : CvGV(cv);
2d8e6c8d 6508 proto = SvPV((SV*)cv, n_a);
46fc3d4c 6509 }
4633a7c4
LW		 6510 }
6511 }
f5d5a27c 6512 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6513 if (o2->op_type == OP_CONST)
6514 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 6515 else if (o2->op_type == OP_LIST) {
6516 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6517 if (o && o->op_type == OP_CONST)
6518 o->op_private &= ~OPpCONST_STRICT;
6519 }
7a52d87a 6520 }
3280af22
NIS		 6521 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6522 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6523 o->op_private |= OPpENTERSUB_DB;
6524 while (o2 != cvop) {
4633a7c4
LW		 6525 if (proto) {
6526 switch (*proto) {
6527 case '\0':
5dc0d613 6528 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 6529 case ';':
6530 optional = 1;
6531 proto++;
6532 continue;
6533 case '$':
6534 proto++;
6535 arg++;
11343788 6536 scalar(o2);
4633a7c4
LW		 6537 break;
6538 case '%':
6539 case '@':
11343788 6540 list(o2);
4633a7c4
LW		 6541 arg++;
6542 break;
6543 case '&':
6544 proto++;
6545 arg++;
11343788 6546 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6547 bad_type(arg,
6548 arg == 1 ? "block or sub {}" : "sub {}",
6549 gv_ename(namegv), o2);
4633a7c4
LW		 6550 break;
6551 case '*':
2ba6ecf4 6552 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6553 proto++;
6554 arg++;
11343788 6555 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6556 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6557 else if (o2->op_type == OP_CONST)
6558 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6559 else if (o2->op_type == OP_ENTERSUB) {
6560 /* accidental subroutine, revert to bareword */
6561 OP *gvop = ((UNOP*)o2)->op_first;
6562 if (gvop && gvop->op_type == OP_NULL) {
6563 gvop = ((UNOP*)gvop)->op_first;
6564 if (gvop) {
6565 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6566 ;
6567 if (gvop &&
6568 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6569 (gvop = ((UNOP*)gvop)->op_first) &&
6570 gvop->op_type == OP_GV)
6571 {
638eceb6 6572 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6573 OP *sibling = o2->op_sibling;
2692f720 6574 SV *n = newSVpvn("",0);
9675f7ac 6575 op_free(o2);
2692f720
GS		 6576 gv_fullname3(n, gv, "");
6577 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6578 sv_chop(n, SvPVX(n)+6);
6579 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6580 prev->op_sibling = o2;
6581 o2->op_sibling = sibling;
6582 }
6583 }
6584 }
6585 }
2ba6ecf4
GS		 6586 scalar(o2);
6587 break;
4633a7c4
LW		 6588 case '\\':
6589 proto++;
6590 arg++;
6591 switch (*proto++) {
6592 case '*':
11343788 6593 if (o2->op_type != OP_RV2GV)
5dc0d613 6594 bad_type(arg, "symbol", gv_ename(namegv), o2);
4633a7c4
LW		 6595 goto wrapref;
6596 case '&':
75fc29ea
GS		 6597 if (o2->op_type != OP_ENTERSUB)
6598 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
4633a7c4
LW		 6599 goto wrapref;
6600 case '$':
386acf99
GS		 6601 if (o2->op_type != OP_RV2SV
6602 && o2->op_type != OP_PADSV
1c01eb51
GS		 6603 && o2->op_type != OP_HELEM
6604 && o2->op_type != OP_AELEM
386acf99
GS		 6605 && o2->op_type != OP_THREADSV)
6606 {
5dc0d613 6607 bad_type(arg, "scalar", gv_ename(namegv), o2);
386acf99 6608 }
4633a7c4
LW		 6609 goto wrapref;
6610 case '@':
11343788 6611 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
5dc0d613 6612 bad_type(arg, "array", gv_ename(namegv), o2);
4633a7c4
LW		 6613 goto wrapref;
6614 case '%':
11343788 6615 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
5dc0d613 6616 bad_type(arg, "hash", gv_ename(namegv), o2);
4633a7c4
LW		 6617 wrapref:
6618 {
11343788 6619 OP* kid = o2;
6fa846a0 6620 OP* sib = kid->op_sibling;
4633a7c4 6621 kid->op_sibling = 0;
6fa846a0
GS		 6622 o2 = newUNOP(OP_REFGEN, 0, kid);
6623 o2->op_sibling = sib;
e858de61 6624 prev->op_sibling = o2;
4633a7c4
LW		 6625 }
6626 break;
6627 default: goto oops;
6628 }
6629 break;
b1cb66bf 6630 case ' ':
6631 proto++;
6632 continue;
4633a7c4
LW		 6633 default:
6634 oops:
cea2e8a9 6635 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
2d8e6c8d 6636 gv_ename(namegv), SvPV((SV*)cv, n_a));
4633a7c4
LW		 6637 }
6638 }
6639 else
11343788
MB		 6640 list(o2);
6641 mod(o2, OP_ENTERSUB);
6642 prev = o2;
6643 o2 = o2->op_sibling;
4633a7c4 6644 }
fb73857a 6645 if (proto && !optional &&
6646 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6647 return too_few_arguments(o, gv_ename(namegv));
11343788 6648 return o;
79072805
LW		 6649}
6650
6651OP *
cea2e8a9 6652Perl_ck_svconst(pTHX_ OP *o)
8990e307 6653{
11343788
MB		 6654 SvREADONLY_on(cSVOPo->op_sv);
6655 return o;
8990e307
LW		 6656}
6657
6658OP *
cea2e8a9 6659Perl_ck_trunc(pTHX_ OP *o)
79072805 6660{
11343788
MB		 6661 if (o->op_flags & OPf_KIDS) {
6662 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6663
a0d0e21e
LW		 6664 if (kid->op_type == OP_NULL)
6665 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6666 if (kid && kid->op_type == OP_CONST &&
6667 (kid->op_private & OPpCONST_BARE))
6668 {
11343788 6669 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6670 kid->op_private &= ~OPpCONST_STRICT;
6671 }
79072805 6672 }
11343788 6673 return ck_fun(o);
79072805
LW		 6674}
6675
35fba0d9
RG		 6676OP *
6677Perl_ck_substr(pTHX_ OP *o)
6678{
6679 o = ck_fun(o);
6680 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6681 OP *kid = cLISTOPo->op_first;
6682
6683 if (kid->op_type == OP_NULL)
6684 kid = kid->op_sibling;
6685 if (kid)
6686 kid->op_flags |= OPf_MOD;
6687
6688 }
6689 return o;
6690}
6691
463ee0b2
LW		 6692/* A peephole optimizer. We visit the ops in the order they're to execute. */
6693
79072805 6694void
864dbfa3 6695Perl_peep(pTHX_ register OP *o)
79072805
LW		 6696{
6697 register OP* oldop = 0;
2d8e6c8d
GS		 6698 STRLEN n_a;
6699
a0d0e21e 6700 if (!o || o->op_seq)
79072805 6701 return;
a0d0e21e 6702 ENTER;
462e5cf6 6703 SAVEOP();
7766f137 6704 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6705 for (; o; o = o->op_next) {
6706 if (o->op_seq)
6707 break;
3280af22
NIS		 6708 if (!PL_op_seqmax)
6709 PL_op_seqmax++;
533c011a 6710 PL_op = o;
a0d0e21e 6711 switch (o->op_type) {
acb36ea4 6712 case OP_SETSTATE:
a0d0e21e
LW		 6713 case OP_NEXTSTATE:
6714 case OP_DBSTATE:
3280af22
NIS		 6715 PL_curcop = ((COP*)o); /* for warnings */
6716 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6717 break;
6718
a0d0e21e 6719 case OP_CONST:
7a52d87a
GS		 6720 if (cSVOPo->op_private & OPpCONST_STRICT)
6721 no_bareword_allowed(o);
7766f137
GS		 6722#ifdef USE_ITHREADS
6723 /* Relocate sv to the pad for thread safety.
6724 * Despite being a "constant", the SV is written to,
6725 * for reference counts, sv_upgrade() etc. */
6726 if (cSVOP->op_sv) {
6727 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6a7129a1
GS		 6728 if (SvPADTMP(cSVOPo->op_sv)) {
6729 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6730 * some pad, so make a copy. */
6a7129a1
GS		 6731 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6732 SvREADONLY_on(PL_curpad[ix]);
6733 SvREFCNT_dec(cSVOPo->op_sv);
6734 }
6735 else {
6736 SvREFCNT_dec(PL_curpad[ix]);
6737 SvPADTMP_on(cSVOPo->op_sv);
6738 PL_curpad[ix] = cSVOPo->op_sv;
9a049f1c
JT		 6739 /* XXX I don't know how this isn't readonly already. */
6740 SvREADONLY_on(PL_curpad[ix]);
6a7129a1 6741 }
7766f137
GS		 6742 cSVOPo->op_sv = Nullsv;
6743 o->op_targ = ix;
6744 }
6745#endif
07447971
GS		 6746 o->op_seq = PL_op_seqmax++;
6747 break;
6748
ed7ab888 6749 case OP_CONCAT:
b162f9ea
IZ		 6750 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6751 if (o->op_next->op_private & OPpTARGET_MY) {
69b47968 6752 if (o->op_flags & OPf_STACKED) /* chained concats */
b162f9ea 6753 goto ignore_optimization;
cd06dffe 6754 else {
07447971 6755 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
b162f9ea 6756 o->op_targ = o->op_next->op_targ;
743e66e6 6757 o->op_next->op_targ = 0;
2c2d71f5 6758 o->op_private |= OPpTARGET_MY;
b162f9ea
IZ		 6759 }
6760 }
93c66552 6761 op_null(o->op_next);
b162f9ea
IZ		 6762 }
6763 ignore_optimization:
3280af22 6764 o->op_seq = PL_op_seqmax++;
a0d0e21e 6765 break;
8990e307 6766 case OP_STUB:
54310121 6767 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 6768 o->op_seq = PL_op_seqmax++;
54310121 6769 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6770 }
748a9306 6771 goto nothin;
79072805 6772 case OP_NULL:
acb36ea4
GS		 6773 if (o->op_targ == OP_NEXTSTATE
6774 || o->op_targ == OP_DBSTATE
6775 || o->op_targ == OP_SETSTATE)
6776 {
3280af22 6777 PL_curcop = ((COP*)o);
acb36ea4 6778 }
748a9306 6779 goto nothin;
79072805 6780 case OP_SCALAR:
93a17b20 6781 case OP_LINESEQ:
463ee0b2 6782 case OP_SCOPE:
748a9306 6783 nothin:
a0d0e21e
LW		 6784 if (oldop && o->op_next) {
6785 oldop->op_next = o->op_next;
79072805
LW		 6786 continue;
6787 }
3280af22 6788 o->op_seq = PL_op_seqmax++;
79072805
LW		 6789 break;
6790
6791 case OP_GV:
a0d0e21e 6792 if (o->op_next->op_type == OP_RV2SV) {
64aac5a9 6793 if (!(o->op_next->op_private & OPpDEREF)) {
93c66552 6794 op_null(o->op_next);
64aac5a9
GS		 6795 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6796 | OPpOUR_INTRO);
a0d0e21e
LW		 6797 o->op_next = o->op_next->op_next;
6798 o->op_type = OP_GVSV;
22c35a8c 6799 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307
LW		 6800 }
6801 }
a0d0e21e
LW		 6802 else if (o->op_next->op_type == OP_RV2AV) {
6803 OP* pop = o->op_next->op_next;
6804 IV i;
8990e307 6805 if (pop->op_type == OP_CONST &&
533c011a 6806 (PL_op = pop->op_next) &&
8990e307 6807 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6808 !(pop->op_next->op_private &
78f9721b 6809 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6810 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6811 <= 255 &&
8990e307
LW		 6812 i >= 0)
6813 {
350de78d 6814 GV *gv;
93c66552
DM		 6815 op_null(o->op_next);
6816 op_null(pop->op_next);
6817 op_null(pop);
a0d0e21e
LW		 6818 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6819 o->op_next = pop->op_next->op_next;
6820 o->op_type = OP_AELEMFAST;
22c35a8c 6821 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6822 o->op_private = (U8)i;
638eceb6 6823 gv = cGVOPo_gv;
350de78d 6824 GvAVn(gv);
8990e307 6825 }
79072805 6826 }
e476b1b5 6827 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 6828 GV *gv = cGVOPo_gv;
76cd736e
GS		 6829 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6830 /* XXX could check prototype here instead of just carping */
6831 SV *sv = sv_newmortal();
6832 gv_efullname3(sv, gv, Nullch);
e476b1b5 6833 Perl_warner(aTHX_ WARN_PROTOTYPE,
76cd736e
GS		 6834 "%s() called too early to check prototype",
6835 SvPV_nolen(sv));
6836 }
6837 }
6838
3280af22 6839 o->op_seq = PL_op_seqmax++;
79072805
LW		 6840 break;
6841
a0d0e21e 6842 case OP_MAPWHILE:
79072805
LW		 6843 case OP_GREPWHILE:
6844 case OP_AND:
6845 case OP_OR:
2c2d71f5
JH		 6846 case OP_ANDASSIGN:
6847 case OP_ORASSIGN:
1a67a97c
SM		 6848 case OP_COND_EXPR:
6849 case OP_RANGE:
3280af22 6850 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 6851 while (cLOGOP->op_other->op_type == OP_NULL)
6852 cLOGOP->op_other = cLOGOP->op_other->op_next;
79072805
LW		 6853 peep(cLOGOP->op_other);
6854 break;
6855
79072805 6856 case OP_ENTERLOOP:
9c2ca71a 6857 case OP_ENTERITER:
3280af22 6858 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 6859 while (cLOOP->op_redoop->op_type == OP_NULL)
6860 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6861 peep(cLOOP->op_redoop);
58cccf98
SM		 6862 while (cLOOP->op_nextop->op_type == OP_NULL)
6863 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6864 peep(cLOOP->op_nextop);
58cccf98
SM		 6865 while (cLOOP->op_lastop->op_type == OP_NULL)
6866 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6867 peep(cLOOP->op_lastop);
6868 break;
6869
8782bef2 6870 case OP_QR:
79072805
LW		 6871 case OP_MATCH:
6872 case OP_SUBST:
3280af22 6873 o->op_seq = PL_op_seqmax++;
9041c2e3 6874 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6875 cPMOP->op_pmreplstart->op_type == OP_NULL)
6876 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6877 peep(cPMOP->op_pmreplstart);
79072805
LW		 6878 break;
6879
a0d0e21e 6880 case OP_EXEC:
3280af22 6881 o->op_seq = PL_op_seqmax++;
1c846c1f 6882 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 6883 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 6884 if (o->op_next->op_sibling &&
20408e3c
GS		 6885 o->op_next->op_sibling->op_type != OP_EXIT &&
6886 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6887 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 6888 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 6889
57843af0 6890 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
eeb6a2c9
GS		 6891 Perl_warner(aTHX_ WARN_EXEC,
6892 "Statement unlikely to be reached");
6893 Perl_warner(aTHX_ WARN_EXEC,
cc507455 6894 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 6895 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 6896 }
6897 }
6898 break;
aeea060c 6899
c750a3ec
MB		 6900 case OP_HELEM: {
6901 UNOP *rop;
6902 SV *lexname;
6903 GV **fields;
9615e741 6904 SV **svp, **indsvp, *sv;
c750a3ec 6905 I32 ind;
1c846c1f 6906 char *key = NULL;
c750a3ec 6907 STRLEN keylen;
aeea060c 6908
9615e741 6909 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 6910
6911 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6912 break;
1c846c1f
NIS		 6913
6914 /* Make the CONST have a shared SV */
6915 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6916 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 6917 key = SvPV(sv, keylen);
8fed10cd 6918 if (SvUTF8(sv))
c3654f1a
IH		 6919 keylen = -keylen;
6920 lexname = newSVpvn_share(key, keylen, 0);
1c846c1f
NIS		 6921 SvREFCNT_dec(sv);
6922 *svp = lexname;
6923 }
6924
6925 if ((o->op_private & (OPpLVAL_INTRO)))
6926 break;
6927
c750a3ec
MB		 6928 rop = (UNOP*)((BINOP*)o)->op_first;
6929 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6930 break;
3280af22 6931 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
c750a3ec
MB		 6932 if (!SvOBJECT(lexname))
6933 break;
5196be3e 6934 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
c750a3ec
MB		 6935 if (!fields || !GvHV(*fields))
6936 break;
c750a3ec 6937 key = SvPV(*svp, keylen);
1aa99e6b
IH		 6938 if (SvUTF8(*svp))
6939 keylen = -keylen;
c750a3ec
MB		 6940 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6941 if (!indsvp) {
88e9b055 6942 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
2d8e6c8d 6943 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
c750a3ec
MB		 6944 }
6945 ind = SvIV(*indsvp);
6946 if (ind < 1)
cea2e8a9 6947 Perl_croak(aTHX_ "Bad index while coercing array into hash");
c750a3ec 6948 rop->op_type = OP_RV2AV;
22c35a8c 6949 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
c750a3ec 6950 o->op_type = OP_AELEM;
22c35a8c 6951 o->op_ppaddr = PL_ppaddr[OP_AELEM];
9615e741
GS		 6952 sv = newSViv(ind);
6953 if (SvREADONLY(*svp))
6954 SvREADONLY_on(sv);
6955 SvFLAGS(sv) |= (SvFLAGS(*svp)
6956 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
c750a3ec 6957 SvREFCNT_dec(*svp);
9615e741 6958 *svp = sv;
c750a3ec
MB		 6959 break;
6960 }
345599ca
GS		 6961
6962 case OP_HSLICE: {
6963 UNOP *rop;
6964 SV *lexname;
6965 GV **fields;
9615e741 6966 SV **svp, **indsvp, *sv;
345599ca
GS		 6967 I32 ind;
6968 char *key;
6969 STRLEN keylen;
6970 SVOP *first_key_op, *key_op;
9615e741
GS		 6971
6972 o->op_seq = PL_op_seqmax++;
345599ca
GS		 6973 if ((o->op_private & (OPpLVAL_INTRO))
6974 /* I bet there's always a pushmark... */
6975 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6976 /* hmmm, no optimization if list contains only one key. */
6977 break;
6978 rop = (UNOP*)((LISTOP*)o)->op_last;
6979 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6980 break;
6981 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6982 if (!SvOBJECT(lexname))
6983 break;
6984 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6985 if (!fields || !GvHV(*fields))
6986 break;
6987 /* Again guessing that the pushmark can be jumped over.... */
6988 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6989 ->op_first->op_sibling;
6990 /* Check that the key list contains only constants. */
6991 for (key_op = first_key_op; key_op;
6992 key_op = (SVOP*)key_op->op_sibling)
6993 if (key_op->op_type != OP_CONST)
6994 break;
6995 if (key_op)
6996 break;
6997 rop->op_type = OP_RV2AV;
6998 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6999 o->op_type = OP_ASLICE;
7000 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7001 for (key_op = first_key_op; key_op;
7002 key_op = (SVOP*)key_op->op_sibling) {
7003 svp = cSVOPx_svp(key_op);
7004 key = SvPV(*svp, keylen);
1aa99e6b
IH		 7005 if (SvUTF8(*svp))
7006 keylen = -keylen;
345599ca
GS		 7007 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7008 if (!indsvp) {
9615e741
GS		 7009 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7010 "in variable %s of type %s",
345599ca
GS		 7011 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7012 }
7013 ind = SvIV(*indsvp);
7014 if (ind < 1)
7015 Perl_croak(aTHX_ "Bad index while coercing array into hash");
9615e741
GS		 7016 sv = newSViv(ind);
7017 if (SvREADONLY(*svp))
7018 SvREADONLY_on(sv);
7019 SvFLAGS(sv) |= (SvFLAGS(*svp)
7020 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
345599ca 7021 SvREFCNT_dec(*svp);
9615e741 7022 *svp = sv;
345599ca
GS		 7023 }
7024 break;
7025 }
c750a3ec 7026
79072805 7027 default:
3280af22 7028 o->op_seq = PL_op_seqmax++;
79072805
LW		 7029 break;
7030 }
a0d0e21e 7031 oldop = o;
79072805 7032 }
a0d0e21e 7033 LEAVE;
79072805 7034}
beab0874
JT		 7035
7036#include "XSUB.h"
7037
7038/* Efficient sub that returns a constant scalar value. */
7039static void
7040const_sv_xsub(pTHXo_ CV* cv)
7041{
7042 dXSARGS;
9cbac4c7
DM		 7043 if (items != 0) {
7044#if 0
7045 Perl_croak(aTHX_ "usage: %s::%s()",
7046 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7047#endif
7048 }
9a049f1c 7049 EXTEND(sp, 1);
0768512c 7050 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 7051 XSRETURN(1);
7052}
2b9d42f0 7053
Unnamed repository; edit this file 'description' to name the repository.