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

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Tslc, DB, DBTables, TkPanel;

type
  TForm1 = class(TForm)
    Button1: TButton;
    DataLabel1: TLabel;
    DataLabel2: TLabel;
    Memo1: TMemo;
    RegLabel1: TLabel;
    RegLabel2: TLabel;
    Memo2: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
uses TclTk, TclDbDef, uTslcBde;

{$R *.DFM}
type
	TTclThread = class(TThread)
    public
    	id: integer;
    	dataLbl: TLabel;
    	tcl: TTcl;
        regSema: pInteger;
        regLbl: TLabel;
        reg: boolean;
        bdem: TBDEMod;
    	expr, data: string;
    	procedure Execute; override;
        procedure UpdateData;
        procedure RegThread;
        constructor Create(AData, AReg: TLabel; ARegSema: pInteger; AExpr: string);
        destructor Destroy; override;
    end;

    TShowCommand = class(TTclCommand)
    private
       	thrd: TTclThread;
    public
    	procedure DoCommand(var result: string; var success: boolean); override;
    end;

    TIterCommand = class(TTclCommand)
    private
       	thrd: TTclThread;
    public
    	procedure DoCommand(var result: string; var success: boolean); override;
    end;

var
	threadSema: integer;

constructor TTclThread.Create(AData, AReg: TLabel; ARegSema: pInteger; AExpr: string);
begin
	inherited Create(True);
    id := threadSema;
    inc(threadSema);
    FreeOnTerminate := True;
    dataLbl := AData;
    regLbl := AReg;
    regSema := ARegSema;
    expr := AExpr;
    tcl := TTcl.Create(nil);
    tcl.name := format('ThrdTcl%d', [threadSema]); // for debug
    tcl.Open;
    with TShowCommand.Create(nil) do
    begin
    	command := 'show';
        thrd := Self;
        install(Self.tcl.Interp);
    end;
    with TiterCommand.Create(nil) do
    begin
    	command := 'iter';
        thrd := Self;
        install(Self.tcl.Interp);
    end;

    bdem := TBDEMod.GetThreadServer(ThreadID);
	bdem.Serve(tcl);
end;

destructor TTclThread.Destroy;
begin
    tcl.Free;
	bdem.ReleaseThreadServer; // ??? if released prior to freeing tcl, thread exceptions occur.
	inherited Destroy;
end;

procedure TTclThread.Execute;
begin
    reg := True;
    Synchronize(RegThread);
	Synchronize(UpdateData);
	tcl.Eval(expr);
	data := tcl.result;
	Synchronize(UpdateData);
    reg := False;
    Synchronize(RegThread);
end;

procedure TTclThread.UpdateData;
begin
	dataLbl.Caption := data;
end;


procedure TTclThread.RegThread;
begin
	if reg then
    	inc(regSema^)
    else
    	dec(regSema^);
    case regSema^ of
    	0: regLbl.Caption := 'No Running Threads';
        1: regLbl.Caption := 'Running One Thread';
    else
    	regLbl.Caption := format('Running %d Concurrent Threads', [regSema^]);
    end;

end;


procedure TShowCommand.DoCommand(var result: string; var success: boolean);
begin
	with thrd do
    begin
    	data := ParamValues[0];
    	Synchronize(UpdateData);
    end;
    sleep(175);
end;


procedure TIterCommand.DoCommand(var result: string; var success: boolean);
begin
	result := inttostr(thrd.id);
end;

var
	s1, s2: integer;

procedure TForm1.Button1Click(Sender: TObject);
const
	cSimpleCounter = 'for { set x 0 } {$x < 100} {incr x} { show $x; }';
var
	t, t2: TTclThread;
begin

	t := TTclThread.Create(DataLabel1, RegLabel1, @s1, Memo1.Lines.Text);
//	t.expr := cSimpleCounter;

	t2 := TTclThread.Create(DataLabel2, RegLabel2, @s2, Memo2.Lines.Text);
//    t2.expr := cSimpleCounter;

	t2.Resume;
	t.Resume;
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
	TslcCriticalEvals(False);
end;

procedure LoadHook(clientData: pointer);
begin
	if clientData = pointer(0) then
    	Form1.Caption := 'Threads - Loading Tcl Engine'
    else
    	Form1.Caption := 'Threads - Tcl Engine Loaded';

end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
	CanClose := not (((s1 > 0) or (s2 > 0)) and
    	(MessageDlg('Active Threads!' + #13 + 'Are you sure you want to close?', mtConfirmation, mbYesNoCancel, 0) <> mrYes));
end;

initialization
	AddTslcLibHook(@LoadHook, pointer(0), thBeforeTclLoad);
    AddTslcLibHook(@LoadHook, pointer(1), thAfterTclLoad);

end.
