{ -----------------------------------------------------------------------
Tcl Scripting Language Components (Tslc)
Copyright (C) 1996-2002 William Byrne

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

WilliamB@ByrneLitho.com
------------------------------------------------------------------------}
unit tkMain;

interface

uses TclTk, Tslc;

procedure Tslc_Main(interp: pTcl_Interp);

implementation
uses TkConsole;

var
	command:	Tcl_DString;
    line:		Tcl_DString;
	interp: pTcl_Interp;

procedure Prompt(interp: pTcl_Interp; partial: integer); cdecl;
var
	promptCmd: pChar;
    code: integer;
    outChannel, errChannel: pTcl_Channel;
begin

	if partial <> 0 then
    	promptCmd := Tcl_GetVar(interp, 'tcl_prompt2', TCL_GLOBAL_ONLY)
    else
        promptCmd := Tcl_GetVar(interp, 'tcl_prompt1', TCL_GLOBAL_ONLY);

    if promptCmd = nil then
    begin
		if partial = 0 then
		begin
		    outChannel := Tcl_GetChannel(interp, 'stdout', nil);
    	    if outChannel <> nil then
                Tcl_Write(outChannel, '% ', 2);
        end;
	end else
    begin
    	code := Tcl_Eval(interp, promptCmd);
        if code <> TCL_OK then
        begin
        	Tcl_AddErrorInfo(interp, #13 + '    (script that generates prompt)');
            errChannel := Tcl_GetChannel(interp, 'stderr', nil);
            if errChannel <> nil then
            begin
            	Tcl_Write(errChannel, interp^.result, -1);
                Tcl_Write(errChannel, #13, 1);
            end;
			if partial = 0 then
			begin
			    outChannel := Tcl_GetChannel(interp, 'stdout', nil);
    	    	if outChannel <> nil then
                	Tcl_Write(outChannel, '% ', 2);
	        end;
        end;
    end;

    outChannel := Tcl_GetChannel(interp, 'stdout', nil);
    if outChannel <> nil then
        Tcl_Flush(outChannel);
end;

procedure StdinProc(clientData: Tcl_ClientData; mask: integer); cdecl;
const
	gotPartial: integer = 0;
label
	GoPrompt;
var
	cmd: pChar;
    code, count: integer;
    chan: pTcl_Channel;
begin

	chan := pTcl_Channel(clientData);

    count := Tcl_Gets(chan, @line);

    if (count < 0) and (gotPartial = 0) then
       	TclError('StdInProc wants exit');

    Tcl_DStringAppend(@command, line.str, -1);
    cmd := Tcl_DStringAppend(@command, #13, -1);
    Tcl_DStringFree(@line);

    if Tcl_CommandComplete(cmd) = 0 then
    begin
        gotPartial := 1;
        goto GoPrompt
	end;
    gotPartial := 0;


    Tcl_CreateChannelHandler(chan, 0, StdinProc, Tcl_ClientData(chan));
    code := Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL);
    Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, Tcl_ClientData(chan));
    Tcl_DStringFree(@command);
{
    if interp^.result[0] <> #0 then
	    puts(interp^.result);
}

GoPrompt:

	Prompt(interp, gotPartial);
    Tcl_ResetResult(interp);

end;

procedure Tslc_Main(interp: pTcl_Interp);
var
	inChannel, outChannel: pTcl_Channel;
begin

	TkConsoleCreate;
	tkMain.interp := interp;
{    if appInitProc(interp) <> TCL_OK then
    	TclError(interp^.result);}

//  	Tcl_StaticPackage(interp, 'Tk', Tk_Init, Tk_SafeInit);
    TkConsoleInit(interp);



{	Tcl_SourceRCFile(interp); }


	inChannel := Tcl_GetStdChannel(TCL_STDIN);
	if inChannel <> nil then
	    Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, Tcl_ClientData(inChannel));
    Prompt(interp, 0);

    outChannel := Tcl_GetStdChannel(TCL_STDOUT);
    if outChannel <> nil then
		Tcl_Flush(outChannel);

    Tcl_DStringInit(@command);
    Tcl_DStringInit(@line);
    Tcl_ResetResult(interp);

    while Tk_GetNumMainWindows > 0 do
    	Tcl_DoOneEvent(0);

end;


end.

