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

///////////////////////////////////////////////////////////////////////////////
//
//  TclDbTbl.pas
//	Copyright(c) 1996-1997 William Byrne
//		WilliamB@ByrneLitho.com
//		76262.13@CompuServe.com
//
//	All rights reserved.
//  	William Byrne makes no representations about the suitability of this
//    	software for any purpose.  It is provided "as is" without express or
//    	implied warranty.
//
//	Usage
//      I hereby grant to the legal purchasors of the source code contained
//      herein a non-exclusive license for the use of said source code in
//      developing compiled, executable software, and for the distribution of
//      said source code as part of said developed, compiled, executable software.
//
//	Editor:
//		Tab stops = 4
//		Page width = 132 characters
//		Font = Courier New, 8pt
//
//  Misc:
//      ??? = Note to self


interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Tslc, TclTk;

type
  TWaitMod = class(TDataModule)
    Tcl1: TTcl;
    TclCmd_vwait: TTclCommand;
    TclCmd_tkwait: TTclCommand;
    TclTimer1: TTclTimer;
    TclCmd_load: TTclCommand;
    procedure TclCmd_vwaitCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_vwaitScriptDelete(Sender: TTclCommand;
      AInterp: pTcl_Interp);
    procedure TclCmd_tkwaitCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_tkwaitScriptDelete(Sender: TTclCommand;
      AInterp: pTcl_Interp);
    procedure TclTimer1Timer(Sender: TTclTimer);
    procedure Tcl1InterpDelete(Sender: TObject; AInterp: pTcl_Interp);
    procedure WaitModCreate(Sender: TObject);
    procedure WaitModDestroy(Sender: TObject);
    procedure Tcl1AfterInitInterp(Sender: TObject; AInterp: pTcl_Interp);
    procedure TclCmd_loadCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_tkwaitInterpDelete(Sender: TObject;
      AInterp: pTcl_Interp);
    procedure TclCmd_vwaitInterpDelete(Sender: TObject;
      AInterp: pTcl_Interp);
  private
    { Private declarations }
	FVwaitInfo: Tcl_CmdInfo;
    FVwaitList: TStringList;
    FTkwaitInfo: Tcl_CmdInfo;
    FTkwaitList: TStringList;
    FLoadInfo: Tcl_CmdInfo;
  public
    { Public declarations }
    procedure KillVwait;
    procedure Serve(AClient: TTcl);
    procedure Unserve(AClient: TTcl);

  end;

procedure KillVwait;

function WaitMod: TWaitMod;

implementation
uses TslcPlat;
{$R *.DFM}


var
  FWaitMod: TWaitMod = nil;

function WaitMod: TWaitMod;
begin
	if FWaitMod = nil then
    	FWaitMod := TWaitMod.Create(nil);
    result := FWaitMod;
end;

procedure KillVwait;
begin
	WaitMod.KillVwait;
end;

procedure TWaitMod.Serve(AClient: TTcl);
var
	x: integer;
begin
	if AClient = nil then // ??? should also check for redundancy
    	exit;

	for x:= 0 to ComponentCount - 1 do
    	if (Components[x] is TTclBridge) and (TTclBridge(Components[x]).Client = AClient) then
			exit;
            
    with TTclBridge.Create(Self) do
    begin
        Options := Options + [boFreeOnClientFree];
    	Server := Tcl1;
        Client := AClient;
    end;
end;


procedure TWaitMod.Unserve(AClient: TTcl);
var
    x: integer;
begin

	for x:= 0 to ComponentCount - 1 do
    	if (Components[x] is TTclBridge) and (TTclBridge(Components[x]).Client = AClient) then
        begin
        	Components[x].Free;
            break;
        end;
end;

//
// The next few procedures deal primarily with the *vwait* and *tkwait* event loop commands. Together they
// provide the means to terminate *vwait* event loops by making a call to the procedure KillVwait.
//

//{$O-}
procedure TWaitMod.Tcl1AfterInitInterp(Sender: TObject;
  AInterp: pTcl_Interp);
begin

	// Let's get the internal Tcl function that handles the *vwait* command.
    // We'll mask calls to the original *vwait* so we can capture the script variable that must be
    // set to terminate the loop. Note below that a bogus event generator, TclTimer1, is used
    // to promote an event cycle in situations where there are no other events waiting.
	if (Tcl_GetCommandInfo(AInterp, 'vwait', FVwaitInfo) <> 0) then // The expected native command info should always be the same.
	begin
        if IsTslcCmdInfo(TclCmd_vwait, @FVwaitInfo, nil) then // oops... our command installed prior to this AfterInitInterp event
        	TclError('Potential infinite recursion in "vwait" command');
        TclCmd_vwait.Install(AInterp); // coAutoInstall is unset so we'll manually install. Necessary in order to get native command.
    end;


    // Do the same for Tk's *tkwait*. Potentially replaced by Tk package's version of the 'tkwait' command due to dynamic load of Tk.
    if (Tcl_GetCommandInfo(AInterp, 'tkwait', FTkwaitInfo) <> 0) then
    begin
		if IsTslcCmdInfo(TclCmd_tkwait, @FTkwaitInfo, nil) then
        	TclError('Potential infinite recursion in "tkwait" command');
        TclCmd_tkwait.Install(AInterp);
    end;

    // Do the same for Tcl's *load*
    if (Tcl_GetCommandInfo(AInterp, 'load', FLoadInfo) <> 0) then
    begin
		if IsTslcCmdInfo(TclCmd_load, @FLoadInfo, nil) then
        	TclError('Potential infinite recursion in "load" command');
        TclCmd_load.Install(AInterp);
    end;
end;

// Replaces original Tcl Command *vwait* so we can conveniently abort script loops
procedure TWaitMod.TclCmd_vwaitCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	if True {@FVwaitProc <> nil} then
    begin
    	if Sender.Argc > 1 then // else, InvokeTclProc(*vwait*) will return TCL_ERROR
        						// As of Tcl8.0, argc = 2 or fail; however, future releases
                                // ?may? allow for additional args...
			FVwaitList.addObject( Sender.Argv[1], TObject(Sender.Interp));
		// this duration of this call depends on the script event loop
    	success := Sender.InvokeCmd(@FVwaitInfo) = TCL_OK;
        result := Sender.InterpResult;
    end else
    	TclError(Sender.ErrorMsg); // never found original *vwait*
end;

procedure TWaitMod.TclCmd_tkwaitCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	if True {@FTkwaitProc <> nil} then
    begin
    	if Sender.Argc > 2 then // else, InvokeTclProc(*tkwait*) will return TCL_ERROR
        						// As of Tk8.0, argc = 3 or fail; however, future releases
                                // ?may? allow for additional args...
			if TslcTextEqual(Sender.Argv[1], 'variable') then
				FTkwaitList.addObject( Sender.Argv[2], TObject(Sender.Interp));
		// this duration of this call depends on the script event loop
    	success := Sender.InvokeCmd(@FTkwaitInfo) = TCL_OK;
        result := Sender.InterpResult;
    end else
    	TclError(Sender.ErrorMsg); // never found original *tkwait*
end;

procedure TWaitMod.KillVwait;
var
	x: integer;
begin
	TclTimer1.Active := True; // this timer is necessary to generate an event so the script loop will cycle.
    						  // It's analogous to messages for Windows.GetMessage.
                              // This particular SetVar is analogous to PostMessage(WM_QUIT); though, limited to
                              //   the *vwait* event loop.
                              // The FVwaitList handles situations where there are nested *vwait* and/or
                              //   multiple/slave interpreters.
	with FVwaitList do
    	for x := Count - 1 downto 0 do // last in first out
        try
        	SetVar(pTcl_Interp(Objects[x]), Strings[x], '', 'User Aborted', []);
        finally
        	Delete(x); // Get rid of it even if there was a problem
        end;
	with FTkwaitList do
    	for x := Count - 1 downto 0 do // last in first out
        try
        	SetVar(pTcl_Interp(Objects[x]), Strings[x], '', 'User Aborted', []);
        finally
        	Delete(x); // Get rid of it even if there was a problem
        end;

end;

procedure TWaitMod.TclCmd_vwaitScriptDelete(Sender: TTclCommand;
  AInterp: pTcl_Interp);
var
	idx: integer;
begin
	while False do // house cleaning...
    begin
		idx := FVwaitList.IndexOfObject(TObject(AInterp));
    	if idx >= 0 then
    		FVwaitList.Delete(idx)
        else
        	break;
    end;
end;

procedure TWaitMod.TclCmd_vwaitInterpDelete(Sender: TObject;
  AInterp: pTcl_Interp);
var
	idx: integer;
begin
	while true do // house cleaning...
    begin
		idx := FVwaitList.IndexOfObject(TObject(AInterp));
    	if idx >= 0 then
    		FVwaitList.Delete(idx)
        else
        	break;
    end;
end;

procedure TWaitMod.TclCmd_tkwaitScriptDelete(Sender: TTclCommand;
  AInterp: pTcl_Interp);
var
	idx: integer;
begin
	while False do // house cleaning...
    begin
		idx := FTkwaitList.IndexOfObject(TObject(AInterp));
    	if idx >= 0 then
    		FTkwaitList.Delete(idx)
        else
        	break;
    end;
end;

procedure TWaitMod.TclCmd_tkwaitInterpDelete(Sender: TObject;
  AInterp: pTcl_Interp);
var
	idx: integer;
begin
	while true do // house cleaning...
    begin
		idx := FTkwaitList.IndexOfObject(TObject(AInterp));
    	if idx >= 0 then
    		FTkwaitList.Delete(idx)
        else
        	break;
    end;
end;

procedure TWaitMod.TclTimer1Timer(Sender: TTclTimer);
begin
	// The presence of this timer event handler is enough to cycle an event loop for *vwait*
    // If this event handler did exist and there were no other event generators/sources such as
    // sockets or file reads, then the *vwait* loop would wait indefinitely
    // Note that the Tcl Win port responds to WM_QUIT by calling Tcl_Exit, a Tcl API function that
    // terminates the current process.
	if (FVwaitList.Count = 0) and (FTkwaitList.Count = 0) then
    	Sender.Active := False; // If count = 0, then we've set all the *vwait* terminator variables
        						// we've listed in FVwaitList; therefor, turn off the timer since it
                                // serves no other purpose for normal script evaluation.
end;

procedure TWaitMod.Tcl1InterpDelete(Sender: TObject; AInterp: pTcl_Interp);
begin
    TclCmd_tkwaitScriptDelete(nil, AInterp);
    TclCmd_vwaitScriptDelete(nil, AInterp);
    TclTimer1Timer(TclTimer1);
end;

// We interested in making sure that our version of the *tkwait* command is available.
// By intercepting the *load* command, we can check for situations where our *tkwait* was
// replaced by that of another package. This isn't bullet-proof; however, it's fairly practicle.
procedure TWaitMod.TclCmd_loadCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	cmdInfo: Tcl_CmdInfo;
begin
	if True {@FLoadProc <> nil} then
    begin
    	success := Sender.InvokeCmd(@FLoadInfo) = TCL_OK;
        result := Sender.InterpResult;

	    if (Tcl_GetCommandInfo(Sender.Interp, 'tkwait', cmdInfo) <> 0) then
    	begin
        	if not IsTslcCmdInfo(TclCmd_tkwait, @cmdInfo, nil) then
            begin
		    	FTkwaitInfo := cmdInfo;
                TclCmd_tkwait.Install(Sender.Interp);
            end;
	    end;

    end else
    	TclError(Sender.ErrorMsg); // never found original *load*
end;

//
// Done *vwait* and *tkwait*
//

procedure TWaitMod.WaitModCreate(Sender: TObject);
begin
    FVwaitList := TStringList.Create;
    FTkwaitList := TStringList.Create;
end;

procedure TWaitMod.WaitModDestroy(Sender: TObject);
begin
	FVwaitList.Free;
    FTkwaitList.Free;
end;

initialization

finalization
	FWaitMod.Free;

end.
