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