source: vendor/perl/5.8.8/op.c@ 3401

Last change on this file since 3401 was 3181, checked in by bird, 18 years ago

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