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

interface
uses Classes, SysUtils, Forms, TclTk, Tslc;
//{$D-}
type

	TTclThreadServerClass = class of TTclThreadServer;
	TTclThreadServer = class(TDataModule)
    private
    	FThreadId: integer;
    protected
		constructor Create(AOwner: TComponent; AThreadId: integer); virtual;
        procedure ReadState(reader: TReader); override;
		procedure ReadFix(Reader: TReader; const Message: string; var Handled: Boolean);
    public
		destructor Destroy; override;
		procedure Free;
        class function GetThreadServer(AClass: TTclThreadServerClass; AThreadId: integer): TTclThreadServer;
		procedure ReleaseThreadServer;
        procedure Serve(AClient: TTcl); virtual; abstract;
        procedure ServeInterp(AInterp: pTcl_Interp); virtual; abstract;

        property ThreadId: integer read FThreadId;
    end;


procedure RegisterTclServer(AClass: TTclThreadServerClass);

implementation
uses TslcPlat;

//{$DEFINE TRACE}

type
//	ppServerRecord = ^pServerRecord;
	pServerRecord = ^TServerRecord;
	TServerRecord = record
    	threadId:	integer;
        server:		TTclThreadServer;
        refs:		integer;
        next:		pServerRecord;
    end;

	pServerList = ^TServerList;
	TServerList = record
    	_class:		TComponentClass;
        pSR:		pServerRecord;
        next:		pServerList;
    end;

var
	ServerList: pServerList = nil;

procedure RegisterTclServer(AClass: TTclThreadServerClass); // Do this before threads.
var
	s: pServerList;
begin
    New(s);
    s^._class := AClass;
    s^.pSR := nil;
    s^.next := ServerList;
    ServerList := s;
end;


function FindServerList(AClass: TTclThreadServerClass): pServerList;
begin
	result := ServerList;
    while result <> nil do
    begin
    	if result^._class = AClass then
        	break;
        result := result^.next;
    end;

    if result = nil then
		TclErrorFmt('%s not registered as a Tcl Server', [AClass.ClassName]);
end;

procedure TTclThreadServer.ReadState(reader: TReader);
begin
	reader.OnError := ReadFix;
    inherited ReadState(reader);
end;

procedure TTclThreadServer.ReadFix(Reader: TReader; const Message: string; var Handled: Boolean);
begin
	Handled := True;
end;

class function TTclThreadServer.GetThreadServer(AClass: TTclThreadServerClass; AThreadId: integer): TTclThreadServer;
var
	r, last: pServerRecord;
    l: pServerList;
begin

	TslcEnterCritical;
    try
		l := FindServerList(AClass);
	    r := l.pSR;
	    last := nil;
	    while r <> nil do
	    begin
			if r^.threadId = AThreadId then
	        begin
	        	result := r^.Server;
	            break;
	        end;
	        last := r;
	        r := r^.next;
	    end;

		if r = nil then
	    begin
			result := TTclThreadServer(l^._class.NewInstance);
	        result.Create(nil, AThreadId);
			New(r);
	        r^.threadId := AThreadId;
	        r^.next := nil;
	        r^.refs := 0;
			r^.Server := result;
			if last = nil then
	        	l^.pSR := r
	        else
				last^.next := r;
	    end;
	    inc(r^.refs);
    finally
    	TslcLeaveCritical;
    end;
end;

var
	ShuttingDown: boolean = False;

procedure TTclThreadServer.ReleaseThreadServer;
var
    r, last: pServerRecord;
    l: pServerList;
    id: integer;
begin
    TslcEnterCritical;
    try
    	if not ShuttingDown then
        begin
        	l := FindServerList(TTclThreadServerClass(ClassType));
			r := l^.pSR;
            last := nil;
            while r <> nil do
            begin
				if (r^.threadId = FThreadId) and (r^.Server = Self) then
                begin
					dec(r^.refs);
                    if r^.refs = 0 then
                    begin
	                    if last = nil then
	                    	l^.pSR := r^.next
	                    else
	                    	last^.next := r^.next;
						Dispose(r);
{$IFDEF TRACE}
						id := ThreadId;
						TslcClientTrace(format('TSLCMOD: Release Thread Server - Destroying Module Thread Id: %d',[id]), tkEnter);
                        Destroy;
						TslcClientTrace(format('TSLCMOD: Release Thread Server - Destroyed Module Thread Id: %d',[id]), tkExit);
{$ELSE}
						Destroy;
{$ENDIF}
                    end;
                    break;
                end;
                last := r;
                r := r^.next;
            end;
        end;
    finally
    	TslcLeaveCritical;
    end;
end;


constructor TTclThreadServer.Create(AOwner: TComponent; AThreadId: integer);
begin
    try
        // Getting EReadError's due to missing property ???
        // Good chance the DFM contains invalid properties from another Delphi version
        // Adding EReadError to the debug ignore exception list will mask warnings
        // Tools->Debugger Options->Language Exceptions
    	inherited Create(AOwner);
    except
        on EReadError do;
    end;
    FThreadId := AThreadId;
end;

destructor TTclThreadServer.Destroy;
begin
	Destroying;
    inherited Destroy;
end;

procedure TTclThreadServer.Free;
begin
	if Self <> nil then
    	ReleaseThreadServer;
end;

procedure CleanUpList;
var
	rfirst, rnext: pServerRecord;
    lnext: pServerList;
begin
{$IFDEF TRACE}
	TslcClientTrace('TSLCMOD - Cleaning Up', tkXNEST);
{$ENDIF}

	TslcEnterCritical;
    try
		ShuttingDown := True;
        while ServerList <> nil do
        begin
        	rfirst := ServerList^.pSR;
            while rfirst <> nil do
            begin
            	try
                	rfirst^.Server.Free;
                except
                end;
                rnext := rfirst^.next;
                Dispose(rfirst);
                rfirst := rnext;
            end;
            lnext := ServerList^.next;
            Dispose(ServerList);
            ServerList := lnext;
        end;
    finally
    	TslcLeaveCritical;
    end;
end;

procedure HandleException(ExceptObject: TObject; ExceptAddr: pointer);
begin
{$IFDEF TRACE}
	TslcClientTrace(format('TSLCMOD EXCEPTION: %s',[Exception(ExceptObject).Message]), tkXNEST);
{$ENDIF}
end;

initialization
	TslcPrepareCritical;
	TslcPrepareTrace;
    ExceptProc := @HandleException;
finalization
	CleanUpList;
    TslcDoneTrace;
    TslcDoneCritical;
end.
