The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#include "perl_extractor.h"

SV *
perl_extractor_new_sv_from_ptr (void *ptr, const char *class) {
	SV *obj, *sv;
	HV *stash;

	obj = (SV *)newHV ();
	sv_magic (obj, 0, PERL_MAGIC_ext, (const char *)ptr, 0);

	sv = newRV_noinc (obj);
	stash = gv_stashpv (class, 0);
	sv_bless (sv, stash);

	return sv;
}

void *
perl_extractor_get_ptr_from_sv (SV *sv, const char *class) {
	MAGIC *mg;

	if (!sv || !SvOK (sv) || !SvROK (sv)
	 || SvTYPE (SvRV (sv)) != SVt_PVHV
	 || (class && !sv_derived_from (sv, class))
	 || !(mg = mg_find (SvRV (sv), PERL_MAGIC_ext))) {
		croak ("invalid object");
	}

	if (perl_extractor_object_is_invalid (sv)) {
		croak ("You used the instance methods loadConfigLibraries, addLibrary, "
		       "addLibraryLast or removeLibrary to create a new extractor from "
		       "an existing one. This automatically invalidates the old object "
		       "and you will need to use the return value of the above methods "
		       "to call any any method on them.");
	}

	return (void *)mg->mg_ptr;
}

SV *
perl_extractor_keyword_type_to_sv (EXTRACTOR_KeywordType type) {
	SV *ret;

	ret = newSVpv (EXTRACTOR_getKeywordTypeAsString (type), 0);

	return ret;
}

char *
perl_extractor_slurp_from_handle (SV *handle, STRLEN *len) {
	char *ret;
	SV *sv;
	PerlIO *io;
	int got;
	char buf[4096];

	io = IoIFP (sv_2io (handle));
	sv = sv_2mortal (newSVpv ("", 0));

	while ((got = PerlIO_read (io, &buf, sizeof (buf))) > 0) {
		sv_catpvn (sv, (const char *)&buf, got);
	}

	ret = SvPV (sv, *len);

	return ret;
}

void
perl_extractor_invalidate_object (SV *obj) {
	HV *hv;

	hv = (HV *)SvRV (obj);
	if (!hv_stores (hv, PERL_EXTRACTOR_INVALIDED, &PL_sv_yes)) {
		croak ("failed to store invalidation flag");
	}
}

bool
perl_extractor_object_is_invalid (SV *obj) {
	HV *hv;
	SV **val;

	if (!obj || !SvOK (obj) || !SvROK (obj)
	 || SvTYPE (SvRV (obj)) != SVt_PVHV
	 || !mg_find (SvRV (obj), PERL_MAGIC_ext)) {
		croak ("invalid object");
	}

	hv = (HV *)SvRV (obj);
	val = hv_fetchs (hv, PERL_EXTRACTOR_INVALIDED, 0);

	if (!val || !*val) {
		return 0;
	}

	return SvTRUE (*val);
}