################################################################################

##

##  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

PL_ppaddr

PL_no_modify

PL_DBsignal

PL_DBsingle

PL_DBsub

PL_DBtrace

PL_Sv

PL_bufend

PL_bufptr

PL_compiling

PL_copline

PL_curcop

PL_curstash

PL_debstash

PL_defgv

PL_diehook

PL_dirty

PL_dowarn

PL_errgv

PL_error_count

PL_expect

PL_hexdigit

PL_hints

PL_in_my

PL_in_my_stash

PL_laststatval

PL_lex_state

PL_lex_stuff

PL_linestr

PL_na

PL_parser

PL_perl_destruct_level

PL_perldb

PL_rsfp_filters

PL_rsfp

PL_stack_base

PL_stack_sp

PL_statcache

PL_stdingv

PL_sv_arenaroot

PL_sv_no

PL_sv_undef

PL_sv_yes

PL_tainted

PL_tainting

PL_tokenbuf

PL_signals

PERL_SIGNALS_UNSAFE_FLAG

=implementation

#ifndef PERL_SIGNALS_UNSAFE_FLAG

#define PERL_SIGNALS_UNSAFE_FLAG 0x0001

#if { VERSION < 5.8.0 }

#  define D_PPP_PERL_SIGNALS_INIT   PERL_SIGNALS_UNSAFE_FLAG

#else

#  define D_PPP_PERL_SIGNALS_INIT   0

#endif

__NEED_VAR__ U32 PL_signals = D_PPP_PERL_SIGNALS_INIT;

#endif

/* Hint: PL_ppaddr

 * Calling an op via PL_ppaddr requires passing a context argument

 * for threaded builds. Since the context argument is different for

 * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will

 * automatically be defined as the correct argument.

 */

#if { VERSION <= 5.005_05 }

/* Replace: 1 */

#  define PL_ppaddr                 ppaddr

#  define PL_no_modify              no_modify

/* Replace: 0 */

#endif

#if { VERSION <= 5.004_05 }

/* Replace: 1 */

#  define PL_DBsignal               DBsignal

#  define PL_DBsingle               DBsingle

#  define PL_DBsub                  DBsub

#  define PL_DBtrace                DBtrace

#  define PL_Sv                     Sv

#  define PL_bufend                 bufend

#  define PL_bufptr                 bufptr

#  define PL_compiling              compiling

#  define PL_copline                copline

#  define PL_curcop                 curcop

#  define PL_curstash               curstash

#  define PL_debstash               debstash

#  define PL_defgv                  defgv

#  define PL_diehook                diehook

#  define PL_dirty                  dirty

#  define PL_dowarn                 dowarn

#  define PL_errgv                  errgv

#  define PL_error_count            error_count

#  define PL_expect                 expect

#  define PL_hexdigit               hexdigit

#  define PL_hints                  hints

#  define PL_in_my                  in_my

#  define PL_laststatval            laststatval

#  define PL_lex_state              lex_state

#  define PL_lex_stuff              lex_stuff

#  define PL_linestr                linestr

#  define PL_na                     na

#  define PL_perl_destruct_level    perl_destruct_level

#  define PL_perldb                 perldb

#  define PL_rsfp_filters           rsfp_filters

#  define PL_rsfp                   rsfp

#  define PL_stack_base             stack_base

#  define PL_stack_sp               stack_sp

#  define PL_statcache              statcache

#  define PL_stdingv                stdingv

#  define PL_sv_arenaroot           sv_arenaroot

#  define PL_sv_no                  sv_no

#  define PL_sv_undef               sv_undef

#  define PL_sv_yes                 sv_yes

#  define PL_tainted                tainted

#  define PL_tainting               tainting

#  define PL_tokenbuf               tokenbuf

/* Replace: 0 */

#endif

/* Warning: PL_parser

 * For perl versions earlier than 5.9.5, this is an always

 * non-NULL dummy. Also, it cannot be dereferenced. Don't

 * use it if you can avoid is and unless you absolutely know

 * what you're doing.

 * If you always check that PL_parser is non-NULL, you can

 * define DPPP_PL_parser_NO_DUMMY to avoid the creation of

 * a dummy parser structure.

 */

#if { VERSION >= 5.9.5 }

# ifdef DPPP_PL_parser_NO_DUMMY

#  define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \

                (croak("panic: PL_parser == NULL in %s:%d", \

                       __FILE__, __LINE__), (yy_parser *) NULL))->var)

# else

#  ifdef DPPP_PL_parser_NO_DUMMY_WARNING

#   define D_PPP_parser_dummy_warning(var)

#  else

#   define D_PPP_parser_dummy_warning(var) \

             warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__),

#  endif

#  define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \

                (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var)

__NEED_DUMMY_VAR__ yy_parser PL_parser;

# endif

/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */

/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf

 * Do not use this variable unless you know exactly what you're

 * doing. It is internal to the perl parser and may change or even

 * be removed in the future. As of perl 5.9.5, you have to check

 * for (PL_parser != NULL) for this variable to have any effect.

 * An always non-NULL PL_parser dummy is provided for earlier

 * perl versions.

 * If PL_parser is NULL when you try to access this variable, a

 * dummy is being accessed instead and a warning is issued unless

 * you define DPPP_PL_parser_NO_DUMMY_WARNING.

 * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access

 * this variable will croak with a panic message.

 */

# define PL_expect         D_PPP_my_PL_parser_var(expect)

# define PL_copline        D_PPP_my_PL_parser_var(copline)

# define PL_rsfp           D_PPP_my_PL_parser_var(rsfp)

# define PL_rsfp_filters   D_PPP_my_PL_parser_var(rsfp_filters)

# define PL_linestr        D_PPP_my_PL_parser_var(linestr)

# define PL_bufptr         D_PPP_my_PL_parser_var(bufptr)

# define PL_bufend         D_PPP_my_PL_parser_var(bufend)

# define PL_lex_state      D_PPP_my_PL_parser_var(lex_state)

# define PL_lex_stuff      D_PPP_my_PL_parser_var(lex_stuff)

# define PL_tokenbuf       D_PPP_my_PL_parser_var(tokenbuf)

# define PL_in_my          D_PPP_my_PL_parser_var(in_my)

# define PL_in_my_stash    D_PPP_my_PL_parser_var(in_my_stash)

# define PL_error_count    D_PPP_my_PL_parser_var(error_count)

#else

/* ensure that PL_parser != NULL and cannot be dereferenced */

# define PL_parser         ((void *) 1)

#endif

=xsinit

#define NEED_PL_signals

#define NEED_PL_parser

#define DPPP_PL_parser_NO_DUMMY_WARNING

=xsmisc

U32 get_PL_signals_1(void)

{

#ifdef PERL_NO_GET_CONTEXT

  dTHX;

#endif

  return PL_signals;

}

extern U32 get_PL_signals_2(void);

extern U32 get_PL_signals_3(void);

int no_dummy_parser_vars(int);

int dummy_parser_warning(void);

/* No PTRSIZE IN 5.004 and below, so PTR2IV would warn and possibly misbehave */

#if { VERSION > 5.004 }

  #define ppp_TESTVAR(var)          STMT_START { mXPUSHi(PTR2IV(&var);; count++; } STMT_END

#else

  #define ppp_TESTVAR(var)          STMT_START { mXPUSHi(&var); count++; } STMT_END

#endif

#define ppp_PARSERVAR(type, var)  STMT_START {                   \

                                    type volatile my_ ## var;    \

                                    type volatile *my_p_ ## var; \

                                    my_ ## var = var;            \

                                    my_p_ ## var = &var;         \

                                    var = my_ ## var;            \

                                    var = *my_p_ ## var;         \

                                    mXPUSHi(&var != NULL);       \

                                    count++;                     \

                                  } STMT_END

#define ppp_PARSERVAR_dummy       STMT_START {                   \

                                    mXPUSHi(1);                  \

                                    count++;                     \

                                  } STMT_END

#if { VERSION < 5.004 }

# define ppp_rsfp_t FILE *

#else

# define ppp_rsfp_t PerlIO *

#endif

#if { VERSION < 5.6.0 }

# define ppp_expect_t expectation

#elif { VERSION < 5.9.5 }

# define ppp_expect_t int

#else

# define ppp_expect_t U8

#endif

#if { VERSION < 5.9.5 }

# define ppp_lex_state_t U32

#else

# define ppp_lex_state_t U8

#endif

#if { VERSION < 5.6.0 }

# define ppp_in_my_t bool

#elif { VERSION < 5.9.5 }

# define ppp_in_my_t I32

#else

# define ppp_in_my_t U16

#endif

#if { VERSION < 5.9.5 }

# define ppp_error_count_t I32

#else

# define ppp_error_count_t U8

#endif

=xsubs

int

compare_PL_signals()

        CODE:

                {

                  U32 ref = get_PL_signals_1();

                  RETVAL = ref == get_PL_signals_2() && ref == get_PL_signals_3();

                }

        OUTPUT:

                RETVAL

SV *

PL_sv_undef()

        CODE:

                RETVAL = newSVsv(&PL_sv_undef);

        OUTPUT:

                RETVAL

SV *

PL_sv_yes()

        CODE:

                RETVAL = newSVsv(&PL_sv_yes);

        OUTPUT:

                RETVAL

SV *

PL_sv_no()

        CODE:

                RETVAL = newSVsv(&PL_sv_no);

        OUTPUT:

                RETVAL

int

PL_na(string)

        char *string

        CODE:

                PL_na = strlen(string);

                RETVAL = PL_na;

        OUTPUT:

                RETVAL

SV *

PL_Sv()

        CODE:

                PL_Sv = newSVpv("mhx", 0);

                RETVAL = PL_Sv;

        OUTPUT:

                RETVAL

SV *

PL_tokenbuf()

        CODE:

                RETVAL = newSViv(PL_tokenbuf[0]);

        OUTPUT:

                RETVAL

SV *

PL_parser()

        CODE:

                RETVAL = newSViv(PL_parser != NULL);

        OUTPUT:

                RETVAL

SV *

PL_hexdigit()

        CODE:

                RETVAL = newSVpv((char *) PL_hexdigit, 0);

        OUTPUT:

                RETVAL

SV *

PL_hints()

        CODE:

                RETVAL = newSViv((IV) PL_hints);

        OUTPUT:

                RETVAL

void

PL_ppaddr(string)

        char *string

        PPCODE:

                PUSHMARK(SP);

                mXPUSHs(newSVpv(string, 0));

                PUTBACK;

                ENTER;

                (void)*(PL_ppaddr[OP_UC])(aTHXR);

                SPAGAIN;

                LEAVE;

                XSRETURN(1);

void

other_variables()

        PREINIT:

                int count = 0;

        PPCODE:

                ppp_TESTVAR(PL_DBsignal);

                ppp_TESTVAR(PL_DBsingle);

                ppp_TESTVAR(PL_DBsub);

                ppp_TESTVAR(PL_DBtrace);

                ppp_TESTVAR(PL_compiling);

                ppp_TESTVAR(PL_curcop);

                ppp_TESTVAR(PL_curstash);

                ppp_TESTVAR(PL_debstash);

                ppp_TESTVAR(PL_defgv);

                ppp_TESTVAR(PL_diehook);

#if { VERSION >= 5.13.7 }

                /* can't get a pointer any longer */

                mXPUSHi(PL_dirty ? 1 : 1);

                count++;

#else

                ppp_TESTVAR(PL_dirty);

#endif

                ppp_TESTVAR(PL_dowarn);

                ppp_TESTVAR(PL_errgv);

                ppp_TESTVAR(PL_laststatval);

                ppp_TESTVAR(PL_no_modify);

                ppp_TESTVAR(PL_perl_destruct_level);

                ppp_TESTVAR(PL_perldb);

                ppp_TESTVAR(PL_stack_base);

                ppp_TESTVAR(PL_stack_sp);

                ppp_TESTVAR(PL_statcache);

                ppp_TESTVAR(PL_stdingv);

                ppp_TESTVAR(PL_sv_arenaroot);

                ppp_TESTVAR(PL_tainted);

                ppp_TESTVAR(PL_tainting);

                ppp_PARSERVAR(ppp_expect_t, PL_expect);

                ppp_PARSERVAR(line_t, PL_copline);

                ppp_PARSERVAR(ppp_rsfp_t, PL_rsfp);

                ppp_PARSERVAR(AV *, PL_rsfp_filters);

                ppp_PARSERVAR(SV *, PL_linestr);

                ppp_PARSERVAR(char *, PL_bufptr);

                ppp_PARSERVAR(char *, PL_bufend);

                ppp_PARSERVAR(ppp_lex_state_t, PL_lex_state);

                ppp_PARSERVAR(SV *, PL_lex_stuff);

                ppp_PARSERVAR(ppp_error_count_t, PL_error_count);

                ppp_PARSERVAR(ppp_in_my_t, PL_in_my);

#if { VERSION >= 5.5.0 }

                ppp_PARSERVAR(HV*, PL_in_my_stash);

#else

                ppp_PARSERVAR_dummy;

#endif

                XSRETURN(count);

int

no_dummy_parser_vars(check)

        int check

int

dummy_parser_warning()

=tests plan => 52

ok(Devel::PPPort::compare_PL_signals());

ok(!defined(&Devel::PPPort::PL_sv_undef()));

ok(&Devel::PPPort::PL_sv_yes());

ok(!&Devel::PPPort::PL_sv_no());

ok(&Devel::PPPort::PL_na("abcd"), 4);

ok(&Devel::PPPort::PL_Sv(), "mhx");

ok(defined &Devel::PPPort::PL_tokenbuf());

ok($] >= 5.009005 || &Devel::PPPort::PL_parser());

ok(&Devel::PPPort::PL_hexdigit() =~ /^[0-9a-zA-Z]+$/);

ok(defined &Devel::PPPort::PL_hints());

ok(&Devel::PPPort::PL_ppaddr("mhx"), "MHX");

for (&Devel::PPPort::other_variables()) {

  ok($_ != 0);

}

{

  my @w;

  my $fail = 0;

  {

    local $SIG{'__WARN__'} = sub { push @w, @_ };

    ok(&Devel::PPPort::dummy_parser_warning());

  }

  if ($] >= 5.009005) {

    ok(@w >= 0);

    for (@w) {

      print "# $_";

      unless (/^warning: dummy PL_bufptr used in.*module3.*:\d+/i) {

        warn $_;

        $fail++;

      }

    }

  }

  else {

    ok(@w == 0);

  }

  ok($fail, 0);

}

ok(&Devel::PPPort::no_dummy_parser_vars(1) >= ($] < 5.009005 ? 1 : 0));

eval { &Devel::PPPort::no_dummy_parser_vars(0) };

if ($] < 5.009005) {

  ok($@, '');

}

else {

  if ($@) {

    print "# $@";

    ok($@ =~ /^panic: PL_parser == NULL in.*module2.*:\d+/i);

  }

  else {

    ok(1);

  }

}