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

interface

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

type
  TStatEvalForm = class(TForm)
    Tcl1: TTcl;
    OpenDialog1: TOpenDialog;
    BtnOpen: TButton;
    LabelStatus: TLabel;
    TclChannel1: TTclChannel;
    TclCmd_StatEval: TTclCommand;
    procedure TclChannel1Output(Sender: TTclChannel; buf: PChar;
      toWrite: Integer; var errorCode, result: Integer);
    procedure FormCreate(Sender: TObject);
    procedure BtnOpenClick(Sender: TObject);
    procedure TclCmd_StatEvalCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
  private
    { Private declarations }
    FCancel, FEvaluating, FClose: boolean;
    FScript: string;
	procedure OpenScript(fileName: string);
    function  GetCancel: boolean;
	procedure SetCancel(value: boolean);
  public
    { Public declarations }
    function CancelHit: boolean;
    property Cancel: boolean read GetCancel write SetCancel;
  end;

var
  StatEvalForm: TStatEvalForm;

implementation
uses TslcDES, TslcZLib, uTslcBde, uTslcCmp, uTslcUti, TslcFile, TslcKey, uTslcLib, TslcUtil, TslcPlat;
{$R *.DFM}

procedure TStatEvalForm.TclChannel1Output(Sender: TTclChannel; buf: PChar;
  toWrite: Integer; var errorCode, result: Integer);
var
	str: string;
begin
	SetString(str, buf, toWrite);
    LabelStatus.Caption := str;
    Update;
end;

procedure TStatEvalForm.OpenScript(fileName: string);
	function  IsRich(strm: TStream): boolean;
    var
        buf: array[0..5] of char;
        pos: integer;
    begin
    	pos := strm.Position;
		strm.read(buf, 5);
        strm.Position := pos;
        buf[5] := #0;
        result := StrComp(buf, '{\rtf') = 0;
    end;
const
	cZero: integer = 0;
var
	fstrm: TStream;
    mStrm: TMemoryStream;
    buf: array[0..cMaxKeyLen] of char;
    retval: integer;
begin

	retval := StaticDecrypt(TslcGetSecondaryKey, buf, cMaxKeyLen + 1);
    if retval <> 0 then
    	TclErrorFmt('Hard Error: %d', [retval]);

	fstrm := TFileStream.Create(FileName, fmOpenRead);
    try
	    mstrm := UncrunchScriptStream(fstrm, StrToScriptType(ExtractFileExt(FileName)), buf);
    finally
    	fstrm.Free;
    end;

	try
        mstrm.Seek(0, 2);
        mstrm.Write(cZero, sizeof(cZero));
        if IsRich(mstrm) then
        	TclError('Rich Stream');

		FEvaluating := True;
    	try
	        Tcl1.Eval(pChar(mstrm.Memory));
        finally
        	FEvaluating := False;
        end;
        labelStatus.Caption := Tcl1.Result;
    finally
    	mstrm.Free;
    end;

end;

function TStatEvalForm.GetCancel: boolean;
begin
	result := FCancel;
end;

procedure TStatEvalForm.SetCancel(value: boolean);
begin
	if FCancel = value then
    	exit;
    FCancel := value;
    if not FEvaluating then
    	exit;
	BtnOpen.Enabled := FCancel;
    BtnOpen.Invalidate;
    Update;
end;

function TStatEvalForm.CancelHit: boolean;
var
	msg: TMsg;
begin
	result := PeekMessage(msg, BtnOpen.handle, WM_LBUTTONDOWN, WM_LBUTTONDOWN, PM_REMOVE) or
       PeekMessage(msg, BtnOpen.handle, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE);
end;

procedure TStatEvalForm.FormCreate(Sender: TObject);
begin
    ResourceServeThread(GetCurrentThreadId, Tcl1);
	BDEServeThread(GetCurrentThreadId, Tcl1);
    UtilityServeThread(GetCurrentThreadId, Tcl1);
   	CompressServeThread(GetCurrentThreadId, Tcl1);
    FCancel := True;
end;

procedure TStatEvalForm.BtnOpenClick(Sender: TObject);
var
	msg: TMsg;
begin
	if FClose then
    begin
    	Close;
        exit;
    end;
	with OpenDialog1 do
   		if execute then
        begin
		    while PeekMessage(msg, BtnOpen.handle, WM_LBUTTONDOWN, WM_LBUTTONDOWN, PM_REMOVE) do; // Clear any jitters.
    	    while PeekMessage(msg, BtnOpen.handle, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) do;
			BtnOpen.Enabled := FCancel;
            BtnOpen.Caption := 'Cancel';
            FClose := False;
            FScript := FileName;
            try
               	OpenScript(FScript);
        	finally
            	if FClose then
                	BtnOpen.Caption := 'Close'
                else
	            	BtnOpen.Caption := 'Open';
    			BtnOpen.Enabled := True;
            end;
        end;
end;

// Control command for this application
procedure TStatEvalForm.TclCmd_StatEvalCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	cnt: integer;
    param: string;
    msg: TMsg;
begin
	with Sender do
    begin
    	cnt := ParamValuesCount;
        if cnt < 1 then
        	TclError(ErrorMsg);
        param := ParamValues[0];
        if TslcTextEqual(param, 'ENABLECANCEL') then
        begin
        	result := inttostr(integer(Cancel));
            if cnt < 2 then
            	exit;
            if cnt > 2 then
            	TclError(ErrorMsg);
            Cancel := TslcStrTruth(ParamValues[1]);
            exit;
        end;
        if TslcTextEqual(param, 'CANCELHIT') then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
        	result := inttostr(integer(CancelHit));
            exit;
        end;
        if TslcTextEqual(param, 'CANCELCLEAR') then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
			while PeekMessage(msg, BtnOpen.handle, WM_LBUTTONDOWN, WM_LBUTTONDOWN, PM_REMOVE) do; // Clear any jitters.
            while PeekMessage(msg, BtnOpen.handle, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) do;
		end;
        if TslcTextEqual(param, 'STALE') then
        begin
        	if cnt <> 2 then
            	TclError(ErrorMsg);
            FClose := TslcStrTruth(ParamValues[1]);
        end;
        if TslcTextEqual(param, 'SCRIPT') then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
            result := FScript;
        	exit;
        end;
    end;
end;

initialization
	SetStaticKey(TslcGetStaticKey, 0);

end.
