157 lines
3.5 KiB
C
157 lines
3.5 KiB
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 <memory.h>
|
|
|
|
/**** general use tcl procs for processing arguments ****/
|
|
#include "cobtools.h"
|
|
|
|
#ifdef WINDOWS
|
|
#include <windows.h>
|
|
#define TCTCL_PATH_DELIM_STR '\\'
|
|
|
|
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;
|
|
}
|
|
#else
|
|
#define TCTCL_PATH_DELIM_STR '/'
|
|
#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 initTcl()
|
|
{
|
|
// int argc=0;
|
|
// char *argv[]= { "tinycobol", ""};
|
|
Tcl_FindExecutable("");
|
|
interp = Tcl_CreateInterp();
|
|
Tcl_AppInit(interp);
|
|
mainwin = Tk_MainWindow(interp);
|
|
return TCL_OK;
|
|
}
|
|
|
|
int newGui()
|
|
{
|
|
script_sourced = 0;
|
|
error_code = Tcl_Eval(interp, newgui);
|
|
if (error_code != TCL_OK)
|
|
{
|
|
tclErr("newGui: error in Tcl_Eval");
|
|
}
|
|
return TCL_OK;
|
|
}
|
|
|
|
int endTcl()
|
|
{
|
|
Tcl_DeleteInterp(interp);
|
|
return TCL_OK;
|
|
}
|
|
|
|
int tcleval(char *data, char *scriptn)
|
|
{
|
|
char *r;
|
|
char *cobbuf;
|
|
int size;
|
|
char script[128], *s, *s1, *d;
|
|
d = getenv("TCTCL_LIBRARY_PATH");
|
|
s = script;
|
|
s1 = scriptn;
|
|
if (d)
|
|
{
|
|
while (*d != 0) *s++ = *d++;
|
|
|
|
if (*d != TCTCL_PATH_DELIM_STR) *s++ = TCTCL_PATH_DELIM_STR;
|
|
}
|
|
|
|
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);
|
|
return TCL_OK;
|
|
}
|
|
|
|
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;
|
|
}
|
|
|