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

MODULE = PDL::NDBin::Iterator	PACKAGE = PDL::NDBin::Iterator

SV *
advance( HV *self )
  PREINIT:
	AV  *av_active   = NULL;
	SV  *bin         = NULL,
	    *var         = NULL;
	SV **svp         = NULL,
	   **selection   = NULL,
	   **unflattened = NULL,
	   **want        = NULL;
	IV   nbins       = -1,
	     nvars       = -1;
	IV  *active      = NULL;
	IV   b = -1, v, i;
  CODE:
	RETVAL = &PL_sv_undef;
	if( (svp = hv_fetch(self, "bin", 3, FALSE)) ) bin = *svp;
	else croak( "advance: need bin" );
	if( (svp = hv_fetch(self, "nbins", 5, FALSE)) ) nbins = SvIV( *svp );
	else croak( "advance: need nbins" );
	if( SvIV(bin) >= nbins ) goto done;
	if( (svp = hv_fetch(self, "var", 3, FALSE)) ) var = *svp;
	else croak( "advance: need var" );
	if( (svp = hv_fetch(self, "nvars", 5, FALSE)) ) nvars = SvIV( *svp );
	else croak( "advance: need nvars" );
	if( (svp = hv_fetch(self, "active", 6, FALSE)) ) {
		if( SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV ) {
			av_active = (AV *) SvRV( *svp );
		}
		else croak( "advance: active is of wrong type" );
	}
	else croak( "advance: need active" );
	selection = hv_fetch(self, "selection", 9, FALSE);
	unflattened = hv_fetch(self, "unflattened", 11, FALSE);
	want = hv_fetch(self, "want", 4, FALSE);
	/* copy SVs to native data types */
	b = SvIV( bin );
	v = SvIV( var );
	Newx( active, nvars, IV );
	for( i = 0; i < nvars; i++ ) {
		if( (svp = av_fetch(av_active, (I32) i, FALSE)) ) {
			active[i] = SvIV( *svp );
		}
		else croak( "advance: need state" );
	}
	for( ;; ) {
		/* invalidate cached data */
		if( selection ) {
			SvREFCNT_dec( *selection );
			*selection = newSVsv( &PL_sv_undef );
			selection = NULL;
		}
		if( ++v >= nvars ) {
			v = 0;
			if( ++b >= nbins ) goto done;
			/* invalidate cached data */
			if( want ) {
				SvREFCNT_dec( *want );
				*want = newSVsv( &PL_sv_undef );
				want = NULL;
			}
			if( unflattened ) {
				SvREFCNT_dec( *unflattened );
				*unflattened = newSVsv( &PL_sv_undef );
				unflattened = NULL;
			}
		}
		if( active[v] ) break;
	}
	RETVAL = &PL_sv_yes;
    done:
	/* copy native data types back to SVs */
	if( b >= 0 ) sv_setiv( bin, b );
	if( var ) sv_setiv( var, v );
	if( active ) Safefree( active );
  OUTPUT:
	RETVAL