view release on metacpan or  search on metacpan

perl/Cluster.xs  view on Meta::CPAN

    dSP;

    I32 count;
    bool isEnabled; 
    SV * mysv;

    ENTER ;
    SAVETMPS;
    PUSHMARK(SP) ;
    XPUSHs(sv_2mortal(newSVpv("Algorithm::Cluster",18)));
    PUTBACK ;

    count = perl_call_pv("warnings::enabled", G_SCALAR) ;

    if (count != 1) croak("No arguments returned from call_pv()\n") ;

    mysv = POPs; 
    isEnabled = (bool) SvTRUE(mysv); 

    PUTBACK ;
    FREETMPS ;
    LEAVE ;

    return isEnabled;
}

/* -------------------------------------------------
 * Create a row of doubles, initialized to a value
 */
static double*
malloc_row_dbl(pTHX_ int ncols, double val) {

    int j;
    double * row;

    row = malloc(ncols * sizeof(double) );
    if (!row) {
        return NULL;
    }

    for (j = 0; j < ncols; j++) { 
        row[j] = val;
    }
    return row;
}

/* -------------------------------------------------
 * Only coerce to a double if we already know it's 
 * an integer or double, or a string which is actually numeric.
 * Don't blindly run the macro SvNV, because that will coerce 
 * a non-numeric string to be a double of value 0.0, 
 * and we do not want that to happen, because if we test it again, 
 * it will then appear to be a valid double value. 
 */
static int
extract_double_from_scalar(pTHX_ SV * mysv, double * number) {

    if (SvPOKp(mysv) && SvLEN(mysv)) {  

        /* This function is not in the public perl API */
        if (Perl_looks_like_number(aTHX_ mysv)) {
            *number = SvNV( mysv );
            return 1;
        } else {
            return 0;
        } 
    } else if (SvNIOK(mysv)) {  
        *number = SvNV( mysv );
        return 1;
    } else {
        return 0;
    }
}



/* -------------------------------------------------
 * Convert a Perl 2D matrix into a 2D matrix of C doubles.
 * If no data are masked, mask can be passed as NULL.
 * NOTE: on errors this function returns a value greater than zero.
 */
static double**
parse_data(pTHX_ SV * matrix_ref, int** mask) {

    AV * matrix_av;
    SV * row_ref;
    AV * row_av;
    SV * cell;

    int type, i, j, nrows, ncols, n;

    double** matrix;

    /* NOTE -- we will just assume that matrix_ref points to an arrayref,
     * and that the first item in the array is itself an arrayref.
     * The calling perl functions must check this before we get this pointer.  
     * (It's easier to implement these checks in Perl rather than C.)
     * The value of perl_rows is now fixed. But the value of
     * rows will be decremented, if we skip any (invalid) Perl rows.
     */
    matrix_av  = (AV *) SvRV(matrix_ref);
    nrows = (int) av_len(matrix_av) + 1;

    if(nrows <= 0) {
        return NULL;
    }
    matrix   = malloc(nrows*sizeof(double*));
    if (!matrix) {
        return NULL;
    }

    row_ref  = *(av_fetch(matrix_av, (I32) 0, 0)); 
    row_av   = (AV *) SvRV(row_ref);
    ncols    = (int) av_len(row_av) + 1;


    /* ------------------------------------------------------------ 
     * Loop once for each row in the Perl matrix, and convert it to
     * C doubles. 
     */
    for (i=0; i < nrows; i++) {