93 lines
2.3 KiB
C
93 lines
2.3 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>
|
|
|
|
#define min(x,y) ((x)<(y) ? (x) : (y))
|
|
/**** general use tcl procs for processing arguments ****/
|
|
char cobtools[] = "proc split_fields {} {\n"
|
|
"global data_block cobol_fields result_format\n"
|
|
"set ix 0\nset result_format \"\"\n"
|
|
"foreach {varname size} $cobol_fields {\nglobal $varname\n"
|
|
"set $varname [string range $data_block $ix [expr $ix+$size-1]]\n"
|
|
"incr ix $size\nappend result_format \"%-$size.${size}s\"\n}\n}\n"
|
|
"proc do_exit {} {\nglobal result_format result ready cobol_fields\n"
|
|
"foreach child [winfo children .] {\ndestroy $child\n"
|
|
"}\nset vars {}\nforeach {varname size} $cobol_fields {\n"
|
|
"upvar $varname v\nlappend vars $v\n}\n"
|
|
"set result [eval format $result_format $vars]\nset ready 1\n}";
|
|
|
|
Tcl_Interp *interp;
|
|
int error_code;
|
|
Tk_Window mainwin;
|
|
|
|
int
|
|
call_cobol(ClientData *clientData, Tcl_Interp *interp,
|
|
int argc, char *argv[] ) {
|
|
|
|
char buf[81];
|
|
if (argc!=2) {
|
|
Tcl_SetResult(interp, "wrong number of arguments",
|
|
TCL_STATIC);
|
|
return TCL_ERROR;
|
|
}
|
|
memset(buf,' ',80);
|
|
memmove(buf,argv[1],min(strlen(argv[1]),80));
|
|
testgui06(buf);
|
|
return TCL_OK;
|
|
}
|
|
|
|
int initTcl () {
|
|
int argc=0;
|
|
char *argv[]= { "tinycobol", ""};
|
|
|
|
interp = Tcl_CreateInterp();
|
|
mainwin = Tk_MainWindow(interp);
|
|
Tcl_AppInit(interp);
|
|
Tcl_CreateCommand(interp, "call_cobol", call_cobol, NULL, NULL);
|
|
Tcl_Eval(interp,cobtools);
|
|
}
|
|
|
|
int endTcl () {
|
|
Tcl_DeleteInterp(interp);
|
|
}
|
|
|
|
/* this function assumes a command buffer of 80 characters */
|
|
int exec_tcl(char *cmd, char *result) {
|
|
char cmdbuf[81];
|
|
char *r,*s=cmd;
|
|
/* trim right spaces on the cmd buffer */
|
|
memmove(cmdbuf,cmd,80);
|
|
cmdbuf[80]=0;
|
|
s = cmdbuf+79;
|
|
while ((s >= cmdbuf) && (*s == ' ')) s--;
|
|
if (s >= cmdbuf)
|
|
*(s+1)=0;
|
|
//printf("Eval: [%s]\n",cmdbuf);
|
|
Tcl_Eval(interp,cmdbuf);
|
|
r=Tcl_GetStringResult(interp);
|
|
memset(result,' ',80);
|
|
memmove(result,r,min(strlen(r),80));
|
|
}
|
|
|
|
int
|
|
Tcl_AppInit(Tcl_Interp *interp) {
|
|
if (Tcl_Init(interp) == TCL_ERROR) {
|
|
return TCL_ERROR;
|
|
}
|
|
if (Tk_Init(interp) == TCL_ERROR) {
|
|
return TCL_ERROR;
|
|
}
|
|
Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit);
|
|
Tcl_SetVar(interp, "tcl_rcFileName", "~/.wishrc", TCL_GLOBAL_ONLY);
|
|
return TCL_OK;
|
|
}
|
|
|