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

interface

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

type
  TUtilityMod = class(TTclThreadServer)
    TclUtility: TTcl;
    TclCmd_Stream: TTclCommand;
    TclCmd_Tslc: TTclCommand;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    TclCmd_Critical: TTclCommand;
    TclCmd_System: TTclCommand;
    TclCmd_Hash: TTclCommand;
    procedure TclCmd_StreamCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_TslcCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclUtilityAfterInitInterp(Sender: TObject; AInterp: pTcl_Interp);
    procedure TclCmd_CriticalCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_SystemCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_HashCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
  private
    { Private declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent; AThreadId: integer); override;
	class function GetThreadServer(AThreadId: integer): TUtilityMod;
    procedure Serve(AClient: TTcl); override;
    procedure ServeInterp(AInterp: pTcl_Interp); override;
    procedure Unserve(AClient: TTcl);
  end;


  TTclCommandBuffer = class(TTclCommand)
  private
  	FNullSubst: string;
  protected
   	procedure DoCommand(var result: string; var success: boolean); override;
    function GetCapacity: longint; virtual; abstract;
  	function GetSize: longint; virtual; abstract;
    function GetHex: string;
    function GetString: string;
    function GetTell: longint; virtual; abstract;
    procedure SetCapacity(value: longint); virtual; abstract;
    procedure SetSize(value: longint); virtual; abstract;
    procedure SetHex(value: string);
    procedure SetString(value: string);
  public
  	procedure Clear; virtual; abstract;
   	function Read(buf: pChar; count: longint): longint; virtual; abstract;
	function Seek(offset: longint; whence: integer): longint; virtual; abstract;
    function Write(buf: pChar; count: longint): longint; virtual; abstract;
    property AsString: string read GetString write SetString;
    property AsHex: string read GetHex write SetHex;
    property Capacity: longint read GetCapacity write SetCapacity;
	property NullSubst: string read FNullSubst write FNullSubst;
	property Size: longint read GetSize write SetSize;
    property Tell: longint read GetTell;
  end;


	TTclCommandStream = class(TTclCommandBuffer) // Customize TTclCommand for specific task (BDE streaming)
	private
    	FStream: TStream;
	protected
	   	procedure DoCommand(var result: string; var success: boolean); override;
	    function GetCapacity: longint; override;
	  	function GetSize: longint; override;
    	function GetTell: longint; override;
	    procedure SetCapacity(value: longint); override;
    	procedure SetSize(value: longint); override;
        procedure SetStream(AStream: TStream);
    public
    	constructor Create(AOwner: TComponent; fileName: string; mode: integer);
        destructor Destroy; override;
        procedure Clear; override;
	   	function Read(buf: pChar; count: longint): longint; override;
		function Seek(offset: longint; whence: integer): longint; override;
	    function Write(buf: pChar; count: longint): longint; override;
        property Stream: TStream read FStream write SetStream;
	end;


function StreamFromCommand(AInterp: pTcl_Interp; command: string): TStream; // throws ETclError

const
	TSLC_UTILITY_VERSION_MAJOR = 1;
	TSLC_UTILITY_VERSION_MINOR = 0;
	TSLC_UTILITY_VERSION_ISSUE = 'a';
	TSLC_UTILITY_NAME = 'TslcUtility';

procedure UtilityServeThread(AThreadId: integer; AClient: TTcl);
procedure UtilityServeThreadInterp(AThreadId: integer; AInterp: pTcl_Interp);

implementation
uses TslcUtil, TslcPlat, TslcRsrc, TslcHash, TslcDES;
{$R *.DFM}

procedure UtilityServeThread(AThreadId: integer; AClient: TTcl);
begin
	if AClient = nil then
    	exit;
	with TUtilityMod.GetThreadServer(AThreadId) do
    	Serve(AClient);
end;

procedure UtilityServeThreadInterp(AThreadId: integer; AInterp: pTcl_Interp);
begin
	if AInterp = nil then
    	exit;
	with TUtilityMod.GetThreadServer(AThreadId) do
    	ServeInterp(AInterp);
end;

class function TUtilityMod.GetThreadServer(AThreadId: integer): TUtilityMod;
begin
	result := TTclThreadServer.GetThreadServer(TUtilityMod, AThreadId) as TUtilityMod;
end;

procedure TUtilityMod.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 := TclUtility;
        Client := AClient;
    end;
end;

procedure TUtilityMod.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;



procedure TUtilityMod.ServeInterp(AInterp: pTcl_Interp);
begin
	if AInterp = nil then
    	exit;
	TclUtility.ServiceInterp(AInterp);
end;

constructor TUtilityMod.Create(AOwner: TComponent; AThreadId: integer);
begin
	InitTcl(''); // make sure Tcl procedure pointers get bound. Returns immediately if already initialized.
	inherited Create(AOwner, AThreadId);
    TclUtility.AutoActivate := False;
end;

{~~~ TTclCommandBuffer ~~~}

function TTclCommandBuffer.GetHex: string;
var
	buf, p, q: pChar;
	x, o, sz, sz2, where: integer;
begin
	sz := Size;
    where := Tell;
	GetMem(buf, sz);
    try
	    Seek(0, 0);
	    Read(buf, sz);
        sz2 := sz * 2;
    	System.SetString(result, nil, sz2);
		if Bytes2Hex(pChar(result), sz2 + 1, buf, sz) <> 0 then
        	TclError('unable to encode hex string');
    finally
    	FreeMem(buf);
		Seek(where, 0);
    end;
end;

procedure TTclCommandBuffer.SetHex(value: string);
var
	sz, sz2: integer;
    p, buf: pChar;
begin
	p := pChar(value);
	sz := strlen(p);
    sz2 := sz div 2;
    inc(sz2);
    GetMem(buf, sz2);
    try
		if Hex2Bytes(buf, sz2, p, sz) <> 0 then
        	TclError('unable to parse hex string');
        Clear;
        dec(sz2);
        Write(buf, sz2);
    finally
    	FreeMem(buf);
    end;

end;

function TTclCommandBuffer.GetString: string;
var
	buf, buf2, p, q: pChar;
    x, sz, sz2, where, nulls, len: longint;
begin
	sz := Size;
    where := Tell;
	GetMem(buf, sz);
    try
	    Seek(0, 0);
	    Read(buf, sz);
	    nulls := 0;
		if FNullSubst <> '' then
	    begin
		    p := buf;
	    	for x:= 0 to sz - 1 do
		    begin
				if p^ = #0 then
	        		inc(nulls);
		        inc(p);
	    	end;
		end;
	    if nulls = 0 then
	    	System.SetString(result, buf, sz)
	    else
        begin
        	len := strlen(pChar(FNullSubst));
            sz2 := sz + (nulls * len) - nulls;
			GetMem(buf2, sz2);
            try
            	p := buf;
                q := buf2;
                for x:= 0 to sz - 1 do
                	if p^ = #0 then
                    begin
                        strcopy(q, pChar(FNullSubst));
						inc(q, len);
                        inc(p);
                    end else
                    begin
                    	q^ := p^;
                        inc(q);
                        inc(p);
                    end;
				System.SetString(result, buf2, sz2);
            finally
            	FreeMem(buf2);
            end;
        end;
    finally
    	FreeMem(buf);
		Seek(where, 0);
    end;

end;

procedure TTclCommandBuffer.SetString(value: string);
begin
	Clear;
    Write(pChar(value), strlen(pChar(value)));
end;

procedure TTclCommandBuffer.DoCommand(var result: string; var success: boolean);
var
	cnt, i: integer;
    param, str: string;
begin
	cnt := ParamValuesCount;
    if cnt < 1 then
    	TclError(ErrorMsg);
    param := ParamValues[0];
    if TslcTextEqual(param, 'ASSTRING') then
    begin
    	if cnt > 2 then
        	TclError(ErrorMsg)
        else if cnt = 2 then
			AsString := ParamValues[1]
        else
        	result := AsString;
        exit;
    end;
	if TslcTextEqual(param, 'ASHEX') then
    begin
    	if cnt > 2 then
        	TclError(ErrorMsg)
        else if cnt = 2 then
        	AsHex := ParamValues[1]
        else
        	result := AsHex;
        exit;
    end;
    if TslcTextEqual(param, 'WRITE') then
    begin
    	if cnt <> 3 then
			TclError(ErrorMsg);
        result := inttostr(Write(pChar(ParamValues[1]), TslcStrToInt(ParamValues[2])));
        exit;
    end;
    if TslcTextEqual(param, 'READ') then
    begin
    	if cnt <> 3 then
        	TclError(ErrorMsg);
        result := inttostr(Read(pChar(ParamValues[1]), TslcStrToInt(ParamValues[2])));
        exit;
    end;
    if TslcTextEqual(param, 'SEEK') then
    begin
    	if (cnt > 3) or (cnt < 2) then
        	TclError(ErrorMsg);
    	if cnt = 2 then
        	result := inttostr(Seek(TslcStrToInt(ParamValues[1]), 0))
        else
        	result := inttostr(Seek(TslcStrToInt(ParamValues[1]), TslcStrToInt(ParamValues[2])));
        exit;
    end;
	if TslcTextEqual(param, 'TELL') then
    begin
    	if cnt > 1 then
        	TclError(ErrorMsg);
        result := inttostr(Tell);
        exit;
    end;
    if TslcTextEqual(param, 'CAPACITY') then
    begin
    	if (cnt > 2) or (cnt < 1) then
        	TclError(ErrorMsg);
        if cnt = 2 then
        	Capacity := TslcStrToInt(ParamValues[1])
		else
        	result := inttostr(Capacity);
		exit;
    end;
    if TslcTextEqual(param, 'NULLSUBST') then
    begin
    	if (cnt > 2) or (cnt < 1) then
        	TclError(ErrorMsg);
        if cnt = 2 then
			NullSubst := ParamValues[1]
        else
        	result := NullSubst;
		exit;
    end;
    if TslcTextEqual(param, 'CLEAR') then
    begin
    	if cnt > 1 then
        	TclError(ErrorMsg);
        Clear;
        exit;
    end;
	TclError(ErrorMsg);
end;

type
	TMemoryStream2 = class(TMemoryStream)
    end;

constructor TTclCommandStream.Create(AOwner: TComponent; fileName: string; mode: integer);
begin
	inherited Create(AOwner);
	if fileName = '' then
    	FStream := TMemoryStream.Create
    else
	    FStream := TFileStream.Create(fileName, mode);
    ErrorMsg := 'Syntax: <?stream?> <pos [?newpos? [0|1|2]]|writeInt <?value?>|readInt|writeStr <?value?>|readStr>';
end;

destructor TTclCommandStream.Destroy;
begin
	FStream.Free;
    inherited Destroy;
end;

procedure TTclCommandStream.Clear;
begin
	if FStream is TMemoryStream then
    	TMemoryStream(FStream).Clear
    else
    	TclError('Unsupported');
end;

procedure TTclCommandStream.DoCommand(var result: string; var success: boolean);
var
	cnt, i: integer;
    param, str: string;
begin
	cnt := ParamValuesCount;
    if cnt > 0 then
    begin
    param := ParamValues[0];
    if TslcTextEqual(param, 'POS') then
    begin
    	if cnt > 3 then
        	TclError(ErrorMsg);
        result := inttostr(FStream.Position);
    	if cnt = 2 then
        	FStream.Seek(TslcStrToInt(ParamValues[1]), 0)
        else if cnt > 2 then
        	FStream.Seek(TslcStrToInt(ParamValues[1]), TslcStrToInt(ParamValues[2]));
        exit;
    end;
    if TslcTextEqual(param, 'WRITEINT') then
    begin
    	if cnt <> 2 then
        	TclError(ErrorMsg);
		i := TslcStrToInt(ParamValues[1]);
        FStream.Write(i, sizeof(integer));
        exit;
    end;
    if TslcTextEqual(param, 'READINT') then
    begin
    	if cnt > 1 then
        	TclError(ErrorMsg);
        if FStream.Read(i, sizeof(integer)) <> sizeof(integer) then
        	TclErrorFmt('Error Reading Stream %s', [command]);
        result := inttostr(i);
        exit;
    end;
    if TslcTextEqual(param, 'WRITESTR') then
    begin
    	if cnt <> 2 then
        	TclError(ErrorMsg);
        str := ParamValues[1];
        i := length(str);
        FStream.Write(i, sizeof(integer));
        FStream.Write(pChar(str)^, i);
        exit;
    end;
    if TslcTextEqual(param, 'READSTR') then
    begin
    	if cnt > 1 then
        	TclError(ErrorMsg);
        if FStream.Read(i, sizeof(integer)) <> sizeof(integer) then
        	TclErrorFmt('Error Reading Stream %s', [command]);
        System.SetString(str, nil, i);
        if FStream.Read(pChar(str)^, i) <> i then
        	TclErrorFmt('Error Reading Stream %s', [command]);
		result := str;
        exit;
    end;
    if TslcTextEqual(param, 'FREE') then
    begin
    	Free;
        exit;
    end;
	end;
    inherited DoCommand(result, success);
end;

function TTclCommandStream.GetCapacity: longint;
begin
	if FStream is TMemoryStream then
    	result := TMemoryStream2(FStream).Capacity
    else
    	TclError('Unsupported');
end;

function TTclCommandStream.GetSize: longint;
begin
	result := FStream.Size;
end;

function TTclCommandStream.GetTell: longint;
begin
	result := FStream.Position;
end;

function TTclCommandStream.Read(buf: pChar; count: longint): longint;
begin
	result := FStream.Read(buf^, count);
end;

function TTclCommandStream.Seek(offset: longint; whence: integer): longint;
begin
	result := FStream.Seek(offset, whence);
end;

procedure TTclCommandStream.SetCapacity(value: longint);
begin
	if FStream is TMemoryStream then
    	TMemoryStream2(FStream).Capacity := value
    else
    	TclError('Unsupported');
end;

procedure TTclCommandStream.SetSize(value: longint);
begin
	if FStream is TMemoryStream then
    	TMemoryStream(FStream).SetSize(value)
    else
    	TclError('Unsupported');
end;

procedure TTclCommandStream.SetStream(AStream: TStream);
begin
	FStream.Free;
    FStream := AStream;
end;

function TTclCommandStream.Write(buf: pChar; count: longint): longint;
begin
	result := FStream.Write(buf^, count);
end;


function StreamFromCommand(AInterp: pTcl_Interp; command: string): TStream; // throws ETclError
var
	cmd: TTclCommand;
begin
	cmd := TslcFindCommand(AInterp, command);
    if cmd is TTclCommandStream then
    	result := (cmd as TTclCommandStream).Stream
    else
    	TclErrorFmt('%s is not a ::TslcUtility::Stream command', [command]);
end;

procedure TUtilityMod.TclCmd_StreamCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	mode: integer;
    param: string;
    fName: string;
begin
	fName := Sender.ParamValues[1];
	param := Sender.ParamValues[2]; //  Property MinArgs/MaxArgs requires 3 params; so, index is OK
    if TslcTextEqual(param, 'CREATE') then
    	mode := fmCreate
    else if TslcTextEqual(param, 'READ') then
    	mode := fmOpenRead
    else if TslcTextEqual(param, 'WRITE') then
    	mode := fmOpenWrite
    else if TslcTextEqual(param, 'READWRITE') then
    	mode := fmOpenReadWrite
    else if TslcTextEqual(param, 'MEMORY') then
		fName := ''
    else
    	TclError(Sender.ErrorMsg);
	with TTclCommandStream.Create(Sender.Owner, fName, mode) do
    begin
    	Command := Sender.ParamValues[0];
 		Install(Sender.Interp);
    end;
end;

procedure TUtilityMod.TclCmd_TslcCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	cnt: integer;

begin
	cnt := Sender.ParamValuesCount;
    if cnt < 1 then
    	TclError(Sender.ErrorMsg);
    if TslcTextEqual(Sender.ParamValues[0], 'ISTSLCCOMMAND') then
    begin
		if cnt <> 2 then
        	TclError(Sender.ErrorMsg);

		// ??? Not going to walk module list for command using TslcFindCommandModule since
        // export functions would be needed to utilize the TTclCommand class. future...
		if TslcFindCommand(Sender.Interp, Sender.ParamValues[1]) <> nil then
        	result := '1'
        else
        	result := '0';
        exit;
    end;
end;

procedure TUtilityMod.TclUtilityAfterInitInterp(Sender: TObject;
  AInterp: pTcl_Interp);
var
	ver: string;
begin
	ver := format('%d.%d',[TSLC_UTILITY_VERSION_MAJOR, TSLC_UTILITY_VERSION_MINOR]);
	Tcl_PkgProvide(AInterp, TSLC_UTILITY_NAME, pChar(ver));
end;

procedure TUtilityMod.TclCmd_CriticalCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	TslcEnterCritical;
    try

		// Showing another way to access arguments passed to Critical Command
		if Sender.Argc <> 2 then // Argc includes Command (*Critical*) argument
        	TclError(Sender.ErrorMsg);

		// Never write to RawArgv       TclTk
        if Sender.ObjectArgs then
        	success := Tcl_EvalObj(Sender.Interp, pTcl_Obj(ArgvItem(Sender.RawArgv,1))) <> TCL_ERROR
        else
			success := Tcl_Eval(Sender.Interp, ArgvItem(Sender.RawArgv,1)) <> TCL_ERROR;
        result := Tcl_GetStringResult(Sender.Interp);
    finally
    	TslcLeaveCritical;
    end;
end;

procedure TUtilityMod.TclCmd_SystemCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	sectorsPerCluster, bytesPerSector, totalClusters, freeClusters: dword;
	p: pChar;
	e: extended;
    cnt: integer;
begin
	with Sender do
    begin
    	cnt := ParamValuesCount;
        if TslcTextEqual(ParamValues[0], 'DISK') then
        begin
        	if cnt < 2 then
            	TclError(ErrorMsg);
			if TslcTextEqual(ParamValues[1], 'FREESPACE') then
			begin
				if ParamValuesCount > 2 then
					p := pChar(ParamValues[2])
				else
					p := nil;
				success := GetDiskFreeSpace(p, sectorsPerCluster, bytesPerSector, freeClusters, totalClusters);
				if success then
				begin
					e := freeClusters;
					result := floattostr((freeClusters * sectorsPerCluster) * bytesPerSector)
				end else
					result := format('GetDiskFreeSpace returned error %d', [GetLastError]);
            	exit;
            end;
        end;
    	TclError(ErrorMsg);
    end;
end;

procedure TUtilityMod.TclCmd_HashCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := inttostr(Hash(pChar(Sender.ParamValues[0])));

end;

initialization
	RegisterTclServer(TUtilityMod);
	TslcPrepareCritical;

finalization
	TslcDoneCritical;

end.
