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:
[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 4870 }
d34f9d2e 4871 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 4872 LOGOP *enter;
4873
11343788
MB		 4874 cUNOPo->op_first = 0;
4875 op_free(o);
79072805 4876
b7dc083c 4877 NewOp(1101, enter, 1, LOGOP);
79072805 4878 enter->op_type = OP_ENTERTRY;
22c35a8c 4879 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 4880 enter->op_private = 0;
4881
4882 /* establish postfix order */
4883 enter->op_next = (OP*)enter;
4884
11343788
MB		 4885 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4886 o->op_type = OP_LEAVETRY;
22c35a8c 4887 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 4888 enter->op_other = o;
4889 return o;
79072805 4890 }
c7cc6f1c 4891 else
473986ff 4892 scalar((OP*)kid);
79072805
LW		 4893 }
4894 else {
11343788 4895 op_free(o);
54b9620d 4896 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 4897 }
3280af22 4898 o->op_targ = (PADOFFSET)PL_hints;
11343788 4899 return o;
79072805
LW		 4900}
4901
4902OP *
d98f61e7
GS		 4903Perl_ck_exit(pTHX_ OP *o)
4904{
4905#ifdef VMS
4906 HV *table = GvHV(PL_hintgv);
4907 if (table) {
4908 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4909 if (svp && *svp && SvTRUE(*svp))
4910 o->op_private |= OPpEXIT_VMSISH;
4911 }
96e176bf 4912 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 4913#endif
4914 return ck_fun(o);
4915}
4916
4917OP *
cea2e8a9 4918Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 4919{
4920 OP *kid;
11343788
MB		 4921 if (o->op_flags & OPf_STACKED) {
4922 o = ck_fun(o);
4923 kid = cUNOPo->op_first->op_sibling;
8990e307 4924 if (kid->op_type == OP_RV2GV)
93c66552 4925 op_null(kid);
79072805 4926 }
463ee0b2 4927 else
11343788
MB		 4928 o = listkids(o);
4929 return o;
79072805
LW		 4930}
4931
4932OP *
cea2e8a9 4933Perl_ck_exists(pTHX_ OP *o)
5f05dabc 4934{
5196be3e
MB		 4935 o = ck_fun(o);
4936 if (o->op_flags & OPf_KIDS) {
4937 OP *kid = cUNOPo->op_first;
afebc493
GS		 4938 if (kid->op_type == OP_ENTERSUB) {
4939 (void) ref(kid, o->op_type);
4940 if (kid->op_type != OP_RV2CV && !PL_error_count)
4941 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 4942 OP_DESC(o));
afebc493
GS		 4943 o->op_private |= OPpEXISTS_SUB;
4944 }
4945 else if (kid->op_type == OP_AELEM)
01020589
GS		 4946 o->op_flags |= OPf_SPECIAL;
4947 else if (kid->op_type != OP_HELEM)
4948 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 4949 OP_DESC(o));
93c66552 4950 op_null(kid);
5f05dabc 4951 }
5196be3e 4952 return o;
5f05dabc 4953}
4954
22c35a8c 4955#if 0
5f05dabc 4956OP *
cea2e8a9 4957Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 4958{
4959 o = fold_constants(o);
4960 if (o->op_type == OP_CONST)
4961 o->op_type = OP_GV;
4962 return o;
4963}
22c35a8c 4964#endif
79072805
LW		 4965
4966OP *
cea2e8a9 4967Perl_ck_rvconst(pTHX_ register OP *o)
79072805 4968{
11343788 4969 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 4970
3280af22 4971 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 4972 if (kid->op_type == OP_CONST) {
44a8e56a 4973 char *name;
4974 int iscv;
4975 GV *gv;
779c5bc9 4976 SV *kidsv = kid->op_sv;
2d8e6c8d 4977 STRLEN n_a;
44a8e56a 4978
779c5bc9
GS		 4979 /* Is it a constant from cv_const_sv()? */
4980 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4981 SV *rsv = SvRV(kidsv);
4982 int svtype = SvTYPE(rsv);
4983 char *badtype = Nullch;
4984
4985 switch (o->op_type) {
4986 case OP_RV2SV:
4987 if (svtype > SVt_PVMG)
4988 badtype = "a SCALAR";
4989 break;
4990 case OP_RV2AV:
4991 if (svtype != SVt_PVAV)
4992 badtype = "an ARRAY";
4993 break;
4994 case OP_RV2HV:
4995 if (svtype != SVt_PVHV) {
4996 if (svtype == SVt_PVAV) { /* pseudohash? */
4997 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
4998 if (ksv && SvROK(*ksv)
4999 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5000 {
5001 break;
5002 }
5003 }
5004 badtype = "a HASH";
5005 }
5006 break;
5007 case OP_RV2CV:
5008 if (svtype != SVt_PVCV)
5009 badtype = "a CODE";
5010 break;
5011 }
5012 if (badtype)
cea2e8a9 5013 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5014 return o;
5015 }
2d8e6c8d 5016 name = SvPV(kidsv, n_a);
3280af22 5017 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 5018 char *badthing = Nullch;
5dc0d613 5019 switch (o->op_type) {
44a8e56a 5020 case OP_RV2SV:
5021 badthing = "a SCALAR";
5022 break;
5023 case OP_RV2AV:
5024 badthing = "an ARRAY";
5025 break;
5026 case OP_RV2HV:
5027 badthing = "a HASH";
5028 break;
5029 }
5030 if (badthing)
1c846c1f 5031 Perl_croak(aTHX_
44a8e56a 5032 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5033 name, badthing);
5034 }
93233ece
CS		 5035 /*
5036 * This is a little tricky. We only want to add the symbol if we
5037 * didn't add it in the lexer. Otherwise we get duplicate strict
5038 * warnings. But if we didn't add it in the lexer, we must at
5039 * least pretend like we wanted to add it even if it existed before,
5040 * or we get possible typo warnings. OPpCONST_ENTERED says
5041 * whether the lexer already added THIS instance of this symbol.
5042 */
5196be3e 5043 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5044 do {
44a8e56a 5045 gv = gv_fetchpv(name,
748a9306 5046 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5047 iscv
5048 ? SVt_PVCV
11343788 5049 : o->op_type == OP_RV2SV
a0d0e21e 5050 ? SVt_PV
11343788 5051 : o->op_type == OP_RV2AV
a0d0e21e 5052 ? SVt_PVAV
11343788 5053 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5054 ? SVt_PVHV
5055 : SVt_PVGV);
93233ece
CS		 5056 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5057 if (gv) {
5058 kid->op_type = OP_GV;
5059 SvREFCNT_dec(kid->op_sv);
350de78d 5060#ifdef USE_ITHREADS
638eceb6 5061 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5062 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
9755d405 5063 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 5064 GvIN_PAD_on(gv);
9755d405 5065 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
350de78d 5066#else
93233ece 5067 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5068#endif
23f1ca44 5069 kid->op_private = 0;
76cd736e 5070 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5071 }
79072805 5072 }
11343788 5073 return o;
79072805
LW		 5074}
5075
5076OP *
cea2e8a9 5077Perl_ck_ftst(pTHX_ OP *o)
79072805 5078{
11343788 5079 I32 type = o->op_type;
79072805 5080
d0dca557
JD		 5081 if (o->op_flags & OPf_REF) {
5082 /* nothing */
5083 }
5084 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5085 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5086
5087 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5088 STRLEN n_a;
a0d0e21e 5089 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5090 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5091 op_free(o);
d0dca557 5092 o = newop;
79072805
LW		 5093 }
5094 }
5095 else {
11343788 5096 op_free(o);
79072805 5097 if (type == OP_FTTTY)
5835a535 5098 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5099 else
d0dca557 5100 o = newUNOP(type, 0, newDEFSVOP());
79072805 5101 }
11343788 5102 return o;
79072805
LW		 5103}
5104
5105OP *
cea2e8a9 5106Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5107{
5108 register OP *kid;
5109 OP **tokid;
5110 OP *sibl;
5111 I32 numargs = 0;
11343788 5112 int type = o->op_type;
22c35a8c 5113 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5114
11343788 5115 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5116 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5117 oa &= ~OA_OPTIONAL;
5118 else
11343788 5119 return no_fh_allowed(o);
79072805
LW		 5120 }
5121
11343788 5122 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5123 STRLEN n_a;
11343788
MB		 5124 tokid = &cLISTOPo->op_first;
5125 kid = cLISTOPo->op_first;
8990e307 5126 if (kid->op_type == OP_PUSHMARK ||
155aba94 5127 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5128 {
79072805
LW		 5129 tokid = &kid->op_sibling;
5130 kid = kid->op_sibling;
5131 }
22c35a8c 5132 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5133 *tokid = kid = newDEFSVOP();
79072805
LW		 5134
5135 while (oa && kid) {
5136 numargs++;
5137 sibl = kid->op_sibling;
5138 switch (oa & 7) {
5139 case OA_SCALAR:
62c18ce2
GS		 5140 /* list seen where single (scalar) arg expected? */
5141 if (numargs == 1 && !(oa >> 4)
5142 && kid->op_type == OP_LIST && type != OP_SCALAR)
5143 {
5144 return too_many_arguments(o,PL_op_desc[type]);
5145 }
79072805
LW		 5146 scalar(kid);
5147 break;
5148 case OA_LIST:
5149 if (oa < 16) {
5150 kid = 0;
5151 continue;
5152 }
5153 else
5154 list(kid);
5155 break;
5156 case OA_AVREF:
936edb8b 5157 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5158 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5159 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5160 "Useless use of %s with no values",
936edb8b 5161 PL_op_desc[type]);
b2ffa427 5162
79072805 5163 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5164 (kid->op_private & OPpCONST_BARE))
5165 {
2d8e6c8d 5166 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5167 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5168 gv_fetchpv(name, TRUE, SVt_PVAV) ));
12bcd1a6
PM		 5169 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5170 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5171 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5172 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5173 op_free(kid);
5174 kid = newop;
5175 kid->op_sibling = sibl;
5176 *tokid = kid;
5177 }
8990e307 5178 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5179 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5180 mod(kid, type);
79072805
LW		 5181 break;
5182 case OA_HVREF:
5183 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5184 (kid->op_private & OPpCONST_BARE))
5185 {
2d8e6c8d 5186 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5187 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5188 gv_fetchpv(name, TRUE, SVt_PVHV) ));
12bcd1a6
PM		 5189 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5190 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5191 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5192 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5193 op_free(kid);
5194 kid = newop;
5195 kid->op_sibling = sibl;
5196 *tokid = kid;
5197 }
8990e307 5198 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5199 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5200 mod(kid, type);
79072805
LW		 5201 break;
5202 case OA_CVREF:
5203 {
a0d0e21e 5204 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5205 kid->op_sibling = 0;
5206 linklist(kid);
5207 newop->op_next = newop;
5208 kid = newop;
5209 kid->op_sibling = sibl;
5210 *tokid = kid;
5211 }
5212 break;
5213 case OA_FILEREF:
c340be78 5214 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5215 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5216 (kid->op_private & OPpCONST_BARE))
5217 {
79072805 5218 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5219 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5220 SVt_PVIO) );
afbdacea 5221 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5222 kid == cLISTOPo->op_last)
364daeac 5223 cLISTOPo->op_last = newop;
79072805
LW		 5224 op_free(kid);
5225 kid = newop;
5226 }
1ea32a52
GS		 5227 else if (kid->op_type == OP_READLINE) {
5228 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5229 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5230 }
79072805 5231 else {
35cd451c 5232 I32 flags = OPf_SPECIAL;
a6c40364 5233 I32 priv = 0;
2c8ac474
GS		 5234 PADOFFSET targ = 0;
5235
35cd451c 5236 /* is this op a FH constructor? */
853846ea 5237 if (is_handle_constructor(o,numargs)) {
2c8ac474 5238 char *name = Nullch;
9755d405 5239 STRLEN len = 0;
2c8ac474
GS		 5240
5241 flags = 0;
5242 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5243 * need to "prove" flag does not mean something
5244 * else already - NI-S 1999/05/07
2c8ac474
GS		 5245 */
5246 priv = OPpDEREF;
5247 if (kid->op_type == OP_PADSV) {
9755d405
JH		 5248 /*XXX DAPM 2002.08.25 tmp assert test */
5249 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5250 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5251
5252 name = PAD_COMPNAME_PV(kid->op_targ);
5253 /* SvCUR of a pad namesv can't be trusted
5254 * (see PL_generation), so calc its length
5255 * manually */
5256 if (name)
5257 len = strlen(name);
5258
2c8ac474
GS		 5259 }
5260 else if (kid->op_type == OP_RV2SV
5261 && kUNOP->op_first->op_type == OP_GV)
5262 {
5263 GV *gv = cGVOPx_gv(kUNOP->op_first);
5264 name = GvNAME(gv);
5265 len = GvNAMELEN(gv);
5266 }
afd1915d
GS		 5267 else if (kid->op_type == OP_AELEM
5268 || kid->op_type == OP_HELEM)
5269 {
5270 name = "__ANONIO__";
5271 len = 10;
5272 mod(kid,type);
5273 }
2c8ac474
GS		 5274 if (name) {
5275 SV *namesv;
5276 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
9755d405 5277 namesv = PAD_SVl(targ);
155aba94 5278 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5279 if (*name != '$')
5280 sv_setpvn(namesv, "$", 1);
5281 sv_catpvn(namesv, name, len);
5282 }
853846ea 5283 }
79072805 5284 kid->op_sibling = 0;
35cd451c 5285 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5286 kid->op_targ = targ;
5287 kid->op_private |= priv;
79072805
LW		 5288 }
5289 kid->op_sibling = sibl;
5290 *tokid = kid;
5291 }
5292 scalar(kid);
5293 break;
5294 case OA_SCALARREF:
a0d0e21e 5295 mod(scalar(kid), type);
79072805
LW		 5296 break;
5297 }
5298 oa >>= 4;
5299 tokid = &kid->op_sibling;
5300 kid = kid->op_sibling;
5301 }
11343788 5302 o->op_private |= numargs;
79072805 5303 if (kid)
53e06cf0 5304 return too_many_arguments(o,OP_DESC(o));
11343788 5305 listkids(o);
79072805 5306 }
22c35a8c 5307 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5308 op_free(o);
54b9620d 5309 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5310 }
5311
79072805
LW		 5312 if (oa) {
5313 while (oa & OA_OPTIONAL)
5314 oa >>= 4;
5315 if (oa && oa != OA_LIST)
53e06cf0 5316 return too_few_arguments(o,OP_DESC(o));
79072805 5317 }
11343788 5318 return o;
79072805
LW		 5319}
5320
5321OP *
cea2e8a9 5322Perl_ck_glob(pTHX_ OP *o)
79072805 5323{
fb73857a 5324 GV *gv;
5325
649da076 5326 o = ck_fun(o);
1f2bfc8a 5327 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5328 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5329
b9f751c0
GS		 5330 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5331 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5332 {
fb73857a 5333 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b9f751c0 5334 }
b1cb66bf 5335
52bb0670 5336#if !defined(PERL_EXTERNAL_GLOB)
72b16652
GS		 5337 /* XXX this can be tightened up and made more failsafe. */
5338 if (!gv) {
7d3fb230 5339 GV *glob_gv;
72b16652 5340 ENTER;
00ca71c1
NIS		 5341 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5342 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
72b16652 5343 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5344 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5345 GvCV(gv) = GvCV(glob_gv);
445266f0 5346 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5347 GvIMPORTED_CV_on(gv);
72b16652
GS		 5348 LEAVE;
5349 }
52bb0670 5350#endif /* PERL_EXTERNAL_GLOB */
72b16652 5351
b9f751c0 5352 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5353 append_elem(OP_GLOB, o,
80252599 5354 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5355 o->op_type = OP_LIST;
22c35a8c 5356 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5357 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5358 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
1f2bfc8a 5359 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5360 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5361 scalar(newUNOP(OP_RV2CV, 0,
5362 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5363 o = newUNOP(OP_NULL, 0, ck_subr(o));
5364 o->op_targ = OP_GLOB; /* hint at what it used to be */
5365 return o;
b1cb66bf 5366 }
5367 gv = newGVgen("main");
a0d0e21e 5368 gv_IOadd(gv);
11343788
MB		 5369 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5370 scalarkids(o);
649da076 5371 return o;
79072805
LW		 5372}
5373
5374OP *
cea2e8a9 5375Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 5376{
5377 LOGOP *gwop;
5378 OP *kid;
11343788 5379 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 5380
22c35a8c 5381 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5382 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5383
11343788 5384 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5385 OP* k;
11343788
MB		 5386 o = ck_sort(o);
5387 kid = cLISTOPo->op_first->op_sibling;
5388 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 5389 kid = k;
5390 }
5391 kid->op_next = (OP*)gwop;
11343788 5392 o->op_flags &= ~OPf_STACKED;
93a17b20 5393 }
11343788 5394 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5395 if (type == OP_MAPWHILE)
5396 list(kid);
5397 else
5398 scalar(kid);
11343788 5399 o = ck_fun(o);
3280af22 5400 if (PL_error_count)
11343788 5401 return o;
aeea060c 5402 kid = cLISTOPo->op_first->op_sibling;
79072805 5403 if (kid->op_type != OP_NULL)
cea2e8a9 5404 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5405 kid = kUNOP->op_first;
5406
a0d0e21e 5407 gwop->op_type = type;
22c35a8c 5408 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5409 gwop->op_first = listkids(o);
79072805
LW		 5410 gwop->op_flags |= OPf_KIDS;
5411 gwop->op_private = 1;
5412 gwop->op_other = LINKLIST(kid);
a0d0e21e 5413 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 5414 kid->op_next = (OP*)gwop;
5415
11343788 5416 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5417 if (!kid || !kid->op_sibling)
53e06cf0 5418 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5419 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5420 mod(kid, OP_GREPSTART);
5421
79072805
LW		 5422 return (OP*)gwop;
5423}
5424
5425OP *
cea2e8a9 5426Perl_ck_index(pTHX_ OP *o)
79072805 5427{
11343788
MB		 5428 if (o->op_flags & OPf_KIDS) {
5429 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5430 if (kid)
5431 kid = kid->op_sibling; /* get past "big" */
79072805 5432 if (kid && kid->op_type == OP_CONST)
2779dcf1 5433 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5434 }
11343788 5435 return ck_fun(o);
79072805
LW		 5436}
5437
5438OP *
cea2e8a9 5439Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5440{
5441 /* XXX length optimization goes here */
11343788 5442 return ck_fun(o);
79072805
LW		 5443}
5444
5445OP *
cea2e8a9 5446Perl_ck_lfun(pTHX_ OP *o)
79072805 5447{
5dc0d613
MB		 5448 OPCODE type = o->op_type;
5449 return modkids(ck_fun(o), type);
79072805
LW		 5450}
5451
5452OP *
cea2e8a9 5453Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5454{
12bcd1a6 5455 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5456 switch (cUNOPo->op_first->op_type) {
5457 case OP_RV2AV:
a8739d98
JH		 5458 /* This is needed for
5459 if (defined %stash::)
5460 to work. Do not break Tk.
5461 */
1c846c1f 5462 break; /* Globals via GV can be undef */
d0334bed
GS		 5463 case OP_PADAV:
5464 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5465 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5466 "defined(@array) is deprecated");
12bcd1a6 5467 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5468 "\t(Maybe you should just omit the defined()?)\n");
69794302 5469 break;
d0334bed 5470 case OP_RV2HV:
a8739d98
JH		 5471 /* This is needed for
5472 if (defined %stash::)
5473 to work. Do not break Tk.
5474 */
1c846c1f 5475 break; /* Globals via GV can be undef */
d0334bed 5476 case OP_PADHV:
12bcd1a6 5477 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5478 "defined(%%hash) is deprecated");
12bcd1a6 5479 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5480 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5481 break;
5482 default:
5483 /* no warning */
5484 break;
5485 }
69794302
MJD		 5486 }
5487 return ck_rfun(o);
5488}
5489
5490OP *
cea2e8a9 5491Perl_ck_rfun(pTHX_ OP *o)
8990e307 5492{
5dc0d613
MB		 5493 OPCODE type = o->op_type;
5494 return refkids(ck_fun(o), type);
8990e307
LW		 5495}
5496
5497OP *
cea2e8a9 5498Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5499{
5500 register OP *kid;
aeea060c 5501
11343788 5502 kid = cLISTOPo->op_first;
79072805 5503 if (!kid) {
11343788
MB		 5504 o = force_list(o);
5505 kid = cLISTOPo->op_first;
79072805
LW		 5506 }
5507 if (kid->op_type == OP_PUSHMARK)
5508 kid = kid->op_sibling;
11343788 5509 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 5510 kid = kid->op_sibling;
5511 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5512 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 5513 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 5514 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 5515 cLISTOPo->op_first->op_sibling = kid;
5516 cLISTOPo->op_last = kid;
79072805
LW		 5517 kid = kid->op_sibling;
5518 }
5519 }
b2ffa427 5520
79072805 5521 if (!kid)
54b9620d 5522 append_elem(o->op_type, o, newDEFSVOP());
79072805 5523
2de3dbcc 5524 return listkids(o);
bbce6d69 5525}
5526
5527OP *
b162f9ea
IZ		 5528Perl_ck_sassign(pTHX_ OP *o)
5529{
5530 OP *kid = cLISTOPo->op_first;
5531 /* has a disposable target? */
5532 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 5533 && !(kid->op_flags & OPf_STACKED)
5534 /* Cannot steal the second time! */
5535 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 5536 {
5537 OP *kkid = kid->op_sibling;
5538
5539 /* Can just relocate the target. */
2c2d71f5
JH		 5540 if (kkid && kkid->op_type == OP_PADSV
5541 && !(kkid->op_private & OPpLVAL_INTRO))
5542 {
b162f9ea 5543 kid->op_targ = kkid->op_targ;
743e66e6 5544 kkid->op_targ = 0;
b162f9ea
IZ		 5545 /* Now we do not need PADSV and SASSIGN. */
5546 kid->op_sibling = o->op_sibling; /* NULL */
5547 cLISTOPo->op_first = NULL;
5548 op_free(o);
5549 op_free(kkid);
5550 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5551 return kid;
5552 }
5553 }
5554 return o;
5555}
5556
5557OP *
cea2e8a9 5558Perl_ck_match(pTHX_ OP *o)
79072805 5559{
5dc0d613 5560 o->op_private |= OPpRUNTIME;
11343788 5561 return o;
79072805
LW		 5562}
5563
5564OP *
f5d5a27c
CS		 5565Perl_ck_method(pTHX_ OP *o)
5566{
5567 OP *kid = cUNOPo->op_first;
5568 if (kid->op_type == OP_CONST) {
5569 SV* sv = kSVOP->op_sv;
5570 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5571 OP *cmop;
1c846c1f
NIS		 5572 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5573 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5574 }
5575 else {
5576 kSVOP->op_sv = Nullsv;
5577 }
f5d5a27c 5578 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 5579 op_free(o);
5580 return cmop;
5581 }
5582 }
5583 return o;
5584}
5585
5586OP *
cea2e8a9 5587Perl_ck_null(pTHX_ OP *o)
79072805 5588{
11343788 5589 return o;
79072805
LW		 5590}
5591
5592OP *
16fe6d59
GS		 5593Perl_ck_open(pTHX_ OP *o)
5594{
5595 HV *table = GvHV(PL_hintgv);
5596 if (table) {
5597 SV **svp;
5598 I32 mode;
5599 svp = hv_fetch(table, "open_IN", 7, FALSE);
5600 if (svp && *svp) {
5601 mode = mode_from_discipline(*svp);
5602 if (mode & O_BINARY)
5603 o->op_private |= OPpOPEN_IN_RAW;
5604 else if (mode & O_TEXT)
5605 o->op_private |= OPpOPEN_IN_CRLF;
5606 }
5607
5608 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5609 if (svp && *svp) {
5610 mode = mode_from_discipline(*svp);
5611 if (mode & O_BINARY)
5612 o->op_private |= OPpOPEN_OUT_RAW;
5613 else if (mode & O_TEXT)
5614 o->op_private |= OPpOPEN_OUT_CRLF;
5615 }
5616 }
5617 if (o->op_type == OP_BACKTICK)
5618 return o;
5619 return ck_fun(o);
5620}
5621
5622OP *
cea2e8a9 5623Perl_ck_repeat(pTHX_ OP *o)
79072805 5624{
11343788
MB		 5625 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5626 o->op_private |= OPpREPEAT_DOLIST;
5627 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 5628 }
5629 else
11343788
MB		 5630 scalar(o);
5631 return o;
79072805
LW		 5632}
5633
5634OP *
cea2e8a9 5635Perl_ck_require(pTHX_ OP *o)
8990e307 5636{
ec4ab249
GA		 5637 GV* gv;
5638
11343788
MB		 5639 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5640 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 5641
5642 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 5643 char *s;
a0d0e21e
LW		 5644 for (s = SvPVX(kid->op_sv); *s; s++) {
5645 if (*s == ':' && s[1] == ':') {
5646 *s = '/';
1aef975c 5647 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 5648 --SvCUR(kid->op_sv);
5649 }
8990e307 5650 }
ce3b816e
GS		 5651 if (SvREADONLY(kid->op_sv)) {
5652 SvREADONLY_off(kid->op_sv);
5653 sv_catpvn(kid->op_sv, ".pm", 3);
5654 SvREADONLY_on(kid->op_sv);
5655 }
5656 else
5657 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 5658 }
5659 }
ec4ab249
GA		 5660
5661 /* handle override, if any */
5662 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
b9f751c0 5663 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
ec4ab249
GA		 5664 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5665
b9f751c0 5666 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
ec4ab249
GA		 5667 OP *kid = cUNOPo->op_first;
5668 cUNOPo->op_first = 0;
5669 op_free(o);
5670 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5671 append_elem(OP_LIST, kid,
5672 scalar(newUNOP(OP_RV2CV, 0,
5673 newGVOP(OP_GV, 0,
5674 gv))))));
5675 }
5676
11343788 5677 return ck_fun(o);
8990e307
LW		 5678}
5679
78f9721b
SM		 5680OP *
5681Perl_ck_return(pTHX_ OP *o)
5682{
5683 OP *kid;
5684 if (CvLVALUE(PL_compcv)) {
5685 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5686 mod(kid, OP_LEAVESUBLV);
5687 }
5688 return o;
5689}
5690
22c35a8c 5691#if 0
8990e307 5692OP *
cea2e8a9 5693Perl_ck_retarget(pTHX_ OP *o)
79072805 5694{
cea2e8a9 5695 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 5696 /* STUB */
11343788 5697 return o;
79072805 5698}
22c35a8c 5699#endif
79072805
LW		 5700
5701OP *
cea2e8a9 5702Perl_ck_select(pTHX_ OP *o)
79072805 5703{
c07a80fd 5704 OP* kid;
11343788
MB		 5705 if (o->op_flags & OPf_KIDS) {
5706 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 5707 if (kid && kid->op_sibling) {
11343788 5708 o->op_type = OP_SSELECT;
22c35a8c 5709 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 5710 o = ck_fun(o);
5711 return fold_constants(o);
79072805
LW		 5712 }
5713 }
11343788
MB		 5714 o = ck_fun(o);
5715 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 5716 if (kid && kid->op_type == OP_RV2GV)
5717 kid->op_private &= ~HINT_STRICT_REFS;
11343788 5718 return o;
79072805
LW		 5719}
5720
5721OP *
cea2e8a9 5722Perl_ck_shift(pTHX_ OP *o)
79072805 5723{
11343788 5724 I32 type = o->op_type;
79072805 5725
11343788 5726 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 5727 OP *argop;
b2ffa427 5728
11343788 5729 op_free(o);
4d1ff10f 5730#ifdef USE_5005THREADS
533c011a 5731 if (!CvUNIQUE(PL_compcv)) {
6d4ff0d2 5732 argop = newOP(OP_PADAV, OPf_REF);
9755d405 5733 argop->op_targ = 0; /* PAD_SV(0) is @_ */
6d4ff0d2
MB		 5734 }
5735 else {
5736 argop = newUNOP(OP_RV2AV, 0,
5737 scalar(newGVOP(OP_GV, 0,
5738 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5739 }
5740#else
5741 argop = newUNOP(OP_RV2AV, 0,
5835a535 5742 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
4d1ff10f 5743#endif /* USE_5005THREADS */
6d4ff0d2 5744 return newUNOP(type, 0, scalar(argop));
79072805 5745 }
11343788 5746 return scalar(modkids(ck_fun(o), type));
79072805
LW		 5747}
5748
5749OP *
cea2e8a9 5750Perl_ck_sort(pTHX_ OP *o)
79072805 5751{
8e3f9bdf 5752 OP *firstkid;
bbce6d69 5753
9ea6e965 5754 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 5755 simplify_sort(o);
8e3f9bdf
GS		 5756 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5757 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 5758 OP *k = NULL;
8e3f9bdf 5759 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 5760
463ee0b2 5761 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 5762 linklist(kid);
463ee0b2
LW		 5763 if (kid->op_type == OP_SCOPE) {
5764 k = kid->op_next;
5765 kid->op_next = 0;
79072805 5766 }
463ee0b2 5767 else if (kid->op_type == OP_LEAVE) {
11343788 5768 if (o->op_type == OP_SORT) {
93c66552 5769 op_null(kid); /* wipe out leave */
748a9306 5770 kid->op_next = kid;
463ee0b2 5771
748a9306
LW		 5772 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5773 if (k->op_next == kid)
5774 k->op_next = 0;
71a29c3c
GS		 5775 /* don't descend into loops */
5776 else if (k->op_type == OP_ENTERLOOP
5777 || k->op_type == OP_ENTERITER)
5778 {
5779 k = cLOOPx(k)->op_lastop;
5780 }
748a9306 5781 }
463ee0b2 5782 }
748a9306
LW		 5783 else
5784 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 5785 k = kLISTOP->op_first;
463ee0b2 5786 }
a2efc822 5787 CALL_PEEP(k);
a0d0e21e 5788
8e3f9bdf
GS		 5789 kid = firstkid;
5790 if (o->op_type == OP_SORT) {
5791 /* provide scalar context for comparison function/block */
5792 kid = scalar(kid);
a0d0e21e 5793 kid->op_next = kid;
8e3f9bdf 5794 }
a0d0e21e
LW		 5795 else
5796 kid->op_next = k;
11343788 5797 o->op_flags |= OPf_SPECIAL;
79072805 5798 }
c6e96bcb 5799 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 5800 op_null(firstkid);
8e3f9bdf
GS		 5801
5802 firstkid = firstkid->op_sibling;
79072805 5803 }
bbce6d69 5804
8e3f9bdf
GS		 5805 /* provide list context for arguments */
5806 if (o->op_type == OP_SORT)
5807 list(firstkid);
5808
11343788 5809 return o;
79072805 5810}
bda4119b
GS		 5811
5812STATIC void
cea2e8a9 5813S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 5814{
5815 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5816 OP *k;
5817 int reversed;
350de78d 5818 GV *gv;
9c007264
JH		 5819 if (!(o->op_flags & OPf_STACKED))
5820 return;
1c846c1f
NIS		 5821 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5822 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 5823 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 5824 if (kid->op_type != OP_SCOPE)
5825 return;
5826 kid = kLISTOP->op_last; /* get past scope */
5827 switch(kid->op_type) {
5828 case OP_NCMP:
5829 case OP_I_NCMP:
5830 case OP_SCMP:
5831 break;
5832 default:
5833 return;
5834 }
5835 k = kid; /* remember this node*/
5836 if (kBINOP->op_first->op_type != OP_RV2SV)
5837 return;
5838 kid = kBINOP->op_first; /* get past cmp */
5839 if (kUNOP->op_first->op_type != OP_GV)
5840 return;
5841 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5842 gv = kGVOP_gv;
350de78d 5843 if (GvSTASH(gv) != PL_curstash)
9c007264 5844 return;
350de78d 5845 if (strEQ(GvNAME(gv), "a"))
9c007264 5846 reversed = 0;
0f79a09d 5847 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 5848 reversed = 1;
5849 else
5850 return;
5851 kid = k; /* back to cmp */
5852 if (kBINOP->op_last->op_type != OP_RV2SV)
5853 return;
5854 kid = kBINOP->op_last; /* down to 2nd arg */
5855 if (kUNOP->op_first->op_type != OP_GV)
5856 return;
5857 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5858 gv = kGVOP_gv;
350de78d 5859 if (GvSTASH(gv) != PL_curstash
9c007264 5860 || ( reversed
350de78d
GS		 5861 ? strNE(GvNAME(gv), "a")
5862 : strNE(GvNAME(gv), "b")))
9c007264
JH		 5863 return;
5864 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5865 if (reversed)
5866 o->op_private |= OPpSORT_REVERSE;
5867 if (k->op_type == OP_NCMP)
5868 o->op_private |= OPpSORT_NUMERIC;
5869 if (k->op_type == OP_I_NCMP)
5870 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 5871 kid = cLISTOPo->op_first->op_sibling;
5872 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5873 op_free(kid); /* then delete it */
9c007264 5874}
79072805
LW		 5875
5876OP *
cea2e8a9 5877Perl_ck_split(pTHX_ OP *o)
79072805
LW		 5878{
5879 register OP *kid;
aeea060c 5880
11343788
MB		 5881 if (o->op_flags & OPf_STACKED)
5882 return no_fh_allowed(o);
79072805 5883
11343788 5884 kid = cLISTOPo->op_first;
8990e307 5885 if (kid->op_type != OP_NULL)
cea2e8a9 5886 Perl_croak(aTHX_ "panic: ck_split");
8990e307 5887 kid = kid->op_sibling;
11343788
MB		 5888 op_free(cLISTOPo->op_first);
5889 cLISTOPo->op_first = kid;
85e6fe83 5890 if (!kid) {
79cb57f6 5891 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 5892 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 5893 }
79072805 5894
de4bf5b3 5895 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 5896 OP *sibl = kid->op_sibling;
463ee0b2 5897 kid->op_sibling = 0;
79072805 5898 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 5899 if (cLISTOPo->op_first == cLISTOPo->op_last)
5900 cLISTOPo->op_last = kid;
5901 cLISTOPo->op_first = kid;
79072805
LW		 5902 kid->op_sibling = sibl;
5903 }
5904
5905 kid->op_type = OP_PUSHRE;
22c35a8c 5906 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 5907 scalar(kid);
f34840d8
MJD		 5908 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5909 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5910 "Use of /g modifier is meaningless in split");
5911 }
79072805
LW		 5912
5913 if (!kid->op_sibling)
54b9620d 5914 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 5915
5916 kid = kid->op_sibling;
5917 scalar(kid);
5918
5919 if (!kid->op_sibling)
11343788 5920 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 5921
5922 kid = kid->op_sibling;
5923 scalar(kid);
5924
5925 if (kid->op_sibling)
53e06cf0 5926 return too_many_arguments(o,OP_DESC(o));
79072805 5927
11343788 5928 return o;
79072805
LW		 5929}
5930
5931OP *
1c846c1f 5932Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 5933{
5934 if (ckWARN(WARN_SYNTAX)) {
5935 OP *kid = cLISTOPo->op_first->op_sibling;
5936 if (kid && kid->op_type == OP_MATCH) {
5937 char *pmstr = "STRING";
aaa362c4
RS		 5938 if (PM_GETRE(kPMOP))
5939 pmstr = PM_GETRE(kPMOP)->precomp;
9014280d 5940 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 5941 "/%s/ should probably be written as \"%s\"",
5942 pmstr, pmstr);
5943 }
5944 }
5945 return ck_fun(o);
5946}
5947
5948OP *
cea2e8a9 5949Perl_ck_subr(pTHX_ OP *o)
79072805 5950{
11343788
MB		 5951 OP *prev = ((cUNOPo->op_first->op_sibling)
5952 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5953 OP *o2 = prev->op_sibling;
4633a7c4
LW		 5954 OP *cvop;
5955 char *proto = 0;
5956 CV *cv = 0;
46fc3d4c 5957 GV *namegv = 0;
4633a7c4
LW		 5958 int optional = 0;
5959 I32 arg = 0;
5b794e05 5960 I32 contextclass = 0;
90b7f708 5961 char *e = 0;
2d8e6c8d 5962 STRLEN n_a;
4633a7c4 5963
d3011074 5964 o->op_private |= OPpENTERSUB_HASTARG;
11343788 5965 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 5966 if (cvop->op_type == OP_RV2CV) {
5967 SVOP* tmpop;
11343788 5968 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 5969 op_null(cvop); /* disable rv2cv */
4633a7c4 5970 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 5971 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 5972 GV *gv = cGVOPx_gv(tmpop);
350de78d 5973 cv = GvCVu(gv);
76cd736e
GS		 5974 if (!cv)
5975 tmpop->op_private |= OPpEARLY_CV;
5976 else if (SvPOK(cv)) {
350de78d 5977 namegv = CvANON(cv) ? gv : CvGV(cv);
2d8e6c8d 5978 proto = SvPV((SV*)cv, n_a);
46fc3d4c 5979 }
4633a7c4
LW		 5980 }
5981 }
f5d5a27c 5982 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 5983 if (o2->op_type == OP_CONST)
5984 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 5985 else if (o2->op_type == OP_LIST) {
5986 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5987 if (o && o->op_type == OP_CONST)
5988 o->op_private &= ~OPpCONST_STRICT;
5989 }
7a52d87a 5990 }
3280af22
NIS		 5991 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5992 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 5993 o->op_private |= OPpENTERSUB_DB;
5994 while (o2 != cvop) {
4633a7c4
LW		 5995 if (proto) {
5996 switch (*proto) {
5997 case '\0':
5dc0d613 5998 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 5999 case ';':
6000 optional = 1;
6001 proto++;
6002 continue;
6003 case '$':
6004 proto++;
6005 arg++;
11343788 6006 scalar(o2);
4633a7c4
LW		 6007 break;
6008 case '%':
6009 case '@':
11343788 6010 list(o2);
4633a7c4
LW		 6011 arg++;
6012 break;
6013 case '&':
6014 proto++;
6015 arg++;
11343788 6016 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6017 bad_type(arg,
6018 arg == 1 ? "block or sub {}" : "sub {}",
6019 gv_ename(namegv), o2);
4633a7c4
LW		 6020 break;
6021 case '*':
2ba6ecf4 6022 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6023 proto++;
6024 arg++;
11343788 6025 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6026 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6027 else if (o2->op_type == OP_CONST)
6028 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6029 else if (o2->op_type == OP_ENTERSUB) {
6030 /* accidental subroutine, revert to bareword */
6031 OP *gvop = ((UNOP*)o2)->op_first;
6032 if (gvop && gvop->op_type == OP_NULL) {
6033 gvop = ((UNOP*)gvop)->op_first;
6034 if (gvop) {
6035 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6036 ;
6037 if (gvop &&
6038 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6039 (gvop = ((UNOP*)gvop)->op_first) &&
6040 gvop->op_type == OP_GV)
6041 {
638eceb6 6042 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6043 OP *sibling = o2->op_sibling;
2692f720 6044 SV *n = newSVpvn("",0);
9675f7ac 6045 op_free(o2);
2692f720
GS		 6046 gv_fullname3(n, gv, "");
6047 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6048 sv_chop(n, SvPVX(n)+6);
6049 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6050 prev->op_sibling = o2;
6051 o2->op_sibling = sibling;
6052 }
6053 }
6054 }
6055 }
2ba6ecf4
GS		 6056 scalar(o2);
6057 break;
5b794e05
JH		 6058 case '[': case ']':
6059 goto oops;
6060 break;
4633a7c4
LW		 6061 case '\\':
6062 proto++;
6063 arg++;
5b794e05 6064 again:
4633a7c4 6065 switch (*proto++) {
5b794e05
JH		 6066 case '[':
6067 if (contextclass++ == 0) {
841d93c8 6068 e = strchr(proto, ']');
5b794e05
JH		 6069 if (!e || e == proto)
6070 goto oops;
6071 }
6072 else
6073 goto oops;
6074 goto again;
6075 break;
6076 case ']':
466bafcd
RGS		 6077 if (contextclass) {
6078 char *p = proto;
6079 char s = *p;
6080 contextclass = 0;
6081 *p = '\0';
6082 while (*--p != '[');
1eb1540c 6083 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6084 gv_ename(namegv), o2);
6085 *proto = s;
6086 } else
5b794e05
JH		 6087 goto oops;
6088 break;
4633a7c4 6089 case '*':
5b794e05
JH		 6090 if (o2->op_type == OP_RV2GV)
6091 goto wrapref;
6092 if (!contextclass)
6093 bad_type(arg, "symbol", gv_ename(namegv), o2);
6094 break;
4633a7c4 6095 case '&':
5b794e05
JH		 6096 if (o2->op_type == OP_ENTERSUB)
6097 goto wrapref;
6098 if (!contextclass)
6099 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6100 break;
4633a7c4 6101 case '$':
5b794e05
JH		 6102 if (o2->op_type == OP_RV2SV ||
6103 o2->op_type == OP_PADSV ||
6104 o2->op_type == OP_HELEM ||
6105 o2->op_type == OP_AELEM ||
6106 o2->op_type == OP_THREADSV)
6107 goto wrapref;
6108 if (!contextclass)
5dc0d613 6109 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6110 break;
4633a7c4 6111 case '@':
5b794e05
JH		 6112 if (o2->op_type == OP_RV2AV ||
6113 o2->op_type == OP_PADAV)
6114 goto wrapref;
6115 if (!contextclass)
5dc0d613 6116 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6117 break;
4633a7c4 6118 case '%':
5b794e05
JH		 6119 if (o2->op_type == OP_RV2HV ||
6120 o2->op_type == OP_PADHV)
6121 goto wrapref;
6122 if (!contextclass)
6123 bad_type(arg, "hash", gv_ename(namegv), o2);
6124 break;
6125 wrapref:
4633a7c4 6126 {
11343788 6127 OP* kid = o2;
6fa846a0 6128 OP* sib = kid->op_sibling;
4633a7c4 6129 kid->op_sibling = 0;
6fa846a0
GS		 6130 o2 = newUNOP(OP_REFGEN, 0, kid);
6131 o2->op_sibling = sib;
e858de61 6132 prev->op_sibling = o2;
4633a7c4 6133 }
841d93c8 6134 if (contextclass && e) {
5b794e05
JH		 6135 proto = e + 1;
6136 contextclass = 0;
6137 }
4633a7c4
LW		 6138 break;
6139 default: goto oops;
6140 }
5b794e05
JH		 6141 if (contextclass)
6142 goto again;
4633a7c4 6143 break;
b1cb66bf 6144 case ' ':
6145 proto++;
6146 continue;
4633a7c4
LW		 6147 default:
6148 oops:
cea2e8a9 6149 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
5b794e05 6150 gv_ename(namegv), SvPV((SV*)cv, n_a));
4633a7c4
LW		 6151 }
6152 }
6153 else
11343788
MB		 6154 list(o2);
6155 mod(o2, OP_ENTERSUB);
6156 prev = o2;
6157 o2 = o2->op_sibling;
4633a7c4 6158 }
fb73857a 6159 if (proto && !optional &&
6160 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6161 return too_few_arguments(o, gv_ename(namegv));
11343788 6162 return o;
79072805
LW		 6163}
6164
6165OP *
cea2e8a9 6166Perl_ck_svconst(pTHX_ OP *o)
8990e307 6167{
11343788
MB		 6168 SvREADONLY_on(cSVOPo->op_sv);
6169 return o;
8990e307
LW		 6170}
6171
6172OP *
cea2e8a9 6173Perl_ck_trunc(pTHX_ OP *o)
79072805 6174{
11343788
MB		 6175 if (o->op_flags & OPf_KIDS) {
6176 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6177
a0d0e21e
LW		 6178 if (kid->op_type == OP_NULL)
6179 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6180 if (kid && kid->op_type == OP_CONST &&
6181 (kid->op_private & OPpCONST_BARE))
6182 {
11343788 6183 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6184 kid->op_private &= ~OPpCONST_STRICT;
6185 }
79072805 6186 }
11343788 6187 return ck_fun(o);
79072805
LW		 6188}
6189
35fba0d9
RG		 6190OP *
6191Perl_ck_substr(pTHX_ OP *o)
6192{
6193 o = ck_fun(o);
6194 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6195 OP *kid = cLISTOPo->op_first;
6196
6197 if (kid->op_type == OP_NULL)
6198 kid = kid->op_sibling;
6199 if (kid)
6200 kid->op_flags |= OPf_MOD;
6201
6202 }
6203 return o;
6204}
6205
463ee0b2
LW		 6206/* A peephole optimizer. We visit the ops in the order they're to execute. */
6207
79072805 6208void
864dbfa3 6209Perl_peep(pTHX_ register OP *o)
79072805
LW		 6210{
6211 register OP* oldop = 0;
2d8e6c8d
GS		 6212 STRLEN n_a;
6213
a0d0e21e 6214 if (!o || o->op_seq)
79072805 6215 return;
a0d0e21e 6216 ENTER;
462e5cf6 6217 SAVEOP();
7766f137 6218 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6219 for (; o; o = o->op_next) {
6220 if (o->op_seq)
6221 break;
338501c1
JH		 6222 /* The special value -1 is used by the B::C compiler backend to indicate
6223 * that an op is statically defined and should not be freed */
6224 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6225 PL_op_seqmax = 1;
533c011a 6226 PL_op = o;
a0d0e21e 6227 switch (o->op_type) {
acb36ea4 6228 case OP_SETSTATE:
a0d0e21e
LW		 6229 case OP_NEXTSTATE:
6230 case OP_DBSTATE:
3280af22
NIS		 6231 PL_curcop = ((COP*)o); /* for warnings */
6232 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6233 break;
6234
a0d0e21e 6235 case OP_CONST:
7a52d87a
GS		 6236 if (cSVOPo->op_private & OPpCONST_STRICT)
6237 no_bareword_allowed(o);
7766f137 6238#ifdef USE_ITHREADS
a868f49f 6239 case OP_METHOD_NAMED:
7766f137
GS		 6240 /* Relocate sv to the pad for thread safety.
6241 * Despite being a "constant", the SV is written to,
6242 * for reference counts, sv_upgrade() etc. */
6243 if (cSVOP->op_sv) {
6244 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
a868f49f 6245 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6246 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6247 * some pad, so make a copy. */
9755d405
JH		 6248 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6249 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6250 SvREFCNT_dec(cSVOPo->op_sv);
6251 }
6252 else {
9755d405 6253 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6254 SvPADTMP_on(cSVOPo->op_sv);
9755d405 6255 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6256 /* XXX I don't know how this isn't readonly already. */
9755d405 6257 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6258 }
7766f137
GS		 6259 cSVOPo->op_sv = Nullsv;
6260 o->op_targ = ix;
6261 }
6262#endif
07447971
GS		 6263 o->op_seq = PL_op_seqmax++;
6264 break;
6265
ed7ab888 6266 case OP_CONCAT:
b162f9ea
IZ		 6267 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6268 if (o->op_next->op_private & OPpTARGET_MY) {
69b47968 6269 if (o->op_flags & OPf_STACKED) /* chained concats */
b162f9ea 6270 goto ignore_optimization;
cd06dffe 6271 else {
07447971 6272 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
b162f9ea 6273 o->op_targ = o->op_next->op_targ;
743e66e6 6274 o->op_next->op_targ = 0;
2c2d71f5 6275 o->op_private |= OPpTARGET_MY;
b162f9ea
IZ		 6276 }
6277 }
93c66552 6278 op_null(o->op_next);
b162f9ea
IZ		 6279 }
6280 ignore_optimization:
3280af22 6281 o->op_seq = PL_op_seqmax++;
a0d0e21e 6282 break;
8990e307 6283 case OP_STUB:
54310121 6284 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 6285 o->op_seq = PL_op_seqmax++;
54310121 6286 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6287 }
748a9306 6288 goto nothin;
79072805 6289 case OP_NULL:
acb36ea4
GS		 6290 if (o->op_targ == OP_NEXTSTATE
6291 || o->op_targ == OP_DBSTATE
6292 || o->op_targ == OP_SETSTATE)
6293 {
3280af22 6294 PL_curcop = ((COP*)o);
acb36ea4 6295 }
dad75012
AMS		 6296 /* XXX: We avoid setting op_seq here to prevent later calls
6297 to peep() from mistakenly concluding that optimisation
6298 has already occurred. This doesn't fix the real problem,
6299 though (See 20010220.007). AMS 20010719 */
6300 if (oldop && o->op_next) {
6301 oldop->op_next = o->op_next;
6302 continue;
6303 }
6304 break;
79072805 6305 case OP_SCALAR:
93a17b20 6306 case OP_LINESEQ:
463ee0b2 6307 case OP_SCOPE:
748a9306 6308 nothin:
a0d0e21e
LW		 6309 if (oldop && o->op_next) {
6310 oldop->op_next = o->op_next;
79072805
LW		 6311 continue;
6312 }
3280af22 6313 o->op_seq = PL_op_seqmax++;
79072805
LW		 6314 break;
6315
6316 case OP_GV:
a0d0e21e 6317 if (o->op_next->op_type == OP_RV2SV) {
64aac5a9 6318 if (!(o->op_next->op_private & OPpDEREF)) {
93c66552 6319 op_null(o->op_next);
64aac5a9
GS		 6320 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6321 | OPpOUR_INTRO);
a0d0e21e
LW		 6322 o->op_next = o->op_next->op_next;
6323 o->op_type = OP_GVSV;
22c35a8c 6324 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307
LW		 6325 }
6326 }
a0d0e21e
LW		 6327 else if (o->op_next->op_type == OP_RV2AV) {
6328 OP* pop = o->op_next->op_next;
6329 IV i;
f9dc862f 6330 if (pop && pop->op_type == OP_CONST &&
533c011a 6331 (PL_op = pop->op_next) &&
8990e307 6332 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6333 !(pop->op_next->op_private &
78f9721b 6334 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6335 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6336 <= 255 &&
8990e307
LW		 6337 i >= 0)
6338 {
350de78d 6339 GV *gv;
93c66552
DM		 6340 op_null(o->op_next);
6341 op_null(pop->op_next);
6342 op_null(pop);
a0d0e21e
LW		 6343 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6344 o->op_next = pop->op_next->op_next;
6345 o->op_type = OP_AELEMFAST;
22c35a8c 6346 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6347 o->op_private = (U8)i;
638eceb6 6348 gv = cGVOPo_gv;
350de78d 6349 GvAVn(gv);
8990e307 6350 }
79072805 6351 }
e476b1b5 6352 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 6353 GV *gv = cGVOPo_gv;
76cd736e
GS		 6354 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6355 /* XXX could check prototype here instead of just carping */
6356 SV *sv = sv_newmortal();
6357 gv_efullname3(sv, gv, Nullch);
9014280d 6358 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
76cd736e
GS		 6359 "%s() called too early to check prototype",
6360 SvPV_nolen(sv));
6361 }
6362 }
89de2904
AMS		 6363 else if (o->op_next->op_type == OP_READLINE
6364 && o->op_next->op_next->op_type == OP_CONCAT
6365 && (o->op_next->op_next->op_flags & OPf_STACKED))
6366 {
d2c45030
AMS		 6367 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6368 o->op_type = OP_RCATLINE;
6369 o->op_flags |= OPf_STACKED;
6370 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6371 op_null(o->op_next->op_next);
d2c45030 6372 op_null(o->op_next);
89de2904 6373 }
76cd736e 6374
3280af22 6375 o->op_seq = PL_op_seqmax++;
79072805
LW		 6376 break;
6377
a0d0e21e 6378 case OP_MAPWHILE:
79072805
LW		 6379 case OP_GREPWHILE:
6380 case OP_AND:
6381 case OP_OR:
2c2d71f5
JH		 6382 case OP_ANDASSIGN:
6383 case OP_ORASSIGN:
1a67a97c
SM		 6384 case OP_COND_EXPR:
6385 case OP_RANGE:
3280af22 6386 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 6387 while (cLOGOP->op_other->op_type == OP_NULL)
6388 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 6389 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 6390 break;
6391
79072805 6392 case OP_ENTERLOOP:
9c2ca71a 6393 case OP_ENTERITER:
3280af22 6394 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 6395 while (cLOOP->op_redoop->op_type == OP_NULL)
6396 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6397 peep(cLOOP->op_redoop);
58cccf98
SM		 6398 while (cLOOP->op_nextop->op_type == OP_NULL)
6399 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6400 peep(cLOOP->op_nextop);
58cccf98
SM		 6401 while (cLOOP->op_lastop->op_type == OP_NULL)
6402 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6403 peep(cLOOP->op_lastop);
6404 break;
6405
8782bef2 6406 case OP_QR:
79072805
LW		 6407 case OP_MATCH:
6408 case OP_SUBST:
3280af22 6409 o->op_seq = PL_op_seqmax++;
9041c2e3 6410 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6411 cPMOP->op_pmreplstart->op_type == OP_NULL)
6412 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6413 peep(cPMOP->op_pmreplstart);
79072805
LW		 6414 break;
6415
a0d0e21e 6416 case OP_EXEC:
3280af22 6417 o->op_seq = PL_op_seqmax++;
1c846c1f 6418 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 6419 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 6420 if (o->op_next->op_sibling &&
20408e3c
GS		 6421 o->op_next->op_sibling->op_type != OP_EXIT &&
6422 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6423 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 6424 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 6425
57843af0 6426 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 6427 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 6428 "Statement unlikely to be reached");
9014280d 6429 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 6430 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 6431 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 6432 }
6433 }
6434 break;
b2ffa427 6435
c750a3ec
MB		 6436 case OP_HELEM: {
6437 UNOP *rop;
6438 SV *lexname;
6439 GV **fields;
9615e741 6440 SV **svp, **indsvp, *sv;
c750a3ec 6441 I32 ind;
1c846c1f 6442 char *key = NULL;
c750a3ec 6443 STRLEN keylen;
b2ffa427 6444
9615e741 6445 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 6446
6447 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6448 break;
1c846c1f
NIS		 6449
6450 /* Make the CONST have a shared SV */
6451 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6452 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 6453 key = SvPV(sv, keylen);
25716404
GS		 6454 lexname = newSVpvn_share(key,
6455 SvUTF8(sv) ? -(I32)keylen : keylen,
6456 0);
1c846c1f
NIS		 6457 SvREFCNT_dec(sv);
6458 *svp = lexname;
6459 }
6460
6461 if ((o->op_private & (OPpLVAL_INTRO)))
6462 break;
6463
c750a3ec
MB		 6464 rop = (UNOP*)((BINOP*)o)->op_first;
6465 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6466 break;
3280af22 6467 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
524189f1 6468 if (!(SvFLAGS(lexname) & SVpad_TYPED))
c750a3ec 6469 break;
5196be3e 6470 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
c750a3ec
MB		 6471 if (!fields || !GvHV(*fields))
6472 break;
c750a3ec 6473 key = SvPV(*svp, keylen);
25716404
GS		 6474 indsvp = hv_fetch(GvHV(*fields), key,
6475 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
c750a3ec 6476 if (!indsvp) {
88e9b055 6477 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
2d8e6c8d 6478 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
c750a3ec
MB		 6479 }
6480 ind = SvIV(*indsvp);
6481 if (ind < 1)
cea2e8a9 6482 Perl_croak(aTHX_ "Bad index while coercing array into hash");
c750a3ec 6483 rop->op_type = OP_RV2AV;
22c35a8c 6484 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
c750a3ec 6485 o->op_type = OP_AELEM;
22c35a8c 6486 o->op_ppaddr = PL_ppaddr[OP_AELEM];
9615e741
GS		 6487 sv = newSViv(ind);
6488 if (SvREADONLY(*svp))
6489 SvREADONLY_on(sv);
6490 SvFLAGS(sv) |= (SvFLAGS(*svp)
6491 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
c750a3ec 6492 SvREFCNT_dec(*svp);
9615e741 6493 *svp = sv;
c750a3ec
MB		 6494 break;
6495 }
b2ffa427 6496
345599ca
GS		 6497 case OP_HSLICE: {
6498 UNOP *rop;
6499 SV *lexname;
6500 GV **fields;
9615e741 6501 SV **svp, **indsvp, *sv;
345599ca
GS		 6502 I32 ind;
6503 char *key;
6504 STRLEN keylen;
6505 SVOP *first_key_op, *key_op;
9615e741
GS		 6506
6507 o->op_seq = PL_op_seqmax++;
345599ca
GS		 6508 if ((o->op_private & (OPpLVAL_INTRO))
6509 /* I bet there's always a pushmark... */
6510 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6511 /* hmmm, no optimization if list contains only one key. */
6512 break;
6513 rop = (UNOP*)((LISTOP*)o)->op_last;
6514 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6515 break;
6516 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
524189f1 6517 if (!(SvFLAGS(lexname) & SVpad_TYPED))
345599ca
GS		 6518 break;
6519 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6520 if (!fields || !GvHV(*fields))
6521 break;
6522 /* Again guessing that the pushmark can be jumped over.... */
6523 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6524 ->op_first->op_sibling;
6525 /* Check that the key list contains only constants. */
6526 for (key_op = first_key_op; key_op;
6527 key_op = (SVOP*)key_op->op_sibling)
6528 if (key_op->op_type != OP_CONST)
6529 break;
6530 if (key_op)
6531 break;
6532 rop->op_type = OP_RV2AV;
6533 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6534 o->op_type = OP_ASLICE;
6535 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6536 for (key_op = first_key_op; key_op;
6537 key_op = (SVOP*)key_op->op_sibling) {
6538 svp = cSVOPx_svp(key_op);
6539 key = SvPV(*svp, keylen);
25716404
GS		 6540 indsvp = hv_fetch(GvHV(*fields), key,
6541 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
345599ca 6542 if (!indsvp) {
9615e741
GS		 6543 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6544 "in variable %s of type %s",
345599ca
GS		 6545 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6546 }
6547 ind = SvIV(*indsvp);
6548 if (ind < 1)
6549 Perl_croak(aTHX_ "Bad index while coercing array into hash");
9615e741
GS		 6550 sv = newSViv(ind);
6551 if (SvREADONLY(*svp))
6552 SvREADONLY_on(sv);
6553 SvFLAGS(sv) |= (SvFLAGS(*svp)
6554 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
345599ca 6555 SvREFCNT_dec(*svp);
9615e741 6556 *svp = sv;
345599ca
GS		 6557 }
6558 break;
6559 }
c750a3ec 6560
79072805 6561 default:
3280af22 6562 o->op_seq = PL_op_seqmax++;
79072805
LW		 6563 break;
6564 }
a0d0e21e 6565 oldop = o;
79072805 6566 }
a0d0e21e 6567 LEAVE;
79072805 6568}
beab0874 6569
19e8ce8e
AB		 6570
6571
6572char* Perl_custom_op_name(pTHX_ OP* o)
53e06cf0
SC		 6573{
6574 IV index = PTR2IV(o->op_ppaddr);
6575 SV* keysv;
6576 HE* he;
6577
6578 if (!PL_custom_op_names) /* This probably shouldn't happen */
6579 return PL_op_name[OP_CUSTOM];
6580
6581 keysv = sv_2mortal(newSViv(index));
6582
6583 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6584 if (!he)
6585 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6586
6587 return SvPV_nolen(HeVAL(he));
6588}
6589
19e8ce8e 6590char* Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0
SC		 6591{
6592 IV index = PTR2IV(o->op_ppaddr);
6593 SV* keysv;
6594 HE* he;
6595
6596 if (!PL_custom_op_descs)
6597 return PL_op_desc[OP_CUSTOM];
6598
6599 keysv = sv_2mortal(newSViv(index));
6600
6601 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6602 if (!he)
6603 return PL_op_desc[OP_CUSTOM];
6604
6605 return SvPV_nolen(HeVAL(he));
6606}
19e8ce8e 6607
53e06cf0 6608
beab0874
JT		 6609#include "XSUB.h"
6610
6611/* Efficient sub that returns a constant scalar value. */
6612static void
acfe0abc 6613const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 6614{
6615 dXSARGS;
9cbac4c7
DM		 6616 if (items != 0) {
6617#if 0
6618 Perl_croak(aTHX_ "usage: %s::%s()",
6619 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6620#endif
6621 }
9a049f1c 6622 EXTEND(sp, 1);
0768512c 6623 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 6624 XSRETURN(1);
6625}
Unnamed repository; edit this file 'description' to name the repository.