tinycobol/test.code/00_FernandoWuthstrack/tcl/tctcl.c

/*
	Example embedding a tcl interpreter 
	for GUI enabling a Cobol program.

	Recife, Brazil, 2001 -- Rildo Pragana
*/

#include <tcl.h>
#include <tk.h>
#include <stdio.h>
#include <stdlib.h>
#include <stdlib.h>
#define __USE_GNU
#include <dlfcn.h>
#undef __USE_GNU

#define min(a,b) (((a) < (b)) ? (a) : (b))
/**** general use tcl procs for processing arguments ****/
#include "cobtools.h"

#ifdef WINDOWS
#include <windows.h>
BOOL _export WINAPI DllEntryPoint (HINSTANCE hInstance, DWORD seginfo,
LPVOID lpCmdLine)
{
  /* Microsoft ONLY MAKES CRAP!!!!!!!! 
  THIS DUMB FUNCTION EXISTS ONLY TO FULFILL MS-WINDOWS NEEDS.
  Bill Gates will burn in HELL. */
    return TRUE;
}
#endif

Tcl_Interp *interp;
int error_code;
Tk_Window mainwin;
int script_sourced=0;

int tclErr (const char *msg) {
	char *r;
	r=(char *)Tcl_GetVar(interp, "errorInfo",TCL_GLOBAL_ONLY);
	fprintf(stderr,"%s:%s\n",msg,r);
	exit(1);
}

int call_cobol(ClientData clientData, Tcl_Interp *interp, 
	int objc, Tcl_Obj * CONST objv[] ) {

	char buf[81],*arg1,*arg2;
	if (objc!=3) {
		Tcl_SetResult(interp, "wrong number of arguments",
			TCL_STATIC);
		return TCL_ERROR;
	}
	arg1 = Tcl_GetString(objv[1]);
	arg2 = Tcl_GetString(objv[2]);
	memset(buf,' ',80);
	memmove(buf,arg2,min(strlen(arg2),80));
   int  (*fptr)();
   if ((fptr = (int (*)())dlsym(RTLD_DEFAULT,arg1)) == NULL) {
		Tcl_SetResult(interp, "library subroutine not found: ",
			TCL_STATIC);
		Tcl_AppendResult(interp, arg1,(char *)NULL);
		return TCL_ERROR;
	}
	(*fptr)(buf);
	return TCL_OK;
}

int initTcl () {
	int argc=0;
	char *argv[]= { "tinycobol", ""};

	Tcl_FindExecutable("");
	interp = Tcl_CreateInterp();
	Tcl_AppInit(interp);
	Tcl_CreateObjCommand(interp, "call_cobol", call_cobol, NULL, NULL);
	mainwin = Tk_MainWindow(interp);
}

int newGui () {
	script_sourced=0;
	error_code = Tcl_Eval(interp,newgui);
	if (error_code != TCL_OK) {
		tclErr("newGui: error in Tcl_Eval");
	}
}

int endTcl () {
	script_sourced=0;
	Tcl_DeleteInterp(interp);
}

int tcleval(char *data, char *scriptn) {
	char *r;
	char *cobbuf;
	int size;
	char script[128],*s,*s1;
	s=script;
	s1=scriptn;
	while (*s1 != ' ') *s++=*s1++;
	*s=0;
	if (!script_sourced) {
		script_sourced++;
		error_code = Tcl_Eval(interp,cobtools);
		if (error_code != TCL_OK) {
			tclErr("tcleval: error evaluating cobtools");
		}
		error_code = Tcl_EvalFile(interp, script);
		if (error_code != TCL_OK) {
			tclErr("tcleval: error evaluating script");
		}
	}
	else {
		error_code = Tcl_Eval(interp,"cobol_update");
		if (error_code != TCL_OK) {
			tclErr("tcleval: error evaluating cobol_update");
		}
	}
	error_code = Tcl_Eval(interp,compute_block_size);
	if (error_code != TCL_OK) {
		tclErr("tcleval: error evaluating compute_block_size");
	}
	Tcl_GetInt(interp,Tcl_GetVar(interp,"block_size",TCL_GLOBAL_ONLY),&size);
	cobbuf = malloc(size+1);
	memmove(cobbuf,data,size);
	cobbuf[size]=0;
	/*printf("C script: %s received: %s\n",script,cobbuf);*/
	Tcl_SetVar(interp,"data_block",cobbuf,TCL_GLOBAL_ONLY);
	Tcl_Eval(interp,wait_ready);
	r=(char *)Tcl_GetVar(interp, "result",TCL_GLOBAL_ONLY);
	if (r!=NULL) {
		memmove(data,r,strlen(r));
	}
	free(cobbuf);
}

/* stcleval evaluates any tcl command and returns the result of 
	this evaluation. Requirements: (1) the string to be evaluated
	must be null-terminated; (2) the result buffer (tres) must 
	hold 80 chars. */
int stcleval(char *scriptn, char *tres) {
	char *r;
	error_code = Tcl_GlobalEval(interp,scriptn);
	r=(char *)Tcl_GetStringResult(interp);
	memset(tres,' ',80);
	memmove(tres,r,min(strlen(r),80));
}

int
Tcl_AppInit(Tcl_Interp *interp) {
    
	if (Tcl_Init(interp) == TCL_ERROR) {
		return TCL_ERROR;
    }
  /*	Tcl_Eval(interp,"set dir $tcl_library;source $dir/tclIndex;unset dir");
    */
	if (Tk_Init(interp) == TCL_ERROR) {
		return TCL_ERROR;
    }
  	Tcl_StaticPackage(interp,"Tk", Tk_Init, 0);
    /*Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit);
  	Tcl_Eval(interp,"set dir $tk_library;source $dir/tclIndex;unset dir");
   */
    Tcl_SetVar(interp, "tcl_rcFileName", "~/.tctclrc", TCL_GLOBAL_ONLY);
    return TCL_OK;
}