{ -----------------------------------------------------------------------
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 tkConsole;

interface
uses TclTk, Tslc;

type
    TTclConsoleCommand = class(TTclCommand)
    private
    	FConsoleInterp: pTcl_Interp;
    protected
       	procedure DoCommand(var newValue: string; var success: boolean); override;
        procedure DoInterpDelete(AInterp: pTcl_Interp); override;
    public
    	constructor Create(AInterp, AConsoleInterp: pTcl_Interp);
        destructor Destroy; override;
    end;

    TTclConsoleInterpCommand = class(TTclCommand)
    private
    	FOtherInterp: pTcl_Interp;
    protected
       	procedure DoCommand(var newValue: string; var success: boolean); override;
        procedure DoInterpDelete(AInterp: pTcl_Interp); override;
    public
    	constructor Create(AInterp, AOtherInterp: pTcl_Interp);
        destructor Destroy; override;
    end;



procedure TkConsoleCreate;
function TkConsoleInit(interp: pTcl_Interp): integer;
procedure TkConsolePrint(interp: pTcl_Interp; devId: integer; buffer: pChar; size: longint); cdecl;
procedure ConsoleEventProc(clientData: Tcl_ClientData; eventPtr: pXEvent); cdecl;
function GetConsoleInterp: pTcl_Interp;

type
	TInterpCreateProc = function: pTcl_Interp;

var
	gStdoutInterp: pTcl_Interp;
    InterpCreateProc: TInterpCreateProc;

implementation
uses Windows, SysUtils;

var
	consoleChannelType: Tcl_ChannelType;
    TclCmd_console: TTclConsoleCommand;


function GetConsoleInterp: pTcl_Interp;
begin
	if TclCmd_console <> nil then
		result := TclCmd_console.FConsoleInterp
    else
    	result := nil;
end;

procedure TkConsoleCreate;
const
	cTrans = 'auto';
var
	consoleChannel: pTcl_Channel;
begin
    consoleChannel := Tcl_CreateChannel(@consoleChannelType, 'console0', Tcl_ClientData(TCL_STDIN), TCL_READABLE);
	if consoleChannel <> nil then
    begin
    	Tcl_SetChannelOption(nil, consoleChannel, '-translation', cTrans);
        Tcl_SetChannelOption(nil, consoleChannel, '-buffering', 'none');
    end;
    Tcl_SetStdChannel(consoleChannel, TCL_STDIN);
    consoleChannel := Tcl_CreateChannel(@consoleChannelType, 'console1', Tcl_ClientData(TCL_STDOUT), TCL_WRITABLE);
	if consoleChannel <> nil then
    begin
    	Tcl_SetChannelOption(nil, consoleChannel, '-translation', cTrans);
        Tcl_SetChannelOption(nil, consoleChannel, '-buffering', 'none');
    end;
    Tcl_SetStdChannel(consoleChannel, TCL_STDOUT);
    consoleChannel := Tcl_CreateChannel(@consoleChannelType, 'console2', Tcl_ClientData(TCL_STDERR), TCL_WRITABLE);
	if consoleChannel <> nil then
    begin
    	Tcl_SetChannelOption(nil, consoleChannel, '-translation', cTrans);
        Tcl_SetChannelOption(nil, consoleChannel, '-buffering', 'none');
    end;
    Tcl_SetStdChannel(consoleChannel, TCL_STDERR);
end;


procedure OnDeleteConsoleInterp(clientData: Tcl_ClientData; interp: pTcl_Interp); cdecl;
begin
	// Precaution: sets ConsoleInterp to nil in the event the interpreter is deleted in script
	if (clientData <> nil) and (clientData = TclCmd_console) and (TclCmd_console.FConsoleInterp = interp) then
		TclCmd_console.FConsoleInterp := nil;
end;

function TkConsoleInit(interp: pTcl_Interp): integer;
const
	initCmd = 'source $tk_library/console.tcl';
var
	consoleInterp: pTcl_Interp;
    mainWindow: pTk_Window;
    buf: array[0..255] of char;
begin

	result := TCL_ERROR;

    mainWindow := Tk_MainWindow(interp);
    if mainWindow = nil then
    	TclError(Tcl_GetStringResult(interp));
    Tk_MakeWindowExist(mainWindow);
	if Assigned(InterpCreateProc) then
    	consoleInterp := InterpCreateProc
    else
		consoleInterp := Tcl_CreateInterp;

    if consoleInterp = nil then
    	exit;

    try
        if Tcl_Init(consoleInterp) <> TCL_OK then
        	TclError(Tcl_GetStringResult(consoleInterp));
        if Tk_Init(consoleInterp) <> TCL_OK then
        	TclError(Tcl_GetStringResult(consoleInterp));
        gStdoutInterp := interp;
		TclCmd_console := TTclConsoleCommand.Create(interp, consoleInterp);
        Tcl_CallWhenDeleted(consoleInterp, OnDeleteConsoleInterp, TclCmd_console);
		TTclConsoleInterpCommand.Create(consoleInterp, interp);

        Tk_CreateEventHandler(mainWindow, StructureNotifyMask, ConsoleEventProc, TclCmd_console);

        Tcl_Preserve(consoleInterp);
        if Tcl_Eval(consoleInterp, initCmd) <> TCL_OK then
        	MessageBox(0, Tcl_GetStringResult(consoleInterp), 'Eval Error', MB_ICONSTOP);
		Tcl_Release(consoleInterp);
// attempting to force initialization of Tk stuff
//		Tk_MakeWindowExist(Tk_MainWindow(consoleInterp));
// end

        result := TCL_OK;
        exit;
    except
    	Tcl_DeleteInterp(consoleInterp);
        raise;
    end;
end;

function ConsoleOutput(instanceData: Tcl_ClientData; buf: pChar; toWrite: integer; errorCode: pInteger): integer; cdecl;
begin
	errorCode^ := 0;
    Tcl_SetErrno(0);
    if gStdoutInterp <> nil then
    	TkConsolePrint(gStdoutInterp, integer(instanceData), buf, toWrite);
    result := toWrite;
end;

function ConsoleInput(instanceData: Tcl_ClientData; buf: pChar; bufSize: integer; errorCode: pInteger): integer; cdecl;
begin
	result := 0;
end;

function ConsoleClose(instanceData: Tcl_ClientData; interp: pTcl_Interp): integer; cdecl;
begin
	result := 0;
end;

procedure ConsoleWatch(instanceData: Tcl_ClientData; mask: integer); cdecl;
begin
end;

function ConsoleHandle(instanceData: Tcl_ClientData; direction: integer; handlePtr: Tcl_ClientData): integer; cdecl;
begin
	result := TCL_ERROR;
end;

procedure TTclConsoleCommand.DoCommand(var newValue: string; var success: boolean);
var
	dString: Tcl_DString;
    c: char;
    len: integer;
    prm: string;

	function IsStr(str: pChar): boolean;
    begin
        result := ( c = str^) and (strlcomp(pChar(prm), str, len) = 0)
	end;
begin
	if ParamValuesCount < 1 then
    	TclErrorFmt('wrong # args: should be "%s option ?arg arg ...?"',[Command]);

	prm := ParamValues[0];
	c := prm[1];
	len := Length(prm);

	Tcl_Preserve(FConsoleInterp);
    try
		if IsStr('title') then
    	begin
    		Tcl_DStringInit(@dString);
	        Tcl_DStringAppend(@dString, 'wm title .', -1);
	        if ParamValuesCount = 2 then
				Tcl_DStringAppendElement(@dString, pChar(ParamValues[1]));
	        Tcl_Eval(FConsoleInterp, dString.str);
	        Tcl_DStringFree(@dString);
	    end else if IsStr('hide') then
	    	Tcl_Eval(FConsoleInterp, 'wm withdraw .')
	    else if IsStr('show') then
	    	Tcl_Eval(FConsoleInterp, 'wm deiconify .')
		    else if IsStr('eval') then
	    begin
	    	if ParamValuesCount = 2 then
	        	Tcl_Eval(FConsoleInterp, pChar(ParamValues[1]))
    	    else
	        	TclErrorFmt('wrong # args: should be "%s eval command"', [Command]);
	    end else
	    	TclErrorFmt('bad option %s: should be hide, show, or title', [ParamValues[0]]);
	finally
    	Tcl_Release(FConsoleInterp);
    end;
end;

procedure TTclConsoleInterpCommand.DoCommand(var newValue: string; var success: boolean);
var
    c: char;
    len: integer;
    prm, str: string;
    result: integer;

	function IsStr(str: pChar): boolean;
    begin
        result := ( c = str^) and (strlcomp(pChar(prm), str, len) = 0)
	end;
begin
	if ParamValuesCount < 1 then
    	TclErrorFmt('wrong # args: should be "%s option ?arg arg ...?"',[Command]);

	prm := ParamValues[0];
	c := prm[1];
	len := Length(prm);

	Tcl_Preserve(FOtherInterp);
    try
    	if IsStr('eval') then
        begin
        	success := Tcl_GlobalEval(FOtherInterp, pChar(ParamValues[1])) = TCL_OK;
            newValue := Tcl_GetStringResult(Interp) + '' + Tcl_GetStringResult(FOtherInterp);
		end else if IsStr('record') then
        begin
        	Tcl_RecordAndEval(FOtherInterp, pChar(ParamValues[1]), TCL_EVAL_GLOBAL);
            newValue := Tcl_GetStringResult(Interp) + '' + Tcl_GetStringResult(FOtherInterp);
		end else
	    	TclErrorFmt('bad option %s: should be eval or record', [ParamValues[0]]);
	finally
    	Tcl_Release(FOtherInterp);
    end;
end;

constructor TTclConsoleCommand.Create(AInterp, AConsoleInterp: pTcl_Interp);
begin
	inherited Create(nil);
    Command := 'console';
	FConsoleInterp := AConsoleInterp;
	Install(AInterp);
end;

constructor TTclConsoleInterpCommand.Create(AInterp, AOtherInterp: pTcl_Interp);
begin
	inherited Create(nil);
    Command := 'consoleinterp';
	FOtherInterp := AOtherInterp;
	Install(AInterp);
end;

destructor TTclConsoleCommand.Destroy;
begin
	inherited Destroy;
end;

procedure TTclConsoleCommand.DoInterpDelete(AInterp: pTcl_Interp);
begin
	if FConsoleInterp <> nil then
    	Tcl_DeleteInterp(FConsoleInterp);
	Free;
    TclCmd_console := nil;
end;

destructor TTclConsoleInterpCommand.Destroy;
begin
	inherited Destroy;
end;

procedure TTclConsoleInterpCommand.DoInterpDelete(AInterp: pTcl_Interp);
begin
	Free;
end;

procedure ConsoleEventProc(clientData: Tcl_ClientData; eventPtr: pXEvent); cdecl;
begin
	if eventPtr^.typ = DestroyNotify then
    with TTclConsoleCommand(clientData) do
    begin
		if FConsoleInterp = nil then
        	exit;
        Tcl_Preserve(FConsoleInterp);
        Tcl_Eval(FConsoleInterp, 'tkConsoleExit');
        Tcl_Release(FConsoleInterp);
    end;
end;

procedure TkConsolePrint(interp: pTcl_Interp; devId: integer; buffer: pChar; size: longint); cdecl;
var
	command, output: Tcl_DString;
    cmdInfo: Tcl_CmdInfo;
    cmd: pChar;
begin

	if (interp = nil) then
    	exit;

    if devId = TCL_STDERR then
    	cmd := 'tkConsoleOutput strderr'
    else
    	cmd := 'tkConsoleOutput stdout';

    if Tcl_GetCommandInfo(interp, 'console', cmdInfo)  = 0 then
    	exit;

    Tcl_DStringInit(@output);
    Tcl_DStringAppend(@output, buffer, size);

	Tcl_DStringInit(@command);
    Tcl_DStringAppend(@command, cmd, strlen(cmd));
    Tcl_DStringAppendElement(@command, output.str);

	cmd := command.str;
    if cmdInfo.IsNativeObjectProc <> 0 then
    with TTclConsoleCommand(cmdInfo.ObjClientData) do
    begin
    	if FConsoleInterp <> nil then
        begin
	    	Tcl_Preserve(FConsoleInterp);
	        Tcl_Eval(FConsoleInterp, cmd);
	        Tcl_Release(FConsoleInterp);
        end;
    end else
    with TTclConsoleCommand(cmdInfo.ClientData) do
    begin
    	if FConsoleInterp <> nil then
        begin
	    	Tcl_Preserve(FConsoleInterp);
	        Tcl_Eval(FConsoleInterp, cmd);
	        Tcl_Release(FConsoleInterp);
        end;
    end;

    Tcl_DStringFree(@command);
    Tcl_DStringFree(@output);
end;


initialization
	with ConsoleChannelType do
    begin
    	typeName		:= 'console';
        blockModeProc	:= nil;
        closeProc		:= @ConsoleClose;
        inputProc		:= @ConsoleInput;
        ouputProc		:= @ConsoleOutput;
        seekProc		:= nil;
        setOptionProc	:= nil;
        getOptionProc	:= nil;
        watchProc		:= @ConsoleWatch;
        getHandleProc	:= @ConsoleHandle;
	end;

finalization
end.


function ConsoleOutput(instanceData: Tcl_ClientData; buf: pChar; toWrite: integer; errorCode: pInteger): integer; cdecl;
function ConsoleInput(instanceData: Tcl_ClientData; buf: pChar; bufSize: integer; errorCode: pInteger): integer; cdecl;
function ConsoleClose(instanceData: Tcl_ClientData; interp: pTcl_Interp): integer; cdecl;
procedure ConsoleWatch(instanceData: Tcl_ClientData; mask: integer); cdecl;
function ConsoleHandle(instanceData: Tcl_ClientData; direction: integer; handlePtr: Tcl_ClientData): integer; cdecl;

