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

interface

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

type
  TIntraBdeMod = class(TDataModule)
    Tcl1: TTcl;
    TclBridge1: TTclBridge;
    TclCmd_Print: TTclCommand;
    TclCmd_Print_c: TTclCmdSwitch;
    procedure IntraBdeModCreate(Sender: TObject);
    procedure IntraBdeModDestroy(Sender: TObject);
    procedure TclCmd_PrintCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_Print_cSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
  private
    { Private declarations }
    	FPrintList: TStringList;
		procedure ProcessScript(script: pChar; reset: integer);
  public
    { Public declarations }
  end;

function EvalBdeScript(script: pChar; quote: integer; reset: integer): pChar; cdecl;

implementation
uses uTslcBde;
{$R *.DFM}

var
	IntraBdeMod: TIntraBdeMod;
    resultStrm: TMemoryStream;

procedure SetResultStrm(value: string);
begin
	resultStrm.Clear;
    resultStrm.Write(pChar(value)^, strlen(pChar(value)) + 1); // add in terminating null char
end;

procedure TIntraBdeMod.ProcessScript(script: pChar; reset: integer);
const
	zero: integer = 0;
begin

	if reset <> 0 then
    	Tcl1.Close;

	FPrintList.Clear;

	if not Tcl1.Eval(script) then
    	SetResultStrm(Tcl1.Result)
    else
    begin
    	resultStrm.Clear;
        TslcAddTextToStrings(pChar(Tcl1.Result), FPrintList);
   		FPrintList.SaveToStream(resultStrm);
		resultStrm.Write(zero, sizeof(integer));
    end;
end;


function EvalBdeScript(script: pChar; quote: integer; reset: integer): pChar; cdecl;
var
	buf: pChar;
    x, len: integer;
    c: char;
begin
	if IntraBdeMod = nil then
    	IntraBdeMod := TIntraBdeMod.Create(nil);

	with IntraBdeMod do
    try
		if quote = 0 then 	// quote is work around for IntraBuilder v1.0/Netscape incompatibility
  		      				// Get the latest IB update if you don't have it.
        	ProcessScript( script, reset )
        else
        begin
			len := strlen( script );
    	    GetMem( buf, len + 1);
        	try
	       		for x := 0 to len do
    	        begin
        	    	c := script[x];
            	    if c = char(quote) then
                		c := '"';
	                buf[x] := c;
    	        end;
				ProcessScript( buf, reset );
    	    finally
        		FreeMem( buf );
            end;
        end;
    except
    	on E:Exception do
        	SetResultStrm( E.Message );
    end;
    result := pChar(resultStrm.memory);
end;

procedure TIntraBdeMod.IntraBdeModCreate(Sender: TObject);
begin
	TclBridge1.Server := BDEMod.Tcl1;
    FPrintList := TStringList.Create;
end;

procedure TIntraBdeMod.IntraBdeModDestroy(Sender: TObject);
begin
	FPrintList.Free;
end;

procedure TIntraBdeMod.TclCmd_PrintCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	str: string;
    x: integer;
begin
	str := '';
	with Sender do
    	for x:= 0 to ParamValuesCount - 1 do
        	if x = 0 then
            	str := ParamValues[0]
            else
            	str := str + ' ' + ParamValues[x];
    FPrintList.Add(str);
end;

procedure TIntraBdeMod.TclCmd_Print_cSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	FPrintList.Clear;
end;

initialization
	resultStrm:= TMemoryStream.Create;

finalization
	resultStrm.Free;
	IntraBdeMod.Free;
end.
