view release on metacpan or  search on metacpan

FANN.xs  view on Meta::CPAN

/* -*- Mode: C -*- */

#define PERL_NO_GET_CONTEXT 1

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"

#include <doublefann.h>
#include "morefann.h"
#include "constants.h"

#define WANT_MORTAL 1

typedef fann_type *fta; /* fta: fann_type array */
typedef fta fta_input;
typedef fta fta_output;

static SV *
_obj2sv(pTHX_ void *ptr, SV * klass, char * ctype) {
    if (ptr) {
	SV *rv;
	SV *sv = newSVpvf("%s(0x%p)", ctype, ptr);
	SV *mgobj = sv_2mortal(newSViv(PTR2IV(ptr)));
	SvREADONLY_on(mgobj);
	sv_magic(sv, mgobj, '~', ctype, 0);
	/* SvREADONLY_on(sv); */
	rv = newRV_noinc(sv);
	if (SvOK(klass)) {
	    HV *stash;
	    if (SvROK(klass))
		stash = SvSTASH(klass);
	    else
		stash = gv_stashsv(klass, 1);
	    
	    sv_bless(rv, stash);
	}
	return rv;
    }
    return &PL_sv_undef;
}

static void *
_sv2obj(pTHX_ SV* self, char * ctype, int required) {
    SV *sv = SvRV(self);
    if (sv) {
        if (SvTYPE(sv) == SVt_PVMG) {
            MAGIC *mg = mg_find(sv, '~');
            if (mg) {
                if (strcmp(ctype, mg->mg_ptr) == 0 && mg->mg_obj) {
                    return INT2PTR(void *, SvIV(mg->mg_obj));
                }
            }
        }
    }
    if (required) {
        Perl_croak(aTHX_ "object of class %s expected", ctype);
    }
    return NULL;
}

static SV *
_fta2sv(pTHX_ fann_type *fta, unsigned int len) {
    unsigned int i;
    AV *av = newAV();
    av_extend(av, len - 1);
    for (i = 0; i < len; i++) {
        SV *sv = newSVnv(fta[i]);
        av_store(av, i, sv);
    }
    return newRV_noinc((SV*)av);
}

static AV*
_srv2av(pTHX_ SV* sv, unsigned int len, char * const name) {
    if (SvROK(sv)) {
        AV *av = (AV*)SvRV(sv);
        if (SvTYPE((SV*)av)==SVt_PVAV) {
            if (av_len(av)+1 == len) {
                return av;
            }
            else {
                Perl_croak(aTHX_ "wrong number of elements in %s array, %d found when %d were required",
                           name, (unsigned int)(av_len(av)+1), len);
            }
        }
    }
    Perl_croak(aTHX_ "wrong type for %s argument, array reference expected", name);
}

static fann_type*
_sv2fta(pTHX_ SV *sv, unsigned int len, int flags, char * const name) {
    unsigned int i;
    fann_type *fta;
    AV *av = _srv2av(aTHX_ sv, len, name);