view release on metacpan or  search on metacpan

lib/Algorithm/SVMLight.xs  view on Meta::CPAN

#ifdef __cplusplus
extern "C" {
#endif
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef __cplusplus
}
#endif

/* Standard system headers: */
#include <stdio.h>
#include <string.h>
#include <math.h>
#include <stdlib.h>
#include <time.h>
#include <assert.h>

/* Stuff from the SVM Light source: */
/* #include "kernel.h" */
#include "svm_common.h"
#include "svm_learn.h"


#define INITIAL_DOCS 8
#define EXPANSION_FACTOR 2.0

typedef struct {
  long num_features;
  long num_docs;
  long allocated_docs;
  DOC **docs;
  double *labels;
} corpus;

double ranking_callback(DOC **docs, double *rankvalue, long i, long j, LEARN_PARM *learn_parm) {
  dSP;
  SV *callback = (SV *) learn_parm->costfunccustom;
  int count;
  double result;

  /* Don't bother checking the type of 'callback' - it could be a CODE
   * reference or a string, and perl will throw its own error otherwise.
   */

  ENTER;
  SAVETMPS;

  PUSHMARK(SP);
  XPUSHs(sv_2mortal(newSVnv(rankvalue[i])));
  XPUSHs(sv_2mortal(newSVnv(rankvalue[j])));
  XPUSHs(sv_2mortal(newSVnv(docs[i]->costfactor)));
  XPUSHs(sv_2mortal(newSVnv(docs[j]->costfactor)));
  PUTBACK ;

  count = call_sv(callback, G_SCALAR);
  SPAGAIN;
  if (count != 1)
    croak("Expected 1 return value from ranking callback, but got %d", count);
  result = POPn;

  PUTBACK;
  FREETMPS;
  LEAVE;

  return result;
}


SV **
self_store(SV *self, void *ptr, const char *slot, int make_readonly) {
  HV *self_hash = (HV*) SvRV(self);
  SV **fetched = hv_fetch(self_hash, slot, strlen(slot), 1);
  if (fetched == NULL) croak("Couldn't create the %s slot in $self", slot);
  
  SvREADONLY_off(*fetched);
  sv_setiv(*fetched, (IV) ptr);
  if (make_readonly) SvREADONLY_on(*fetched);
  return fetched;
}

void *
self_fetch(SV *self, const char *slot) {
  HV *self_hash = (HV*) SvRV(self);
  SV **fetched = hv_fetch(self_hash, slot, strlen(slot), 0);
  if (fetched == NULL) croak("Couldn't fetch the %s slot in $self", slot);

  return (void *) SvIV(*fetched);
}

/* Extract the '_corpus' structure out of $self */
corpus *get_corpus (SV *self) {
  return (corpus *) self_fetch(self, "_corpus");
}

/* Convert a SV* containing an arrayref into an AV* */
AV *unpack_aref(SV *input_rv, char *name) {
  if ( !SvROK(input_rv) || SvTYPE(SvRV(input_rv)) != SVt_PVAV ) {
    croak("Argument '%s' must be array reference", name);
  }
  
  return (AV*) SvRV(input_rv);
}