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