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

///////////////////////////////////////////////////////////////////////////////
//
//  TclDbTbl.pas
//	Copyright(c) 1996-1997 William Byrne
//		WilliamB@ByrneLitho.com
//		76262.13@CompuServe.com
//
//	All rights reserved.
//  	William Byrne makes no representations about the suitability of this
//    	software for any purpose.  It is provided "as is" without express or
//    	implied warranty.
//
//	Usage
//      I hereby grant to the legal purchasors of the source code contained
//      herein a non-exclusive license for the use of said source code in
//      developing compiled, executable software, and for the distribution of
//      said source code as part of said developed, compiled, executable software.
//
//	Editor:
//		Tab stops = 4
//		Page width = 132 characters
//		Font = Courier New, 8pt
//
//  Misc:
//      ??? = Note to self


interface

type
	TTslcMsgKind = ( tmInfo, tmConfirm, tmWarning, tmError, tmPanic, tmTrace );
    TTslcMessageHandler = function(msg: pChar; kind: integer; data: integer): integer; cdecl;

function TslcMessage( msg: string; kind: TTslcMsgKind ): integer;

procedure TslcPrepareTrace;
procedure TslcDoneTrace;
function TslcRegisterMessageHandler(handler: TTslcMessageHandler; data: integer): integer; cdecl;

var
	TraceFile: string;

implementation
uses Windows, SysUtils;

var
	Tracer: TextFile;
    Tracing, Tracable: boolean;
    TraceClients: integer = 0;

// Tracing will most likely begin very early in an application. If a different trace file is needed, change
// the Tracer variable below, or do it in the initialization section of another unit that WILL get initialized
// before Tslc.dcu; it should be the first unit in the Project source file. Since the ?MyTrace? unit will need
// to reference this unit, the initialization below will happen first so not to overwrite the value set in
// the ?MyTrace? unit. Examples are given in various distribution projects.
// Traces originating from Tslc.bug are critically wrapped along with TslcClientTrace that is available from Tslc.dcu.

procedure TslcPrepareTrace;
begin
	inc(TraceClients);
end;

procedure TslcDoneTrace;
begin
	dec(TraceClients);
    if (TraceClients = 0) and Tracable then
        Close(Tracer);
end;


function Trace(msg: string): integer;
begin
	result := 1;
    if not Tracing then
    begin
		try
	    	AssignFile(Tracer, ExtractFilePath(ParamStr(0)) + TraceFile);
    	    Rewrite(Tracer);
        	Tracable := True;
        except
            MessageBox(GetActiveWindow, pChar(Exception(ExceptObject).Message), 'Trace Error', MB_TASKMODAL);
		end;
        Tracing := True;
    end;
    if Tracable then
    begin
	    WriteLn(Tracer, msg);
        Flush(Tracer);
    end;
end;

function WinMessage(msg: string; kind: TTslcMsgKind): integer;
const
	StyleKind : array[tmInfo..tmTrace] of integer =
    	( MB_ICONINFORMATION, MB_ICONQUESTION, MB_ICONWARNING, MB_ICONSTOP, MB_ICONSTOP, MB_ICONASTERISK );
    CaptionKind : array[tmInfo..tmTrace] of pChar =
    	( 'Information',      'Confirm',       'Warning',      'Error',     'Panic',	'Trace' );
var
	i: integer;
begin
	result := 0;
	try
		if kind = tmConfirm then
	    	i := MB_OKCANCEL
	    else
	    	i := MB_OK;
		if kind = tmPanic then
        	Trace(msg);
        if kind = tmTrace then
        	result := Trace(msg)
        else if MessageBox(0, pChar(msg), CaptionKind[kind], StyleKind[kind] or i) = ID_OK then
	    	result := 1
	    else
	    	result := 0;
        if kind = tmPanic then
        	MessageBox(0, 'Panic called from within Tcl Engine. Application is unstable', CaptionKind[tmPanic], StyleKind[tmPanic]);
    except
    	on Exception do;
		// although this a safe procedure, exceptions should not run out of it because
        // it can be called from within a Tcl engine callback.
    end;

end;

var
	MessageHandler: TTslcMessageHandler;
    MessageData: integer;

function TslcRegisterMessageHandler(handler: TTslcMessageHandler; data: integer): integer;
begin
    MessageHandler := handler;
    MessageData := data;
    result := 0;
end;

function TslcMessage( msg: string; kind: TTslcMsgKind ): integer;
begin
	if @MessageHandler <> nil then
    	result := MessageHandler(pChar(msg), integer(kind), MessageData)
    else
    	result := WinMessage(msg, kind);
end;

initialization
	TraceFile := 'Trace.txt';

finalization
end.
