view release on metacpan or  search on metacpan

Compile.xs  view on Meta::CPAN

	else if ( optype == 1 ){
	    SV *sv;
	    sv =  out_values [ position_from ];
	    closure_values[ position_to ] = sv;
	}
	else if ( optype == 2 ){
	    SV *sv;
	    sv = out_values [ position_from ];
	    closure_values[ position_to ] = cl->temporary [ j ];
	}
    }
}
void
cl_run_closure( pTHX_ p_closure closure){
    dSP;
    I32 ret_count;
    int i;
    PUSHMARK(SP);
    PUTBACK;
    cl_prepare_closure( aTHX_ closure, 1); 
    ret_count = call_sv( (SV*)closure->closure_cv, G_NOARGS | G_SCALAR |G_EVAL );
    cl_prepare_closure( aTHX_ closure, 2); 
    SPAGAIN;
    if ( ret_count != 1 )
	croak( "Incorrect number of stack items " );
    for( i=0; i<ret_count; ++i){
	closure->return_value = POPs;
    }
    PUTBACK;
}


long
dive_in_stack(){
    long i;
    for( i= cxstack_ix; i>= 0 ;--i ){
	if (CxTYPE(&cxstack[i]) == CXt_SUB) {
	    CV * cur_cv = cxstack[i].blk_sub.cv;
	    if ( PL_DBsub && GvCV(PL_DBsub) == cur_cv ){
		continue;
	    }
	    return i;
	}
	else if ( CxTYPE( &cxstack[i] )  ==CXt_EVAL ) {
	    if (CxOLD_OP_TYPE( &cxstack[i] ) == OP_ENTERTRY ){
		continue;
	    }
	    return -2;
	}
    }
    return -1;
}
static AV *eval_cache=0;

MODULE = Eval::Compile		PACKAGE = Eval::Compile		

void 
cache_eval_undef()
    PREINIT:
    SV *last;
    PPCODE:
    last = eval_cache;
    if ( !eval_cache ){
	XSRETURN(0);
    };
    eval_cache=0;
    SvREFCNT_dec( last );
    last =0 ;
    XSRETURN(0);
	

void 
cache_eval (SV * eval_string,  ... )
    ALIAS:
	ceval=1
	cached_eval=2
    PROTOTYPE: $@
    PREINIT:
    I32 ret_count;
    //I32 i;
    SV **value;
    char *pstr;
    STRLEN plen;
    AV* temppad;
    HV* closure_cache;
    p_closure closure;
    dXSTARG;
    PPCODE:
    PERL_UNUSED_VAR(ix);
    if ( !eval_cache ){
	eval_cache = newAV();
	temppad = eval_cache;
	closure_cache = newHV();
	AvPUSHs( eval_cache, (SV*)closure_cache );
    }
    else {
	temppad = eval_cache;
	closure_cache =( HV*)  AvELT( eval_cache,  0);
	if ( SvTYPE( closure_cache ) != SVt_PVHV )
	    croak( "panic: not a hash" );
    }
    temppad = (AV *) eval_cache;
    sv_setpvn( TARG, &PL_curcop, sizeof( &PL_curcop ));
    sv_catsv(  TARG, eval_string );

    pstr = SvPV( TARG, plen );
    value = hv_fetch( closure_cache , pstr, plen, 0);

    if ( value){
	closure = (p_closure) SvIV( * value );
	// XPUSHs(*value);
	// XSRETURN(1);
    };

    if ( !value ){
	SV *text;
	SV *anonsub;
	// Allocation of closure body
	closure = ( p_closure ) M_alloc( temppad,  sizeof( *closure) );

	hv_store( closure_cache, pstr, plen, newSViv( PTR2IV( closure )),0);
	
	
	text= sv_newmortal( );
	// TODO
	
	sv_setpv( text , "sub {\n" );
	sv_catpvf( text, "#line 0 \"<%s:%d>\"\n", CopFILE( PL_curcop ), CopLINE( PL_curcop ));
	sv_catsv( text,  eval_string );
	sv_catpv( text, ";\n};\n" );
	// fprintf( stderr, "%s\n", SvPV_nolen( text ));


	{
	dSP;
	sv_setpvn( ERRSV, "", 0);
	eval_sv( text , G_SCALAR | G_KEEPERR  );
	SPAGAIN;
	anonsub = POPs;
	PUTBACK;
	};
	
	// TODO
	//sv_dump( anonsub );
	closure->ok = 0;

	if ( SvOK(anonsub) && !SvTRUE(ERRSV)){
	    AvPUSHs( temppad, anonsub );
	    closure->ok = 1;
	    closure->closure_cv = (CV *)SvRV(anonsub);
	    cl_init( aTHX_ closure, temppad);
	}
	else {
	    warn( "%s", SvPVx_nolen_const( ERRSV ));
	    closure->ok = 0;
	    closure->return_value = newSVsv( ERRSV );
	    AvPUSHs( temppad, closure->return_value );
	    cl_init( aTHX_ closure, temppad);
	};
    }

    if ( closure->ok ){
	SV *result;
	ENTER;
	PUSHMARK(SP);
	cl_prepare_closure( aTHX_ closure, 1); 
	ret_count = call_sv( (SV *) closure->closure_cv, G_SCALAR | G_EVAL |  G_NOARGS );
	cl_prepare_closure( aTHX_ closure, 2); 

	SPAGAIN;
	result = POPs;
	if (ret_count != 1)
	    croak( "Invalid sub call" );
	if ( SvTRUE(ERRSV) )
	    warn("%s", SvPV_nolen( ERRSV ));
	PUTBACK;
	PUSHs(result);
	LEAVE;
	//sv_dump( result );
	XSRETURN(1);
    }
    else {
	sv_setsv( ERRSV, closure->return_value );
	XSRETURN_UNDEF;
    }
    
void 
cache_this ( SV * key, CV * calc_sv )
    PREINIT:
    I32 ret_count;
    //I32 i;
    SV **value;
    char *pstr;
    STRLEN plen;
    dXSTARG;
    PPCODE:
    if ( ! (PL_op->op_private & OPpENTERSUB_HASTARG )){
	croak( "panic: XS sub no target " );
    };
    if (SvTYPE(TARG) != SVt_PVHV ){
	(void)SvUPGRADE( TARG , SVt_PVHV );
    }
    pstr = SvPV( key, plen );
    value = hv_fetch( (HV*) TARG, pstr, plen, 0);
    if (value){
	XPUSHs(*value);
	XSRETURN(1);
    };
    PUSHMARK(SP);
    XPUSHs(ST(0));
    PUTBACK;
    ret_count = call_sv( (SV *)calc_sv, G_SCALAR | G_EVAL);
    SPAGAIN;
    if (ret_count != 1)
	croak( "Invalid sub call" );
    if ( SvTRUE(ERRSV) )
	warn("%s", SvPV_nolen( ERRSV ));
    else {
	SV *ret = POPs;
	SvREFCNT_inc_simple_void_NN(ret);
	(void) hv_store( (HV *)TARG, pstr, plen, ret , 0);
    }
    PUTBACK;
    XSRETURN(1);
    


    

void run_sub( SV * code )
    PREINIT:
    I32 ret_count;
    int i;
    PPCODE:
    dSP;
    PUSHMARK(SP);
    PUTBACK;
    ret_count = call_sv( code, G_NOARGS | G_SCALAR );
    SPAGAIN;
    for( i=0; i<ret_count; ++i){
	sv_dump( POPs );
    }
    PUTBACK;



void
compile_sub( SV *codetext)
    PREINIT:
    SV *text;
    SV *anonsub;
    PPCODE:
    //dSP;
    text= sv_newmortal( );
    sv_setpv( text , "sub {\n" );
    sv_catsv( text,  codetext );
    sv_catpv( text, "\n};\n" );

    anonsub = eval_pv( SvPV_nolen(text) , 0 );
    if ( !SvTRUE(ERRSV)){
	XPUSHs(&PL_sv_no);
	XPUSHs( anonsub );
	XPUSHs( codetext );
    }
    else {
	XPUSHs( ERRSV );
    };


void
callers( CV * cv, SV *eval_string )
    PREINIT:
    int i;
    PADNAMELIST *names;
    PAD *values;
    CV *subcv;
    long subcv_depth;
    long stack_depth;
    bool context_match;
    U32  context_seq;
    AV *results;
    PPCODE:
    if (cv && CvPADLIST( cv ) ){
	PADLIST *padlist = CvPADLIST( cv );
	if (CvDEPTH(cv)){
	    croak( "Fail compile: cv is running" );
	}
	stack_depth = dive_in_stack();
	if ( stack_depth < 0 ){
	    warn( "found no variables " );
	}
	context_match = FALSE;
	context_seq   = 0;
	if ( cxstack[ stack_depth ].blk_sub.cv != CvOUTSIDE(cv) ){
	    CV *out;
	    U32 seq;
	    out = CvOUTSIDE(cv);
	    seq = CvOUTSIDE_SEQ(cv);
	    while( out ){
		if ( cxstack[ stack_depth ].blk_sub.cv == out ){
		    context_match = TRUE;
		    context_seq = seq;
		    break;
		};
		seq = CvOUTSIDE_SEQ(out);
		out = CvOUTSIDE(out);
	    }
	    if ( ! context_match )
		warn("Cv from other context %p", CvOUTSIDE(cv) );
	};
	subcv = cxstack[ stack_depth ].blk_sub.cv;
	subcv_depth =  cxstack[ stack_depth ].blk_sub.olddepth+1;
	results = newAV();
	sv_2mortal( (SV *) results );
	AvPUSHi( results, 1 ) ; //0:  set that everything ok
	AvPUSHi( results, cxstack_ix - stack_depth ); //1: stack depth
	AvPUSHs( results, newRV((SV*)subcv));//2: context_cv
	AvPUSHs( results, eval_string );     //3:eval string
	AvPUSHs( results, newRV( (SV*)cv ) );//4: cv
	mXPUSHi(cxstack_ix - stack_depth); //  5: context_depth
	AvPUSHi( results, context_seq); //     6: seq

	_show_cvpad( cxstack[ stack_depth ].blk_sub.cv );

	names = PadlistNAMES(padlist);
	values =PadlistARRAY(padlist)[1];

	for (i=0; i<= PadnamelistMAX( names ) ; ++i ){
	    PADNAME *padn;
	    SV *val_sv;
	    padn = (PadnamelistARRAY(names)[i]);
	    val_sv  = PadARRAY( values )[i];
	    if ( PadnamePV(padn) && PadnameOUTER(padn) 
		    && !PadnameIsOUR(padn)
		    && PadnameLEN(padn) > 1 ){
		I32 position;
		SV * const name_sv = PadnameSV(padn);
		XPUSHs(name_sv);
		mXPUSHi( i );
		position = find_sv( subcv, subcv_depth, context_seq, val_sv);
		mXPUSHi( position );
		AvPUSHi( results, position );