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