+STATIC SV *
+new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
+{
+ dSP;
+ HV *table = perl_get_hv("\10", FALSE); /* ^H */
+ BINOP myop;
+ SV *res;
+ bool oldcatch = CATCH_GET;
+ SV **cvp;
+ SV *cv, *typesv;
+ char buf[128];
+
+ if (!table) {
+ yyerror("%^H is not defined");
+ return sv;
+ }
+ cvp = hv_fetch(table, key, strlen(key), FALSE);
+ if (!cvp || !SvOK(*cvp)) {
+ sprintf(buf,"$^H{%s} is not defined", key);
+ yyerror(buf);
+ return sv;
+ }
+ sv_2mortal(sv); /* Parent created it permanently */
+ cv = *cvp;
+ if (!pv)
+ pv = sv_2mortal(newSVpv(s, len));
+ if (type)
+ typesv = sv_2mortal(newSVpv(type, 0));
+ else
+ typesv = &sv_undef;
+ CATCH_SET(TRUE);
+ Zero(&myop, 1, BINOP);
+ myop.op_last = (OP *) &myop;
+ myop.op_next = Nullop;
+ myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+
+ PUSHSTACKi(SI_OVERLOAD);
+ ENTER;
+ SAVEOP();
+ op = (OP *) &myop;
+ if (PERLDB_SUB && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
+ PUTBACK;
+ pp_pushmark(ARGS);
+
+ EXTEND(sp, 3);
+ PUSHs(pv);
+ PUSHs(sv);
+ PUSHs(typesv);
+ PUSHs(cv);
+ PUTBACK;
+
+ if (op = pp_entersub(ARGS))
+ CALLRUNOPS();
+ LEAVE;
+ SPAGAIN;
+
+ res = POPs;
+ PUTBACK;
+ CATCH_SET(oldcatch);
+ POPSTACK;
+
+ if (!SvOK(res)) {
+ sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
+ yyerror(buf);
+ }
+ return SvREFCNT_inc(res);
+}
+