view release on metacpan or  search on metacpan

lib/C/Blocks.xs  view on Meta::CPAN

		/* Indicate we've handled this character */
		return PR_NON_SIGIL;
	}
	/* revert to the default parser to handle this character since it is
	   not a colon. */
	return pstate->default_next_char(aTHX_ pstate);
}

int process_next_char_post_sigil(pTHX_ parse_state * pstate) {
	/* Only called on the first character after the sigil. */
	
	/* If the sigil is a dollar sign and the next character is an
	 * opening bracket, then we have an interpolation block. */
	if (pstate->data->end[-1] == '$' && pstate->data->end[0] == '{') {
		pstate->process_next_char = process_next_char_no_vars;
		pstate->interpolation_bracket_count_start = pstate->bracket_count++;
		return PR_NON_SIGIL;
	}
	
	/* IF our default parser accepts sigiled variables, then check for a
	 * valid identifier character and set up continued searching for the
	 * end of the variable name. */
	if (pstate->default_next_char == process_next_char_sigil_vars_ok
		&& _is_id_cont(pstate->data->end[0]))
	{
		pstate->process_next_char = process_next_char_sigiled_var;
		return PR_NON_SIGIL;
	}
	
	/* We either have a lone sigil character followed by a space or a
	 * sigiled variable name being parsed when sigiled variable names
	 * are not allowed. Reset the state and defer to the default
	 * handler. */
	pstate->process_next_char = pstate->default_next_char;
	return pstate->default_next_char(aTHX_ pstate);
}

int direct_replace_double_colons(char * to_check) {
	if (to_check[0] == 0) return 0;
	int found = 0;
	for (to_check++; *to_check != 0; to_check++) {
		if (to_check[-1] == ':' && to_check[0] == ':') {
			to_check[-1] = to_check[0] = '_';
			found = 1;
		}
	}
	return found;
}

int process_next_char_sigiled_var(pTHX_ parse_state * pstate) {
	/* keep collecting if the current character looks like a valid
	 * identifier character */
	if (_is_id_cont(pstate->data->end[0])) return PR_NON_SIGIL;
	
	/* make sure we have the PerlAPI loaded */
	ensure_perlapi(aTHX_ pstate->data);
	
	/* We just identified the character that is one past the end of our
	 * Perl variable name. Identify the type and construct the mangled
	 * name for the C-side variable. */
	char backup = *pstate->data->end;
	*pstate->data->end = '\0';
	char * type;
	char * long_name;
	if (*pstate->sigil_start == '$') {
		type = "SV";
		long_name = savepv(form("_PERL_SCALAR_%s", 
			pstate->sigil_start + 1));
	}
	else if (*pstate->sigil_start == '@') {
		type = "AV";
		long_name = savepv(form("_PERL_ARRAY_%s", 
			pstate->sigil_start + 1));
	}
	else if (*pstate->sigil_start == '%') {
		type = "HV";
		long_name = savepv(form("_PERL_HASH_%s", 
			pstate->sigil_start + 1));
	}
	else {
		/* should never happen */
		*pstate->data->end = backup;
		croak("C::Blocks internal error: unknown sigil %c\n",
			*pstate->sigil_start);
	}
	
	/* replace any double-colons */
	int is_package_global = direct_replace_double_colons(long_name);
	
	/* Check if we need to add a declaration for the C-side variable */
	if (strstr(SvPVbyte_nolen(pstate->data->code_top), long_name) == NULL) {
		/* Add a new declaration for it */
		
		/* NOTE: pad_findmy_pv expects the sigil, but get_sv/get_av/get_hv
		   do not!! */
		
		if (is_package_global) {
			sv_catpvf(pstate->data->code_top, "%s * %s = (%s(\"%s\", GV_ADD)); ",
				type, long_name,
				  *pstate->sigil_start == '$' ? "get_sv"
				: *pstate->sigil_start == '@' ? "get_av"
				:                               "get_hv",
				pstate->sigil_start + 1);
		}
		else {
			int var_offset = (int)pad_findmy_pv(pstate->sigil_start, 0);
			/* Ensure that the variable exists in the pad */
			if (var_offset == NOT_IN_PAD) {
				CopLINE(PL_curcop) += pstate->data->N_newlines;
				*pstate->data->end = backup;
				croak("Could not find lexically scoped \"%s\"",
					pstate->sigil_start);
			}
			
			/* If the variable has an annotated type, use the type's
			 * code builder. Otherwise, declare the basic type. */
			if (!call_init_cleanup_builder_method(aTHX_ pstate, type,
					long_name, var_offset))
			{
				sv_catpvf(pstate->data->code_top, "%s * %s = (%s*)PAD_SV(%d); ",
					type, long_name, type, var_offset);
			}
		}
	}
	
	/* Reset the character just following the var name */
	*pstate->data->end = backup;
	
	/* Add the long name to the main code block in place of the sigiled
	 * expression, and remove the sigiled varname from the buffer. */
	sv_catpv_nomg(pstate->data->code_main, long_name);
	lex_unstuff(pstate->data->end);
	pstate->data->end = PL_bufptr;
	
	/* Cleanup memory */
	Safefree(long_name);
	
	/* Reset the parser state and process the current character with
	 * the default parser */
	pstate->process_next_char = pstate->default_next_char;
	return pstate->default_next_char(aTHX_ pstate);
}

/* Support for type-annotated variables. Save the SV in an even
 * more obfuscated variable, and the given type in the expected
 * variable. */
int call_init_cleanup_builder_method(pTHX_ parse_state * pstate,
	char * type, char * long_name, int var_offset)
{
	/* does this variable have a type? */
	HV * stash = PAD_COMPNAME_TYPE(var_offset);
	if (stash == 0) return 0;
	
	/* get the method; warn and exit if we can't find it */
	GV * declaration_gv;
	CV * declaration_cv;
	declaration_gv = gv_fetchmeth_autoload(stash, "c_blocks_init_cleanup", 21, 0);
	if (declaration_gv != 0) declaration_cv = GvCV(declaration_gv);
	if (declaration_gv == 0 || declaration_cv == 0) {
		my_warnif (aTHX_ "type", sv_2mortal(newSVpvf("C::Blocks could "
			"not find method 'c_blocks_init_cleanup' for %s's type, %s",
			pstate->sigil_start, HvENAME(stash))));
		return 0;
	}
	
	/* prepare the call stack for the init_cleanup method */
	dSP;
	int count;
	ENTER;
	SAVETMPS;
	PUSHMARK(SP);
	XPUSHs(sv_2mortal(newSVpv(HvENAME(stash), 0))); // class name
	XPUSHs(sv_2mortal(newSVpv(long_name, 0))); // long C name
	XPUSHs(sv_2mortal(newSVpv(type, 0)));      // var type: SV, AV, HV
	XPUSHs(sv_2mortal(newSViv(var_offset)));   // pad offset
	PUTBACK;
	
	/* call the init_cleanup method */
	count = call_sv((SV*)declaration_cv, G_ARRAY); /* G_EVAL | G_KEEPERR ??? */
	SPAGAIN;
	
	/* make sure we got the init and cleanup code */
	while (count > 2) {
		POPs;
		count--;
	}
	if (count == 2) {

lib/C/Blocks.xs  view on Meta::CPAN

	if (count == 0) {
		my_warnif (aTHX_ "type", sv_2mortal(newSVpvf("C::Blocks expected "
			"one or two return values from %s::c_blocks_init_cleanup' "
			"but got none", HvENAME(stash))));
		return 0;
	}

	// success!
	return 1;
}

void extract_C_code(pTHX_ c_blocks_data * data, int keyword_type) {
	/* copy data out of the buffer until we encounter the matching
	 * closing bracket, accounting for brackets that may occur in
	 * comments and strings. Process sigiled variables as well. */
	
	/* Set up the parser state */
	parse_state my_parse_state;
	my_parse_state.data = data;
	my_parse_state.sigil_start = 0;
	my_parse_state.bracket_count = 0;
	my_parse_state.interpolation_bracket_count_start = 0;
	if (keyword_type == IS_CBLOCK) {
		my_parse_state.process_next_char = process_next_char_sigil_vars_ok;
		my_parse_state.default_next_char = process_next_char_sigil_vars_ok;
	}
	else {
		my_parse_state.process_next_char = process_next_char_no_vars;
		my_parse_state.default_next_char = process_next_char_no_vars;
	}
	
	
	data->end = PL_bufptr;
	int still_working;
	do {
		ENSURE_LEX_BUFFER(data->end, "C::Blocks expected closing curly brace but did not find it");
		
		if (*data->end == '\n') data->N_newlines++;
		still_working = my_parse_state.process_next_char(aTHX_ &my_parse_state);
		if (still_working == PR_EXCEPTION) {
			/* XXX working here - if an exception in Perl block, must clean up! */
		}
		data->end++;
	} while (still_working);
	
	/* Finish by moving the (remaining) contents of the lexical buffer
	 * into the main code container. Don't copy the final bracket, so
	 * that bottom's code can be appended later. */
	sv_catpvn(data->code_main, PL_bufptr, data->end - PL_bufptr - 1);
	/* end points to the first character after the closing bracket, so
	 * don't copy (or unstuff) that. */
	lex_unstuff(data->end);
	data->end = PL_bufptr;
	/* Add the closing bracket to the end, if appropriate */
	if (data->keep_curly_brackets) sv_catpvn(data->code_bottom, "}", 1);
}

void run_filters (pTHX_ c_blocks_data * data, int keyword_type) {
	/* Get $_ and place the code in it */
	SV * underbar = find_rundefsv();
	SV * under_backup = newSVsv(underbar);
	sv_setpvf(underbar, "%s%s%s", SvPVbyte_nolen(data->code_top),
		SvPVbyte_nolen(data->code_main), SvPVbyte_nolen(data->code_bottom));
	
	/* Apply the different filters */
	SV * filters_SV = cophh_fetch_pvs(data->hints_hash, "C::Blocks/filters", 0);
	if (filters_SV != &PL_sv_placeholder) {
		dSP;
		char * filters = SvPVbyte_nolen(filters_SV);
		char * start = filters;
		char backup;
		while(1) {
			if (*filters == '\0' && start == filters) break;
			if (*filters == '|') {
				backup = *filters;
				*filters = '\0';
				/* construct the function name to call */
				char * full_method;
				/* if it starts with an ampersand, it's a function name */
				if (*start == '&') {
					full_method = start + 1;
				}
				else {
					/* we have the package name; append the normal method */
					full_method = form("%s::c_blocks_filter", start);
				}
				PUSHMARK(SP);
				call_pv(full_method, G_DISCARD|G_NOARGS);
				start = filters + 1;
				*filters = backup;
			}
			filters++;
		}
	}
	
	/* copy contents of underbar into main */
	sv_setsv(data->code_main, underbar);
	
	/* restore underbar when done */
	sv_setsv(underbar, under_backup);
}

/*************************/
/**** Keyword plugin ****/
/************************/

void initialize_c_blocks_data(pTHX_ c_blocks_data* data) {
	data->N_newlines = 0;
	data->xs_c_name = 0;
	data->xs_perl_name = 0;
	data->xsub_name = 0;
	data->add_test_SV = 0;
	data->keep_curly_brackets = 1;
	
	/* The user may have loaded perlapi explicitly. However, we won't
	 * check unless we find a need to check. Start by assuming it's not
	 * loaded. */
	data->has_loaded_perlapi = 0;
	
	data->hints_hash = CopHINTHASH_get(PL_curcop);
	data->add_test_SV = get_sv("C::Blocks::_add_msg_functions", 0);
	data->code_top = newSVpvn("", 0);
	data->code_main = newSVpvn("", 0);
	data->code_bottom = newSVpvn("", 0);
	data->error_msg_sv = newSV(0);
	
	/* This is called after we have cleared out whitespace, so just assign */
	data->end = PL_bufptr;
	
	/* Get the current exsymtabs list. If this doesn't exist, we'll have */
	data->exsymtabs = cophh_fetch_pvs(data->hints_hash, "C::Blocks/extended_symtab_tables", 0);
}

void add_function_signature_to_block(pTHX_ c_blocks_data* data) {
	/* Add the function declaration. The definition of the THX_DECL
	 * macro will be defined later. */
	sv_catpv_nomg(data->code_top, "void op_func(C_BLOCKS_THX_DECL) {");
}

void cleanup_c_blocks_data(pTHX_ c_blocks_data* data) {
	SvREFCNT_dec(data->error_msg_sv);
	SvREFCNT_dec(data->code_top);
	SvREFCNT_dec(data->code_main);
	SvREFCNT_dec(data->code_bottom);
	/* Bottom and top, if they were even used, should have been
	 * de-allocated already. */
	//if (SvPOK(data->exsymtabs)) SvREFCNT_dec(data->exsymtabs);
	Safefree(data->xs_c_name);
	Safefree(data->xs_perl_name);
	Safefree(data->xsub_name);
}

void ensure_perlapi(pTHX_ c_blocks_data * data) {
	if (data->has_loaded_perlapi) return;
	
	/* XXX This will add a second perlapi symtab entry to the symtab
	 * list if the user already explicitly loaded PerlAPI. So this could
	 * be streamlined with a check for existenct of PerlAPI in current
	 * symtab list. */