-/* James Bond: Do you expect me to talk?
- Auric Goldfinger: No, Mr. Bond. I expect you to die.
-
- This code is an ugly hack, doesn't work with lexicals in subroutines that are
- called more than once, and is only used by regcomp.c, for (?{}) blocks.
-
- Currently it is not used outside the core code. Best if it stays that way.
-
- Hence it's now deprecated, and will be removed.
-*/
-OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
-/* sv Text to convert to OP tree. */
-/* startop op_free() this to undo. */
-/* code Short string id of the caller. */
-{
- PERL_ARGS_ASSERT_SV_COMPILE_2OP;
- return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
-}
-
-/* Don't use this. It will go away without warning once the regexp engine is
- refactored not to use it. */
-OP *
-Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
- PAD **padp)
-{
- dVAR; dSP; /* Make POPBLOCK work. */
- PERL_CONTEXT *cx;
- SV **newsp;
- I32 gimme = G_VOID;
- I32 optype;
- OP dummy;
- char tbuf[TYPE_DIGITS(long) + 12 + 10];
- char *tmpbuf = tbuf;
- char *safestr;
- int runtime;
- CV* runcv = NULL; /* initialise to avoid compiler warnings */
- STRLEN len;
- bool need_catch;
-
- PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
-
- ENTER_with_name("eval");
- lex_start(sv, NULL, LEX_START_SAME_FILTER);
- SAVETMPS;
- /* switch to eval mode */
-
- if (IN_PERL_COMPILETIME) {
- SAVECOPSTASH_FREE(&PL_compiling);
- CopSTASH_set(&PL_compiling, PL_curstash);
- }
- if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
- SV * const sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
- code, (unsigned long)++PL_evalseq,
- CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- tmpbuf = SvPVX(sv);
- len = SvCUR(sv);
- }
- else
- len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
- (unsigned long)++PL_evalseq);
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tmpbuf+2);
- SAVECOPLINE(&PL_compiling);
- CopLINE_set(&PL_compiling, 1);
- /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
- deleting the eval's FILEGV from the stash before gv_check() runs
- (i.e. before run-time proper). To work around the coredump that
- ensues, we always turn GvMULTI_on for any globals that were
- introduced within evals. See force_ident(). GSAR 96-10-12 */
- safestr = savepvn(tmpbuf, len);
- SAVEDELETE(PL_defstash, safestr, len);
- SAVEHINTS();
-#ifdef OP_IN_REGISTER
- PL_opsave = op;
-#else
- SAVEVPTR(PL_op);
-#endif
-
- /* we get here either during compilation, or via pp_regcomp at runtime */
- runtime = IN_PERL_RUNTIME;
- if (runtime)
- {
- runcv = find_runcv(NULL);
-
- /* At run time, we have to fetch the hints from PL_curcop. */
- PL_hints = PL_curcop->cop_hints;
- if (PL_hints & HINT_LOCALIZE_HH) {
- /* SAVEHINTS created a new HV in PL_hintgv, which we
- need to GC */
- SvREFCNT_dec(GvHV(PL_hintgv));
- GvHV(PL_hintgv) =
- refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
- hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
- }
- SAVECOMPILEWARNINGS();
- PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- cophh_free(CopHINTHASH_get(&PL_compiling));
- /* XXX Does this need to avoid copying a label? */
- PL_compiling.cop_hints_hash
- = cophh_copy(PL_curcop->cop_hints_hash);
- }
-
- PL_op = &dummy;
- PL_op->op_type = OP_ENTEREVAL;
- PL_op->op_flags = 0; /* Avoid uninit warning. */
- PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
- PUSHEVAL(cx, 0);
- need_catch = CATCH_GET;
- CATCH_SET(TRUE);
-
- if (runtime)
- (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
- else
- (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
- CATCH_SET(need_catch);
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
-
- (*startop)->op_type = OP_NULL;
- (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
- /* XXX DAPM do this properly one year */
- *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
- LEAVE_with_name("eval");
- if (IN_PERL_COMPILETIME)
- CopHINTS_set(&PL_compiling, PL_hints);
-#ifdef OP_IN_REGISTER
- op = PL_opsave;
-#endif
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(optype);
-
- return PL_eval_start;
-}
-