Posted to tcl by xharx at Tue Mar 09 11:46:43 GMT 2021view pretty

#include <stdio.h>
#include <unistd.h>
#include <tk.h>
#include <tcl.h>
#include <string.h>
#include <pthread.h>
#include <stdlib.h>

char ptglobstr[1024];

int TKquit(ClientData clientdata, Tcl_Interp *interp, int argc, const char **argv) {
	exit (0);
}

typedef struct {
	Tcl_Interp *pti;
	char *varname;
	char *str;
}tfast;

int fast(tfast *ptin) {
	sleep(1);
	sprintf(ptin->str, "zweiter Versuch");
	printf("%s %s\n", ptin->varname, ptin->str);
	Tcl_UpdateLinkedVar(ptin->pti, ptin->varname);
}

int TKgettext(ClientData clientdata, Tcl_Interp *interp, int argc, const char **argv) {
	//printf("TKgettext\n");
	char *str=malloc(1024);
	char *varname=malloc(1024);
	sprintf(varname, "linkedstr");
	Tcl_LinkVar(interp, varname, str, TCL_LINK_STRING);
	pthread_t mthread;
	if (argc>1 && !strcmp(argv[1], "slow")) {
		tfast *ptfast=calloc(1, sizeof(tfast));
		ptfast->pti=interp;
		ptfast->varname=varname;
		ptfast->str=str;
		//pthread_create(&mthread, 0, (void *)fast, ptfast);
		Tcl_Eval(interp, "procver1");
		sprintf(str, "fast 444");
	}
	else if (argc>1 && !strcmp(argv[1], "utext")) {
		str=ptglobstr;
		printf("gettext utext %s\n", str);
	}
	else {
		static int i=0;
		sprintf(str, "{.c gettext bla %i}", i++);
	}
	Tcl_Obj *mobj=Tcl_NewStringObj(str, strlen(str));
	Tcl_SetObjResult(interp, mobj);
	return TCL_OK;
}

char *realloc_strcat(char *str1, char*str2) {
	char *ptraus=realloc(str1, strlen(str1)+strlen(str2)+1);
	if (!ptraus) {
		printf("realloc_strcat: Kein Speicher %d %d\n", (int) strlen(str1), (int) strlen(str2));
		exit (0);
	}
	strcat(ptraus,str2);
	return ptraus;
}

void utthread(Tcl_Interp *interp) {
	int i=0;
	while (1) {
		char puf[1024];
		sprintf(puf, "{ut %i} \n", i++);
		strcat(ptglobstr, puf);
		Tcl_Eval(interp, "updateutext");
		sleep(1);
	}
}

int TKutext(ClientData clientdata, Tcl_Interp *interp, int argc, const char **argv) {
	pthread_t thread;
	pthread_create(&thread, 0, (void *)utthread, interp);
}

void registercommands (Tcl_Interp *tcl_interp) {
	Tcl_CreateCommand(tcl_interp, "quit", TKquit, (ClientData)(NULL), (Tcl_CmdDeleteProc *)NULL);
	Tcl_CreateCommand(tcl_interp, "gettext", TKgettext, (ClientData)(NULL), (Tcl_CmdDeleteProc *)NULL);
	Tcl_CreateCommand(tcl_interp, "utext", TKutext, (ClientData)(NULL), (Tcl_CmdDeleteProc *)NULL);
}

Tcl_Interp *EPtkinit() {
	Tcl_Interp * tcl_interp = Tcl_CreateInterp() ;
	if ( tcl_interp == NULL )
	{
		fprintf( stderr, "Could not create interpreter!\n" ) ;
		return 0;
	}
	if (Tcl_Init(tcl_interp) != TCL_OK) {
		printf("Tcl_Init error\n");
		return 0;
	}
	if (Tk_Init(tcl_interp) != TCL_OK) {
		printf("Tk_Init error\n");
		return 0;
	}
	return tcl_interp;
}

int EPtkexecfile(Tcl_Interp *tcl_interp, char *filename) {
	int          rc       ;
	size_t       filesize ;
	char       * pstr   ;

	if (filename) {
		FILE *infile = fopen(filename, "r") ;
		if ( infile == NULL )
		{
			printf("datei nicht gefunden: %s\n", filename);
			return 0;
		}

		//read the whole file ...
		fseek( infile, 0L, SEEK_END ) ;
		filesize = ftell( infile ) ;
		pstr     = (char * ) malloc( (filesize+1) * sizeof(char) ) ;
		if ( pstr == NULL )
		{
			printf("Datei ist leer\n");
			return 0;
		}
		fseek( infile, 0L, SEEK_SET ) ;
		fread( pstr, filesize, 1, infile ) ;
		pstr[filesize] = '\0' ;
		rc = Tcl_Eval( tcl_interp, pstr ) ;
		if ( rc != TCL_OK )
		{
			fprintf( stderr, "Error loading script library\n" ) ;
			return 0;
		}

		free( pstr ) ;
	}
	else {
		printf("Kein Dateiname angegeben\n");
		return 0;
	}
	return 1;
}

int exec_tkmainloop_thread(char *filename) {
	Tcl_Interp *tcl_interp=EPtkinit();
	registercommands(tcl_interp);
	EPtkexecfile(tcl_interp, filename);
	printf("start Tk_MainLoop()\n");
	Tk_MainLoop();
	printf("stop TK_MainLoop\n");
	return 0;
}

int main() {
	pthread_t tkmainloopthread;
	char *filename="tkupdatev2.tk";
	pthread_create(&tkmainloopthread, 0, (void *)exec_tkmainloop_thread, filename);
	pthread_join(tkmainloopthread, 0);
	printf("main ends\n");
}



proc buttoncommand {} {
	quit
	destroy .
}

proc new {} { 
	utext
} 

proc updateutext {} {
	set ret [gettext utext]
	puts $ret
	set ::ltext $ret
	update
}

listbox .l1 -width 50 -height 10 -listvariable ::ltext
pack .l1
button .b1 -text "ok" -command {quit}
button .b2 -text "update" -command {new}
pack .b1
pack .b2