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