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
another Storable test (Re: perl@16005)
[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);
198 for (off = top; 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 &&
748a9306 311 seq <= SvIVX(sv) &&
13826f2c 312 seq > 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) ||
474 (seq <= SvIVX(sv) &&
475 seq > 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)
781 type = o->op_targ;
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:
1246 case OP_COND_EXPR:
11343788 1247 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1248 scalarvoid(kid);
1249 break;
5aabfad6 1250
a0d0e21e 1251 case OP_NULL:
11343788 1252 if (o->op_flags & OPf_STACKED)
a0d0e21e 1253 break;
5aabfad6 1254 /* FALL THROUGH */
2ebea0a1
GS		 1255 case OP_NEXTSTATE:
1256 case OP_DBSTATE:
79072805
LW		 1257 case OP_ENTERTRY:
1258 case OP_ENTER:
11343788 1259 if (!(o->op_flags & OPf_KIDS))
79072805 1260 break;
54310121 1261 /* FALL THROUGH */
463ee0b2 1262 case OP_SCOPE:
79072805
LW		 1263 case OP_LEAVE:
1264 case OP_LEAVETRY:
a0d0e21e 1265 case OP_LEAVELOOP:
79072805 1266 case OP_LINESEQ:
79072805 1267 case OP_LIST:
11343788 1268 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1269 scalarvoid(kid);
1270 break;
c90c0ff4 1271 case OP_ENTEREVAL:
5196be3e 1272 scalarkids(o);
c90c0ff4 1273 break;
5aabfad6 1274 case OP_REQUIRE:
c90c0ff4 1275 /* all requires must return a boolean value */
5196be3e 1276 o->op_flags &= ~OPf_WANT;
d6483035
GS		 1277 /* FALL THROUGH */
1278 case OP_SCALAR:
5196be3e 1279 return scalar(o);
a0d0e21e 1280 case OP_SPLIT:
11343788 1281 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 1282 if (!kPMOP->op_pmreplroot)
12bcd1a6 1283 deprecate_old("implicit split to @_");
a0d0e21e
LW		 1284 }
1285 break;
79072805 1286 }
411caa50 1287 if (useless && ckWARN(WARN_VOID))
9014280d 1288 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 1289 return o;
79072805
LW		 1290}
1291
1292OP *
864dbfa3 1293Perl_listkids(pTHX_ OP *o)
79072805
LW		 1294{
1295 OP *kid;
11343788
MB		 1296 if (o && o->op_flags & OPf_KIDS) {
1297 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1298 list(kid);
1299 }
11343788 1300 return o;
79072805
LW		 1301}
1302
1303OP *
864dbfa3 1304Perl_list(pTHX_ OP *o)
79072805
LW		 1305{
1306 OP *kid;
1307
a0d0e21e 1308 /* assumes no premature commitment */
3280af22 1309 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1310 || o->op_type == OP_RETURN)
7e363e51 1311 {
11343788 1312 return o;
7e363e51 1313 }
79072805 1314
b162f9ea 1315 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1316 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1317 {
b162f9ea 1318 return o; /* As if inside SASSIGN */
7e363e51 1319 }
1c846c1f 1320
5dc0d613 1321 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1322
11343788 1323 switch (o->op_type) {
79072805
LW		 1324 case OP_FLOP:
1325 case OP_REPEAT:
11343788 1326 list(cBINOPo->op_first);
79072805
LW		 1327 break;
1328 case OP_OR:
1329 case OP_AND:
1330 case OP_COND_EXPR:
11343788 1331 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1332 list(kid);
1333 break;
1334 default:
1335 case OP_MATCH:
8782bef2 1336 case OP_QR:
79072805
LW		 1337 case OP_SUBST:
1338 case OP_NULL:
11343788 1339 if (!(o->op_flags & OPf_KIDS))
79072805 1340 break;
11343788
MB		 1341 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1342 list(cBINOPo->op_first);
1343 return gen_constant_list(o);
79072805
LW		 1344 }
1345 case OP_LIST:
11343788 1346 listkids(o);
79072805
LW		 1347 break;
1348 case OP_LEAVE:
1349 case OP_LEAVETRY:
5dc0d613 1350 kid = cLISTOPo->op_first;
54310121 1351 list(kid);
155aba94 1352 while ((kid = kid->op_sibling)) {
54310121 1353 if (kid->op_sibling)
1354 scalarvoid(kid);
1355 else
1356 list(kid);
1357 }
3280af22 1358 WITH_THR(PL_curcop = &PL_compiling);
54310121 1359 break;
748a9306 1360 case OP_SCOPE:
79072805 1361 case OP_LINESEQ:
11343788 1362 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1363 if (kid->op_sibling)
1364 scalarvoid(kid);
1365 else
1366 list(kid);
1367 }
3280af22 1368 WITH_THR(PL_curcop = &PL_compiling);
79072805 1369 break;
c90c0ff4 1370 case OP_REQUIRE:
1371 /* all requires must return a boolean value */
5196be3e
MB		 1372 o->op_flags &= ~OPf_WANT;
1373 return scalar(o);
79072805 1374 }
11343788 1375 return o;
79072805
LW		 1376}
1377
1378OP *
864dbfa3 1379Perl_scalarseq(pTHX_ OP *o)
79072805
LW		 1380{
1381 OP *kid;
1382
11343788
MB		 1383 if (o) {
1384 if (o->op_type == OP_LINESEQ ||
1385 o->op_type == OP_SCOPE ||
1386 o->op_type == OP_LEAVE ||
1387 o->op_type == OP_LEAVETRY)
463ee0b2 1388 {
11343788 1389 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1390 if (kid->op_sibling) {
463ee0b2 1391 scalarvoid(kid);
ed6116ce 1392 }
463ee0b2 1393 }
3280af22 1394 PL_curcop = &PL_compiling;
79072805 1395 }
11343788 1396 o->op_flags &= ~OPf_PARENS;
3280af22 1397 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1398 o->op_flags |= OPf_PARENS;
79072805 1399 }
8990e307 1400 else
11343788
MB		 1401 o = newOP(OP_STUB, 0);
1402 return o;
79072805
LW		 1403}
1404
76e3520e 1405STATIC OP *
cea2e8a9 1406S_modkids(pTHX_ OP *o, I32 type)
79072805
LW		 1407{
1408 OP *kid;
11343788
MB		 1409 if (o && o->op_flags & OPf_KIDS) {
1410 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1411 mod(kid, type);
79072805 1412 }
11343788 1413 return o;
79072805
LW		 1414}
1415
79072805 1416OP *
864dbfa3 1417Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW		 1418{
1419 OP *kid;
2d8e6c8d 1420 STRLEN n_a;
79072805 1421
3280af22 1422 if (!o || PL_error_count)
11343788 1423 return o;
79072805 1424
b162f9ea 1425 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1426 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1427 {
b162f9ea 1428 return o;
7e363e51 1429 }
1c846c1f 1430
11343788 1431 switch (o->op_type) {
68dc0745 1432 case OP_UNDEF:
3280af22 1433 PL_modcount++;
5dc0d613 1434 return o;
a0d0e21e 1435 case OP_CONST:
11343788 1436 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1437 goto nomod;
3280af22 1438 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1439 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1440 PL_eval_start = 0;
a0d0e21e
LW		 1441 }
1442 else if (!type) {
3280af22
NIS		 1443 SAVEI32(PL_compiling.cop_arybase);
1444 PL_compiling.cop_arybase = 0;
a0d0e21e
LW		 1445 }
1446 else if (type == OP_REFGEN)
1447 goto nomod;
1448 else
cea2e8a9 1449 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1450 break;
5f05dabc 1451 case OP_STUB:
5196be3e 1452 if (o->op_flags & OPf_PARENS)
5f05dabc 1453 break;
1454 goto nomod;
a0d0e21e
LW		 1455 case OP_ENTERSUB:
1456 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1457 !(o->op_flags & OPf_STACKED)) {
1458 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1459 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1460 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1461 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1462 break;
1463 }
95f0a2f1
SB		 1464 else if (o->op_private & OPpENTERSUB_NOMOD)
1465 return o;
cd06dffe
GS		 1466 else { /* lvalue subroutine call */
1467 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1468 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1469 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1470 /* Backward compatibility mode: */
1471 o->op_private |= OPpENTERSUB_INARGS;
1472 break;
1473 }
1474 else { /* Compile-time error message: */
1475 OP *kid = cUNOPo->op_first;
1476 CV *cv;
1477 OP *okid;
1478
1479 if (kid->op_type == OP_PUSHMARK)
1480 goto skip_kids;
1481 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1482 Perl_croak(aTHX_
1483 "panic: unexpected lvalue entersub "
55140b79 1484 "args: type/targ %ld:%"UVuf,
3d811634 1485 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1486 kid = kLISTOP->op_first;
1487 skip_kids:
1488 while (kid->op_sibling)
1489 kid = kid->op_sibling;
1490 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1491 /* Indirect call */
1492 if (kid->op_type == OP_METHOD_NAMED
1493 || kid->op_type == OP_METHOD)
1494 {
87d7fd28 1495 UNOP *newop;
b2ffa427 1496
87d7fd28 1497 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1498 newop->op_type = OP_RV2CV;
1499 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS		 1500 newop->op_first = Nullop;
1501 newop->op_next = (OP*)newop;
1502 kid->op_sibling = (OP*)newop;
349fd7b7 1503 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS		 1504 break;
1505 }
b2ffa427 1506
cd06dffe
GS		 1507 if (kid->op_type != OP_RV2CV)
1508 Perl_croak(aTHX_
1509 "panic: unexpected lvalue entersub "
55140b79 1510 "entry via type/targ %ld:%"UVuf,
3d811634 1511 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1512 kid->op_private |= OPpLVAL_INTRO;
1513 break; /* Postpone until runtime */
1514 }
b2ffa427
NIS		 1515
1516 okid = kid;
cd06dffe
GS		 1517 kid = kUNOP->op_first;
1518 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1519 kid = kUNOP->op_first;
b2ffa427 1520 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1521 Perl_croak(aTHX_
1522 "Unexpected constant lvalue entersub "
55140b79 1523 "entry via type/targ %ld:%"UVuf,
3d811634 1524 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1525 if (kid->op_type != OP_GV) {
1526 /* Restore RV2CV to check lvalueness */
1527 restore_2cv:
1528 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1529 okid->op_next = kid->op_next;
1530 kid->op_next = okid;
1531 }
1532 else
1533 okid->op_next = Nullop;
1534 okid->op_type = OP_RV2CV;
1535 okid->op_targ = 0;
1536 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1537 okid->op_private |= OPpLVAL_INTRO;
1538 break;
1539 }
b2ffa427 1540
638eceb6 1541 cv = GvCV(kGVOP_gv);
1c846c1f 1542 if (!cv)
cd06dffe
GS		 1543 goto restore_2cv;
1544 if (CvLVALUE(cv))
1545 break;
1546 }
1547 }
79072805
LW		 1548 /* FALL THROUGH */
1549 default:
a0d0e21e
LW		 1550 nomod:
1551 /* grep, foreach, subcalls, refgen */
1552 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1553 break;
cea2e8a9 1554 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1555 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1556 ? "do block"
1557 : (o->op_type == OP_ENTERSUB
1558 ? "non-lvalue subroutine call"
53e06cf0 1559 : OP_DESC(o))),
22c35a8c 1560 type ? PL_op_desc[type] : "local"));
11343788 1561 return o;
79072805 1562
a0d0e21e
LW		 1563 case OP_PREINC:
1564 case OP_PREDEC:
1565 case OP_POW:
1566 case OP_MULTIPLY:
1567 case OP_DIVIDE:
1568 case OP_MODULO:
1569 case OP_REPEAT:
1570 case OP_ADD:
1571 case OP_SUBTRACT:
1572 case OP_CONCAT:
1573 case OP_LEFT_SHIFT:
1574 case OP_RIGHT_SHIFT:
1575 case OP_BIT_AND:
1576 case OP_BIT_XOR:
1577 case OP_BIT_OR:
1578 case OP_I_MULTIPLY:
1579 case OP_I_DIVIDE:
1580 case OP_I_MODULO:
1581 case OP_I_ADD:
1582 case OP_I_SUBTRACT:
11343788 1583 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1584 goto nomod;
3280af22 1585 PL_modcount++;
a0d0e21e 1586 break;
b2ffa427 1587
79072805 1588 case OP_COND_EXPR:
11343788 1589 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1590 mod(kid, type);
79072805
LW		 1591 break;
1592
1593 case OP_RV2AV:
1594 case OP_RV2HV:
93af7a87 1595 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1596 Perl_croak(aTHX_ "Can't localize through a reference");
11343788 1597 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1598 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1599 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1600 }
1601 /* FALL THROUGH */
79072805 1602 case OP_RV2GV:
5dc0d613 1603 if (scalar_mod_type(o, type))
3fe9a6f1 1604 goto nomod;
11343788 1605 ref(cUNOPo->op_first, o->op_type);
79072805 1606 /* FALL THROUGH */
79072805
LW		 1607 case OP_ASLICE:
1608 case OP_HSLICE:
78f9721b
SM		 1609 if (type == OP_LEAVESUBLV)
1610 o->op_private |= OPpMAYBE_LVSUB;
1611 /* FALL THROUGH */
1612 case OP_AASSIGN:
93a17b20
LW		 1613 case OP_NEXTSTATE:
1614 case OP_DBSTATE:
a0d0e21e 1615 case OP_CHOMP:
e6438c1a 1616 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1617 break;
463ee0b2 1618 case OP_RV2SV:
11343788 1619 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1620 Perl_croak(aTHX_ "Can't localize through a reference");
aeea060c 1621 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1622 /* FALL THROUGH */
79072805 1623 case OP_GV:
463ee0b2 1624 case OP_AV2ARYLEN:
3280af22 1625 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1626 case OP_SASSIGN:
bf4b1e52
GS		 1627 case OP_ANDASSIGN:
1628 case OP_ORASSIGN:
8990e307 1629 case OP_AELEMFAST:
3280af22 1630 PL_modcount++;
8990e307
LW		 1631 break;
1632
748a9306
LW		 1633 case OP_PADAV:
1634 case OP_PADHV:
e6438c1a 1635 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1636 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1637 return o; /* Treat \(@foo) like ordinary list. */
1638 if (scalar_mod_type(o, type))
3fe9a6f1 1639 goto nomod;
78f9721b
SM		 1640 if (type == OP_LEAVESUBLV)
1641 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1642 /* FALL THROUGH */
1643 case OP_PADSV:
3280af22 1644 PL_modcount++;
748a9306 1645 if (!type)
cea2e8a9 1646 Perl_croak(aTHX_ "Can't localize lexical variable %s",
2d8e6c8d 1647 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
463ee0b2
LW		 1648 break;
1649
4d1ff10f 1650#ifdef USE_5005THREADS
2faa37cc 1651 case OP_THREADSV:
533c011a 1652 PL_modcount++; /* XXX ??? */
554b3eca 1653 break;
4d1ff10f 1654#endif /* USE_5005THREADS */
554b3eca 1655
748a9306
LW		 1656 case OP_PUSHMARK:
1657 break;
b2ffa427 1658
69969c6f
SB		 1659 case OP_KEYS:
1660 if (type != OP_SASSIGN)
1661 goto nomod;
5d82c453
GA		 1662 goto lvalue_func;
1663 case OP_SUBSTR:
1664 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1665 goto nomod;
5f05dabc 1666 /* FALL THROUGH */
a0d0e21e 1667 case OP_POS:
463ee0b2 1668 case OP_VEC:
78f9721b
SM		 1669 if (type == OP_LEAVESUBLV)
1670 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1671 lvalue_func:
11343788
MB		 1672 pad_free(o->op_targ);
1673 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1674 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1675 if (o->op_flags & OPf_KIDS)
1676 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1677 break;
a0d0e21e 1678
463ee0b2
LW		 1679 case OP_AELEM:
1680 case OP_HELEM:
11343788 1681 ref(cBINOPo->op_first, o->op_type);
68dc0745 1682 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1683 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1684 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1685 if (type == OP_LEAVESUBLV)
1686 o->op_private |= OPpMAYBE_LVSUB;
3280af22 1687 PL_modcount++;
463ee0b2
LW		 1688 break;
1689
1690 case OP_SCOPE:
1691 case OP_LEAVE:
1692 case OP_ENTER:
78f9721b 1693 case OP_LINESEQ:
11343788
MB		 1694 if (o->op_flags & OPf_KIDS)
1695 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1696 break;
1697
1698 case OP_NULL:
638bc118
GS		 1699 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1700 goto nomod;
1701 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1702 break;
11343788
MB		 1703 if (o->op_targ != OP_LIST) {
1704 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1705 break;
1706 }
1707 /* FALL THROUGH */
463ee0b2 1708 case OP_LIST:
11343788 1709 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1710 mod(kid, type);
1711 break;
78f9721b
SM		 1712
1713 case OP_RETURN:
1714 if (type != OP_LEAVESUBLV)
1715 goto nomod;
1716 break; /* mod()ing was handled by ck_return() */
463ee0b2 1717 }
58d95175 1718
8be1be90
AMS		 1719 /* [20011101.069] File test operators interpret OPf_REF to mean that
1720 their argument is a filehandle; thus \stat(".") should not set
1721 it. AMS 20011102 */
1722 if (type == OP_REFGEN &&
1723 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1724 return o;
1725
1726 if (type != OP_LEAVESUBLV)
1727 o->op_flags |= OPf_MOD;
1728
1729 if (type == OP_AASSIGN || type == OP_SASSIGN)
1730 o->op_flags |= OPf_SPECIAL|OPf_REF;
1731 else if (!type) {
1732 o->op_private |= OPpLVAL_INTRO;
1733 o->op_flags &= ~OPf_SPECIAL;
1734 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1735 }
8be1be90
AMS		 1736 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1737 && type != OP_LEAVESUBLV)
1738 o->op_flags |= OPf_REF;
11343788 1739 return o;
463ee0b2
LW		 1740}
1741
864dbfa3 1742STATIC bool
cea2e8a9 1743S_scalar_mod_type(pTHX_ OP *o, I32 type)
3fe9a6f1 1744{
1745 switch (type) {
1746 case OP_SASSIGN:
5196be3e 1747 if (o->op_type == OP_RV2GV)
3fe9a6f1 1748 return FALSE;
1749 /* FALL THROUGH */
1750 case OP_PREINC:
1751 case OP_PREDEC:
1752 case OP_POSTINC:
1753 case OP_POSTDEC:
1754 case OP_I_PREINC:
1755 case OP_I_PREDEC:
1756 case OP_I_POSTINC:
1757 case OP_I_POSTDEC:
1758 case OP_POW:
1759 case OP_MULTIPLY:
1760 case OP_DIVIDE:
1761 case OP_MODULO:
1762 case OP_REPEAT:
1763 case OP_ADD:
1764 case OP_SUBTRACT:
1765 case OP_I_MULTIPLY:
1766 case OP_I_DIVIDE:
1767 case OP_I_MODULO:
1768 case OP_I_ADD:
1769 case OP_I_SUBTRACT:
1770 case OP_LEFT_SHIFT:
1771 case OP_RIGHT_SHIFT:
1772 case OP_BIT_AND:
1773 case OP_BIT_XOR:
1774 case OP_BIT_OR:
1775 case OP_CONCAT:
1776 case OP_SUBST:
1777 case OP_TRANS:
49e9fbe6
GS		 1778 case OP_READ:
1779 case OP_SYSREAD:
1780 case OP_RECV:
bf4b1e52
GS		 1781 case OP_ANDASSIGN:
1782 case OP_ORASSIGN:
3fe9a6f1 1783 return TRUE;
1784 default:
1785 return FALSE;
1786 }
1787}
1788
35cd451c 1789STATIC bool
cea2e8a9 1790S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
35cd451c
GS		 1791{
1792 switch (o->op_type) {
1793 case OP_PIPE_OP:
1794 case OP_SOCKPAIR:
1795 if (argnum == 2)
1796 return TRUE;
1797 /* FALL THROUGH */
1798 case OP_SYSOPEN:
1799 case OP_OPEN:
ded8aa31 1800 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1801 case OP_SOCKET:
1802 case OP_OPEN_DIR:
1803 case OP_ACCEPT:
1804 if (argnum == 1)
1805 return TRUE;
1806 /* FALL THROUGH */
1807 default:
1808 return FALSE;
1809 }
1810}
1811
463ee0b2 1812OP *
864dbfa3 1813Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1814{
1815 OP *kid;
11343788
MB		 1816 if (o && o->op_flags & OPf_KIDS) {
1817 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1818 ref(kid, type);
1819 }
11343788 1820 return o;
463ee0b2
LW		 1821}
1822
1823OP *
864dbfa3 1824Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1825{
1826 OP *kid;
463ee0b2 1827
3280af22 1828 if (!o || PL_error_count)
11343788 1829 return o;
463ee0b2 1830
11343788 1831 switch (o->op_type) {
a0d0e21e 1832 case OP_ENTERSUB:
afebc493 1833 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1834 !(o->op_flags & OPf_STACKED)) {
1835 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1836 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1837 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1838 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1839 o->op_flags |= OPf_SPECIAL;
8990e307
LW		 1840 }
1841 break;
aeea060c 1842
463ee0b2 1843 case OP_COND_EXPR:
11343788 1844 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW		 1845 ref(kid, type);
1846 break;
8990e307 1847 case OP_RV2SV:
35cd451c
GS		 1848 if (type == OP_DEFINED)
1849 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1850 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW		 1851 /* FALL THROUGH */
1852 case OP_PADSV:
5f05dabc 1853 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1854 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1855 : type == OP_RV2HV ? OPpDEREF_HV
1856 : OPpDEREF_SV);
11343788 1857 o->op_flags |= OPf_MOD;
a0d0e21e 1858 }
8990e307 1859 break;
1c846c1f 1860
2faa37cc 1861 case OP_THREADSV:
a863c7d1
MB		 1862 o->op_flags |= OPf_MOD; /* XXX ??? */
1863 break;
1864
463ee0b2
LW		 1865 case OP_RV2AV:
1866 case OP_RV2HV:
aeea060c 1867 o->op_flags |= OPf_REF;
8990e307 1868 /* FALL THROUGH */
463ee0b2 1869 case OP_RV2GV:
35cd451c
GS		 1870 if (type == OP_DEFINED)
1871 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1872 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1873 break;
8990e307 1874
463ee0b2
LW		 1875 case OP_PADAV:
1876 case OP_PADHV:
aeea060c 1877 o->op_flags |= OPf_REF;
79072805 1878 break;
aeea060c 1879
8990e307 1880 case OP_SCALAR:
79072805 1881 case OP_NULL:
11343788 1882 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1883 break;
11343788 1884 ref(cBINOPo->op_first, type);
79072805
LW		 1885 break;
1886 case OP_AELEM:
1887 case OP_HELEM:
11343788 1888 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1889 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1890 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1891 : type == OP_RV2HV ? OPpDEREF_HV
1892 : OPpDEREF_SV);
11343788 1893 o->op_flags |= OPf_MOD;
8990e307 1894 }
79072805
LW		 1895 break;
1896
463ee0b2 1897 case OP_SCOPE:
79072805
LW		 1898 case OP_LEAVE:
1899 case OP_ENTER:
8990e307 1900 case OP_LIST:
11343788 1901 if (!(o->op_flags & OPf_KIDS))
79072805 1902 break;
11343788 1903 ref(cLISTOPo->op_last, type);
79072805 1904 break;
a0d0e21e
LW		 1905 default:
1906 break;
79072805 1907 }
11343788 1908 return scalar(o);
8990e307 1909
79072805
LW		 1910}
1911
09bef843
SB		 1912STATIC OP *
1913S_dup_attrlist(pTHX_ OP *o)
1914{
1915 OP *rop = Nullop;
1916
1917 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1918 * where the first kid is OP_PUSHMARK and the remaining ones
1919 * are OP_CONST. We need to push the OP_CONST values.
1920 */
1921 if (o->op_type == OP_CONST)
1922 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1923 else {
1924 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1925 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1926 if (o->op_type == OP_CONST)
1927 rop = append_elem(OP_LIST, rop,
1928 newSVOP(OP_CONST, o->op_flags,
1929 SvREFCNT_inc(cSVOPo->op_sv)));
1930 }
1931 }
1932 return rop;
1933}
1934
1935STATIC void
95f0a2f1 1936S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1937{
09bef843
SB		 1938 SV *stashsv;
1939
1940 /* fake up C<use attributes $pkg,$rv,@attrs> */
1941 ENTER; /* need to protect against side-effects of 'use' */
1942 SAVEINT(PL_expect);
a9164de8 1943 if (stash)
09bef843
SB		 1944 stashsv = newSVpv(HvNAME(stash), 0);
1945 else
1946 stashsv = &PL_sv_no;
e4783991 1947
09bef843 1948#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1949#define ATTRSMODULE_PM "attributes.pm"
1950
1951 if (for_my) {
1952 SV **svp;
1953 /* Don't force the C<use> if we don't need it. */
1954 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1955 sizeof(ATTRSMODULE_PM)-1, 0);
1956 if (svp && *svp != &PL_sv_undef)
1957 ; /* already in %INC */
1958 else
1959 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1960 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1961 Nullsv);
1962 }
1963 else {
1964 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1965 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1966 Nullsv,
1967 prepend_elem(OP_LIST,
1968 newSVOP(OP_CONST, 0, stashsv),
1969 prepend_elem(OP_LIST,
1970 newSVOP(OP_CONST, 0,
1971 newRV(target)),
1972 dup_attrlist(attrs))));
1973 }
09bef843
SB		 1974 LEAVE;
1975}
1976
95f0a2f1
SB		 1977STATIC void
1978S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1979{
1980 OP *pack, *imop, *arg;
1981 SV *meth, *stashsv;
1982
1983 if (!attrs)
1984 return;
1985
1986 assert(target->op_type == OP_PADSV ||
1987 target->op_type == OP_PADHV ||
1988 target->op_type == OP_PADAV);
1989
1990 /* Ensure that attributes.pm is loaded. */
1991 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1992
1993 /* Need package name for method call. */
1994 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1995
1996 /* Build up the real arg-list. */
1997 if (stash)
1998 stashsv = newSVpv(HvNAME(stash), 0);
1999 else
2000 stashsv = &PL_sv_no;
2001 arg = newOP(OP_PADSV, 0);
2002 arg->op_targ = target->op_targ;
2003 arg = prepend_elem(OP_LIST,
2004 newSVOP(OP_CONST, 0, stashsv),
2005 prepend_elem(OP_LIST,
2006 newUNOP(OP_REFGEN, 0,
2007 mod(arg, OP_REFGEN)),
2008 dup_attrlist(attrs)));
2009
2010 /* Fake up a method call to import */
2011 meth = newSVpvn("import", 6);
2012 (void)SvUPGRADE(meth, SVt_PVIV);
2013 (void)SvIOK_on(meth);
2014 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2015 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2016 append_elem(OP_LIST,
2017 prepend_elem(OP_LIST, pack, list(arg)),
2018 newSVOP(OP_METHOD_NAMED, 0, meth)));
2019 imop->op_private |= OPpENTERSUB_NOMOD;
2020
2021 /* Combine the ops. */
2022 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2023}
2024
2025/*
2026=notfor apidoc apply_attrs_string
2027
2028Attempts to apply a list of attributes specified by the C<attrstr> and
2029C<len> arguments to the subroutine identified by the C<cv> argument which
2030is expected to be associated with the package identified by the C<stashpv>
2031argument (see L<attributes>). It gets this wrong, though, in that it
2032does not correctly identify the boundaries of the individual attribute
2033specifications within C<attrstr>. This is not really intended for the
2034public API, but has to be listed here for systems such as AIX which
2035need an explicit export list for symbols. (It's called from XS code
2036in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2037to respect attribute syntax properly would be welcome.
2038
2039=cut
2040*/
2041
be3174d2
GS		 2042void
2043Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2044 char *attrstr, STRLEN len)
2045{
2046 OP *attrs = Nullop;
2047
2048 if (!len) {
2049 len = strlen(attrstr);
2050 }
2051
2052 while (len) {
2053 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2054 if (len) {
2055 char *sstr = attrstr;
2056 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2057 attrs = append_elem(OP_LIST, attrs,
2058 newSVOP(OP_CONST, 0,
2059 newSVpvn(sstr, attrstr-sstr)));
2060 }
2061 }
2062
2063 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2064 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2065 Nullsv, prepend_elem(OP_LIST,
2066 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2067 prepend_elem(OP_LIST,
2068 newSVOP(OP_CONST, 0,
2069 newRV((SV*)cv)),
2070 attrs)));
2071}
2072
09bef843 2073STATIC OP *
95f0a2f1 2074S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20
LW		 2075{
2076 OP *kid;
93a17b20
LW		 2077 I32 type;
2078
3280af22 2079 if (!o || PL_error_count)
11343788 2080 return o;
93a17b20 2081
11343788 2082 type = o->op_type;
93a17b20 2083 if (type == OP_LIST) {
11343788 2084 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2085 my_kid(kid, attrs, imopsp);
dab48698 2086 } else if (type == OP_UNDEF) {
7766148a 2087 return o;
77ca0c92
LW		 2088 } else if (type == OP_RV2SV || /* "our" declaration */
2089 type == OP_RV2AV ||
2090 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
b6512f48 2091 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
763acdb2 2092 yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
b6512f48 2093 }
0256094b
DM		 2094 if (attrs) {
2095 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2096 PL_in_my = FALSE;
2097 PL_in_my_stash = Nullhv;
2098 apply_attrs(GvSTASH(gv),
2099 (type == OP_RV2SV ? GvSV(gv) :
2100 type == OP_RV2AV ? (SV*)GvAV(gv) :
2101 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
95f0a2f1 2102 attrs, FALSE);
0256094b 2103 }
192587c2 2104 o->op_private |= OPpOUR_INTRO;
77ca0c92 2105 return o;
95f0a2f1
SB		 2106 }
2107 else if (type != OP_PADSV &&
93a17b20
LW		 2108 type != OP_PADAV &&
2109 type != OP_PADHV &&
2110 type != OP_PUSHMARK)
2111 {
eb64745e 2112 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2113 OP_DESC(o),
eb64745e 2114 PL_in_my == KEY_our ? "our" : "my"));
11343788 2115 return o;
93a17b20 2116 }
09bef843
SB		 2117 else if (attrs && type != OP_PUSHMARK) {
2118 HV *stash;
09bef843
SB		 2119 SV **namesvp;
2120
eb64745e
GS		 2121 PL_in_my = FALSE;
2122 PL_in_my_stash = Nullhv;
2123
09bef843
SB		 2124 /* check for C<my Dog $spot> when deciding package */
2125 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
a9164de8 2126 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
09bef843
SB		 2127 stash = SvSTASH(*namesvp);
2128 else
2129 stash = PL_curstash;
95f0a2f1 2130 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2131 }
11343788
MB		 2132 o->op_flags |= OPf_MOD;
2133 o->op_private |= OPpLVAL_INTRO;
2134 return o;
93a17b20
LW		 2135}
2136
2137OP *
09bef843
SB		 2138Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2139{
95f0a2f1
SB		 2140 OP *rops = Nullop;
2141 int maybe_scalar = 0;
2142
09bef843
SB		 2143 if (o->op_flags & OPf_PARENS)
2144 list(o);
95f0a2f1
SB		 2145 else
2146 maybe_scalar = 1;
09bef843
SB		 2147 if (attrs)
2148 SAVEFREEOP(attrs);
95f0a2f1
SB		 2149 o = my_kid(o, attrs, &rops);
2150 if (rops) {
2151 if (maybe_scalar && o->op_type == OP_PADSV) {
2152 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2153 o->op_private |= OPpLVAL_INTRO;
2154 }
2155 else
2156 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2157 }
eb64745e
GS		 2158 PL_in_my = FALSE;
2159 PL_in_my_stash = Nullhv;
2160 return o;
09bef843
SB		 2161}
2162
2163OP *
2164Perl_my(pTHX_ OP *o)
2165{
95f0a2f1 2166 return my_attrs(o, Nullop);
09bef843
SB		 2167}
2168
2169OP *
864dbfa3 2170Perl_sawparens(pTHX_ OP *o)
79072805
LW		 2171{
2172 if (o)
2173 o->op_flags |= OPf_PARENS;
2174 return o;
2175}
2176
2177OP *
864dbfa3 2178Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2179{
11343788 2180 OP *o;
79072805 2181
e476b1b5 2182 if (ckWARN(WARN_MISC) &&
599cee73
PM		 2183 (left->op_type == OP_RV2AV ||
2184 left->op_type == OP_RV2HV ||
2185 left->op_type == OP_PADAV ||
2186 left->op_type == OP_PADHV)) {
22c35a8c 2187 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM		 2188 right->op_type == OP_TRANS)
2189 ? right->op_type : OP_MATCH];
dff6d3cd
GS		 2190 const char *sample = ((left->op_type == OP_RV2AV ||
2191 left->op_type == OP_PADAV)
2192 ? "@array" : "%hash");
9014280d 2193 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2194 "Applying %s to %s will act on scalar(%s)",
599cee73 2195 desc, sample, sample);
2ae324a7 2196 }
2197
5cc9e5c9
RH		 2198 if (right->op_type == OP_CONST &&
2199 cSVOPx(right)->op_private & OPpCONST_BARE &&
2200 cSVOPx(right)->op_private & OPpCONST_STRICT)
2201 {
2202 no_bareword_allowed(right);
2203 }
2204
de4bf5b3
MG		 2205 if (!(right->op_flags & OPf_STACKED) &&
2206 (right->op_type == OP_MATCH ||
79072805 2207 right->op_type == OP_SUBST ||
de4bf5b3 2208 right->op_type == OP_TRANS)) {
79072805 2209 right->op_flags |= OPf_STACKED;
18808301
JH		 2210 if (right->op_type != OP_MATCH &&
2211 ! (right->op_type == OP_TRANS &&
2212 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 2213 left = mod(left, right->op_type);
79072805 2214 if (right->op_type == OP_TRANS)
11343788 2215 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 2216 else
11343788 2217 o = prepend_elem(right->op_type, scalar(left), right);
79072805 2218 if (type == OP_NOT)
11343788
MB		 2219 return newUNOP(OP_NOT, 0, scalar(o));
2220 return o;
79072805
LW		 2221 }
2222 else
2223 return bind_match(type, left,
2224 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2225}
2226
2227OP *
864dbfa3 2228Perl_invert(pTHX_ OP *o)
79072805 2229{
11343788
MB		 2230 if (!o)
2231 return o;
79072805 2232 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 2233 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2234}
2235
2236OP *
864dbfa3 2237Perl_scope(pTHX_ OP *o)
79072805
LW		 2238{
2239 if (o) {
3280af22 2240 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 2241 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2242 o->op_type = OP_LEAVE;
22c35a8c 2243 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2
LW		 2244 }
2245 else {
2246 if (o->op_type == OP_LINESEQ) {
2247 OP *kid;
2248 o->op_type = OP_SCOPE;
22c35a8c 2249 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
c3ed7a6a
GS		 2250 kid = ((LISTOP*)o)->op_first;
2251 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
93c66552 2252 op_null(kid);
463ee0b2
LW		 2253 }
2254 else
748a9306 2255 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
463ee0b2 2256 }
79072805
LW		 2257 }
2258 return o;
2259}
2260
b3ac6de7 2261void
864dbfa3 2262Perl_save_hints(pTHX)
b3ac6de7 2263{
3280af22
NIS		 2264 SAVEI32(PL_hints);
2265 SAVESPTR(GvHV(PL_hintgv));
2266 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2267 SAVEFREESV(GvHV(PL_hintgv));
b3ac6de7
IZ		 2268}
2269
a0d0e21e 2270int
864dbfa3 2271Perl_block_start(pTHX_ int full)
79072805 2272{
3280af22 2273 int retval = PL_savestack_ix;
b3ac6de7 2274
3280af22 2275 SAVEI32(PL_comppad_name_floor);
43d4d5c6
GS		 2276 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2277 if (full)
2278 PL_comppad_name_fill = PL_comppad_name_floor;
2279 if (PL_comppad_name_floor < 0)
2280 PL_comppad_name_floor = 0;
3280af22
NIS		 2281 SAVEI32(PL_min_intro_pending);
2282 SAVEI32(PL_max_intro_pending);
2283 PL_min_intro_pending = 0;
2284 SAVEI32(PL_comppad_name_fill);
2285 SAVEI32(PL_padix_floor);
2286 PL_padix_floor = PL_padix;
2287 PL_pad_reset_pending = FALSE;
b3ac6de7 2288 SAVEHINTS();
3280af22 2289 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 2290 SAVESPTR(PL_compiling.cop_warnings);
0453d815 2291 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 2292 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2293 SAVEFREESV(PL_compiling.cop_warnings) ;
2294 }
ac27b0f5
NIS		 2295 SAVESPTR(PL_compiling.cop_io);
2296 if (! specialCopIO(PL_compiling.cop_io)) {
2297 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2298 SAVEFREESV(PL_compiling.cop_io) ;
2299 }
a0d0e21e
LW		 2300 return retval;
2301}
2302
2303OP*
864dbfa3 2304Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2305{
3280af22 2306 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
d8a34499
IK		 2307 line_t copline = PL_copline;
2308 /* there should be a nextstate in every block */
2309 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2310 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
e9818f4e 2311 LEAVE_SCOPE(floor);
3280af22 2312 PL_pad_reset_pending = FALSE;
e24b16f9 2313 PL_compiling.op_private = PL_hints;
a0d0e21e 2314 if (needblockscope)
3280af22
NIS		 2315 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2316 pad_leavemy(PL_comppad_name_fill);
2317 PL_cop_seqmax++;
a0d0e21e
LW		 2318 return retval;
2319}
2320
76e3520e 2321STATIC OP *
cea2e8a9 2322S_newDEFSVOP(pTHX)
54b9620d 2323{
4d1ff10f 2324#ifdef USE_5005THREADS
54b9620d
MB		 2325 OP *o = newOP(OP_THREADSV, 0);
2326 o->op_targ = find_threadsv("_");
2327 return o;
2328#else
3280af22 2329 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
4d1ff10f 2330#endif /* USE_5005THREADS */
54b9620d
MB		 2331}
2332
a0d0e21e 2333void
864dbfa3 2334Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2335{
3280af22 2336 if (PL_in_eval) {
b295d113
TH		 2337 if (PL_eval_root)
2338 return;
faef0170
HS		 2339 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2340 ((PL_in_eval & EVAL_KEEPERR)
2341 ? OPf_SPECIAL : 0), o);
3280af22 2342 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2343 PL_eval_root->op_private |= OPpREFCOUNTED;
2344 OpREFCNT_set(PL_eval_root, 1);
3280af22 2345 PL_eval_root->op_next = 0;
a2efc822 2346 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2347 }
2348 else {
5dc0d613 2349 if (!o)
a0d0e21e 2350 return;
3280af22
NIS		 2351 PL_main_root = scope(sawparens(scalarvoid(o)));
2352 PL_curcop = &PL_compiling;
2353 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2354 PL_main_root->op_private |= OPpREFCOUNTED;
2355 OpREFCNT_set(PL_main_root, 1);
3280af22 2356 PL_main_root->op_next = 0;
a2efc822 2357 CALL_PEEP(PL_main_start);
3280af22 2358 PL_compcv = 0;
3841441e 2359
4fdae800 2360 /* Register with debugger */
84902520 2361 if (PERLDB_INTER) {
864dbfa3 2362 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 2363 if (cv) {
2364 dSP;
924508f0 2365 PUSHMARK(SP);
cc49e20b 2366 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2367 PUTBACK;
864dbfa3 2368 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 2369 }
2370 }
79072805 2371 }
79072805
LW		 2372}
2373
2374OP *
864dbfa3 2375Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW		 2376{
2377 if (o->op_flags & OPf_PARENS)
2378 list(o);
8990e307 2379 else {
64420d0d
JH		 2380 if (ckWARN(WARN_PARENTHESIS)
2381 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2382 {
2383 char *s = PL_bufptr;
2384
2385 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2386 s++;
2387
a0d0e21e 2388 if (*s == ';' || *s == '=')
9014280d 2389 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
eb64745e
GS		 2390 "Parentheses missing around \"%s\" list",
2391 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
8990e307
LW		 2392 }
2393 }
93a17b20 2394 if (lex)
eb64745e 2395 o = my(o);
93a17b20 2396 else
eb64745e
GS		 2397 o = mod(o, OP_NULL); /* a bit kludgey */
2398 PL_in_my = FALSE;
2399 PL_in_my_stash = Nullhv;
2400 return o;
79072805
LW		 2401}
2402
2403OP *
864dbfa3 2404Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2405{
2406 if (o->op_type == OP_LIST) {
554b3eca 2407 OP *o2;
4d1ff10f 2408#ifdef USE_5005THREADS
2faa37cc 2409 o2 = newOP(OP_THREADSV, 0);
54b9620d 2410 o2->op_targ = find_threadsv(";");
554b3eca
MB		 2411#else
2412 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
4d1ff10f 2413#endif /* USE_5005THREADS */
554b3eca 2414 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2415 }
2416 return o;
2417}
2418
2419OP *
864dbfa3 2420Perl_fold_constants(pTHX_ register OP *o)
79072805
LW		 2421{
2422 register OP *curop;
2423 I32 type = o->op_type;
748a9306 2424 SV *sv;
79072805 2425
22c35a8c 2426 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2427 scalar(o);
b162f9ea 2428 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2429 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2430
eac055e9
GS		 2431 /* integerize op, unless it happens to be C<-foo>.
2432 * XXX should pp_i_negate() do magic string negation instead? */
2433 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2434 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2435 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2436 {
22c35a8c 2437 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2438 }
85e6fe83 2439
22c35a8c 2440 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2441 goto nope;
2442
de939608 2443 switch (type) {
7a52d87a
GS		 2444 case OP_NEGATE:
2445 /* XXX might want a ck_negate() for this */
2446 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2447 break;
de939608
CS		 2448 case OP_SPRINTF:
2449 case OP_UCFIRST:
2450 case OP_LCFIRST:
2451 case OP_UC:
2452 case OP_LC:
69dcf70c
MB		 2453 case OP_SLT:
2454 case OP_SGT:
2455 case OP_SLE:
2456 case OP_SGE:
2457 case OP_SCMP:
2de3dbcc
JH		 2458 /* XXX what about the numeric ops? */
2459 if (PL_hints & HINT_LOCALE)
de939608
CS		 2460 goto nope;
2461 }
2462
3280af22 2463 if (PL_error_count)
a0d0e21e
LW		 2464 goto nope; /* Don't try to run w/ errors */
2465
79072805 2466 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 2467 if ((curop->op_type != OP_CONST ||
2468 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 2469 curop->op_type != OP_LIST &&
2470 curop->op_type != OP_SCALAR &&
2471 curop->op_type != OP_NULL &&
2472 curop->op_type != OP_PUSHMARK)
2473 {
79072805
LW		 2474 goto nope;
2475 }
2476 }
2477
2478 curop = LINKLIST(o);
2479 o->op_next = 0;
533c011a 2480 PL_op = curop;
cea2e8a9 2481 CALLRUNOPS(aTHX);
3280af22 2482 sv = *(PL_stack_sp--);
748a9306 2483 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
79072805 2484 pad_swipe(o->op_targ);
748a9306
LW		 2485 else if (SvTEMP(sv)) { /* grab mortal temp? */
2486 (void)SvREFCNT_inc(sv);
2487 SvTEMP_off(sv);
85e6fe83 2488 }
79072805
LW		 2489 op_free(o);
2490 if (type == OP_RV2GV)
b1cb66bf 2491 return newGVOP(OP_GV, 0, (GV*)sv);
748a9306 2492 else {
ee580363
GS		 2493 /* try to smush double to int, but don't smush -2.0 to -2 */
2494 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2495 type != OP_NEGATE)
2496 {
28e5dec8
JH		 2497#ifdef PERL_PRESERVE_IVUV
2498 /* Only bother to attempt to fold to IV if
2499 most operators will benefit */
2500 SvIV_please(sv);
2501#endif
748a9306 2502 }
a86a20aa 2503 return newSVOP(OP_CONST, 0, sv);
748a9306 2504 }
aeea060c 2505
79072805 2506 nope:
79072805
LW		 2507 return o;
2508}
2509
2510OP *
864dbfa3 2511Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW		 2512{
2513 register OP *curop;
3280af22 2514 I32 oldtmps_floor = PL_tmps_floor;
79072805 2515
a0d0e21e 2516 list(o);
3280af22 2517 if (PL_error_count)
a0d0e21e
LW		 2518 return o; /* Don't attempt to run with errors */
2519
533c011a 2520 PL_op = curop = LINKLIST(o);
a0d0e21e 2521 o->op_next = 0;
a2efc822 2522 CALL_PEEP(curop);
cea2e8a9
GS		 2523 pp_pushmark();
2524 CALLRUNOPS(aTHX);
533c011a 2525 PL_op = curop;
cea2e8a9 2526 pp_anonlist();
3280af22 2527 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2528
2529 o->op_type = OP_RV2AV;
22c35a8c 2530 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
c13f253a 2531 o->op_seq = 0; /* needs to be revisited in peep() */
79072805 2532 curop = ((UNOP*)o)->op_first;
3280af22 2533 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2534 op_free(curop);
79072805
LW		 2535 linklist(o);
2536 return list(o);
2537}
2538
2539OP *
864dbfa3 2540Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2541{
11343788
MB		 2542 if (!o || o->op_type != OP_LIST)
2543 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2544 else
5dc0d613 2545 o->op_flags &= ~OPf_WANT;
79072805 2546
22c35a8c 2547 if (!(PL_opargs[type] & OA_MARK))
93c66552 2548 op_null(cLISTOPo->op_first);
8990e307 2549
11343788 2550 o->op_type = type;
22c35a8c 2551 o->op_ppaddr = PL_ppaddr[type];
11343788 2552 o->op_flags |= flags;
79072805 2553
11343788
MB		 2554 o = CHECKOP(type, o);
2555 if (o->op_type != type)
2556 return o;
79072805 2557
11343788 2558 return fold_constants(o);
79072805
LW		 2559}
2560
2561/* List constructors */
2562
2563OP *
864dbfa3 2564Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2565{
2566 if (!first)
2567 return last;
8990e307
LW		 2568
2569 if (!last)
79072805 2570 return first;
8990e307 2571
155aba94
GS		 2572 if (first->op_type != type
2573 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2574 {
2575 return newLISTOP(type, 0, first, last);
2576 }
79072805 2577
a0d0e21e
LW		 2578 if (first->op_flags & OPf_KIDS)
2579 ((LISTOP*)first)->op_last->op_sibling = last;
2580 else {
2581 first->op_flags |= OPf_KIDS;
2582 ((LISTOP*)first)->op_first = last;
2583 }
2584 ((LISTOP*)first)->op_last = last;
a0d0e21e 2585 return first;
79072805
LW		 2586}
2587
2588OP *
864dbfa3 2589Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2590{
2591 if (!first)
2592 return (OP*)last;
8990e307
LW		 2593
2594 if (!last)
79072805 2595 return (OP*)first;
8990e307
LW		 2596
2597 if (first->op_type != type)
79072805 2598 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW		 2599
2600 if (last->op_type != type)
79072805
LW		 2601 return append_elem(type, (OP*)first, (OP*)last);
2602
2603 first->op_last->op_sibling = last->op_first;
2604 first->op_last = last->op_last;
117dada2 2605 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2606
238a4c30
NIS		 2607 FreeOp(last);
2608
79072805
LW		 2609 return (OP*)first;
2610}
2611
2612OP *
864dbfa3 2613Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2614{
2615 if (!first)
2616 return last;
8990e307
LW		 2617
2618 if (!last)
79072805 2619 return first;
8990e307
LW		 2620
2621 if (last->op_type == type) {
2622 if (type == OP_LIST) { /* already a PUSHMARK there */
2623 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2624 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2625 if (!(first->op_flags & OPf_PARENS))
2626 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2627 }
2628 else {
2629 if (!(last->op_flags & OPf_KIDS)) {
2630 ((LISTOP*)last)->op_last = first;
2631 last->op_flags |= OPf_KIDS;
2632 }
2633 first->op_sibling = ((LISTOP*)last)->op_first;
2634 ((LISTOP*)last)->op_first = first;
79072805 2635 }
117dada2 2636 last->op_flags |= OPf_KIDS;
79072805
LW		 2637 return last;
2638 }
2639
2640 return newLISTOP(type, 0, first, last);
2641}
2642
2643/* Constructors */
2644
2645OP *
864dbfa3 2646Perl_newNULLLIST(pTHX)
79072805 2647{
8990e307
LW		 2648 return newOP(OP_STUB, 0);
2649}
2650
2651OP *
864dbfa3 2652Perl_force_list(pTHX_ OP *o)
8990e307 2653{
11343788
MB		 2654 if (!o || o->op_type != OP_LIST)
2655 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2656 op_null(o);
11343788 2657 return o;
79072805
LW		 2658}
2659
2660OP *
864dbfa3 2661Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2662{
2663 LISTOP *listop;
2664
b7dc083c 2665 NewOp(1101, listop, 1, LISTOP);
79072805
LW		 2666
2667 listop->op_type = type;
22c35a8c 2668 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2669 if (first || last)
2670 flags |= OPf_KIDS;
79072805 2671 listop->op_flags = flags;
79072805
LW		 2672
2673 if (!last && first)
2674 last = first;
2675 else if (!first && last)
2676 first = last;
8990e307
LW		 2677 else if (first)
2678 first->op_sibling = last;
79072805
LW		 2679 listop->op_first = first;
2680 listop->op_last = last;
8990e307
LW		 2681 if (type == OP_LIST) {
2682 OP* pushop;
2683 pushop = newOP(OP_PUSHMARK, 0);
2684 pushop->op_sibling = first;
2685 listop->op_first = pushop;
2686 listop->op_flags |= OPf_KIDS;
2687 if (!last)
2688 listop->op_last = pushop;
2689 }
79072805
LW		 2690
2691 return (OP*)listop;
2692}
2693
2694OP *
864dbfa3 2695Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2696{
11343788 2697 OP *o;
b7dc083c 2698 NewOp(1101, o, 1, OP);
11343788 2699 o->op_type = type;
22c35a8c 2700 o->op_ppaddr = PL_ppaddr[type];
11343788 2701 o->op_flags = flags;
79072805 2702
11343788
MB		 2703 o->op_next = o;
2704 o->op_private = 0 + (flags >> 8);
22c35a8c 2705 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2706 scalar(o);
22c35a8c 2707 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2708 o->op_targ = pad_alloc(type, SVs_PADTMP);
2709 return CHECKOP(type, o);
79072805
LW		 2710}
2711
2712OP *
864dbfa3 2713Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW		 2714{
2715 UNOP *unop;
2716
93a17b20 2717 if (!first)
aeea060c 2718 first = newOP(OP_STUB, 0);
22c35a8c 2719 if (PL_opargs[type] & OA_MARK)
8990e307 2720 first = force_list(first);
93a17b20 2721
b7dc083c 2722 NewOp(1101, unop, 1, UNOP);
79072805 2723 unop->op_type = type;
22c35a8c 2724 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2725 unop->op_first = first;
2726 unop->op_flags = flags | OPf_KIDS;
c07a80fd 2727 unop->op_private = 1 | (flags >> 8);
e50aee73 2728 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2729 if (unop->op_next)
2730 return (OP*)unop;
2731
a0d0e21e 2732 return fold_constants((OP *) unop);
79072805
LW		 2733}
2734
2735OP *
864dbfa3 2736Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2737{
2738 BINOP *binop;
b7dc083c 2739 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2740
2741 if (!first)
2742 first = newOP(OP_NULL, 0);
2743
2744 binop->op_type = type;
22c35a8c 2745 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2746 binop->op_first = first;
2747 binop->op_flags = flags | OPf_KIDS;
2748 if (!last) {
2749 last = first;
c07a80fd 2750 binop->op_private = 1 | (flags >> 8);
79072805
LW		 2751 }
2752 else {
c07a80fd 2753 binop->op_private = 2 | (flags >> 8);
79072805
LW		 2754 first->op_sibling = last;
2755 }
2756
e50aee73 2757 binop = (BINOP*)CHECKOP(type, binop);
b162f9ea 2758 if (binop->op_next || binop->op_type != type)
79072805
LW		 2759 return (OP*)binop;
2760
7284ab6f 2761 binop->op_last = binop->op_first->op_sibling;
79072805 2762
a0d0e21e 2763 return fold_constants((OP *)binop);
79072805
LW		 2764}
2765
a0ed51b3 2766static int
2b9d42f0
NIS		 2767uvcompare(const void *a, const void *b)
2768{
2769 if (*((UV *)a) < (*(UV *)b))
2770 return -1;
2771 if (*((UV *)a) > (*(UV *)b))
2772 return 1;
2773 if (*((UV *)a+1) < (*(UV *)b+1))
2774 return -1;
2775 if (*((UV *)a+1) > (*(UV *)b+1))
2776 return 1;
a0ed51b3
LW		 2777 return 0;
2778}
2779
79072805 2780OP *
864dbfa3 2781Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2782{
79072805
LW		 2783 SV *tstr = ((SVOP*)expr)->op_sv;
2784 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2785 STRLEN tlen;
2786 STRLEN rlen;
9b877dbb
IH		 2787 U8 *t = (U8*)SvPV(tstr, tlen);
2788 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW		 2789 register I32 i;
2790 register I32 j;
a0ed51b3 2791 I32 del;
79072805 2792 I32 complement;
5d06d08e 2793 I32 squash;
9b877dbb 2794 I32 grows = 0;
79072805
LW		 2795 register short *tbl;
2796
800b4dc4 2797 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2798 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2799 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2800 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2801
036b4402
GS		 2802 if (SvUTF8(tstr))
2803 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2804
2805 if (SvUTF8(rstr))
036b4402 2806 o->op_private |= OPpTRANS_TO_UTF;
79072805 2807
a0ed51b3 2808 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2809 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW		 2810 SV* transv = 0;
2811 U8* tend = t + tlen;
2812 U8* rend = r + rlen;
ba210ebe 2813 STRLEN ulen;
a0ed51b3
LW		 2814 U32 tfirst = 1;
2815 U32 tlast = 0;
2816 I32 tdiff;
2817 U32 rfirst = 1;
2818 U32 rlast = 0;
2819 I32 rdiff;
2820 I32 diff;
2821 I32 none = 0;
2822 U32 max = 0;
2823 I32 bits;
a0ed51b3 2824 I32 havefinal = 0;
9c5ffd7c 2825 U32 final = 0;
a0ed51b3
LW		 2826 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2827 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2828 U8* tsave = NULL;
2829 U8* rsave = NULL;
2830
2831 if (!from_utf) {
2832 STRLEN len = tlen;
2833 tsave = t = bytes_to_utf8(t, &len);
2834 tend = t + len;
2835 }
2836 if (!to_utf && rlen) {
2837 STRLEN len = rlen;
2838 rsave = r = bytes_to_utf8(r, &len);
2839 rend = r + len;
2840 }
a0ed51b3 2841
2b9d42f0
NIS		 2842/* There are several snags with this code on EBCDIC:
2843 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2844 2. scan_const() in toke.c has encoded chars in native encoding which makes
2845 ranges at least in EBCDIC 0..255 range the bottom odd.
2846*/
2847
a0ed51b3 2848 if (complement) {
ad391ad9 2849 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2850 UV *cp;
a0ed51b3 2851 UV nextmin = 0;
2b9d42f0 2852 New(1109, cp, 2*tlen, UV);
a0ed51b3 2853 i = 0;
79cb57f6 2854 transv = newSVpvn("",0);
a0ed51b3 2855 while (t < tend) {
2b9d42f0
NIS		 2856 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2857 t += ulen;
2858 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2859 t++;
2b9d42f0
NIS		 2860 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2861 t += ulen;
a0ed51b3 2862 }
2b9d42f0
NIS		 2863 else {
2864 cp[2*i+1] = cp[2*i];
2865 }
2866 i++;
a0ed51b3 2867 }
2b9d42f0 2868 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2869 for (j = 0; j < i; j++) {
2b9d42f0 2870 UV val = cp[2*j];
a0ed51b3
LW		 2871 diff = val - nextmin;
2872 if (diff > 0) {
9041c2e3 2873 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2874 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2875 if (diff > 1) {
2b9d42f0 2876 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2877 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2878 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2879 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2880 }
2881 }
2b9d42f0 2882 val = cp[2*j+1];
a0ed51b3
LW		 2883 if (val >= nextmin)
2884 nextmin = val + 1;
2885 }
9041c2e3 2886 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2887 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2888 {
2889 U8 range_mark = UTF_TO_NATIVE(0xff);
2890 sv_catpvn(transv, (char *)&range_mark, 1);
2891 }
b851fbc1
JH		 2892 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2893 UNICODE_ALLOW_SUPER);
dfe13c55
GS		 2894 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2895 t = (U8*)SvPVX(transv);
a0ed51b3
LW		 2896 tlen = SvCUR(transv);
2897 tend = t + tlen;
455d824a 2898 Safefree(cp);
a0ed51b3
LW		 2899 }
2900 else if (!rlen && !del) {
2901 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2902 }
2903 if (!squash) {
05d340b8 2904 if ((!rlen && !del) || t == r ||
12ae5dfc 2905 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2906 {
4757a243 2907 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2908 }
a0ed51b3
LW		 2909 }
2910
2911 while (t < tend || tfirst <= tlast) {
2912 /* see if we need more "t" chars */
2913 if (tfirst > tlast) {
9041c2e3 2914 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2915 t += ulen;
2b9d42f0 2916 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2917 t++;
9041c2e3 2918 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2919 t += ulen;
2920 }
2921 else
2922 tlast = tfirst;
2923 }
2924
2925 /* now see if we need more "r" chars */
2926 if (rfirst > rlast) {
2927 if (r < rend) {
9041c2e3 2928 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2929 r += ulen;
2b9d42f0 2930 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2931 r++;
9041c2e3 2932 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2933 r += ulen;
2934 }
2935 else
2936 rlast = rfirst;
2937 }
2938 else {
2939 if (!havefinal++)
2940 final = rlast;
2941 rfirst = rlast = 0xffffffff;
2942 }
2943 }
2944
2945 /* now see which range will peter our first, if either. */
2946 tdiff = tlast - tfirst;
2947 rdiff = rlast - rfirst;
2948
2949 if (tdiff <= rdiff)
2950 diff = tdiff;
2951 else
2952 diff = rdiff;
2953
2954 if (rfirst == 0xffffffff) {
2955 diff = tdiff; /* oops, pretend rdiff is infinite */
2956 if (diff > 0)
894356b3
GS		 2957 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2958 (long)tfirst, (long)tlast);
a0ed51b3 2959 else
894356b3 2960 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2961 }
2962 else {
2963 if (diff > 0)
894356b3
GS		 2964 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2965 (long)tfirst, (long)(tfirst + diff),
2966 (long)rfirst);
a0ed51b3 2967 else
894356b3
GS		 2968 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2969 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2970
2971 if (rfirst + diff > max)
2972 max = rfirst + diff;
9b877dbb 2973 if (!grows)
45005bfb
JH		 2974 grows = (tfirst < rfirst &&
2975 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2976 rfirst += diff + 1;
a0ed51b3
LW		 2977 }
2978 tfirst += diff + 1;
2979 }
2980
2981 none = ++max;
2982 if (del)
2983 del = ++max;
2984
2985 if (max > 0xffff)
2986 bits = 32;
2987 else if (max > 0xff)
2988 bits = 16;
2989 else
2990 bits = 8;
2991
455d824a 2992 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2993 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2994 SvREFCNT_dec(listsv);
2995 if (transv)
2996 SvREFCNT_dec(transv);
2997
45005bfb 2998 if (!del && havefinal && rlen)
b448e4fe
JH		 2999 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3000 newSVuv((UV)final), 0);
a0ed51b3 3001
9b877dbb 3002 if (grows)
a0ed51b3
LW		 3003 o->op_private |= OPpTRANS_GROWS;
3004
9b877dbb
IH		 3005 if (tsave)
3006 Safefree(tsave);
3007 if (rsave)
3008 Safefree(rsave);
3009
a0ed51b3
LW		 3010 op_free(expr);
3011 op_free(repl);
3012 return o;
3013 }
3014
3015 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3016 if (complement) {
3017 Zero(tbl, 256, short);
3018 for (i = 0; i < tlen; i++)
ec49126f 3019 tbl[t[i]] = -1;
79072805
LW		 3020 for (i = 0, j = 0; i < 256; i++) {
3021 if (!tbl[i]) {
3022 if (j >= rlen) {
a0ed51b3 3023 if (del)
79072805
LW		 3024 tbl[i] = -2;
3025 else if (rlen)
ec49126f 3026 tbl[i] = r[j-1];
79072805
LW		 3027 else
3028 tbl[i] = i;
3029 }
9b877dbb
IH		 3030 else {
3031 if (i < 128 && r[j] >= 128)
3032 grows = 1;
ec49126f 3033 tbl[i] = r[j++];
9b877dbb 3034 }
79072805
LW		 3035 }
3036 }
05d340b8
JH		 3037 if (!del) {
3038 if (!rlen) {
3039 j = rlen;
3040 if (!squash)
3041 o->op_private |= OPpTRANS_IDENTICAL;
3042 }
3043 else if (j >= rlen)
3044 j = rlen - 1;
3045 else
3046 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79
JH		 3047 tbl[0x100] = rlen - j;
3048 for (i=0; i < rlen - j; i++)
3049 tbl[0x101+i] = r[j+i];
3050 }
79072805
LW		 3051 }
3052 else {
a0ed51b3 3053 if (!rlen && !del) {
79072805 3054 r = t; rlen = tlen;
5d06d08e 3055 if (!squash)
4757a243 3056 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3057 }
94bfe852
RGS		 3058 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3059 o->op_private |= OPpTRANS_IDENTICAL;
3060 }
79072805
LW		 3061 for (i = 0; i < 256; i++)
3062 tbl[i] = -1;
3063 for (i = 0, j = 0; i < tlen; i++,j++) {
3064 if (j >= rlen) {
a0ed51b3 3065 if (del) {
ec49126f 3066 if (tbl[t[i]] == -1)
3067 tbl[t[i]] = -2;
79072805
LW		 3068 continue;
3069 }
3070 --j;
3071 }
9b877dbb
IH		 3072 if (tbl[t[i]] == -1) {
3073 if (t[i] < 128 && r[j] >= 128)
3074 grows = 1;
ec49126f 3075 tbl[t[i]] = r[j];
9b877dbb 3076 }
79072805
LW		 3077 }
3078 }
9b877dbb
IH		 3079 if (grows)
3080 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 3081 op_free(expr);
3082 op_free(repl);
3083
11343788 3084 return o;
79072805
LW		 3085}
3086
3087OP *
864dbfa3 3088Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 3089{
3090 PMOP *pmop;
3091
b7dc083c 3092 NewOp(1101, pmop, 1, PMOP);
79072805 3093 pmop->op_type = type;
22c35a8c 3094 pmop->op_ppaddr = PL_ppaddr[type];
79072805 3095 pmop->op_flags = flags;
c07a80fd 3096 pmop->op_private = 0 | (flags >> 8);
79072805 3097
3280af22 3098 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 3099 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 3100 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 3101 pmop->op_pmpermflags |= PMf_LOCALE;
3102 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 3103
debc9467 3104#ifdef USE_ITHREADS
13137afc
AB		 3105 {
3106 SV* repointer;
3107 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3108 repointer = av_pop((AV*)PL_regex_pad[0]);
3109 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 3110 SvREPADTMP_off(repointer);
13137afc 3111 sv_setiv(repointer,0);
1eb1540c 3112 } else {
13137afc
AB		 3113 repointer = newSViv(0);
3114 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3115 pmop->op_pmoffset = av_len(PL_regex_padav);
3116 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 3117 }
13137afc 3118 }
debc9467 3119#endif
1eb1540c 3120
1fcf4c12 3121 /* link into pm list */
3280af22
NIS		 3122 if (type != OP_TRANS && PL_curstash) {
3123 pmop->op_pmnext = HvPMROOT(PL_curstash);
3124 HvPMROOT(PL_curstash) = pmop;
cb55de95 3125 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 3126 }
3127
3128 return (OP*)pmop;
3129}
3130
3131OP *
864dbfa3 3132Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 3133{
3134 PMOP *pm;
3135 LOGOP *rcop;
ce862d02 3136 I32 repl_has_vars = 0;
79072805 3137
11343788
MB		 3138 if (o->op_type == OP_TRANS)
3139 return pmtrans(o, expr, repl);
79072805 3140
3280af22 3141 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3142 pm = (PMOP*)o;
79072805
LW		 3143
3144 if (expr->op_type == OP_CONST) {
463ee0b2 3145 STRLEN plen;
79072805 3146 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 3147 char *p = SvPV(pat, plen);
11343788 3148 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 3149 sv_setpvn(pat, "\\s+", 3);
463ee0b2 3150 p = SvPV(pat, plen);
79072805
LW		 3151 pm->op_pmflags |= PMf_SKIPWHITE;
3152 }
5b71a6a7 3153 if (DO_UTF8(pat))
a5961de5 3154 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS		 3155 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3156 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3157 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 3158 op_free(expr);
3159 }
3160 else {
3280af22 3161 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3162 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3163 ? OP_REGCRESET
3164 : OP_REGCMAYBE),0,expr);
463ee0b2 3165
b7dc083c 3166 NewOp(1101, rcop, 1, LOGOP);
79072805 3167 rcop->op_type = OP_REGCOMP;
22c35a8c 3168 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3169 rcop->op_first = scalar(expr);
1c846c1f 3170 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3171 ? (OPf_SPECIAL | OPf_KIDS)
3172 : OPf_KIDS);
79072805 3173 rcop->op_private = 1;
11343788 3174 rcop->op_other = o;
79072805
LW		 3175
3176 /* establish postfix order */
3280af22 3177 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3178 LINKLIST(expr);
3179 rcop->op_next = expr;
3180 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3181 }
3182 else {
3183 rcop->op_next = LINKLIST(expr);
3184 expr->op_next = (OP*)rcop;
3185 }
79072805 3186
11343788 3187 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3188 }
3189
3190 if (repl) {
748a9306 3191 OP *curop;
0244c3a4 3192 if (pm->op_pmflags & PMf_EVAL) {
748a9306 3193 curop = 0;
57843af0
GS		 3194 if (CopLINE(PL_curcop) < PL_multi_end)
3195 CopLINE_set(PL_curcop, PL_multi_end);
0244c3a4 3196 }
4d1ff10f 3197#ifdef USE_5005THREADS
2faa37cc 3198 else if (repl->op_type == OP_THREADSV
554b3eca 3199 && strchr("&`'123456789+",
533c011a 3200 PL_threadsv_names[repl->op_targ]))
554b3eca
MB		 3201 {
3202 curop = 0;
3203 }
4d1ff10f 3204#endif /* USE_5005THREADS */
748a9306
LW		 3205 else if (repl->op_type == OP_CONST)
3206 curop = repl;
79072805 3207 else {
79072805
LW		 3208 OP *lastop = 0;
3209 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3210 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4d1ff10f 3211#ifdef USE_5005THREADS
ce862d02
IZ		 3212 if (curop->op_type == OP_THREADSV) {
3213 repl_has_vars = 1;
be949f6f 3214 if (strchr("&`'123456789+", curop->op_private))
ce862d02 3215 break;
554b3eca
MB		 3216 }
3217#else
79072805 3218 if (curop->op_type == OP_GV) {
638eceb6 3219 GV *gv = cGVOPx_gv(curop);
ce862d02 3220 repl_has_vars = 1;
93a17b20 3221 if (strchr("&`'123456789+", *GvENAME(gv)))
79072805
LW		 3222 break;
3223 }
4d1ff10f 3224#endif /* USE_5005THREADS */
79072805
LW		 3225 else if (curop->op_type == OP_RV2CV)
3226 break;
3227 else if (curop->op_type == OP_RV2SV ||
3228 curop->op_type == OP_RV2AV ||
3229 curop->op_type == OP_RV2HV ||
3230 curop->op_type == OP_RV2GV) {
3231 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3232 break;
3233 }
748a9306
LW		 3234 else if (curop->op_type == OP_PADSV ||
3235 curop->op_type == OP_PADAV ||
3236 curop->op_type == OP_PADHV ||
554b3eca 3237 curop->op_type == OP_PADANY) {
ce862d02 3238 repl_has_vars = 1;
748a9306 3239 }
1167e5da
SM		 3240 else if (curop->op_type == OP_PUSHRE)
3241 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3242 else
3243 break;
3244 }
3245 lastop = curop;
3246 }
748a9306 3247 }
ce862d02 3248 if (curop == repl
1c846c1f 3249 && !(repl_has_vars
aaa362c4
RS		 3250 && (!PM_GETRE(pm)
3251 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3252 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3253 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3254 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3255 }
3256 else {
aaa362c4 3257 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 3258 pm->op_pmflags |= PMf_MAYBE_CONST;
3259 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3260 }
b7dc083c 3261 NewOp(1101, rcop, 1, LOGOP);
748a9306 3262 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3263 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3264 rcop->op_first = scalar(repl);
3265 rcop->op_flags |= OPf_KIDS;
3266 rcop->op_private = 1;
11343788 3267 rcop->op_other = o;
748a9306
LW		 3268
3269 /* establish postfix order */
3270 rcop->op_next = LINKLIST(repl);
3271 repl->op_next = (OP*)rcop;
3272
3273 pm->op_pmreplroot = scalar((OP*)rcop);
3274 pm->op_pmreplstart = LINKLIST(rcop);
3275 rcop->op_next = 0;
79072805
LW		 3276 }
3277 }
3278
3279 return (OP*)pm;
3280}
3281
3282OP *
864dbfa3 3283Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 3284{
3285 SVOP *svop;
b7dc083c 3286 NewOp(1101, svop, 1, SVOP);
79072805 3287 svop->op_type = type;
22c35a8c 3288 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3289 svop->op_sv = sv;
3290 svop->op_next = (OP*)svop;
3291 svop->op_flags = flags;
22c35a8c 3292 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3293 scalar((OP*)svop);
22c35a8c 3294 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3295 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3296 return CHECKOP(type, svop);
79072805
LW		 3297}
3298
3299OP *
350de78d
GS		 3300Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3301{
3302 PADOP *padop;
3303 NewOp(1101, padop, 1, PADOP);
3304 padop->op_type = type;
3305 padop->op_ppaddr = PL_ppaddr[type];
3306 padop->op_padix = pad_alloc(type, SVs_PADTMP);
7766f137 3307 SvREFCNT_dec(PL_curpad[padop->op_padix]);
350de78d 3308 PL_curpad[padop->op_padix] = sv;
7766f137 3309 SvPADTMP_on(sv);
350de78d
GS		 3310 padop->op_next = (OP*)padop;
3311 padop->op_flags = flags;
3312 if (PL_opargs[type] & OA_RETSCALAR)
3313 scalar((OP*)padop);
3314 if (PL_opargs[type] & OA_TARGET)
3315 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3316 return CHECKOP(type, padop);
3317}
3318
3319OP *
864dbfa3 3320Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3321{
350de78d 3322#ifdef USE_ITHREADS
743e66e6 3323 GvIN_PAD_on(gv);
350de78d
GS		 3324 return newPADOP(type, flags, SvREFCNT_inc(gv));
3325#else
7934575e 3326 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3327#endif
79072805
LW		 3328}
3329
3330OP *
864dbfa3 3331Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 3332{
3333 PVOP *pvop;
b7dc083c 3334 NewOp(1101, pvop, 1, PVOP);
79072805 3335 pvop->op_type = type;
22c35a8c 3336 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3337 pvop->op_pv = pv;
3338 pvop->op_next = (OP*)pvop;
3339 pvop->op_flags = flags;
22c35a8c 3340 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3341 scalar((OP*)pvop);
22c35a8c 3342 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3343 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3344 return CHECKOP(type, pvop);
79072805
LW		 3345}
3346
79072805 3347void
864dbfa3 3348Perl_package(pTHX_ OP *o)
79072805 3349{
93a17b20 3350 SV *sv;
79072805 3351
3280af22
NIS		 3352 save_hptr(&PL_curstash);
3353 save_item(PL_curstname);
11343788 3354 if (o) {
463ee0b2
LW		 3355 STRLEN len;
3356 char *name;
11343788 3357 sv = cSVOPo->op_sv;
463ee0b2 3358 name = SvPV(sv, len);
3280af22
NIS		 3359 PL_curstash = gv_stashpvn(name,len,TRUE);
3360 sv_setpvn(PL_curstname, name, len);
11343788 3361 op_free(o);
93a17b20
LW		 3362 }
3363 else {
9014280d 3364 deprecate("\"package\" with no arguments");
3280af22
NIS		 3365 sv_setpv(PL_curstname,"<none>");
3366 PL_curstash = Nullhv;
93a17b20 3367 }
7ad382f4 3368 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3369 PL_copline = NOLINE;
3370 PL_expect = XSTATE;
79072805
LW		 3371}
3372
85e6fe83 3373void
864dbfa3 3374Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
85e6fe83 3375{
a0d0e21e 3376 OP *pack;
a0d0e21e 3377 OP *imop;
b1cb66bf 3378 OP *veop;
18fc9488 3379 char *packname = Nullch;
c4e33207 3380 STRLEN packlen = 0;
18fc9488 3381 SV *packsv;
85e6fe83 3382
a0d0e21e 3383 if (id->op_type != OP_CONST)
cea2e8a9 3384 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3385
b1cb66bf 3386 veop = Nullop;
3387
0f79a09d 3388 if (version != Nullop) {
b1cb66bf 3389 SV *vesv = ((SVOP*)version)->op_sv;
3390
44dcb63b 3391 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 3392 arg = version;
3393 }
3394 else {
3395 OP *pack;
0f79a09d 3396 SV *meth;
b1cb66bf 3397
44dcb63b 3398 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3399 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3400
3401 /* Make copy of id so we don't free it twice */
3402 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3403
3404 /* Fake up a method call to VERSION */
0f79a09d
GS		 3405 meth = newSVpvn("VERSION",7);
3406 sv_upgrade(meth, SVt_PVIV);
155aba94 3407 (void)SvIOK_on(meth);
0f79a09d 3408 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 3409 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3410 append_elem(OP_LIST,
0f79a09d
GS		 3411 prepend_elem(OP_LIST, pack, list(version)),
3412 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3413 }
3414 }
aeea060c 3415
a0d0e21e 3416 /* Fake up an import/unimport */
4633a7c4
LW		 3417 if (arg && arg->op_type == OP_STUB)
3418 imop = arg; /* no import on explicit () */
44dcb63b 3419 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
b1cb66bf 3420 imop = Nullop; /* use 5.0; */
3421 }
4633a7c4 3422 else {
0f79a09d
GS		 3423 SV *meth;
3424
4633a7c4
LW		 3425 /* Make copy of id so we don't free it twice */
3426 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
0f79a09d
GS		 3427
3428 /* Fake up a method call to import/unimport */
3429 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
ad4c42df 3430 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 3431 (void)SvIOK_on(meth);
0f79a09d 3432 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 3433 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3434 append_elem(OP_LIST,
3435 prepend_elem(OP_LIST, pack, list(arg)),
3436 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3437 }
3438
d04f2e46
DM		 3439 if (ckWARN(WARN_MISC) &&
3440 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3441 SvPOK(packsv = ((SVOP*)id)->op_sv))
3442 {
18fc9488
DM		 3443 /* BEGIN will free the ops, so we need to make a copy */
3444 packlen = SvCUR(packsv);
3445 packname = savepvn(SvPVX(packsv), packlen);
3446 }
3447
a0d0e21e 3448 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3449 newATTRSUB(floor,
79cb57f6 3450 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3451 Nullop,
09bef843 3452 Nullop,
a0d0e21e 3453 append_elem(OP_LINESEQ,
b1cb66bf 3454 append_elem(OP_LINESEQ,
ec4ab249 3455 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
b1cb66bf 3456 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3457 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3458
18fc9488 3459 if (packname) {
bfc3ae4f
JH		 3460 /* The "did you use incorrect case?" warning used to be here.
3461 * The problem is that on case-insensitive filesystems one
3462 * might get false positives for "use" (and "require"):
3463 * "use Strict" or "require CARP" will work. This causes
3464 * portability problems for the script: in case-strict
3465 * filesystems the script will stop working.
3466 *
3467 * The "incorrect case" warning checked whether "use Foo"
3468 * imported "Foo" to your namespace, but that is wrong, too:
3469 * there is no requirement nor promise in the language that
3470 * a Foo.pm should or would contain anything in package "Foo".
3471 *
3472 * There is very little Configure-wise that can be done, either:
3473 * the case-sensitivity of the build filesystem of Perl does not
3474 * help in guessing the case-sensitivity of the runtime environment.
3475 */
18fc9488
DM		 3476 safefree(packname);
3477 }
3478
c305c6a0 3479 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3480 PL_copline = NOLINE;
3481 PL_expect = XSTATE;
85e6fe83
LW		 3482}
3483
7d3fb230 3484/*
ccfc67b7
JH		 3485=head1 Embedding Functions
3486
7d3fb230
BS		 3487=for apidoc load_module
3488
3489Loads the module whose name is pointed to by the string part of name.
3490Note that the actual module name, not its filename, should be given.
3491Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3492PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3493(or 0 for no flags). ver, if specified, provides version semantics
3494similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3495arguments can be used to specify arguments to the module's import()
3496method, similar to C<use Foo::Bar VERSION LIST>.
3497
3498=cut */
3499
e4783991
GS		 3500void
3501Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3502{
3503 va_list args;
3504 va_start(args, ver);
3505 vload_module(flags, name, ver, &args);
3506 va_end(args);
3507}
3508
3509#ifdef PERL_IMPLICIT_CONTEXT