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
better handling of whitespace in autodoc declarations; fragment from:
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
be3c0a43 3 * Copyright (c) 1991-2002, 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{
5a8e194f
NIS		 40 /*
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
45 */
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 47 if ((PL_OpSpace -= sz) < 0) {
083fcd59
JH		 48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
49 if (!PL_OpPtr) {
238a4c30
NIS		 50 return NULL;
51 }
5a8e194f
NIS		 52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
57 */
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
62 */
5a8e194f 63 PL_OpPtr += PERL_SLAB_SIZE;
238a4c30
NIS		 64 }
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
67 PL_OpPtr -= sz;
5a8e194f 68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
74}
75
76STATIC void
77S_Slab_Free(pTHX_ void *op)
78{
5a8e194f
NIS		 79 I32 **ptr = (I32 **) op;
80 I32 *slab = ptr[-1];
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30
NIS		 83 assert( *slab > 0 );
84 if (--(*slab) == 0) {
083fcd59
JH		 85 #ifdef NETWARE
86 #define PerlMemShared PerlMem
87 #endif
88
89 PerlMemShared_free(slab);
238a4c30
NIS		 90 if (slab == PL_OpSlab) {
91 PL_OpSpace = 0;
92 }
93 }
b7dc083c 94}
76e3520e 95
1c846c1f 96#else
b7dc083c 97#define NewOp(m, var, c, type) Newz(m, var, c, type)
a594c7b4 98#define FreeOp(p) Safefree(p)
b7dc083c 99#endif
e50aee73 100/*
5dc0d613 101 * In the following definition, the ", Nullop" is just to make the compiler
a5f75d66 102 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 103 */
11343788 104#define CHECKOP(type,o) \
3280af22 105 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 106 ? ( op_free((OP*)o), \
cea2e8a9 107 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
28757baa 108 Nullop ) \
fc0dc3b3 109 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 110
c53d7c7d 111#define PAD_MAX 999999999
e6438c1a 112#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 113
76e3520e 114STATIC char*
cea2e8a9 115S_gv_ename(pTHX_ GV *gv)
4633a7c4 116{
2d8e6c8d 117 STRLEN n_a;
4633a7c4 118 SV* tmpsv = sv_newmortal();
46fc3d4c 119 gv_efullname3(tmpsv, gv, Nullch);
2d8e6c8d 120 return SvPV(tmpsv,n_a);
4633a7c4
LW		 121}
122
76e3520e 123STATIC OP *
cea2e8a9 124S_no_fh_allowed(pTHX_ OP *o)
79072805 125{
cea2e8a9 126 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 127 OP_DESC(o)));
11343788 128 return o;
79072805
LW		 129}
130
76e3520e 131STATIC OP *
cea2e8a9 132S_too_few_arguments(pTHX_ OP *o, char *name)
79072805 133{
cea2e8a9 134 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 135 return o;
79072805
LW		 136}
137
76e3520e 138STATIC OP *
cea2e8a9 139S_too_many_arguments(pTHX_ OP *o, char *name)
79072805 140{
cea2e8a9 141 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 142 return o;
79072805
LW		 143}
144
76e3520e 145STATIC void
cea2e8a9 146S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
8990e307 147{
cea2e8a9 148 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 149 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 150}
151
7a52d87a 152STATIC void
cea2e8a9 153S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 154{
5a844595
GS		 155 qerror(Perl_mess(aTHX_
156 "Bareword \"%s\" not allowed while \"strict subs\" in use",
7766f137 157 SvPV_nolen(cSVOPo_sv)));
7a52d87a
GS		 158}
159
79072805
LW		 160/* "register" allocation */
161
162PADOFFSET
864dbfa3 163Perl_pad_allocmy(pTHX_ char *name)
93a17b20 164{
a0d0e21e
LW		 165 PADOFFSET off;
166 SV *sv;
167
155aba94
GS		 168 if (!(PL_in_my == KEY_our ||
169 isALPHA(name[1]) ||
39e02b42 170 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
155aba94 171 (name[1] == '_' && (int)strlen(name) > 2)))
834a4ddd 172 {
c4d0567e 173 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
2b92dfce
GS		 174 /* 1999-02-27 mjd@plover.com */
175 char *p;
176 p = strchr(name, '\0');
177 /* The next block assumes the buffer is at least 205 chars
178 long. At present, it's always at least 256 chars. */
179 if (p-name > 200) {
180 strcpy(name+200, "...");
181 p = name+199;
182 }
183 else {
184 p[1] = '\0';
185 }
186 /* Move everything else down one character */
187 for (; p-name > 2; p--)
188 *p = *(p-1);
46fc3d4c 189 name[2] = toCTRL(name[1]);
190 name[1] = '^';
191 }
cea2e8a9 192 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 193 }
e476b1b5 194 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
3280af22 195 SV **svp = AvARRAY(PL_comppad_name);
33633739
GS		 196 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
197 PADOFFSET top = AvFILLp(PL_comppad_name);
eb160463 198 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
b1cb66bf 199 if ((sv = svp[off])
3280af22 200 && sv != &PL_sv_undef
c53d7c7d 201 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
33633739
GS		 202 && (PL_in_my != KEY_our
203 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
b1cb66bf 204 && strEQ(name, SvPVX(sv)))
205 {
9014280d 206 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 207 "\"%s\" variable %s masks earlier declaration in same %s",
33633739
GS		 208 (PL_in_my == KEY_our ? "our" : "my"),
209 name,
210 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
211 --off;
212 break;
213 }
214 }
215 if (PL_in_my == KEY_our) {
635bab04 216 do {
33633739
GS		 217 if ((sv = svp[off])
218 && sv != &PL_sv_undef
5ce0178e 219 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
33633739
GS		 220 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
221 && strEQ(name, SvPVX(sv)))
f472eb5c 222 {
9014280d 223 Perl_warner(aTHX_ packWARN(WARN_MISC),
33633739 224 "\"our\" variable %s redeclared", name);
9014280d 225 Perl_warner(aTHX_ packWARN(WARN_MISC),
cc507455 226 "\t(Did you mean \"local\" instead of \"our\"?)\n");
33633739 227 break;
f472eb5c 228 }
635bab04 229 } while ( off-- > 0 );
b1cb66bf 230 }
231 }
a0d0e21e
LW		 232 off = pad_alloc(OP_PADSV, SVs_PADMY);
233 sv = NEWSV(1102,0);
93a17b20
LW		 234 sv_upgrade(sv, SVt_PVNV);
235 sv_setpv(sv, name);
3280af22 236 if (PL_in_my_stash) {
c750a3ec 237 if (*name != '$')
eb64745e
GS		 238 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
239 name, PL_in_my == KEY_our ? "our" : "my"));
524189f1 240 SvFLAGS(sv) |= SVpad_TYPED;
c750a3ec 241 (void)SvUPGRADE(sv, SVt_PVMG);
3280af22 242 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
c750a3ec 243 }
f472eb5c
GS		 244 if (PL_in_my == KEY_our) {
245 (void)SvUPGRADE(sv, SVt_PVGV);
ef75a179 246 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
77ca0c92 247 SvFLAGS(sv) |= SVpad_OUR;
f472eb5c 248 }
3280af22 249 av_store(PL_comppad_name, off, sv);
65202027 250 SvNVX(sv) = (NV)PAD_MAX;
8990e307 251 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
3280af22
NIS		 252 if (!PL_min_intro_pending)
253 PL_min_intro_pending = off;
254 PL_max_intro_pending = off;
93a17b20 255 if (*name == '@')
3280af22 256 av_store(PL_comppad, off, (SV*)newAV());
93a17b20 257 else if (*name == '%')
3280af22
NIS		 258 av_store(PL_comppad, off, (SV*)newHV());
259 SvPADMY_on(PL_curpad[off]);
93a17b20
LW		 260 return off;
261}
262
94f23f41
GS		 263STATIC PADOFFSET
264S_pad_addlex(pTHX_ SV *proto_namesv)
265{
266 SV *namesv = NEWSV(1103,0);
267 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
268 sv_upgrade(namesv, SVt_PVNV);
269 sv_setpv(namesv, SvPVX(proto_namesv));
270 av_store(PL_comppad_name, newoff, namesv);
271 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
272 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
273 SvFAKE_on(namesv); /* A ref, not a real var */
274 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
275 SvFLAGS(namesv) |= SVpad_OUR;
276 (void)SvUPGRADE(namesv, SVt_PVGV);
277 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
278 }
524189f1
JH		 279 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
280 SvFLAGS(namesv) |= SVpad_TYPED;
94f23f41
GS		 281 (void)SvUPGRADE(namesv, SVt_PVMG);
282 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
94f23f41
GS		 283 }
284 return newoff;
285}
286
2680586e
GS		 287#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
288
76e3520e 289STATIC PADOFFSET
cea2e8a9 290S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
864dbfa3 291 I32 cx_ix, I32 saweval, U32 flags)
93a17b20 292{
748a9306 293 CV *cv;
93a17b20
LW		 294 I32 off;
295 SV *sv;
93a17b20 296 register I32 i;
c09156bb 297 register PERL_CONTEXT *cx;
93a17b20 298
748a9306 299 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
4fdae800 300 AV *curlist = CvPADLIST(cv);
301 SV **svp = av_fetch(curlist, 0, FALSE);
748a9306 302 AV *curname;
4fdae800 303
3280af22 304 if (!svp || *svp == &PL_sv_undef)
4633a7c4 305 continue;
748a9306
LW		 306 curname = (AV*)*svp;
307 svp = AvARRAY(curname);
93965878 308 for (off = AvFILLp(curname); off > 0; off--) {
748a9306 309 if ((sv = svp[off]) &&
3280af22 310 sv != &PL_sv_undef &&
eb160463
GS		 311 seq <= (U32)SvIVX(sv) &&
312 seq > (U32)I_32(SvNVX(sv)) &&
748a9306
LW		 313 strEQ(SvPVX(sv), name))
314 {
5f05dabc 315 I32 depth;
316 AV *oldpad;
317 SV *oldsv;
318
319 depth = CvDEPTH(cv);
320 if (!depth) {
9607fc9c 321 if (newoff) {
322 if (SvFAKE(sv))
323 continue;
4fdae800 324 return 0; /* don't clone from inactive stack frame */
9607fc9c 325 }
5f05dabc 326 depth = 1;
327 }
94f23f41 328 oldpad = (AV*)AvARRAY(curlist)[depth];
5f05dabc 329 oldsv = *av_fetch(oldpad, off, TRUE);
748a9306 330 if (!newoff) { /* Not a mere clone operation. */
94f23f41 331 newoff = pad_addlex(sv);
3280af22 332 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
28757baa 333 /* "It's closures all the way down." */
3280af22 334 CvCLONE_on(PL_compcv);
54310121 335 if (cv == startcv) {
3280af22 336 if (CvANON(PL_compcv))
54310121 337 oldsv = Nullsv; /* no need to keep ref */
338 }
339 else {
28757baa 340 CV *bcv;
341 for (bcv = startcv;
342 bcv && bcv != cv && !CvCLONE(bcv);
6b35e009
GS		 343 bcv = CvOUTSIDE(bcv))
344 {
94f23f41
GS		 345 if (CvANON(bcv)) {
346 /* install the missing pad entry in intervening
347 * nested subs and mark them cloneable.
348 * XXX fix pad_foo() to not use globals */
349 AV *ocomppad_name = PL_comppad_name;
350 AV *ocomppad = PL_comppad;
351 SV **ocurpad = PL_curpad;
352 AV *padlist = CvPADLIST(bcv);
353 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
354 PL_comppad = (AV*)AvARRAY(padlist)[1];
355 PL_curpad = AvARRAY(PL_comppad);
356 pad_addlex(sv);
357 PL_comppad_name = ocomppad_name;
358 PL_comppad = ocomppad;
359 PL_curpad = ocurpad;
28757baa 360 CvCLONE_on(bcv);
94f23f41 361 }
28757baa 362 else {
6b35e009
GS		 363 if (ckWARN(WARN_CLOSURE)
364 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
365 {
9014280d 366 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
44a8e56a 367 "Variable \"%s\" may be unavailable",
28757baa 368 name);
6b35e009 369 }
28757baa 370 break;
371 }
372 }
373 }
374 }
3280af22 375 else if (!CvUNIQUE(PL_compcv)) {
741b6338
GS		 376 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
377 && !(SvFLAGS(sv) & SVpad_OUR))
378 {
9014280d 379 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
599cee73 380 "Variable \"%s\" will not stay shared", name);
741b6338 381 }
5f05dabc 382 }
748a9306 383 }
3280af22 384 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
748a9306
LW		 385 return newoff;
386 }
93a17b20
LW		 387 }
388 }
389
2680586e
GS		 390 if (flags & FINDLEX_NOSEARCH)
391 return 0;
392
93a17b20
LW		 393 /* Nothing in current lexical context--try eval's context, if any.
394 * This is necessary to let the perldb get at lexically scoped variables.
395 * XXX This will also probably interact badly with eval tree caching.
396 */
397
748a9306 398 for (i = cx_ix; i >= 0; i--) {
93a17b20 399 cx = &cxstack[i];
6b35e009 400 switch (CxTYPE(cx)) {
93a17b20 401 default:
748a9306 402 if (i == 0 && saweval) {
2680586e 403 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
748a9306 404 }
93a17b20
LW		 405 break;
406 case CXt_EVAL:
44a8e56a 407 switch (cx->blk_eval.old_op_type) {
408 case OP_ENTEREVAL:
2090ab20
JH		 409 if (CxREALEVAL(cx)) {
410 PADOFFSET off;
6b35e009 411 saweval = i;
2090ab20
JH		 412 seq = cxstack[i].blk_oldcop->cop_seq;
413 startcv = cxstack[i].blk_eval.cv;
c975facc
JH		 414 if (startcv && CvOUTSIDE(startcv)) {
415 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
416 i-1, saweval, 0);
417 if (off) /* continue looking if not found here */
418 return off;
419 }
2090ab20 420 }
44a8e56a 421 break;
faa7e5bb 422 case OP_DOFILE:
44a8e56a 423 case OP_REQUIRE:
faa7e5bb 424 /* require/do must have their own scope */
44a8e56a 425 return 0;
426 }
93a17b20 427 break;
7766f137 428 case CXt_FORMAT:
93a17b20
LW		 429 case CXt_SUB:
430 if (!saweval)
431 return 0;
432 cv = cx->blk_sub.cv;
3280af22 433 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
748a9306 434 saweval = i; /* so we know where we were called from */
708c0d06 435 seq = cxstack[i].blk_oldcop->cop_seq;
93a17b20 436 continue;
93a17b20 437 }
2680586e 438 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
93a17b20
LW		 439 }
440 }
441
748a9306
LW		 442 return 0;
443}
a0d0e21e 444
748a9306 445PADOFFSET
864dbfa3 446Perl_pad_findmy(pTHX_ char *name)
748a9306
LW		 447{
448 I32 off;
54310121 449 I32 pendoff = 0;
748a9306 450 SV *sv;
3280af22
NIS		 451 SV **svp = AvARRAY(PL_comppad_name);
452 U32 seq = PL_cop_seqmax;
6b35e009 453 PERL_CONTEXT *cx;
33b8ce05 454 CV *outside;
748a9306 455
4d1ff10f 456#ifdef USE_5005THREADS
11343788
MB		 457 /*
458 * Special case to get lexical (and hence per-thread) @_.
459 * XXX I need to find out how to tell at parse-time whether use
460 * of @_ should refer to a lexical (from a sub) or defgv (global
461 * scope and maybe weird sub-ish things like formats). See
462 * startsub in perly.y. It's possible that @_ could be lexical
463 * (at least from subs) even in non-threaded perl.
464 */
465 if (strEQ(name, "@_"))
466 return 0; /* success. (NOT_IN_PAD indicates failure) */
4d1ff10f 467#endif /* USE_5005THREADS */
11343788 468
748a9306 469 /* The one we're looking for is probably just before comppad_name_fill. */
3280af22 470 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
a0d0e21e 471 if ((sv = svp[off]) &&
3280af22 472 sv != &PL_sv_undef &&
54310121 473 (!SvIVX(sv) ||
eb160463
GS		 474 (seq <= (U32)SvIVX(sv) &&
475 seq > (U32)I_32(SvNVX(sv)))) &&
a0d0e21e
LW		 476 strEQ(SvPVX(sv), name))
477 {
77ca0c92 478 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
54310121 479 return (PADOFFSET)off;
480 pendoff = off; /* this pending def. will override import */
a0d0e21e
LW		 481 }
482 }
748a9306 483
33b8ce05
GS		 484 outside = CvOUTSIDE(PL_compcv);
485
486 /* Check if if we're compiling an eval'', and adjust seq to be the
487 * eval's seq number. This depends on eval'' having a non-null
488 * CvOUTSIDE() while it is being compiled. The eval'' itself is
1aff0e91
GS		 489 * identified by CvEVAL being true and CvGV being null. */
490 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
6b35e009
GS		 491 cx = &cxstack[cxstack_ix];
492 if (CxREALEVAL(cx))
493 seq = cx->blk_oldcop->cop_seq;
494 }
495
748a9306 496 /* See if it's in a nested scope */
2680586e 497 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
54310121 498 if (off) {
499 /* If there is a pending local definition, this new alias must die */
500 if (pendoff)
3280af22 501 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
11343788 502 return off; /* pad_findlex returns 0 for failure...*/
54310121 503 }
11343788 504 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
93a17b20
LW		 505}
506
507void
864dbfa3 508Perl_pad_leavemy(pTHX_ I32 fill)
93a17b20
LW		 509{
510 I32 off;
3280af22 511 SV **svp = AvARRAY(PL_comppad_name);
93a17b20 512 SV *sv;
3280af22
NIS		 513 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
514 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
0453d815 515 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
9014280d 516 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "%s never introduced", SvPVX(sv));
8990e307
LW		 517 }
518 }
519 /* "Deintroduce" my variables that are leaving with this scope. */
3280af22 520 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
c53d7c7d 521 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
3280af22 522 SvIVX(sv) = PL_cop_seqmax;
93a17b20
LW		 523 }
524}
525
526PADOFFSET
864dbfa3 527Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
79072805
LW		 528{
529 SV *sv;
530 I32 retval;
531
3280af22 532 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 533 Perl_croak(aTHX_ "panic: pad_alloc");
3280af22 534 if (PL_pad_reset_pending)
a0d0e21e 535 pad_reset();
ed6116ce 536 if (tmptype & SVs_PADMY) {
79072805 537 do {
3280af22 538 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
ed6116ce 539 } while (SvPADBUSY(sv)); /* need a fresh one */
3280af22 540 retval = AvFILLp(PL_comppad);
79072805
LW		 541 }
542 else {
3280af22
NIS		 543 SV **names = AvARRAY(PL_comppad_name);
544 SSize_t names_fill = AvFILLp(PL_comppad_name);
bbce6d69 545 for (;;) {
546 /*
547 * "foreach" index vars temporarily become aliases to non-"my"
548 * values. Thus we must skip, not just pad values that are
549 * marked as current pad values, but also those with names.
550 */
3280af22
NIS		 551 if (++PL_padix <= names_fill &&
552 (sv = names[PL_padix]) && sv != &PL_sv_undef)
bbce6d69 553 continue;
3280af22 554 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
3049cdab
SB		 555 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
556 !IS_PADGV(sv) && !IS_PADCONST(sv))
bbce6d69 557 break;
558 }
3280af22 559 retval = PL_padix;
79072805 560 }
8990e307 561 SvFLAGS(sv) |= tmptype;
3280af22 562 PL_curpad = AvARRAY(PL_comppad);
4d1ff10f 563#ifdef USE_5005THREADS
b900a521
JH		 564 DEBUG_X(PerlIO_printf(Perl_debug_log,
565 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
566 PTR2UV(thr), PTR2UV(PL_curpad),
22c35a8c 567 (long) retval, PL_op_name[optype]));
11343788 568#else
b900a521
JH		 569 DEBUG_X(PerlIO_printf(Perl_debug_log,
570 "Pad 0x%"UVxf" alloc %ld for %s\n",
571 PTR2UV(PL_curpad),
22c35a8c 572 (long) retval, PL_op_name[optype]));
4d1ff10f 573#endif /* USE_5005THREADS */
79072805
LW		 574 return (PADOFFSET)retval;
575}
576
577SV *
864dbfa3 578Perl_pad_sv(pTHX_ PADOFFSET po)
79072805 579{
4d1ff10f 580#ifdef USE_5005THREADS
b900a521 581 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH		 582 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
583 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 584#else
79072805 585 if (!po)
cea2e8a9 586 Perl_croak(aTHX_ "panic: pad_sv po");
97835f67
JH		 587 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
588 PTR2UV(PL_curpad), (IV)po));
4d1ff10f 589#endif /* USE_5005THREADS */
3280af22 590 return PL_curpad[po]; /* eventually we'll turn this into a macro */
79072805
LW		 591}
592
593void
864dbfa3 594Perl_pad_free(pTHX_ PADOFFSET po)
79072805 595{
3280af22 596 if (!PL_curpad)
a0d0e21e 597 return;
3280af22 598 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 599 Perl_croak(aTHX_ "panic: pad_free curpad");
79072805 600 if (!po)
cea2e8a9 601 Perl_croak(aTHX_ "panic: pad_free po");
4d1ff10f 602#ifdef USE_5005THREADS
b900a521 603 DEBUG_X(PerlIO_printf(Perl_debug_log,
7766f137 604 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
f1dbda3d 605 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 606#else
97835f67
JH		 607 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
608 PTR2UV(PL_curpad), (IV)po));
4d1ff10f 609#endif /* USE_5005THREADS */
2aa1bedc 610 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
3280af22 611 SvPADTMP_off(PL_curpad[po]);
2aa1bedc 612#ifdef USE_ITHREADS
d3d0e6f1
NC		 613#ifdef PERL_COPY_ON_WRITE
614 if (SvIsCOW(PL_curpad[po])) {
615 sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
616 } else
617#endif
618 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
2aa1bedc
GS		 619#endif
620 }
3280af22
NIS		 621 if ((I32)po < PL_padix)
622 PL_padix = po - 1;
79072805
LW		 623}
624
625void
864dbfa3 626Perl_pad_swipe(pTHX_ PADOFFSET po)
79072805 627{
3280af22 628 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 629 Perl_croak(aTHX_ "panic: pad_swipe curpad");
79072805 630 if (!po)
cea2e8a9 631 Perl_croak(aTHX_ "panic: pad_swipe po");
4d1ff10f 632#ifdef USE_5005THREADS
b900a521 633 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH		 634 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
635 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 636#else
97835f67
JH		 637 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
638 PTR2UV(PL_curpad), (IV)po));
4d1ff10f 639#endif /* USE_5005THREADS */
ce50c033
AMS		 640 if (PL_curpad[po])
641 SvPADTMP_off(PL_curpad[po]);
3280af22
NIS		 642 PL_curpad[po] = NEWSV(1107,0);
643 SvPADTMP_on(PL_curpad[po]);
644 if ((I32)po < PL_padix)
645 PL_padix = po - 1;
79072805
LW		 646}
647
d9bb4600
GS		 648/* XXX pad_reset() is currently disabled because it results in serious bugs.
649 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
650 * on the stack by OPs that use them, there are several ways to get an alias
651 * to a shared TARG. Such an alias will change randomly and unpredictably.
652 * We avoid doing this until we can think of a Better Way.
653 * GSAR 97-10-29 */
79072805 654void
864dbfa3 655Perl_pad_reset(pTHX)
79072805 656{
d9bb4600 657#ifdef USE_BROKEN_PAD_RESET
79072805
LW		 658 register I32 po;
659
6b88bc9c 660 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 661 Perl_croak(aTHX_ "panic: pad_reset curpad");
4d1ff10f 662#ifdef USE_5005THREADS
b900a521
JH		 663 DEBUG_X(PerlIO_printf(Perl_debug_log,
664 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
665 PTR2UV(thr), PTR2UV(PL_curpad)));
11343788 666#else
b900a521
JH		 667 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
668 PTR2UV(PL_curpad)));
4d1ff10f 669#endif /* USE_5005THREADS */
6b88bc9c
GS		 670 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
671 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
672 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
673 SvPADTMP_off(PL_curpad[po]);
748a9306 674 }
6b88bc9c 675 PL_padix = PL_padix_floor;
79072805 676 }
d9bb4600 677#endif
3280af22 678 PL_pad_reset_pending = FALSE;
79072805
LW		 679}
680
4d1ff10f 681#ifdef USE_5005THREADS
54b9620d 682/* find_threadsv is not reentrant */
a863c7d1 683PADOFFSET
864dbfa3 684Perl_find_threadsv(pTHX_ const char *name)
a863c7d1 685{
a863c7d1
MB		 686 char *p;
687 PADOFFSET key;
554b3eca 688 SV **svp;
54b9620d 689 /* We currently only handle names of a single character */
533c011a 690 p = strchr(PL_threadsv_names, *name);
a863c7d1
MB		 691 if (!p)
692 return NOT_IN_PAD;
533c011a 693 key = p - PL_threadsv_names;
2d8e6c8d 694 MUTEX_LOCK(&thr->mutex);
54b9620d 695 svp = av_fetch(thr->threadsv, key, FALSE);
2d8e6c8d
GS		 696 if (svp)
697 MUTEX_UNLOCK(&thr->mutex);
698 else {
554b3eca 699 SV *sv = NEWSV(0, 0);
54b9620d 700 av_store(thr->threadsv, key, sv);
940cb80d 701 thr->threadsvp = AvARRAY(thr->threadsv);
2d8e6c8d 702 MUTEX_UNLOCK(&thr->mutex);
554b3eca
MB		 703 /*
704 * Some magic variables used to be automagically initialised
705 * in gv_fetchpv. Those which are now per-thread magicals get
706 * initialised here instead.
707 */
708 switch (*name) {
54b9620d
MB		 709 case '_':
710 break;
554b3eca
MB		 711 case ';':
712 sv_setpv(sv, "\034");
14befaf4 713 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 714 break;
c277df42
IZ		 715 case '&':
716 case '`':
717 case '\'':
533c011a 718 PL_sawampersand = TRUE;
a3f914c5
GS		 719 /* FALL THROUGH */
720 case '1':
721 case '2':
722 case '3':
723 case '4':
724 case '5':
725 case '6':
726 case '7':
727 case '8':
728 case '9':
c277df42 729 SvREADONLY_on(sv);
d8b5173a 730 /* FALL THROUGH */
067391ea
GS		 731
732 /* XXX %! tied to Errno.pm needs to be added here.
733 * See gv_fetchpv(). */
734 /* case '!': */
735
54b9620d 736 default:
14befaf4 737 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 738 }
bf49b057 739 DEBUG_S(PerlIO_printf(Perl_error_log,
54b9620d 740 "find_threadsv: new SV %p for $%s%c\n",
554b3eca
MB		 741 sv, (*name < 32) ? "^" : "",
742 (*name < 32) ? toCTRL(*name) : *name));
a863c7d1
MB		 743 }
744 return key;
745}
4d1ff10f 746#endif /* USE_5005THREADS */
a863c7d1 747
79072805
LW		 748/* Destructor */
749
750void
864dbfa3 751Perl_op_free(pTHX_ OP *o)
79072805 752{
85e6fe83 753 register OP *kid, *nextkid;
acb36ea4 754 OPCODE type;
79072805 755
5dc0d613 756 if (!o || o->op_seq == (U16)-1)
79072805
LW		 757 return;
758
7934575e
GS		 759 if (o->op_private & OPpREFCOUNTED) {
760 switch (o->op_type) {
761 case OP_LEAVESUB:
762 case OP_LEAVESUBLV:
763 case OP_LEAVEEVAL:
764 case OP_LEAVE:
765 case OP_SCOPE:
766 case OP_LEAVEWRITE:
767 OP_REFCNT_LOCK;
768 if (OpREFCNT_dec(o)) {
769 OP_REFCNT_UNLOCK;
770 return;
771 }
772 OP_REFCNT_UNLOCK;
773 break;
774 default:
775 break;
776 }
777 }
778
11343788
MB		 779 if (o->op_flags & OPf_KIDS) {
780 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 781 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 782 op_free(kid);
85e6fe83 783 }
79072805 784 }
acb36ea4
GS		 785 type = o->op_type;
786 if (type == OP_NULL)
eb160463 787 type = (OPCODE)o->op_targ;
acb36ea4
GS		 788
789 /* COP* is not cleared by op_clear() so that we may track line
790 * numbers etc even after null() */
791 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
792 cop_free((COP*)o);
793
794 op_clear(o);
238a4c30 795 FreeOp(o);
acb36ea4 796}
79072805 797
93c66552
DM		 798void
799Perl_op_clear(pTHX_ OP *o)
acb36ea4 800{
13137afc 801
11343788 802 switch (o->op_type) {
acb36ea4
GS		 803 case OP_NULL: /* Was holding old type, if any. */
804 case OP_ENTEREVAL: /* Was holding hints. */
4d1ff10f 805#ifdef USE_5005THREADS
acb36ea4
GS		 806 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
807#endif
808 o->op_targ = 0;
a0d0e21e 809 break;
4d1ff10f 810#ifdef USE_5005THREADS
8dd3ba40
SM		 811 case OP_ENTERITER:
812 if (!(o->op_flags & OPf_SPECIAL))
813 break;
814 /* FALL THROUGH */
4d1ff10f 815#endif /* USE_5005THREADS */
a6006777 816 default:
ac4c12e7 817 if (!(o->op_flags & OPf_REF)
0b94c7bb 818 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 819 break;
820 /* FALL THROUGH */
463ee0b2 821 case OP_GVSV:
79072805 822 case OP_GV:
a6006777 823 case OP_AELEMFAST:
350de78d 824#ifdef USE_ITHREADS
971a9dd3
GS		 825 if (cPADOPo->op_padix > 0) {
826 if (PL_curpad) {
638eceb6 827 GV *gv = cGVOPo_gv;
971a9dd3
GS		 828 pad_swipe(cPADOPo->op_padix);
829 /* No GvIN_PAD_off(gv) here, because other references may still
830 * exist on the pad */
831 SvREFCNT_dec(gv);
832 }
833 cPADOPo->op_padix = 0;
834 }
350de78d 835#else
971a9dd3 836 SvREFCNT_dec(cSVOPo->op_sv);
7934575e 837 cSVOPo->op_sv = Nullsv;
350de78d 838#endif
79072805 839 break;
a1ae71d2 840 case OP_METHOD_NAMED:
79072805 841 case OP_CONST:
11343788 842 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 843 cSVOPo->op_sv = Nullsv;
79072805 844 break;
748a9306
LW		 845 case OP_GOTO:
846 case OP_NEXT:
847 case OP_LAST:
848 case OP_REDO:
11343788 849 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 850 break;
851 /* FALL THROUGH */
a0d0e21e 852 case OP_TRANS:
acb36ea4 853 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 854 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS		 855 cSVOPo->op_sv = Nullsv;
856 }
857 else {
a0ed51b3 858 Safefree(cPVOPo->op_pv);
acb36ea4
GS		 859 cPVOPo->op_pv = Nullch;
860 }
a0d0e21e
LW		 861 break;
862 case OP_SUBST:
11343788 863 op_free(cPMOPo->op_pmreplroot);
971a9dd3 864 goto clear_pmop;
748a9306 865 case OP_PUSHRE:
971a9dd3 866#ifdef USE_ITHREADS
ba89bb6e 867 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
971a9dd3 868 if (PL_curpad) {
ba89bb6e
AB		 869 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
870 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
971a9dd3
GS		 871 /* No GvIN_PAD_off(gv) here, because other references may still
872 * exist on the pad */
873 SvREFCNT_dec(gv);
874 }
875 }
876#else
877 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
878#endif
879 /* FALL THROUGH */
a0d0e21e 880 case OP_MATCH:
8782bef2 881 case OP_QR:
971a9dd3 882clear_pmop:
cb55de95
JH		 883 {
884 HV *pmstash = PmopSTASH(cPMOPo);
885 if (pmstash && SvREFCNT(pmstash)) {
886 PMOP *pmop = HvPMROOT(pmstash);
887 PMOP *lastpmop = NULL;
888 while (pmop) {
889 if (cPMOPo == pmop) {
890 if (lastpmop)
891 lastpmop->op_pmnext = pmop->op_pmnext;
892 else
893 HvPMROOT(pmstash) = pmop->op_pmnext;
894 break;
895 }
896 lastpmop = pmop;
897 pmop = pmop->op_pmnext;
898 }
83da49e6 899 }
05ec9bb3 900 PmopSTASH_free(cPMOPo);
cb55de95 901 }
971a9dd3 902 cPMOPo->op_pmreplroot = Nullop;
5f8cb046
DM		 903 /* we use the "SAFE" version of the PM_ macros here
904 * since sv_clean_all might release some PMOPs
905 * after PL_regex_padav has been cleared
906 * and the clearing of PL_regex_padav needs to
907 * happen before sv_clean_all
908 */
909 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
910 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
13137afc
AB		 911#ifdef USE_ITHREADS
912 if(PL_regex_pad) { /* We could be in destruction */
913 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 914 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 915 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
916 }
1eb1540c 917#endif
13137afc 918
a0d0e21e 919 break;
79072805
LW		 920 }
921
743e66e6 922 if (o->op_targ > 0) {
11343788 923 pad_free(o->op_targ);
743e66e6
GS		 924 o->op_targ = 0;
925 }
79072805
LW		 926}
927
76e3520e 928STATIC void
3eb57f73
HS		 929S_cop_free(pTHX_ COP* cop)
930{
05ec9bb3
NIS		 931 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
932 CopFILE_free(cop);
933 CopSTASH_free(cop);
0453d815 934 if (! specialWARN(cop->cop_warnings))
3eb57f73 935 SvREFCNT_dec(cop->cop_warnings);
05ec9bb3
NIS		 936 if (! specialCopIO(cop->cop_io)) {
937#ifdef USE_ITHREADS
042f6df8 938#if 0
05ec9bb3
NIS		 939 STRLEN len;
940 char *s = SvPV(cop->cop_io,len);
b178108d
JH		 941 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
942#endif
05ec9bb3 943#else
ac27b0f5 944 SvREFCNT_dec(cop->cop_io);
05ec9bb3
NIS		 945#endif
946 }
3eb57f73
HS		 947}
948
93c66552
DM		 949void
950Perl_op_null(pTHX_ OP *o)
8990e307 951{
acb36ea4
GS		 952 if (o->op_type == OP_NULL)
953 return;
954 op_clear(o);
11343788
MB		 955 o->op_targ = o->op_type;
956 o->op_type = OP_NULL;
22c35a8c 957 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 958}
959
79072805
LW		 960/* Contextualizers */
961
463ee0b2 962#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 963
964OP *
864dbfa3 965Perl_linklist(pTHX_ OP *o)
79072805
LW		 966{
967 register OP *kid;
968
11343788
MB		 969 if (o->op_next)
970 return o->op_next;
79072805
LW		 971
972 /* establish postfix order */
11343788
MB		 973 if (cUNOPo->op_first) {
974 o->op_next = LINKLIST(cUNOPo->op_first);
975 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 976 if (kid->op_sibling)
977 kid->op_next = LINKLIST(kid->op_sibling);
978 else
11343788 979 kid->op_next = o;
79072805
LW		 980 }
981 }
982 else
11343788 983 o->op_next = o;
79072805 984
11343788 985 return o->op_next;
79072805
LW		 986}
987
988OP *
864dbfa3 989Perl_scalarkids(pTHX_ OP *o)
79072805
LW		 990{
991 OP *kid;
11343788
MB		 992 if (o && o->op_flags & OPf_KIDS) {
993 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 994 scalar(kid);
995 }
11343788 996 return o;
79072805
LW		 997}
998
76e3520e 999STATIC OP *
cea2e8a9 1000S_scalarboolean(pTHX_ OP *o)
8990e307 1001{
d008e5eb 1002 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 1003 if (ckWARN(WARN_SYNTAX)) {
57843af0 1004 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1005
d008e5eb 1006 if (PL_copline != NOLINE)
57843af0 1007 CopLINE_set(PL_curcop, PL_copline);
9014280d 1008 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1009 CopLINE_set(PL_curcop, oldline);
d008e5eb 1010 }
a0d0e21e 1011 }
11343788 1012 return scalar(o);
8990e307
LW		 1013}
1014
1015OP *
864dbfa3 1016Perl_scalar(pTHX_ OP *o)
79072805
LW		 1017{
1018 OP *kid;
1019
a0d0e21e 1020 /* assumes no premature commitment */
3280af22 1021 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1022 || o->op_type == OP_RETURN)
7e363e51 1023 {
11343788 1024 return o;
7e363e51 1025 }
79072805 1026
5dc0d613 1027 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1028
11343788 1029 switch (o->op_type) {
79072805 1030 case OP_REPEAT:
11343788 1031 scalar(cBINOPo->op_first);
8990e307 1032 break;
79072805
LW		 1033 case OP_OR:
1034 case OP_AND:
1035 case OP_COND_EXPR:
11343788 1036 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 1037 scalar(kid);
79072805 1038 break;
a0d0e21e 1039 case OP_SPLIT:
11343788 1040 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 1041 if (!kPMOP->op_pmreplroot)
12bcd1a6 1042 deprecate_old("implicit split to @_");
a0d0e21e
LW		 1043 }
1044 /* FALL THROUGH */
79072805 1045 case OP_MATCH:
8782bef2 1046 case OP_QR:
79072805
LW		 1047 case OP_SUBST:
1048 case OP_NULL:
8990e307 1049 default:
11343788
MB		 1050 if (o->op_flags & OPf_KIDS) {
1051 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 1052 scalar(kid);
1053 }
79072805
LW		 1054 break;
1055 case OP_LEAVE:
1056 case OP_LEAVETRY:
5dc0d613 1057 kid = cLISTOPo->op_first;
54310121 1058 scalar(kid);
155aba94 1059 while ((kid = kid->op_sibling)) {
54310121 1060 if (kid->op_sibling)
1061 scalarvoid(kid);
1062 else
1063 scalar(kid);
1064 }
3280af22 1065 WITH_THR(PL_curcop = &PL_compiling);
54310121 1066 break;
748a9306 1067 case OP_SCOPE:
79072805 1068 case OP_LINESEQ:
8990e307 1069 case OP_LIST:
11343788 1070 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1071 if (kid->op_sibling)
1072 scalarvoid(kid);
1073 else
1074 scalar(kid);
1075 }
3280af22 1076 WITH_THR(PL_curcop = &PL_compiling);
79072805 1077 break;
a801c63c
RGS		 1078 case OP_SORT:
1079 if (ckWARN(WARN_VOID))
9014280d 1080 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 1081 }
11343788 1082 return o;
79072805
LW		 1083}
1084
1085OP *
864dbfa3 1086Perl_scalarvoid(pTHX_ OP *o)
79072805
LW		 1087{
1088 OP *kid;
8990e307
LW		 1089 char* useless = 0;
1090 SV* sv;
2ebea0a1
GS		 1091 U8 want;
1092
acb36ea4
GS		 1093 if (o->op_type == OP_NEXTSTATE
1094 || o->op_type == OP_SETSTATE
1095 || o->op_type == OP_DBSTATE
1096 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1097 || o->op_targ == OP_SETSTATE
1098 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1099 PL_curcop = (COP*)o; /* for warning below */
79072805 1100
54310121 1101 /* assumes no premature commitment */
2ebea0a1
GS		 1102 want = o->op_flags & OPf_WANT;
1103 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 1104 || o->op_type == OP_RETURN)
7e363e51 1105 {
11343788 1106 return o;
7e363e51 1107 }
79072805 1108
b162f9ea 1109 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1110 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1111 {
b162f9ea 1112 return scalar(o); /* As if inside SASSIGN */
7e363e51 1113 }
1c846c1f 1114
5dc0d613 1115 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1116
11343788 1117 switch (o->op_type) {
79072805 1118 default:
22c35a8c 1119 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1120 break;
36477c24 1121 /* FALL THROUGH */
1122 case OP_REPEAT:
11343788 1123 if (o->op_flags & OPf_STACKED)
8990e307 1124 break;
5d82c453
GA		 1125 goto func_ops;
1126 case OP_SUBSTR:
1127 if (o->op_private == 4)
1128 break;
8990e307
LW		 1129 /* FALL THROUGH */
1130 case OP_GVSV:
1131 case OP_WANTARRAY:
1132 case OP_GV:
1133 case OP_PADSV:
1134 case OP_PADAV:
1135 case OP_PADHV:
1136 case OP_PADANY:
1137 case OP_AV2ARYLEN:
8990e307 1138 case OP_REF:
a0d0e21e
LW		 1139 case OP_REFGEN:
1140 case OP_SREFGEN:
8990e307
LW		 1141 case OP_DEFINED:
1142 case OP_HEX:
1143 case OP_OCT:
1144 case OP_LENGTH:
8990e307
LW		 1145 case OP_VEC:
1146 case OP_INDEX:
1147 case OP_RINDEX:
1148 case OP_SPRINTF:
1149 case OP_AELEM:
1150 case OP_AELEMFAST:
1151 case OP_ASLICE:
8990e307
LW		 1152 case OP_HELEM:
1153 case OP_HSLICE:
1154 case OP_UNPACK:
1155 case OP_PACK:
8990e307
LW		 1156 case OP_JOIN:
1157 case OP_LSLICE:
1158 case OP_ANONLIST:
1159 case OP_ANONHASH:
1160 case OP_SORT:
1161 case OP_REVERSE:
1162 case OP_RANGE:
1163 case OP_FLIP:
1164 case OP_FLOP:
1165 case OP_CALLER:
1166 case OP_FILENO:
1167 case OP_EOF:
1168 case OP_TELL:
1169 case OP_GETSOCKNAME:
1170 case OP_GETPEERNAME:
1171 case OP_READLINK:
1172 case OP_TELLDIR:
1173 case OP_GETPPID:
1174 case OP_GETPGRP:
1175 case OP_GETPRIORITY:
1176 case OP_TIME:
1177 case OP_TMS:
1178 case OP_LOCALTIME:
1179 case OP_GMTIME:
1180 case OP_GHBYNAME:
1181 case OP_GHBYADDR:
1182 case OP_GHOSTENT:
1183 case OP_GNBYNAME:
1184 case OP_GNBYADDR:
1185 case OP_GNETENT:
1186 case OP_GPBYNAME:
1187 case OP_GPBYNUMBER:
1188 case OP_GPROTOENT:
1189 case OP_GSBYNAME:
1190 case OP_GSBYPORT:
1191 case OP_GSERVENT:
1192 case OP_GPWNAM:
1193 case OP_GPWUID:
1194 case OP_GGRNAM:
1195 case OP_GGRGID:
1196 case OP_GETLOGIN:
5d82c453 1197 func_ops:
64aac5a9 1198 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 1199 useless = OP_DESC(o);
8990e307
LW		 1200 break;
1201
1202 case OP_RV2GV:
1203 case OP_RV2SV:
1204 case OP_RV2AV:
1205 case OP_RV2HV:
192587c2 1206 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1207 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1208 useless = "a variable";
1209 break;
79072805
LW		 1210
1211 case OP_CONST:
7766f137 1212 sv = cSVOPo_sv;
7a52d87a
GS		 1213 if (cSVOPo->op_private & OPpCONST_STRICT)
1214 no_bareword_allowed(o);
1215 else {
d008e5eb
GS		 1216 if (ckWARN(WARN_VOID)) {
1217 useless = "a constant";
960b4253
MG		 1218 /* the constants 0 and 1 are permitted as they are
1219 conventionally used as dummies in constructs like
1220 1 while some_condition_with_side_effects; */
d008e5eb
GS		 1221 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1222 useless = 0;
1223 else if (SvPOK(sv)) {
a52fe3ac
A		 1224 /* perl4's way of mixing documentation and code
1225 (before the invention of POD) was based on a
1226 trick to mix nroff and perl code. The trick was
1227 built upon these three nroff macros being used in
1228 void context. The pink camel has the details in
1229 the script wrapman near page 319. */
d008e5eb
GS		 1230 if (strnEQ(SvPVX(sv), "di", 2) ||
1231 strnEQ(SvPVX(sv), "ds", 2) ||
1232 strnEQ(SvPVX(sv), "ig", 2))
1233 useless = 0;
1234 }
8990e307
LW		 1235 }
1236 }
93c66552 1237 op_null(o); /* don't execute or even remember it */
79072805
LW		 1238 break;
1239
1240 case OP_POSTINC:
11343788 1241 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1242 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1243 break;
1244
1245 case OP_POSTDEC:
11343788 1246 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1247 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1248 break;
1249
79072805
LW		 1250 case OP_OR:
1251 case OP_AND:
c963b151 1252 case OP_DOR:
79072805 1253 case OP_COND_EXPR:
11343788 1254 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1255 scalarvoid(kid);
1256 break;
5aabfad6 1257
a0d0e21e 1258 case OP_NULL:
11343788 1259 if (o->op_flags & OPf_STACKED)
a0d0e21e 1260 break;
5aabfad6 1261 /* FALL THROUGH */
2ebea0a1
GS		 1262 case OP_NEXTSTATE:
1263 case OP_DBSTATE:
79072805
LW		 1264 case OP_ENTERTRY:
1265 case OP_ENTER:
11343788 1266 if (!(o->op_flags & OPf_KIDS))
79072805 1267 break;
54310121 1268 /* FALL THROUGH */
463ee0b2 1269 case OP_SCOPE:
79072805
LW		 1270 case OP_LEAVE:
1271 case OP_LEAVETRY:
a0d0e21e 1272 case OP_LEAVELOOP:
79072805 1273 case OP_LINESEQ:
79072805 1274 case OP_LIST:
11343788 1275 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1276 scalarvoid(kid);
1277 break;
c90c0ff4 1278 case OP_ENTEREVAL:
5196be3e 1279 scalarkids(o);
c90c0ff4 1280 break;
5aabfad6 1281 case OP_REQUIRE:
c90c0ff4 1282 /* all requires must return a boolean value */
5196be3e 1283 o->op_flags &= ~OPf_WANT;
d6483035
GS		 1284 /* FALL THROUGH */
1285 case OP_SCALAR:
5196be3e 1286 return scalar(o);
a0d0e21e 1287 case OP_SPLIT:
11343788 1288 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 1289 if (!kPMOP->op_pmreplroot)
12bcd1a6 1290 deprecate_old("implicit split to @_");
a0d0e21e
LW		 1291 }
1292 break;
79072805 1293 }
411caa50 1294 if (useless && ckWARN(WARN_VOID))
9014280d 1295 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 1296 return o;
79072805
LW		 1297}
1298
1299OP *
864dbfa3 1300Perl_listkids(pTHX_ OP *o)
79072805
LW		 1301{
1302 OP *kid;
11343788
MB		 1303 if (o && o->op_flags & OPf_KIDS) {
1304 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1305 list(kid);
1306 }
11343788 1307 return o;
79072805
LW		 1308}
1309
1310OP *
864dbfa3 1311Perl_list(pTHX_ OP *o)
79072805
LW		 1312{
1313 OP *kid;
1314
a0d0e21e 1315 /* assumes no premature commitment */
3280af22 1316 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1317 || o->op_type == OP_RETURN)
7e363e51 1318 {
11343788 1319 return o;
7e363e51 1320 }
79072805 1321
b162f9ea 1322 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1323 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1324 {
b162f9ea 1325 return o; /* As if inside SASSIGN */
7e363e51 1326 }
1c846c1f 1327
5dc0d613 1328 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1329
11343788 1330 switch (o->op_type) {
79072805
LW		 1331 case OP_FLOP:
1332 case OP_REPEAT:
11343788 1333 list(cBINOPo->op_first);
79072805
LW		 1334 break;
1335 case OP_OR:
1336 case OP_AND:
1337 case OP_COND_EXPR:
11343788 1338 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1339 list(kid);
1340 break;
1341 default:
1342 case OP_MATCH:
8782bef2 1343 case OP_QR:
79072805
LW		 1344 case OP_SUBST:
1345 case OP_NULL:
11343788 1346 if (!(o->op_flags & OPf_KIDS))
79072805 1347 break;
11343788
MB		 1348 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1349 list(cBINOPo->op_first);
1350 return gen_constant_list(o);
79072805
LW		 1351 }
1352 case OP_LIST:
11343788 1353 listkids(o);
79072805
LW		 1354 break;
1355 case OP_LEAVE:
1356 case OP_LEAVETRY:
5dc0d613 1357 kid = cLISTOPo->op_first;
54310121 1358 list(kid);
155aba94 1359 while ((kid = kid->op_sibling)) {
54310121 1360 if (kid->op_sibling)
1361 scalarvoid(kid);
1362 else
1363 list(kid);
1364 }
3280af22 1365 WITH_THR(PL_curcop = &PL_compiling);
54310121 1366 break;
748a9306 1367 case OP_SCOPE:
79072805 1368 case OP_LINESEQ:
11343788 1369 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1370 if (kid->op_sibling)
1371 scalarvoid(kid);
1372 else
1373 list(kid);
1374 }
3280af22 1375 WITH_THR(PL_curcop = &PL_compiling);
79072805 1376 break;
c90c0ff4 1377 case OP_REQUIRE:
1378 /* all requires must return a boolean value */
5196be3e
MB		 1379 o->op_flags &= ~OPf_WANT;
1380 return scalar(o);
79072805 1381 }
11343788 1382 return o;
79072805
LW		 1383}
1384
1385OP *
864dbfa3 1386Perl_scalarseq(pTHX_ OP *o)
79072805
LW		 1387{
1388 OP *kid;
1389
11343788
MB		 1390 if (o) {
1391 if (o->op_type == OP_LINESEQ ||
1392 o->op_type == OP_SCOPE ||
1393 o->op_type == OP_LEAVE ||
1394 o->op_type == OP_LEAVETRY)
463ee0b2 1395 {
11343788 1396 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1397 if (kid->op_sibling) {
463ee0b2 1398 scalarvoid(kid);
ed6116ce 1399 }
463ee0b2 1400 }
3280af22 1401 PL_curcop = &PL_compiling;
79072805 1402 }
11343788 1403 o->op_flags &= ~OPf_PARENS;
3280af22 1404 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1405 o->op_flags |= OPf_PARENS;
79072805 1406 }
8990e307 1407 else
11343788
MB		 1408 o = newOP(OP_STUB, 0);
1409 return o;
79072805
LW		 1410}
1411
76e3520e 1412STATIC OP *
cea2e8a9 1413S_modkids(pTHX_ OP *o, I32 type)
79072805
LW		 1414{
1415 OP *kid;
11343788
MB		 1416 if (o && o->op_flags & OPf_KIDS) {
1417 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1418 mod(kid, type);
79072805 1419 }
11343788 1420 return o;
79072805
LW		 1421}
1422
79072805 1423OP *
864dbfa3 1424Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW		 1425{
1426 OP *kid;
2d8e6c8d 1427 STRLEN n_a;
79072805 1428
3280af22 1429 if (!o || PL_error_count)
11343788 1430 return o;
79072805 1431
b162f9ea 1432 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1433 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1434 {
b162f9ea 1435 return o;
7e363e51 1436 }
1c846c1f 1437
11343788 1438 switch (o->op_type) {
68dc0745 1439 case OP_UNDEF:
3280af22 1440 PL_modcount++;
5dc0d613 1441 return o;
a0d0e21e 1442 case OP_CONST:
11343788 1443 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1444 goto nomod;
3280af22 1445 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1446 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1447 PL_eval_start = 0;
a0d0e21e
LW		 1448 }
1449 else if (!type) {
3280af22
NIS		 1450 SAVEI32(PL_compiling.cop_arybase);
1451 PL_compiling.cop_arybase = 0;
a0d0e21e
LW		 1452 }
1453 else if (type == OP_REFGEN)
1454 goto nomod;
1455 else
cea2e8a9 1456 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1457 break;
5f05dabc 1458 case OP_STUB:
5196be3e 1459 if (o->op_flags & OPf_PARENS)
5f05dabc 1460 break;
1461 goto nomod;
a0d0e21e
LW		 1462 case OP_ENTERSUB:
1463 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1464 !(o->op_flags & OPf_STACKED)) {
1465 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1466 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1467 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1468 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1469 break;
1470 }
95f0a2f1
SB		 1471 else if (o->op_private & OPpENTERSUB_NOMOD)
1472 return o;
cd06dffe
GS		 1473 else { /* lvalue subroutine call */
1474 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1475 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1476 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1477 /* Backward compatibility mode: */
1478 o->op_private |= OPpENTERSUB_INARGS;
1479 break;
1480 }
1481 else { /* Compile-time error message: */
1482 OP *kid = cUNOPo->op_first;
1483 CV *cv;
1484 OP *okid;
1485
1486 if (kid->op_type == OP_PUSHMARK)
1487 goto skip_kids;
1488 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1489 Perl_croak(aTHX_
1490 "panic: unexpected lvalue entersub "
55140b79 1491 "args: type/targ %ld:%"UVuf,
3d811634 1492 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1493 kid = kLISTOP->op_first;
1494 skip_kids:
1495 while (kid->op_sibling)
1496 kid = kid->op_sibling;
1497 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1498 /* Indirect call */
1499 if (kid->op_type == OP_METHOD_NAMED
1500 || kid->op_type == OP_METHOD)
1501 {
87d7fd28 1502 UNOP *newop;
b2ffa427 1503
87d7fd28 1504 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1505 newop->op_type = OP_RV2CV;
1506 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS		 1507 newop->op_first = Nullop;
1508 newop->op_next = (OP*)newop;
1509 kid->op_sibling = (OP*)newop;
349fd7b7 1510 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS		 1511 break;
1512 }
b2ffa427 1513
cd06dffe
GS		 1514 if (kid->op_type != OP_RV2CV)
1515 Perl_croak(aTHX_
1516 "panic: unexpected lvalue entersub "
55140b79 1517 "entry via type/targ %ld:%"UVuf,
3d811634 1518 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1519 kid->op_private |= OPpLVAL_INTRO;
1520 break; /* Postpone until runtime */
1521 }
b2ffa427
NIS		 1522
1523 okid = kid;
cd06dffe
GS		 1524 kid = kUNOP->op_first;
1525 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1526 kid = kUNOP->op_first;
b2ffa427 1527 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1528 Perl_croak(aTHX_
1529 "Unexpected constant lvalue entersub "
55140b79 1530 "entry via type/targ %ld:%"UVuf,
3d811634 1531 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1532 if (kid->op_type != OP_GV) {
1533 /* Restore RV2CV to check lvalueness */
1534 restore_2cv:
1535 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1536 okid->op_next = kid->op_next;
1537 kid->op_next = okid;
1538 }
1539 else
1540 okid->op_next = Nullop;
1541 okid->op_type = OP_RV2CV;
1542 okid->op_targ = 0;
1543 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1544 okid->op_private |= OPpLVAL_INTRO;
1545 break;
1546 }
b2ffa427 1547
638eceb6 1548 cv = GvCV(kGVOP_gv);
1c846c1f 1549 if (!cv)
cd06dffe
GS		 1550 goto restore_2cv;
1551 if (CvLVALUE(cv))
1552 break;
1553 }
1554 }
79072805
LW		 1555 /* FALL THROUGH */
1556 default:
a0d0e21e
LW		 1557 nomod:
1558 /* grep, foreach, subcalls, refgen */
1559 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1560 break;
cea2e8a9 1561 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1562 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1563 ? "do block"
1564 : (o->op_type == OP_ENTERSUB
1565 ? "non-lvalue subroutine call"
53e06cf0 1566 : OP_DESC(o))),
22c35a8c 1567 type ? PL_op_desc[type] : "local"));
11343788 1568 return o;
79072805 1569
a0d0e21e
LW		 1570 case OP_PREINC:
1571 case OP_PREDEC:
1572 case OP_POW:
1573 case OP_MULTIPLY:
1574 case OP_DIVIDE:
1575 case OP_MODULO:
1576 case OP_REPEAT:
1577 case OP_ADD:
1578 case OP_SUBTRACT:
1579 case OP_CONCAT:
1580 case OP_LEFT_SHIFT:
1581 case OP_RIGHT_SHIFT:
1582 case OP_BIT_AND:
1583 case OP_BIT_XOR:
1584 case OP_BIT_OR:
1585 case OP_I_MULTIPLY:
1586 case OP_I_DIVIDE:
1587 case OP_I_MODULO:
1588 case OP_I_ADD:
1589 case OP_I_SUBTRACT:
11343788 1590 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1591 goto nomod;
3280af22 1592 PL_modcount++;
a0d0e21e 1593 break;
b2ffa427 1594
79072805 1595 case OP_COND_EXPR:
11343788 1596 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1597 mod(kid, type);
79072805
LW		 1598 break;
1599
1600 case OP_RV2AV:
1601 case OP_RV2HV:
93af7a87 1602 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1603 Perl_croak(aTHX_ "Can't localize through a reference");
11343788 1604 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1605 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1606 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1607 }
1608 /* FALL THROUGH */
79072805 1609 case OP_RV2GV:
5dc0d613 1610 if (scalar_mod_type(o, type))
3fe9a6f1 1611 goto nomod;
11343788 1612 ref(cUNOPo->op_first, o->op_type);
79072805 1613 /* FALL THROUGH */
79072805
LW		 1614 case OP_ASLICE:
1615 case OP_HSLICE:
78f9721b
SM		 1616 if (type == OP_LEAVESUBLV)
1617 o->op_private |= OPpMAYBE_LVSUB;
1618 /* FALL THROUGH */
1619 case OP_AASSIGN:
93a17b20
LW		 1620 case OP_NEXTSTATE:
1621 case OP_DBSTATE:
e6438c1a 1622 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1623 break;
463ee0b2 1624 case OP_RV2SV:
11343788 1625 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1626 Perl_croak(aTHX_ "Can't localize through a reference");
aeea060c 1627 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1628 /* FALL THROUGH */
79072805 1629 case OP_GV:
463ee0b2 1630 case OP_AV2ARYLEN:
3280af22 1631 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1632 case OP_SASSIGN:
bf4b1e52
GS		 1633 case OP_ANDASSIGN:
1634 case OP_ORASSIGN:
c963b151 1635 case OP_DORASSIGN:
8990e307 1636 case OP_AELEMFAST:
3280af22 1637 PL_modcount++;
8990e307
LW		 1638 break;
1639
748a9306
LW		 1640 case OP_PADAV:
1641 case OP_PADHV:
e6438c1a 1642 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1643 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1644 return o; /* Treat \(@foo) like ordinary list. */
1645 if (scalar_mod_type(o, type))
3fe9a6f1 1646 goto nomod;
78f9721b
SM		 1647 if (type == OP_LEAVESUBLV)
1648 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1649 /* FALL THROUGH */
1650 case OP_PADSV:
3280af22 1651 PL_modcount++;
748a9306 1652 if (!type)
cea2e8a9 1653 Perl_croak(aTHX_ "Can't localize lexical variable %s",
2d8e6c8d 1654 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
463ee0b2
LW		 1655 break;
1656
4d1ff10f 1657#ifdef USE_5005THREADS
2faa37cc 1658 case OP_THREADSV:
533c011a 1659 PL_modcount++; /* XXX ??? */
554b3eca 1660 break;
4d1ff10f 1661#endif /* USE_5005THREADS */
554b3eca 1662
748a9306
LW		 1663 case OP_PUSHMARK:
1664 break;
b2ffa427 1665
69969c6f
SB		 1666 case OP_KEYS:
1667 if (type != OP_SASSIGN)
1668 goto nomod;
5d82c453
GA		 1669 goto lvalue_func;
1670 case OP_SUBSTR:
1671 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1672 goto nomod;
5f05dabc 1673 /* FALL THROUGH */
a0d0e21e 1674 case OP_POS:
463ee0b2 1675 case OP_VEC:
78f9721b
SM		 1676 if (type == OP_LEAVESUBLV)
1677 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1678 lvalue_func:
11343788
MB		 1679 pad_free(o->op_targ);
1680 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1681 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1682 if (o->op_flags & OPf_KIDS)
1683 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1684 break;
a0d0e21e 1685
463ee0b2
LW		 1686 case OP_AELEM:
1687 case OP_HELEM:
11343788 1688 ref(cBINOPo->op_first, o->op_type);
68dc0745 1689 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1690 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1691 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1692 if (type == OP_LEAVESUBLV)
1693 o->op_private |= OPpMAYBE_LVSUB;
3280af22 1694 PL_modcount++;
463ee0b2
LW		 1695 break;
1696
1697 case OP_SCOPE:
1698 case OP_LEAVE:
1699 case OP_ENTER:
78f9721b 1700 case OP_LINESEQ:
11343788
MB		 1701 if (o->op_flags & OPf_KIDS)
1702 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1703 break;
1704
1705 case OP_NULL:
638bc118
GS		 1706 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1707 goto nomod;
1708 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1709 break;
11343788
MB		 1710 if (o->op_targ != OP_LIST) {
1711 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1712 break;
1713 }
1714 /* FALL THROUGH */
463ee0b2 1715 case OP_LIST:
11343788 1716 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1717 mod(kid, type);
1718 break;
78f9721b
SM		 1719
1720 case OP_RETURN:
1721 if (type != OP_LEAVESUBLV)
1722 goto nomod;
1723 break; /* mod()ing was handled by ck_return() */
463ee0b2 1724 }
58d95175 1725
8be1be90
AMS		 1726 /* [20011101.069] File test operators interpret OPf_REF to mean that
1727 their argument is a filehandle; thus \stat(".") should not set
1728 it. AMS 20011102 */
1729 if (type == OP_REFGEN &&
1730 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1731 return o;
1732
1733 if (type != OP_LEAVESUBLV)
1734 o->op_flags |= OPf_MOD;
1735
1736 if (type == OP_AASSIGN || type == OP_SASSIGN)
1737 o->op_flags |= OPf_SPECIAL|OPf_REF;
1738 else if (!type) {
1739 o->op_private |= OPpLVAL_INTRO;
1740 o->op_flags &= ~OPf_SPECIAL;
1741 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1742 }
8be1be90
AMS		 1743 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1744 && type != OP_LEAVESUBLV)
1745 o->op_flags |= OPf_REF;
11343788 1746 return o;
463ee0b2
LW		 1747}
1748
864dbfa3 1749STATIC bool
cea2e8a9 1750S_scalar_mod_type(pTHX_ OP *o, I32 type)
3fe9a6f1 1751{
1752 switch (type) {
1753 case OP_SASSIGN:
5196be3e 1754 if (o->op_type == OP_RV2GV)
3fe9a6f1 1755 return FALSE;
1756 /* FALL THROUGH */
1757 case OP_PREINC:
1758 case OP_PREDEC:
1759 case OP_POSTINC:
1760 case OP_POSTDEC:
1761 case OP_I_PREINC:
1762 case OP_I_PREDEC:
1763 case OP_I_POSTINC:
1764 case OP_I_POSTDEC:
1765 case OP_POW:
1766 case OP_MULTIPLY:
1767 case OP_DIVIDE:
1768 case OP_MODULO:
1769 case OP_REPEAT:
1770 case OP_ADD:
1771 case OP_SUBTRACT:
1772 case OP_I_MULTIPLY:
1773 case OP_I_DIVIDE:
1774 case OP_I_MODULO:
1775 case OP_I_ADD:
1776 case OP_I_SUBTRACT:
1777 case OP_LEFT_SHIFT:
1778 case OP_RIGHT_SHIFT:
1779 case OP_BIT_AND:
1780 case OP_BIT_XOR:
1781 case OP_BIT_OR:
1782 case OP_CONCAT:
1783 case OP_SUBST:
1784 case OP_TRANS:
49e9fbe6
GS		 1785 case OP_READ:
1786 case OP_SYSREAD:
1787 case OP_RECV:
bf4b1e52
GS		 1788 case OP_ANDASSIGN:
1789 case OP_ORASSIGN:
3fe9a6f1 1790 return TRUE;
1791 default:
1792 return FALSE;
1793 }
1794}
1795
35cd451c 1796STATIC bool
cea2e8a9 1797S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
35cd451c
GS		 1798{
1799 switch (o->op_type) {
1800 case OP_PIPE_OP:
1801 case OP_SOCKPAIR:
1802 if (argnum == 2)
1803 return TRUE;
1804 /* FALL THROUGH */
1805 case OP_SYSOPEN:
1806 case OP_OPEN:
ded8aa31 1807 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1808 case OP_SOCKET:
1809 case OP_OPEN_DIR:
1810 case OP_ACCEPT:
1811 if (argnum == 1)
1812 return TRUE;
1813 /* FALL THROUGH */
1814 default:
1815 return FALSE;
1816 }
1817}
1818
463ee0b2 1819OP *
864dbfa3 1820Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1821{
1822 OP *kid;
11343788
MB		 1823 if (o && o->op_flags & OPf_KIDS) {
1824 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1825 ref(kid, type);
1826 }
11343788 1827 return o;
463ee0b2
LW		 1828}
1829
1830OP *
864dbfa3 1831Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1832{
1833 OP *kid;
463ee0b2 1834
3280af22 1835 if (!o || PL_error_count)
11343788 1836 return o;
463ee0b2 1837
11343788 1838 switch (o->op_type) {
a0d0e21e 1839 case OP_ENTERSUB:
afebc493 1840 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1841 !(o->op_flags & OPf_STACKED)) {
1842 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1843 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1844 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1845 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1846 o->op_flags |= OPf_SPECIAL;
8990e307
LW		 1847 }
1848 break;
aeea060c 1849
463ee0b2 1850 case OP_COND_EXPR:
11343788 1851 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW		 1852 ref(kid, type);
1853 break;
8990e307 1854 case OP_RV2SV:
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);
4633a7c4
LW		 1858 /* FALL THROUGH */
1859 case OP_PADSV:
5f05dabc 1860 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1861 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1862 : type == OP_RV2HV ? OPpDEREF_HV
1863 : OPpDEREF_SV);
11343788 1864 o->op_flags |= OPf_MOD;
a0d0e21e 1865 }
8990e307 1866 break;
1c846c1f 1867
2faa37cc 1868 case OP_THREADSV:
a863c7d1
MB		 1869 o->op_flags |= OPf_MOD; /* XXX ??? */
1870 break;
1871
463ee0b2
LW		 1872 case OP_RV2AV:
1873 case OP_RV2HV:
aeea060c 1874 o->op_flags |= OPf_REF;
8990e307 1875 /* FALL THROUGH */
463ee0b2 1876 case OP_RV2GV:
35cd451c
GS		 1877 if (type == OP_DEFINED)
1878 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1879 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1880 break;
8990e307 1881
463ee0b2
LW		 1882 case OP_PADAV:
1883 case OP_PADHV:
aeea060c 1884 o->op_flags |= OPf_REF;
79072805 1885 break;
aeea060c 1886
8990e307 1887 case OP_SCALAR:
79072805 1888 case OP_NULL:
11343788 1889 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1890 break;
11343788 1891 ref(cBINOPo->op_first, type);
79072805
LW		 1892 break;
1893 case OP_AELEM:
1894 case OP_HELEM:
11343788 1895 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1896 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1897 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1898 : type == OP_RV2HV ? OPpDEREF_HV
1899 : OPpDEREF_SV);
11343788 1900 o->op_flags |= OPf_MOD;
8990e307 1901 }
79072805
LW		 1902 break;
1903
463ee0b2 1904 case OP_SCOPE:
79072805
LW		 1905 case OP_LEAVE:
1906 case OP_ENTER:
8990e307 1907 case OP_LIST:
11343788 1908 if (!(o->op_flags & OPf_KIDS))
79072805 1909 break;
11343788 1910 ref(cLISTOPo->op_last, type);
79072805 1911 break;
a0d0e21e
LW		 1912 default:
1913 break;
79072805 1914 }
11343788 1915 return scalar(o);
8990e307 1916
79072805
LW		 1917}
1918
09bef843
SB		 1919STATIC OP *
1920S_dup_attrlist(pTHX_ OP *o)
1921{
1922 OP *rop = Nullop;
1923
1924 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1925 * where the first kid is OP_PUSHMARK and the remaining ones
1926 * are OP_CONST. We need to push the OP_CONST values.
1927 */
1928 if (o->op_type == OP_CONST)
1929 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1930 else {
1931 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1932 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1933 if (o->op_type == OP_CONST)
1934 rop = append_elem(OP_LIST, rop,
1935 newSVOP(OP_CONST, o->op_flags,
1936 SvREFCNT_inc(cSVOPo->op_sv)));
1937 }
1938 }
1939 return rop;
1940}
1941
1942STATIC void
95f0a2f1 1943S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1944{
09bef843
SB		 1945 SV *stashsv;
1946
1947 /* fake up C<use attributes $pkg,$rv,@attrs> */
1948 ENTER; /* need to protect against side-effects of 'use' */
1949 SAVEINT(PL_expect);
a9164de8 1950 if (stash)
09bef843
SB		 1951 stashsv = newSVpv(HvNAME(stash), 0);
1952 else
1953 stashsv = &PL_sv_no;
e4783991 1954
09bef843 1955#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1956#define ATTRSMODULE_PM "attributes.pm"
1957
1958 if (for_my) {
1959 SV **svp;
1960 /* Don't force the C<use> if we don't need it. */
1961 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1962 sizeof(ATTRSMODULE_PM)-1, 0);
1963 if (svp && *svp != &PL_sv_undef)
1964 ; /* already in %INC */
1965 else
1966 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1967 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1968 Nullsv);
1969 }
1970 else {
1971 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1972 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1973 Nullsv,
1974 prepend_elem(OP_LIST,
1975 newSVOP(OP_CONST, 0, stashsv),
1976 prepend_elem(OP_LIST,
1977 newSVOP(OP_CONST, 0,
1978 newRV(target)),
1979 dup_attrlist(attrs))));
1980 }
09bef843
SB		 1981 LEAVE;
1982}
1983
95f0a2f1
SB		 1984STATIC void
1985S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1986{
1987 OP *pack, *imop, *arg;
1988 SV *meth, *stashsv;
1989
1990 if (!attrs)
1991 return;
1992
1993 assert(target->op_type == OP_PADSV ||
1994 target->op_type == OP_PADHV ||
1995 target->op_type == OP_PADAV);
1996
1997 /* Ensure that attributes.pm is loaded. */
1998 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1999
2000 /* Need package name for method call. */
2001 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
2002
2003 /* Build up the real arg-list. */
2004 if (stash)
2005 stashsv = newSVpv(HvNAME(stash), 0);
2006 else
2007 stashsv = &PL_sv_no;
2008 arg = newOP(OP_PADSV, 0);
2009 arg->op_targ = target->op_targ;
2010 arg = prepend_elem(OP_LIST,
2011 newSVOP(OP_CONST, 0, stashsv),
2012 prepend_elem(OP_LIST,
2013 newUNOP(OP_REFGEN, 0,
2014 mod(arg, OP_REFGEN)),
2015 dup_attrlist(attrs)));
2016
2017 /* Fake up a method call to import */
2018 meth = newSVpvn("import", 6);
2019 (void)SvUPGRADE(meth, SVt_PVIV);
2020 (void)SvIOK_on(meth);
5afd6d42 2021 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
95f0a2f1
SB		 2022 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2023 append_elem(OP_LIST,
2024 prepend_elem(OP_LIST, pack, list(arg)),
2025 newSVOP(OP_METHOD_NAMED, 0, meth)));
2026 imop->op_private |= OPpENTERSUB_NOMOD;
2027
2028 /* Combine the ops. */
2029 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2030}
2031
2032/*
2033=notfor apidoc apply_attrs_string
2034
2035Attempts to apply a list of attributes specified by the C<attrstr> and
2036C<len> arguments to the subroutine identified by the C<cv> argument which
2037is expected to be associated with the package identified by the C<stashpv>
2038argument (see L<attributes>). It gets this wrong, though, in that it
2039does not correctly identify the boundaries of the individual attribute
2040specifications within C<attrstr>. This is not really intended for the
2041public API, but has to be listed here for systems such as AIX which
2042need an explicit export list for symbols. (It's called from XS code
2043in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2044to respect attribute syntax properly would be welcome.
2045
2046=cut
2047*/
2048
be3174d2
GS		 2049void
2050Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2051 char *attrstr, STRLEN len)
2052{
2053 OP *attrs = Nullop;
2054
2055 if (!len) {
2056 len = strlen(attrstr);
2057 }
2058
2059 while (len) {
2060 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2061 if (len) {
2062 char *sstr = attrstr;
2063 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2064 attrs = append_elem(OP_LIST, attrs,
2065 newSVOP(OP_CONST, 0,
2066 newSVpvn(sstr, attrstr-sstr)));
2067 }
2068 }
2069
2070 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2071 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2072 Nullsv, prepend_elem(OP_LIST,
2073 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2074 prepend_elem(OP_LIST,
2075 newSVOP(OP_CONST, 0,
2076 newRV((SV*)cv)),
2077 attrs)));
2078}
2079
09bef843 2080STATIC OP *
95f0a2f1 2081S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20
LW		 2082{
2083 OP *kid;
93a17b20
LW		 2084 I32 type;
2085
3280af22 2086 if (!o || PL_error_count)
11343788 2087 return o;
93a17b20 2088
11343788 2089 type = o->op_type;
93a17b20 2090 if (type == OP_LIST) {
11343788 2091 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2092 my_kid(kid, attrs, imopsp);
dab48698 2093 } else if (type == OP_UNDEF) {
7766148a 2094 return o;
77ca0c92
LW		 2095 } else if (type == OP_RV2SV || /* "our" declaration */
2096 type == OP_RV2AV ||
2097 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS		 2098 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2099 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
2100 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
2101 } else if (attrs) {
2102 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2103 PL_in_my = FALSE;
2104 PL_in_my_stash = Nullhv;
2105 apply_attrs(GvSTASH(gv),
2106 (type == OP_RV2SV ? GvSV(gv) :
2107 type == OP_RV2AV ? (SV*)GvAV(gv) :
2108 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2109 attrs, FALSE);
2110 }
192587c2 2111 o->op_private |= OPpOUR_INTRO;
77ca0c92 2112 return o;
95f0a2f1
SB		 2113 }
2114 else if (type != OP_PADSV &&
93a17b20
LW		 2115 type != OP_PADAV &&
2116 type != OP_PADHV &&
2117 type != OP_PUSHMARK)
2118 {
eb64745e 2119 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2120 OP_DESC(o),
eb64745e 2121 PL_in_my == KEY_our ? "our" : "my"));
11343788 2122 return o;
93a17b20 2123 }
09bef843
SB		 2124 else if (attrs && type != OP_PUSHMARK) {
2125 HV *stash;
09bef843
SB		 2126 SV **namesvp;
2127
eb64745e
GS		 2128 PL_in_my = FALSE;
2129 PL_in_my_stash = Nullhv;
2130
09bef843
SB		 2131 /* check for C<my Dog $spot> when deciding package */
2132 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
a9164de8 2133 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
09bef843
SB		 2134 stash = SvSTASH(*namesvp);
2135 else
2136 stash = PL_curstash;
95f0a2f1 2137 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2138 }
11343788
MB		 2139 o->op_flags |= OPf_MOD;
2140 o->op_private |= OPpLVAL_INTRO;
2141 return o;
93a17b20
LW		 2142}
2143
2144OP *
09bef843
SB		 2145Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2146{
95f0a2f1
SB		 2147 OP *rops = Nullop;
2148 int maybe_scalar = 0;
2149
d2be0de5
YST		 2150/* [perl #17376]: this appears to be premature, and results in code such as
2151 C< my(%x); > executing in list mode rather than void mode */
2152#if 0
09bef843
SB		 2153 if (o->op_flags & OPf_PARENS)
2154 list(o);
95f0a2f1
SB		 2155 else
2156 maybe_scalar = 1;
d2be0de5
YST		 2157#else
2158 maybe_scalar = 1;
2159#endif
09bef843
SB		 2160 if (attrs)
2161 SAVEFREEOP(attrs);
95f0a2f1
SB		 2162 o = my_kid(o, attrs, &rops);
2163 if (rops) {
2164 if (maybe_scalar && o->op_type == OP_PADSV) {
2165 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2166 o->op_private |= OPpLVAL_INTRO;
2167 }
2168 else
2169 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2170 }
eb64745e
GS		 2171 PL_in_my = FALSE;
2172 PL_in_my_stash = Nullhv;
2173 return o;
09bef843
SB		 2174}
2175
2176OP *
2177Perl_my(pTHX_ OP *o)
2178{
95f0a2f1 2179 return my_attrs(o, Nullop);
09bef843
SB		 2180}
2181
2182OP *
864dbfa3 2183Perl_sawparens(pTHX_ OP *o)
79072805
LW		 2184{
2185 if (o)
2186 o->op_flags |= OPf_PARENS;
2187 return o;
2188}
2189
2190OP *
864dbfa3 2191Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2192{
11343788 2193 OP *o;
79072805 2194
e476b1b5 2195 if (ckWARN(WARN_MISC) &&
599cee73
PM		 2196 (left->op_type == OP_RV2AV ||
2197 left->op_type == OP_RV2HV ||
2198 left->op_type == OP_PADAV ||
2199 left->op_type == OP_PADHV)) {
22c35a8c 2200 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM		 2201 right->op_type == OP_TRANS)
2202 ? right->op_type : OP_MATCH];
dff6d3cd
GS		 2203 const char *sample = ((left->op_type == OP_RV2AV ||
2204 left->op_type == OP_PADAV)
2205 ? "@array" : "%hash");
9014280d 2206 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2207 "Applying %s to %s will act on scalar(%s)",
599cee73 2208 desc, sample, sample);
2ae324a7 2209 }
2210
5cc9e5c9
RH		 2211 if (right->op_type == OP_CONST &&
2212 cSVOPx(right)->op_private & OPpCONST_BARE &&
2213 cSVOPx(right)->op_private & OPpCONST_STRICT)
2214 {
2215 no_bareword_allowed(right);
2216 }
2217
de4bf5b3
MG		 2218 if (!(right->op_flags & OPf_STACKED) &&
2219 (right->op_type == OP_MATCH ||
79072805 2220 right->op_type == OP_SUBST ||
de4bf5b3 2221 right->op_type == OP_TRANS)) {
79072805 2222 right->op_flags |= OPf_STACKED;
18808301
JH		 2223 if (right->op_type != OP_MATCH &&
2224 ! (right->op_type == OP_TRANS &&
2225 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 2226 left = mod(left, right->op_type);
79072805 2227 if (right->op_type == OP_TRANS)
11343788 2228 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 2229 else
11343788 2230 o = prepend_elem(right->op_type, scalar(left), right);
79072805 2231 if (type == OP_NOT)
11343788
MB		 2232 return newUNOP(OP_NOT, 0, scalar(o));
2233 return o;
79072805
LW		 2234 }
2235 else
2236 return bind_match(type, left,
2237 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2238}
2239
2240OP *
864dbfa3 2241Perl_invert(pTHX_ OP *o)
79072805 2242{
11343788
MB		 2243 if (!o)
2244 return o;
79072805 2245 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 2246 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2247}
2248
2249OP *
864dbfa3 2250Perl_scope(pTHX_ OP *o)
79072805
LW		 2251{
2252 if (o) {
3280af22 2253 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 2254 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2255 o->op_type = OP_LEAVE;
22c35a8c 2256 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2
LW		 2257 }
2258 else {
2259 if (o->op_type == OP_LINESEQ) {
2260 OP *kid;
2261 o->op_type = OP_SCOPE;
22c35a8c 2262 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
c3ed7a6a
GS		 2263 kid = ((LISTOP*)o)->op_first;
2264 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
93c66552 2265 op_null(kid);
463ee0b2
LW		 2266 }
2267 else
748a9306 2268 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
463ee0b2 2269 }
79072805
LW		 2270 }
2271 return o;
2272}
2273
b3ac6de7 2274void
864dbfa3 2275Perl_save_hints(pTHX)
b3ac6de7 2276{
3280af22
NIS		 2277 SAVEI32(PL_hints);
2278 SAVESPTR(GvHV(PL_hintgv));
2279 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2280 SAVEFREESV(GvHV(PL_hintgv));
b3ac6de7
IZ		 2281}
2282
a0d0e21e 2283int
864dbfa3 2284Perl_block_start(pTHX_ int full)
79072805 2285{
3280af22 2286 int retval = PL_savestack_ix;
b3ac6de7 2287
3280af22 2288 SAVEI32(PL_comppad_name_floor);
43d4d5c6
GS		 2289 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2290 if (full)
2291 PL_comppad_name_fill = PL_comppad_name_floor;
2292 if (PL_comppad_name_floor < 0)
2293 PL_comppad_name_floor = 0;
3280af22
NIS		 2294 SAVEI32(PL_min_intro_pending);
2295 SAVEI32(PL_max_intro_pending);
2296 PL_min_intro_pending = 0;
2297 SAVEI32(PL_comppad_name_fill);
2298 SAVEI32(PL_padix_floor);
2299 PL_padix_floor = PL_padix;
2300 PL_pad_reset_pending = FALSE;
b3ac6de7 2301 SAVEHINTS();
3280af22 2302 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 2303 SAVESPTR(PL_compiling.cop_warnings);
0453d815 2304 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 2305 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2306 SAVEFREESV(PL_compiling.cop_warnings) ;
2307 }
ac27b0f5
NIS		 2308 SAVESPTR(PL_compiling.cop_io);
2309 if (! specialCopIO(PL_compiling.cop_io)) {
2310 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2311 SAVEFREESV(PL_compiling.cop_io) ;
2312 }
a0d0e21e
LW		 2313 return retval;
2314}
2315
2316OP*
864dbfa3 2317Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2318{
3280af22 2319 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
d8a34499
IK		 2320 line_t copline = PL_copline;
2321 /* there should be a nextstate in every block */
2322 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2323 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
e9818f4e 2324 LEAVE_SCOPE(floor);
3280af22 2325 PL_pad_reset_pending = FALSE;
eb160463 2326 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 2327 if (needblockscope)
3280af22
NIS		 2328 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2329 pad_leavemy(PL_comppad_name_fill);
2330 PL_cop_seqmax++;
a0d0e21e
LW		 2331 return retval;
2332}
2333
76e3520e 2334STATIC OP *
cea2e8a9 2335S_newDEFSVOP(pTHX)
54b9620d 2336{
4d1ff10f 2337#ifdef USE_5005THREADS
54b9620d
MB		 2338 OP *o = newOP(OP_THREADSV, 0);
2339 o->op_targ = find_threadsv("_");
2340 return o;
2341#else
3280af22 2342 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
4d1ff10f 2343#endif /* USE_5005THREADS */
54b9620d
MB		 2344}
2345
a0d0e21e 2346void
864dbfa3 2347Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2348{
3280af22 2349 if (PL_in_eval) {
b295d113
TH		 2350 if (PL_eval_root)
2351 return;
faef0170
HS		 2352 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2353 ((PL_in_eval & EVAL_KEEPERR)
2354 ? OPf_SPECIAL : 0), o);
3280af22 2355 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2356 PL_eval_root->op_private |= OPpREFCOUNTED;
2357 OpREFCNT_set(PL_eval_root, 1);
3280af22 2358 PL_eval_root->op_next = 0;
a2efc822 2359 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2360 }
2361 else {
5dc0d613 2362 if (!o)
a0d0e21e 2363 return;
3280af22
NIS		 2364 PL_main_root = scope(sawparens(scalarvoid(o)));
2365 PL_curcop = &PL_compiling;
2366 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2367 PL_main_root->op_private |= OPpREFCOUNTED;
2368 OpREFCNT_set(PL_main_root, 1);
3280af22 2369 PL_main_root->op_next = 0;
a2efc822 2370 CALL_PEEP(PL_main_start);
3280af22 2371 PL_compcv = 0;
3841441e 2372
4fdae800 2373 /* Register with debugger */
84902520 2374 if (PERLDB_INTER) {
864dbfa3 2375 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 2376 if (cv) {
2377 dSP;
924508f0 2378 PUSHMARK(SP);
cc49e20b 2379 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2380 PUTBACK;
864dbfa3 2381 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 2382 }
2383 }
79072805 2384 }
79072805
LW		 2385}
2386
2387OP *
864dbfa3 2388Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW		 2389{
2390 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2391/* [perl #17376]: this appears to be premature, and results in code such as
2392 C< our(%x); > executing in list mode rather than void mode */
2393#if 0
79072805 2394 list(o);
d2be0de5
YST		 2395#else
2396 ;
2397#endif
8990e307 2398 else {
64420d0d
JH		 2399 if (ckWARN(WARN_PARENTHESIS)
2400 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2401 {
2402 char *s = PL_bufptr;
2403
2404 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2405 s++;
2406
a0d0e21e 2407 if (*s == ';' || *s == '=')
9014280d 2408 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
eb64745e
GS		 2409 "Parentheses missing around \"%s\" list",
2410 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
8990e307
LW		 2411 }
2412 }
93a17b20 2413 if (lex)
eb64745e 2414 o = my(o);
93a17b20 2415 else
eb64745e
GS		 2416 o = mod(o, OP_NULL); /* a bit kludgey */
2417 PL_in_my = FALSE;
2418 PL_in_my_stash = Nullhv;
2419 return o;
79072805
LW		 2420}
2421
2422OP *
864dbfa3 2423Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2424{
2425 if (o->op_type == OP_LIST) {
554b3eca 2426 OP *o2;
4d1ff10f 2427#ifdef USE_5005THREADS
2faa37cc 2428 o2 = newOP(OP_THREADSV, 0);
54b9620d 2429 o2->op_targ = find_threadsv(";");
554b3eca
MB		 2430#else
2431 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
4d1ff10f 2432#endif /* USE_5005THREADS */
554b3eca 2433 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2434 }
2435 return o;
2436}
2437
2438OP *
864dbfa3 2439Perl_fold_constants(pTHX_ register OP *o)
79072805
LW		 2440{
2441 register OP *curop;
2442 I32 type = o->op_type;
748a9306 2443 SV *sv;
79072805 2444
22c35a8c 2445 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2446 scalar(o);
b162f9ea 2447 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2448 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2449
eac055e9
GS		 2450 /* integerize op, unless it happens to be C<-foo>.
2451 * XXX should pp_i_negate() do magic string negation instead? */
2452 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2453 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2454 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2455 {
22c35a8c 2456 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2457 }
85e6fe83 2458
22c35a8c 2459 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2460 goto nope;
2461
de939608 2462 switch (type) {
7a52d87a
GS		 2463 case OP_NEGATE:
2464 /* XXX might want a ck_negate() for this */
2465 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2466 break;
de939608
CS		 2467 case OP_SPRINTF:
2468 case OP_UCFIRST:
2469 case OP_LCFIRST:
2470 case OP_UC:
2471 case OP_LC:
69dcf70c
MB		 2472 case OP_SLT:
2473 case OP_SGT:
2474 case OP_SLE:
2475 case OP_SGE:
2476 case OP_SCMP:
2de3dbcc
JH		 2477 /* XXX what about the numeric ops? */
2478 if (PL_hints & HINT_LOCALE)
de939608
CS		 2479 goto nope;
2480 }
2481
3280af22 2482 if (PL_error_count)
a0d0e21e
LW		 2483 goto nope; /* Don't try to run w/ errors */
2484
79072805 2485 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 2486 if ((curop->op_type != OP_CONST ||
2487 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 2488 curop->op_type != OP_LIST &&
2489 curop->op_type != OP_SCALAR &&
2490 curop->op_type != OP_NULL &&
2491 curop->op_type != OP_PUSHMARK)
2492 {
79072805
LW		 2493 goto nope;
2494 }
2495 }
2496
2497 curop = LINKLIST(o);
2498 o->op_next = 0;
533c011a 2499 PL_op = curop;
cea2e8a9 2500 CALLRUNOPS(aTHX);
3280af22 2501 sv = *(PL_stack_sp--);
748a9306 2502 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
79072805 2503 pad_swipe(o->op_targ);
748a9306
LW		 2504 else if (SvTEMP(sv)) { /* grab mortal temp? */
2505 (void)SvREFCNT_inc(sv);
2506 SvTEMP_off(sv);
85e6fe83 2507 }
79072805
LW		 2508 op_free(o);
2509 if (type == OP_RV2GV)
b1cb66bf 2510 return newGVOP(OP_GV, 0, (GV*)sv);
748a9306 2511 else {
ee580363
GS		 2512 /* try to smush double to int, but don't smush -2.0 to -2 */
2513 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2514 type != OP_NEGATE)
2515 {
28e5dec8
JH		 2516#ifdef PERL_PRESERVE_IVUV
2517 /* Only bother to attempt to fold to IV if
2518 most operators will benefit */
2519 SvIV_please(sv);
2520#endif
748a9306 2521 }
a86a20aa 2522 return newSVOP(OP_CONST, 0, sv);
748a9306 2523 }
aeea060c 2524
79072805 2525 nope:
79072805
LW		 2526 return o;
2527}
2528
2529OP *
864dbfa3 2530Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW		 2531{
2532 register OP *curop;
3280af22 2533 I32 oldtmps_floor = PL_tmps_floor;
79072805 2534
a0d0e21e 2535 list(o);
3280af22 2536 if (PL_error_count)
a0d0e21e
LW		 2537 return o; /* Don't attempt to run with errors */
2538
533c011a 2539 PL_op = curop = LINKLIST(o);
a0d0e21e 2540 o->op_next = 0;
a2efc822 2541 CALL_PEEP(curop);
cea2e8a9
GS		 2542 pp_pushmark();
2543 CALLRUNOPS(aTHX);
533c011a 2544 PL_op = curop;
cea2e8a9 2545 pp_anonlist();
3280af22 2546 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2547
2548 o->op_type = OP_RV2AV;
22c35a8c 2549 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
c13f253a 2550 o->op_seq = 0; /* needs to be revisited in peep() */
79072805 2551 curop = ((UNOP*)o)->op_first;
3280af22 2552 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2553 op_free(curop);
79072805
LW		 2554 linklist(o);
2555 return list(o);
2556}
2557
2558OP *
864dbfa3 2559Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2560{
11343788
MB		 2561 if (!o || o->op_type != OP_LIST)
2562 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2563 else
5dc0d613 2564 o->op_flags &= ~OPf_WANT;
79072805 2565
22c35a8c 2566 if (!(PL_opargs[type] & OA_MARK))
93c66552 2567 op_null(cLISTOPo->op_first);
8990e307 2568
eb160463 2569 o->op_type = (OPCODE)type;
22c35a8c 2570 o->op_ppaddr = PL_ppaddr[type];
11343788 2571 o->op_flags |= flags;
79072805 2572
11343788
MB		 2573 o = CHECKOP(type, o);
2574 if (o->op_type != type)
2575 return o;
79072805 2576
11343788 2577 return fold_constants(o);
79072805
LW		 2578}
2579
2580/* List constructors */
2581
2582OP *
864dbfa3 2583Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2584{
2585 if (!first)
2586 return last;
8990e307
LW		 2587
2588 if (!last)
79072805 2589 return first;
8990e307 2590
155aba94
GS		 2591 if (first->op_type != type
2592 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2593 {
2594 return newLISTOP(type, 0, first, last);
2595 }
79072805 2596
a0d0e21e
LW		 2597 if (first->op_flags & OPf_KIDS)
2598 ((LISTOP*)first)->op_last->op_sibling = last;
2599 else {
2600 first->op_flags |= OPf_KIDS;
2601 ((LISTOP*)first)->op_first = last;
2602 }
2603 ((LISTOP*)first)->op_last = last;
a0d0e21e 2604 return first;
79072805
LW		 2605}
2606
2607OP *
864dbfa3 2608Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2609{
2610 if (!first)
2611 return (OP*)last;
8990e307
LW		 2612
2613 if (!last)
79072805 2614 return (OP*)first;
8990e307
LW		 2615
2616 if (first->op_type != type)
79072805 2617 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW		 2618
2619 if (last->op_type != type)
79072805
LW		 2620 return append_elem(type, (OP*)first, (OP*)last);
2621
2622 first->op_last->op_sibling = last->op_first;
2623 first->op_last = last->op_last;
117dada2 2624 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2625
238a4c30
NIS		 2626 FreeOp(last);
2627
79072805
LW		 2628 return (OP*)first;
2629}
2630
2631OP *
864dbfa3 2632Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2633{
2634 if (!first)
2635 return last;
8990e307
LW		 2636
2637 if (!last)
79072805 2638 return first;
8990e307
LW		 2639
2640 if (last->op_type == type) {
2641 if (type == OP_LIST) { /* already a PUSHMARK there */
2642 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2643 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2644 if (!(first->op_flags & OPf_PARENS))
2645 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2646 }
2647 else {
2648 if (!(last->op_flags & OPf_KIDS)) {
2649 ((LISTOP*)last)->op_last = first;
2650 last->op_flags |= OPf_KIDS;
2651 }
2652 first->op_sibling = ((LISTOP*)last)->op_first;
2653 ((LISTOP*)last)->op_first = first;
79072805 2654 }
117dada2 2655 last->op_flags |= OPf_KIDS;
79072805
LW		 2656 return last;
2657 }
2658
2659 return newLISTOP(type, 0, first, last);
2660}
2661
2662/* Constructors */
2663
2664OP *
864dbfa3 2665Perl_newNULLLIST(pTHX)
79072805 2666{
8990e307
LW		 2667 return newOP(OP_STUB, 0);
2668}
2669
2670OP *
864dbfa3 2671Perl_force_list(pTHX_ OP *o)
8990e307 2672{
11343788
MB		 2673 if (!o || o->op_type != OP_LIST)
2674 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2675 op_null(o);
11343788 2676 return o;
79072805
LW		 2677}
2678
2679OP *
864dbfa3 2680Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2681{
2682 LISTOP *listop;
2683
b7dc083c 2684 NewOp(1101, listop, 1, LISTOP);
79072805 2685
eb160463 2686 listop->op_type = (OPCODE)type;
22c35a8c 2687 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2688 if (first || last)
2689 flags |= OPf_KIDS;
eb160463 2690 listop->op_flags = (U8)flags;
79072805
LW		 2691
2692 if (!last && first)
2693 last = first;
2694 else if (!first && last)
2695 first = last;
8990e307
LW		 2696 else if (first)
2697 first->op_sibling = last;
79072805
LW		 2698 listop->op_first = first;
2699 listop->op_last = last;
8990e307
LW		 2700 if (type == OP_LIST) {
2701 OP* pushop;
2702 pushop = newOP(OP_PUSHMARK, 0);
2703 pushop->op_sibling = first;
2704 listop->op_first = pushop;
2705 listop->op_flags |= OPf_KIDS;
2706 if (!last)
2707 listop->op_last = pushop;
2708 }
79072805
LW		 2709
2710 return (OP*)listop;
2711}
2712
2713OP *
864dbfa3 2714Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2715{
11343788 2716 OP *o;
b7dc083c 2717 NewOp(1101, o, 1, OP);
eb160463 2718 o->op_type = (OPCODE)type;
22c35a8c 2719 o->op_ppaddr = PL_ppaddr[type];
eb160463 2720 o->op_flags = (U8)flags;
79072805 2721
11343788 2722 o->op_next = o;
eb160463 2723 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2724 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2725 scalar(o);
22c35a8c 2726 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2727 o->op_targ = pad_alloc(type, SVs_PADTMP);
2728 return CHECKOP(type, o);
79072805
LW		 2729}
2730
2731OP *
864dbfa3 2732Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW		 2733{
2734 UNOP *unop;
2735
93a17b20 2736 if (!first)
aeea060c 2737 first = newOP(OP_STUB, 0);
22c35a8c 2738 if (PL_opargs[type] & OA_MARK)
8990e307 2739 first = force_list(first);
93a17b20 2740
b7dc083c 2741 NewOp(1101, unop, 1, UNOP);
eb160463 2742 unop->op_type = (OPCODE)type;
22c35a8c 2743 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2744 unop->op_first = first;
2745 unop->op_flags = flags | OPf_KIDS;
eb160463 2746 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2747 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2748 if (unop->op_next)
2749 return (OP*)unop;
2750
a0d0e21e 2751 return fold_constants((OP *) unop);
79072805
LW		 2752}
2753
2754OP *
864dbfa3 2755Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2756{
2757 BINOP *binop;
b7dc083c 2758 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2759
2760 if (!first)
2761 first = newOP(OP_NULL, 0);
2762
eb160463 2763 binop->op_type = (OPCODE)type;
22c35a8c 2764 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2765 binop->op_first = first;
2766 binop->op_flags = flags | OPf_KIDS;
2767 if (!last) {
2768 last = first;
eb160463 2769 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2770 }
2771 else {
eb160463 2772 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2773 first->op_sibling = last;
2774 }
2775
e50aee73 2776 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2777 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2778 return (OP*)binop;
2779
7284ab6f 2780 binop->op_last = binop->op_first->op_sibling;
79072805 2781
a0d0e21e 2782 return fold_constants((OP *)binop);
79072805
LW		 2783}
2784
a0ed51b3 2785static int
2b9d42f0
NIS		 2786uvcompare(const void *a, const void *b)
2787{
2788 if (*((UV *)a) < (*(UV *)b))
2789 return -1;
2790 if (*((UV *)a) > (*(UV *)b))
2791 return 1;
2792 if (*((UV *)a+1) < (*(UV *)b+1))
2793 return -1;
2794 if (*((UV *)a+1) > (*(UV *)b+1))
2795 return 1;
a0ed51b3
LW		 2796 return 0;
2797}
2798
79072805 2799OP *
864dbfa3 2800Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2801{
79072805
LW		 2802 SV *tstr = ((SVOP*)expr)->op_sv;
2803 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2804 STRLEN tlen;
2805 STRLEN rlen;
9b877dbb
IH		 2806 U8 *t = (U8*)SvPV(tstr, tlen);
2807 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW		 2808 register I32 i;
2809 register I32 j;
a0ed51b3 2810 I32 del;
79072805 2811 I32 complement;
5d06d08e 2812 I32 squash;
9b877dbb 2813 I32 grows = 0;
79072805
LW		 2814 register short *tbl;
2815
800b4dc4 2816 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2817 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2818 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2819 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2820
036b4402
GS		 2821 if (SvUTF8(tstr))
2822 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2823
2824 if (SvUTF8(rstr))
036b4402 2825 o->op_private |= OPpTRANS_TO_UTF;
79072805 2826
a0ed51b3 2827 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2828 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW		 2829 SV* transv = 0;
2830 U8* tend = t + tlen;
2831 U8* rend = r + rlen;
ba210ebe 2832 STRLEN ulen;
a0ed51b3
LW		 2833 U32 tfirst = 1;
2834 U32 tlast = 0;
2835 I32 tdiff;
2836 U32 rfirst = 1;
2837 U32 rlast = 0;
2838 I32 rdiff;
2839 I32 diff;
2840 I32 none = 0;
2841 U32 max = 0;
2842 I32 bits;
a0ed51b3 2843 I32 havefinal = 0;
9c5ffd7c 2844 U32 final = 0;
a0ed51b3
LW		 2845 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2846 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2847 U8* tsave = NULL;
2848 U8* rsave = NULL;
2849
2850 if (!from_utf) {
2851 STRLEN len = tlen;
2852 tsave = t = bytes_to_utf8(t, &len);
2853 tend = t + len;
2854 }
2855 if (!to_utf && rlen) {
2856 STRLEN len = rlen;
2857 rsave = r = bytes_to_utf8(r, &len);
2858 rend = r + len;
2859 }
a0ed51b3 2860
2b9d42f0
NIS		 2861/* There are several snags with this code on EBCDIC:
2862 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2863 2. scan_const() in toke.c has encoded chars in native encoding which makes
2864 ranges at least in EBCDIC 0..255 range the bottom odd.
2865*/
2866
a0ed51b3 2867 if (complement) {
ad391ad9 2868 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2869 UV *cp;
a0ed51b3 2870 UV nextmin = 0;
2b9d42f0 2871 New(1109, cp, 2*tlen, UV);
a0ed51b3 2872 i = 0;
79cb57f6 2873 transv = newSVpvn("",0);
a0ed51b3 2874 while (t < tend) {
2b9d42f0
NIS		 2875 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2876 t += ulen;
2877 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2878 t++;
2b9d42f0
NIS		 2879 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2880 t += ulen;
a0ed51b3 2881 }
2b9d42f0
NIS		 2882 else {
2883 cp[2*i+1] = cp[2*i];
2884 }
2885 i++;
a0ed51b3 2886 }
2b9d42f0 2887 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2888 for (j = 0; j < i; j++) {
2b9d42f0 2889 UV val = cp[2*j];
a0ed51b3
LW		 2890 diff = val - nextmin;
2891 if (diff > 0) {
9041c2e3 2892 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2893 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2894 if (diff > 1) {
2b9d42f0 2895 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2896 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2897 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2898 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2899 }
2900 }
2b9d42f0 2901 val = cp[2*j+1];
a0ed51b3
LW		 2902 if (val >= nextmin)
2903 nextmin = val + 1;
2904 }
9041c2e3 2905 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2906 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2907 {
2908 U8 range_mark = UTF_TO_NATIVE(0xff);
2909 sv_catpvn(transv, (char *)&range_mark, 1);
2910 }
b851fbc1
JH		 2911 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2912 UNICODE_ALLOW_SUPER);
dfe13c55
GS		 2913 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2914 t = (U8*)SvPVX(transv);
a0ed51b3
LW		 2915 tlen = SvCUR(transv);
2916 tend = t + tlen;
455d824a 2917 Safefree(cp);
a0ed51b3
LW		 2918 }
2919 else if (!rlen && !del) {
2920 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2921 }
2922 if (!squash) {
05d340b8 2923 if ((!rlen && !del) || t == r ||
12ae5dfc 2924 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2925 {
4757a243 2926 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2927 }
a0ed51b3
LW		 2928 }
2929
2930 while (t < tend || tfirst <= tlast) {
2931 /* see if we need more "t" chars */
2932 if (tfirst > tlast) {
9041c2e3 2933 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2934 t += ulen;
2b9d42f0 2935 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2936 t++;
9041c2e3 2937 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2938 t += ulen;
2939 }
2940 else
2941 tlast = tfirst;
2942 }
2943
2944 /* now see if we need more "r" chars */
2945 if (rfirst > rlast) {
2946 if (r < rend) {
9041c2e3 2947 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2948 r += ulen;
2b9d42f0 2949 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2950 r++;
9041c2e3 2951 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2952 r += ulen;
2953 }
2954 else
2955 rlast = rfirst;
2956 }
2957 else {
2958 if (!havefinal++)
2959 final = rlast;
2960 rfirst = rlast = 0xffffffff;
2961 }
2962 }
2963
2964 /* now see which range will peter our first, if either. */
2965 tdiff = tlast - tfirst;
2966 rdiff = rlast - rfirst;
2967
2968 if (tdiff <= rdiff)
2969 diff = tdiff;
2970 else
2971 diff = rdiff;
2972
2973 if (rfirst == 0xffffffff) {
2974 diff = tdiff; /* oops, pretend rdiff is infinite */
2975 if (diff > 0)
894356b3
GS		 2976 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2977 (long)tfirst, (long)tlast);
a0ed51b3 2978 else
894356b3 2979 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2980 }
2981 else {
2982 if (diff > 0)
894356b3
GS		 2983 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2984 (long)tfirst, (long)(tfirst + diff),
2985 (long)rfirst);
a0ed51b3 2986 else
894356b3
GS		 2987 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2988 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2989
2990 if (rfirst + diff > max)
2991 max = rfirst + diff;
9b877dbb 2992 if (!grows)
45005bfb
JH		 2993 grows = (tfirst < rfirst &&
2994 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2995 rfirst += diff + 1;
a0ed51b3
LW		 2996 }
2997 tfirst += diff + 1;
2998 }
2999
3000 none = ++max;
3001 if (del)
3002 del = ++max;
3003
3004 if (max > 0xffff)
3005 bits = 32;
3006 else if (max > 0xff)
3007 bits = 16;
3008 else
3009 bits = 8;
3010
455d824a 3011 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 3012 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3013 SvREFCNT_dec(listsv);
3014 if (transv)
3015 SvREFCNT_dec(transv);
3016
45005bfb 3017 if (!del && havefinal && rlen)
b448e4fe
JH		 3018 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3019 newSVuv((UV)final), 0);
a0ed51b3 3020
9b877dbb 3021 if (grows)
a0ed51b3
LW		 3022 o->op_private |= OPpTRANS_GROWS;
3023
9b877dbb
IH		 3024 if (tsave)
3025 Safefree(tsave);
3026 if (rsave)
3027 Safefree(rsave);
3028
a0ed51b3
LW		 3029 op_free(expr);
3030 op_free(repl);
3031 return o;
3032 }
3033
3034 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3035 if (complement) {
3036 Zero(tbl, 256, short);
eb160463 3037 for (i = 0; i < (I32)tlen; i++)
ec49126f 3038 tbl[t[i]] = -1;
79072805
LW		 3039 for (i = 0, j = 0; i < 256; i++) {
3040 if (!tbl[i]) {
eb160463 3041 if (j >= (I32)rlen) {
a0ed51b3 3042 if (del)
79072805
LW		 3043 tbl[i] = -2;
3044 else if (rlen)
ec49126f 3045 tbl[i] = r[j-1];
79072805 3046 else
eb160463 3047 tbl[i] = (short)i;
79072805 3048 }
9b877dbb
IH		 3049 else {
3050 if (i < 128 && r[j] >= 128)
3051 grows = 1;
ec49126f 3052 tbl[i] = r[j++];
9b877dbb 3053 }
79072805
LW		 3054 }
3055 }
05d340b8
JH		 3056 if (!del) {
3057 if (!rlen) {
3058 j = rlen;
3059 if (!squash)
3060 o->op_private |= OPpTRANS_IDENTICAL;
3061 }
eb160463 3062 else if (j >= (I32)rlen)
05d340b8
JH		 3063 j = rlen - 1;
3064 else
3065 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79 3066 tbl[0x100] = rlen - j;
eb160463 3067 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 3068 tbl[0x101+i] = r[j+i];
3069 }
79072805
LW		 3070 }
3071 else {
a0ed51b3 3072 if (!rlen && !del) {
79072805 3073 r = t; rlen = tlen;
5d06d08e 3074 if (!squash)
4757a243 3075 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3076 }
94bfe852
RGS		 3077 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3078 o->op_private |= OPpTRANS_IDENTICAL;
3079 }
79072805
LW		 3080 for (i = 0; i < 256; i++)
3081 tbl[i] = -1;
eb160463
GS		 3082 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3083 if (j >= (I32)rlen) {
a0ed51b3 3084 if (del) {
ec49126f 3085 if (tbl[t[i]] == -1)
3086 tbl[t[i]] = -2;
79072805
LW		 3087 continue;
3088 }
3089 --j;
3090 }
9b877dbb
IH		 3091 if (tbl[t[i]] == -1) {
3092 if (t[i] < 128 && r[j] >= 128)
3093 grows = 1;
ec49126f 3094 tbl[t[i]] = r[j];
9b877dbb 3095 }
79072805
LW		 3096 }
3097 }
9b877dbb
IH		 3098 if (grows)
3099 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 3100 op_free(expr);
3101 op_free(repl);
3102
11343788 3103 return o;
79072805
LW		 3104}
3105
3106OP *
864dbfa3 3107Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 3108{
3109 PMOP *pmop;
3110
b7dc083c 3111 NewOp(1101, pmop, 1, PMOP);
eb160463 3112 pmop->op_type = (OPCODE)type;
22c35a8c 3113 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 3114 pmop->op_flags = (U8)flags;
3115 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3116
3280af22 3117 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 3118 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 3119 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 3120 pmop->op_pmpermflags |= PMf_LOCALE;
3121 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 3122
debc9467 3123#ifdef USE_ITHREADS
13137afc
AB		 3124 {
3125 SV* repointer;
3126 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3127 repointer = av_pop((AV*)PL_regex_pad[0]);
3128 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 3129 SvREPADTMP_off(repointer);
13137afc 3130 sv_setiv(repointer,0);
1eb1540c 3131 } else {
13137afc
AB		 3132 repointer = newSViv(0);
3133 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3134 pmop->op_pmoffset = av_len(PL_regex_padav);
3135 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 3136 }
13137afc 3137 }
debc9467 3138#endif
1eb1540c 3139
1fcf4c12 3140 /* link into pm list */
3280af22
NIS		 3141 if (type != OP_TRANS && PL_curstash) {
3142 pmop->op_pmnext = HvPMROOT(PL_curstash);
3143 HvPMROOT(PL_curstash) = pmop;
cb55de95 3144 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 3145 }
3146
3147 return (OP*)pmop;
3148}
3149
3150OP *
864dbfa3 3151Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 3152{
3153 PMOP *pm;
3154 LOGOP *rcop;
ce862d02 3155 I32 repl_has_vars = 0;
79072805 3156
11343788
MB		 3157 if (o->op_type == OP_TRANS)
3158 return pmtrans(o, expr, repl);
79072805 3159
3280af22 3160 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3161 pm = (PMOP*)o;
79072805
LW		 3162
3163 if (expr->op_type == OP_CONST) {
463ee0b2 3164 STRLEN plen;
79072805 3165 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 3166 char *p = SvPV(pat, plen);
11343788 3167 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 3168 sv_setpvn(pat, "\\s+", 3);
463ee0b2 3169 p = SvPV(pat, plen);
79072805
LW		 3170 pm->op_pmflags |= PMf_SKIPWHITE;
3171 }
5b71a6a7 3172 if (DO_UTF8(pat))
a5961de5 3173 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS		 3174 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3175 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3176 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 3177 op_free(expr);
3178 }
3179 else {
3280af22 3180 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3181 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3182 ? OP_REGCRESET
3183 : OP_REGCMAYBE),0,expr);
463ee0b2 3184
b7dc083c 3185 NewOp(1101, rcop, 1, LOGOP);
79072805 3186 rcop->op_type = OP_REGCOMP;
22c35a8c 3187 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3188 rcop->op_first = scalar(expr);
1c846c1f 3189 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3190 ? (OPf_SPECIAL | OPf_KIDS)
3191 : OPf_KIDS);
79072805 3192 rcop->op_private = 1;
11343788 3193 rcop->op_other = o;
79072805
LW		 3194
3195 /* establish postfix order */
3280af22 3196 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3197 LINKLIST(expr);
3198 rcop->op_next = expr;
3199 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3200 }
3201 else {
3202 rcop->op_next = LINKLIST(expr);
3203 expr->op_next = (OP*)rcop;
3204 }
79072805 3205
11343788 3206 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3207 }
3208
3209 if (repl) {
748a9306 3210 OP *curop;
0244c3a4 3211 if (pm->op_pmflags & PMf_EVAL) {
748a9306 3212 curop = 0;
57843af0 3213 if (CopLINE(PL_curcop) < PL_multi_end)
eb160463 3214 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 3215 }
4d1ff10f 3216#ifdef USE_5005THREADS
2faa37cc 3217 else if (repl->op_type == OP_THREADSV
554b3eca 3218 && strchr("&`'123456789+",
533c011a 3219 PL_threadsv_names[repl->op_targ]))
554b3eca
MB		 3220 {
3221 curop = 0;
3222 }
4d1ff10f 3223#endif /* USE_5005THREADS */
748a9306
LW		 3224 else if (repl->op_type == OP_CONST)
3225 curop = repl;
79072805 3226 else {
79072805
LW		 3227 OP *lastop = 0;
3228 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3229 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4d1ff10f 3230#ifdef USE_5005THREADS
ce862d02
IZ		 3231 if (curop->op_type == OP_THREADSV) {
3232 repl_has_vars = 1;
be949f6f 3233 if (strchr("&`'123456789+", curop->op_private))
ce862d02 3234 break;
554b3eca
MB		 3235 }
3236#else
79072805 3237 if (curop->op_type == OP_GV) {
638eceb6 3238 GV *gv = cGVOPx_gv(curop);
ce862d02 3239 repl_has_vars = 1;
93a17b20 3240 if (strchr("&`'123456789+", *GvENAME(gv)))
79072805
LW		 3241 break;
3242 }
4d1ff10f 3243#endif /* USE_5005THREADS */
79072805
LW		 3244 else if (curop->op_type == OP_RV2CV)
3245 break;
3246 else if (curop->op_type == OP_RV2SV ||
3247 curop->op_type == OP_RV2AV ||
3248 curop->op_type == OP_RV2HV ||
3249 curop->op_type == OP_RV2GV) {
3250 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3251 break;
3252 }
748a9306
LW		 3253 else if (curop->op_type == OP_PADSV ||
3254 curop->op_type == OP_PADAV ||
3255 curop->op_type == OP_PADHV ||
554b3eca 3256 curop->op_type == OP_PADANY) {
ce862d02 3257 repl_has_vars = 1;
748a9306 3258 }
1167e5da
SM		 3259 else if (curop->op_type == OP_PUSHRE)
3260 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3261 else
3262 break;
3263 }
3264 lastop = curop;
3265 }
748a9306 3266 }
ce862d02 3267 if (curop == repl
1c846c1f 3268 && !(repl_has_vars
aaa362c4
RS		 3269 && (!PM_GETRE(pm)
3270 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3271 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3272 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3273 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3274 }
3275 else {
aaa362c4 3276 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 3277 pm->op_pmflags |= PMf_MAYBE_CONST;
3278 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3279 }
b7dc083c 3280 NewOp(1101, rcop, 1, LOGOP);
748a9306 3281 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3282 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3283 rcop->op_first = scalar(repl);
3284 rcop->op_flags |= OPf_KIDS;
3285 rcop->op_private = 1;
11343788 3286 rcop->op_other = o;
748a9306
LW		 3287
3288 /* establish postfix order */
3289 rcop->op_next = LINKLIST(repl);
3290 repl->op_next = (OP*)rcop;
3291
3292 pm->op_pmreplroot = scalar((OP*)rcop);
3293 pm->op_pmreplstart = LINKLIST(rcop);
3294 rcop->op_next = 0;
79072805
LW		 3295 }
3296 }
3297
3298 return (OP*)pm;
3299}
3300
3301OP *
864dbfa3 3302Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 3303{
3304 SVOP *svop;
b7dc083c 3305 NewOp(1101, svop, 1, SVOP);
eb160463 3306 svop->op_type = (OPCODE)type;
22c35a8c 3307 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3308 svop->op_sv = sv;
3309 svop->op_next = (OP*)svop;
eb160463 3310 svop->op_flags = (U8)flags;
22c35a8c 3311 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3312 scalar((OP*)svop);
22c35a8c 3313 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3314 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3315 return CHECKOP(type, svop);
79072805
LW		 3316}
3317
3318OP *
350de78d
GS		 3319Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3320{
3321 PADOP *padop;
3322 NewOp(1101, padop, 1, PADOP);
eb160463 3323 padop->op_type = (OPCODE)type;
350de78d
GS		 3324 padop->op_ppaddr = PL_ppaddr[type];
3325 padop->op_padix = pad_alloc(type, SVs_PADTMP);
7766f137 3326 SvREFCNT_dec(PL_curpad[padop->op_padix]);
350de78d 3327 PL_curpad[padop->op_padix] = sv;
ce50c033
AMS		 3328 if (sv)
3329 SvPADTMP_on(sv);
350de78d 3330 padop->op_next = (OP*)padop;
eb160463 3331 padop->op_flags = (U8)flags;
350de78d
GS		 3332 if (PL_opargs[type] & OA_RETSCALAR)
3333 scalar((OP*)padop);
3334 if (PL_opargs[type] & OA_TARGET)
3335 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3336 return CHECKOP(type, padop);
3337}
3338
3339OP *
864dbfa3 3340Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3341{
350de78d 3342#ifdef USE_ITHREADS
ce50c033
AMS		 3343 if (gv)
3344 GvIN_PAD_on(gv);
350de78d
GS		 3345 return newPADOP(type, flags, SvREFCNT_inc(gv));
3346#else
7934575e 3347 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3348#endif
79072805
LW		 3349}
3350
3351OP *
864dbfa3 3352Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 3353{
3354 PVOP *pvop;
b7dc083c 3355 NewOp(1101, pvop, 1, PVOP);
eb160463 3356 pvop->op_type = (OPCODE)type;
22c35a8c 3357 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3358 pvop->op_pv = pv;
3359 pvop->op_next = (OP*)pvop;
eb160463 3360 pvop->op_flags = (U8)flags;
22c35a8c 3361 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3362 scalar((OP*)pvop);
22c35a8c 3363 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3364 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3365 return CHECKOP(type, pvop);
79072805
LW		 3366}
3367
79072805 3368void
864dbfa3 3369Perl_package(pTHX_ OP *o)
79072805 3370{
de11ba31
AMS		 3371 char *name;
3372 STRLEN len;
79072805 3373
3280af22
NIS		 3374 save_hptr(&PL_curstash);
3375 save_item(PL_curstname);
de11ba31
AMS		 3376
3377 name = SvPV(cSVOPo->op_sv, len);
3378 PL_curstash = gv_stashpvn(name, len, TRUE);
3379 sv_setpvn(PL_curstname, name, len);
3380 op_free(o);
3381
7ad382f4 3382 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3383 PL_copline = NOLINE;
3384 PL_expect = XSTATE;
79072805
LW		 3385}
3386
85e6fe83 3387void
864dbfa3 3388Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
85e6fe83 3389{
a0d0e21e 3390 OP *pack;
a0d0e21e 3391 OP *imop;
b1cb66bf 3392 OP *veop;
85e6fe83 3393
a0d0e21e 3394 if (id->op_type != OP_CONST)
cea2e8a9 3395 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3396
b1cb66bf 3397 veop = Nullop;
3398
0f79a09d 3399 if (version != Nullop) {
b1cb66bf 3400 SV *vesv = ((SVOP*)version)->op_sv;
3401
44dcb63b 3402 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 3403 arg = version;
3404 }
3405 else {
3406 OP *pack;
0f79a09d 3407 SV *meth;
b1cb66bf 3408
44dcb63b 3409 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3410 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3411
3412 /* Make copy of id so we don't free it twice */
3413 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3414
3415 /* Fake up a method call to VERSION */
0f79a09d
GS		 3416 meth = newSVpvn("VERSION",7);
3417 sv_upgrade(meth, SVt_PVIV);
155aba94 3418 (void)SvIOK_on(meth);
5afd6d42 3419 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 3420 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3421 append_elem(OP_LIST,
0f79a09d
GS		 3422 prepend_elem(OP_LIST, pack, list(version)),
3423 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3424 }
3425 }
aeea060c 3426
a0d0e21e 3427 /* Fake up an import/unimport */
4633a7c4
LW		 3428 if (arg && arg->op_type == OP_STUB)
3429 imop = arg; /* no import on explicit () */
44dcb63b 3430 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
b1cb66bf 3431 imop = Nullop; /* use 5.0; */
3432 }
4633a7c4 3433 else {
0f79a09d
GS		 3434 SV *meth;
3435
4633a7c4
LW		 3436 /* Make copy of id so we don't free it twice */
3437 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
0f79a09d
GS		 3438
3439 /* Fake up a method call to import/unimport */
b47cad08 3440 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
ad4c42df 3441 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 3442 (void)SvIOK_on(meth);
5afd6d42 3443 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 3444 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3445 append_elem(OP_LIST,
3446 prepend_elem(OP_LIST, pack, list(arg)),
3447 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3448 }
3449
a0d0e21e 3450 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3451 newATTRSUB(floor,
79cb57f6 3452 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3453 Nullop,
09bef843 3454 Nullop,
a0d0e21e 3455 append_elem(OP_LINESEQ,
b1cb66bf 3456 append_elem(OP_LINESEQ,
ec4ab249 3457 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
b1cb66bf 3458 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3459 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3460
70f5e4ed
JH		 3461 /* The "did you use incorrect case?" warning used to be here.
3462 * The problem is that on case-insensitive filesystems one
3463 * might get false positives for "use" (and "require"):
3464 * "use Strict" or "require CARP" will work. This causes
3465 * portability problems for the script: in case-strict
3466 * filesystems the script will stop working.
3467 *
3468 * The "incorrect case" warning checked whether "use Foo"
3469 * imported "Foo" to your namespace, but that is wrong, too:
3470 * there is no requirement nor promise in the language that
3471 * a Foo.pm should or would contain anything in package "Foo".
3472 *
3473 * There is very little Configure-wise that can be done, either:
3474 * the case-sensitivity of the build filesystem of Perl does not
3475 * help in guessing the case-sensitivity of the runtime environment.
3476 */
18fc9488 3477
c305c6a0 3478 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3479 PL_copline = NOLINE;
3480 PL_expect = XSTATE;
85e6fe83
LW		 3481}
3482
7d3fb230 3483/*
ccfc67b7
JH		 3484=head1 Embedding Functions
3485
7d3fb230
BS		 3486=for apidoc load_module
3487
3488Loads the module whose name is pointed to by the string part of name.
3489Note that the actual module name, not its filename, should be given.
3490Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3491PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3492(or 0 for no flags). ver, if specified, provides version semantics
3493similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3494arguments can be used to specify arguments to the module's import()
3495method, similar to C<use Foo::Bar VERSION LIST>.
3496
3497=cut */
3498