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