xref: /openbsd/gnu/usr.bin/perl/dist/Devel-PPPort/parts/inc/newCONSTSUB (revision 9a4edab6)

################################################################################
##
##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
##  Version 2.x, Copyright (C) 2001, Paul Marquess.
##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
##
##  This program is free software; you can redistribute it and/or
##  modify it under the same terms as Perl itself.
##
################################################################################

=provides

newCONSTSUB

=dontwarn

NEED_newCONSTSUB    /* Because we define this weirdly */

=implementation

/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
#if { VERSION < 5.004_63 } && { VERSION != 5.004_05 }

/* And before that, we need to make sure this gets compiled for the functions
 * that rely on it */
#define NEED_newCONSTSUB

#if { NEED newCONSTSUB }

/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */
/* (There's no PL_parser in perl < 5.005, so this is completely safe)     */
#define D_PPP_PL_copline PL_copline

CV *
newCONSTSUB(HV *stash, const char *name, SV *sv)
{
        CV *cv;
        U32 oldhints = PL_hints;
        HV *old_cop_stash = PL_curcop->cop_stash;
        HV *old_curstash = PL_curstash;
        line_t oldline = PL_curcop->cop_line;
        PL_curcop->cop_line = D_PPP_PL_copline;

        PL_hints &= ~HINT_BLOCK_SCOPE;
        if (stash)
                PL_curstash = PL_curcop->cop_stash = stash;

        cv = newSUB(

                start_subparse(FALSE, 0),

                newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
                newSVOP(OP_CONST, 0, &PL_sv_no),   /* SvPV(&PL_sv_no) == "" -- GMB */
                newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
        );

        PL_hints = oldhints;
        PL_curcop->cop_stash = old_cop_stash;
        PL_curstash = old_curstash;
        PL_curcop->cop_line = oldline;

        return cv;
}
#endif
#endif

=xsinit

#define NEED_newCONSTSUB

=xsmisc

void call_newCONSTSUB_1(void)
{
#ifdef PERL_NO_GET_CONTEXT
        dTHX;
#endif
        newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1));
}

extern void call_newCONSTSUB_2(void);
extern void call_newCONSTSUB_3(void);

=xsubs

void
call_newCONSTSUB_1()

void
call_newCONSTSUB_2()

void
call_newCONSTSUB_3()

=tests plan => 3

&Devel::PPPort::call_newCONSTSUB_1();
is(&Devel::PPPort::test_value_1(), 1);

&Devel::PPPort::call_newCONSTSUB_2();
is(&Devel::PPPort::test_value_2(), 2);

&Devel::PPPort::call_newCONSTSUB_3();
is(&Devel::PPPort::test_value_3(), 3);