view release on metacpan or  search on metacpan

lib/Parse/Perl.xs  view on Meta::CPAN

#define PERL_NO_GET_CONTEXT 1
#include "EXTERN.h"
#include "perl.h"
#include "callchecker0.h"
#include "XSUB.h"

#define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#define PERL_DECIMAL_VERSION \
	PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#define PERL_VERSION_GE(r,v,s) \
	(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))

#define QHAVE_UNITCHECK PERL_VERSION_GE(5,9,5)

#define QHAVE_WARNINGS_AS_SV (!PERL_VERSION_GE(5,9,4))
#if QHAVE_WARNINGS_AS_SV
# define WARNINGS_t SV
#else /* !QHAVE_WARNINGS_AS_SV */
# define WARNINGS_t STRLEN
#endif /* !QHAVE_WARNINGS_AS_SV */

#define QLEX_START_LINE_IS_SAFE PERL_VERSION_GE(5,13,7)
#define QHAVE_PARSE_STMTSEQ PERL_VERSION_GE(5,13,6)
#define QHAVE_COP_LABEL (!PERL_VERSION_GE(5,11,0))
#define QHAVE_COP_HINTS PERL_VERSION_GE(5,9,4)
#define QHAVE_COP_HINTS_HASH PERL_VERSION_GE(5,9,4)
#define QHAVE_COP_ARYBASE (!PERL_VERSION_GE(5,9,4))
#define QHAVE_COP_IO (!PERL_VERSION_GE(5,9,4) && PERL_VERSION_GE(5,8,0))

#ifndef COP_SEQ_RANGE_LOW
# if PERL_VERSION_GE(5,9,5)
#  define COP_SEQ_RANGE_LOW(sv) ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow
#  define COP_SEQ_RANGE_HIGH(sv) ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh
# else /* <5.9.5 */
#  define COP_SEQ_RANGE_LOW(sv) ((U32)SvNVX(sv))
#  define COP_SEQ_RANGE_HIGH(sv) ((U32)SvIVX(sv))
# endif /* <5.9.5 */
#endif /* !COP_SEQ_RANGE_LOW */

#if PERL_VERSION_GE(5,8,9) && !PERL_VERSION_GE(5,9,0)
/* there is a bogus definition, not actually used */
# undef PARENT_PAD_INDEX
#endif

#ifndef PARENT_PAD_INDEX
# if PERL_VERSION_GE(5,9,5)
#  define PARENT_PAD_INDEX(sv) ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow
#  define PARENT_FAKELEX_FLAGS(sv) \
	((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh
# elif PERL_VERSION_GE(5,9,0)
#  define PARENT_PAD_INDEX(sv) ((U32)SvNVX(sv))
#  define PARENT_FAKELEX_FLAGS(sv) ((U32)SvIVX(sv))
# endif /* >=5.9.0 */
#endif /* !PARENT_PAD_INDEX */

#ifndef pad_findmy_sv
# if PERL_VERSION_GE(5,11,2)
#  define pad_findmy_sv(sv, flags) pad_findmy(SvPVX(sv), SvCUR(sv), flags)
# else /* <5.11.2 */
#  define pad_findmy_sv(sv, flags) pad_findmy(SvPVX(sv))
# endif /* <5.11.2 */
#endif /* !pad_findmy_sv */

#ifndef newSV_type
# define newSV_type(type) THX_newSV_type(aTHX_ type)
static SV *THX_newSV_type(pTHX_ svtype type)
{
	SV *sv = newSV(0);
	(void) SvUPGRADE(sv, type);
	return sv;
}
#endif /* !newSV_type */

lib/Parse/Perl.xs  view on Meta::CPAN

	SAVECOMPILEWARNINGS();
#endif /* !QHAVE_WARNINGS_AS_SV */
	PL_compiling.cop_warnings =
		warnings_from_sv(safe_av_fetch(enva, ENV_WARNINGS));
#if QHAVE_WARNINGS_AS_SV
	if(!specialWARN(PL_compiling.cop_warnings))
		SAVEFREESV(PL_compiling.cop_warnings);
#endif /* QHAVE_WARNINGS_AS_SV */
#if QHAVE_COP_ARYBASE
	SAVEI32(PL_compiling.cop_arybase);
	PL_compiling.cop_arybase =
		iv_from_sv(safe_av_fetch(enva, ENV_ARYBASE));
#endif /* QHAVE_COP_ARYBASE */
#if QHAVE_COP_IO
	SAVESPTR(PL_compiling.cop_io);
	PL_compiling.cop_io = iohint_from_sv(safe_av_fetch(enva, ENV_IOHINT));
	if(PL_compiling.cop_io) SAVEFREESV(PL_compiling.cop_io);
#endif /* QHAVE_COP_IO */
	PL_hints |= HINT_LOCALIZE_HH;
	SAVEHINTS();
	PL_hints = uv_from_sv(safe_av_fetch(enva, ENV_HINTBITS)) |
		HINT_BLOCK_SCOPE;
	{
		HV *old_hh = GvHV(PL_hintgv);
		GvHV(PL_hintgv) =
			hinthash_from_sv(safe_av_fetch(enva, ENV_HINTHASH));
		if(old_hh) SvREFCNT_dec(old_hh);
	}
#if QHAVE_COP_HINTS_HASH
	{
		COPHH *old_cophh = CopHINTHASH_get(&PL_compiling);
		CopHINTHASH_set(&PL_compiling,
			cophh_from_sv(safe_av_fetch(enva, ENV_COPHINTHASH)));
		cophh_free(old_cophh);
	}
#endif /* QHAVE_COP_HINTS_HASH */
#if QHAVE_COP_HINTS
	SAVEI32(PL_compiling.cop_hints);
	PL_compiling.cop_hints = PL_hints;
#endif /* QHAVE_COP_HINTS */
#if QHAVE_COP_LABEL
	SAVEPPTR(PL_compiling.cop_label);
	PL_compiling.cop_label = NULL;
#endif /* QHAVE_COP_LABEL */
	SAVEVPTR(PL_curcop);
	PL_curcop = &PL_compiling;
	/* initialise PL_compcv and related state */
	SAVEGENERICSV(PL_compcv);
	PL_compcv = (CV*)newSV_type(SVt_PVCV);
	CvANON_on(PL_compcv);
	CvOUTSIDE(PL_compcv) =
		function_from_sv(safe_av_fetch(enva, ENV_OUTSIDECV));
	CvOUTSIDE_SEQ(PL_compcv) =
		uv_from_sv(safe_av_fetch(enva, ENV_OUTSIDESEQ));
	CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
	/* initialise other parser state */
	SAVEOP();
	PL_op = NULL;
	SAVEGENERICSV(PL_beginav);
	PL_beginav = newAV();
#if QHAVE_UNITCHECK
	SAVEGENERICSV(PL_unitcheckav);
	PL_unitcheckav = newAV();
#endif /* QHAVE_UNITCHECK */
	/* parse */
#if !QLEX_START_LINE_IS_SAFE
	source = sv_mortalcopy(source);
#endif /* !QLEX_START_LINE_IS_SAFE */
	lex_start_simple(source);
	parse_file_as_sub_body(
		array_from_sv(safe_av_fetch(enva, ENV_OUTSIDEPAD)));
	lex_end();
	if(PL_error_count) {
		if(!(SvPOK(ERRSV) && SvCUR(ERRSV) != 0))
			sv_setpvs(ERRSV, "Compilation error");
		Perl_die(aTHX_ NULL);
	}
	/* finalise */
#if QHAVE_UNITCHECK
	if(PL_unitcheckav) call_list(PL_scopestack_ix, PL_unitcheckav);
#endif /* QHAVE_UNITCHECK */
	RETVAL = (CV*)SvREFCNT_inc((SV*)PL_compcv);
	FREETMPS;
	LEAVE;
OUTPUT:
	RETVAL

MODULE = Parse::Perl PACKAGE = Parse::Perl::CopHintsHash

void
DESTROY(SV *sv)
PREINIT:
#if QHAVE_COP_HINTS_HASH
	SV *usv;
	COPHH *cophh;
#endif /* QHAVE_COP_HINTS_HASH */
CODE:
#if QHAVE_COP_HINTS_HASH
	if(sv_is_undef(sv)) {
		cophh = NULL;
	} else if(SvROK(sv) && (usv = SvRV(sv), 1) &&
			SvOBJECT(usv) && SvSTASH(usv) == stash_cophh &&
			SvIOK(usv)) {
		cophh = (COPHH *)SvUV(usv);
	} else {
		croak("malformed cop_hints_hash");
	}
	cophh_free(cophh);
#else /* !QHAVE_COP_HINTS_HASH */
	PERL_UNUSED_VAR(sv);
#endif /* !QHAVE_COP_HINTS_HASH */