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