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