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

///////////////////////////////////////////////////////////////////////////////
//
//  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
uses Classes;

// Module or FileName but not both. if Module is 0 then Filename is used.
function TslcLoadScriptResource(module: integer; fileName, data: string): string;
function TslcLoadBinaryResource(module: integer; fileName, data: string): TMemoryStream;
function TslcResourceExists(module: integer; fileName, res: string; typ: pChar): boolean;
implementation
uses Windows, SysUtils;

//{$D-,L-,Y-}

type
	TLoadCallback = procedure(res: pointer; cbLen: integer; clientData: pointer);
	ppChar = ^pChar;

procedure TslcLoadResource(module: integer; fileName, data: string; callback: TLoadCallback; clientData: pointer);
var
	hMod: HMODULE;
	hRes: HRSRC;
    hMem: HGLOBAL;
    rSize: DWORD;
    ptr: pointer;
    freeModule: boolean;
begin
	freeModule := False;
    if module <> 0 then
    	hMod := module
    else if fileName = '' then
    	hMod := 0
    else
    begin
        hMod := LoadLibrary(pChar(fileName));
        if hMod = 0 then
	    	raise EInOutError.CreateFmt('Unable to load module %s - Error Code: %d',[fileName, GetLastError] );
		freeModule := True;
	end;
    try
		hRes := FindResource( hMod, pChar( data ), RT_RCDATA); // pass data as '#123' for numerical idents.
	    if hRes = 0 then
	    	raise EInOutError.CreateFmt('Unable to find resource %s->%s - Error Code: %d',[fileName, data, GetLastError] );
		rSize := SizeOfResource( hMod, hRes);
	    hMem := LoadResource( hMod, hRes ); // Win32 SDK states:
	    // The FreeResource function is obsolete. It is provided to simplify porting of 16-bit Windows-based
	    // applications. It is not necessary for Win32-based applications to free resources loaded by using
	    // the LoadResource function.

	    if hMem = 0 then
	    	raise EInOutError.CreateFmt('Unable to load resource %s->%s - Error Code: %d',[fileName, data, GetLastError] );
	    ptr := LockResource( hMem ); // Win32 SDK states it's not necessary to *UnlockResource*
	    if ptr = nil then
	    	raise EInOutError.CreateFmt('Unable to lock resource %s->%s - Error Code: %d',[fileName, data, GetLastError] );
		callback(ptr, rSize, clientData);
    finally
    	if freeModule then
        	FreeLibrary( hMod );
    end;
end;

procedure ResString(res: pointer; cbLen: integer; var s: string);
begin
	SetString(s, pChar(res), cbLen);
end;

function TslcLoadScriptResource(module: integer; fileName, data: string): string;
begin
	TslcLoadResource(module, fileName, data, TLoadCallback(@ResString), @result);
end;

procedure ResMStream(res: pointer; cbLen: integer; var strm: TMemoryStream);
begin
	strm := TMemoryStream.Create;
    try
		strm.Write(pChar(res)^, cbLen);
        strm.Position := 0;
    except
    	strm.Free;
        raise;
    end;
end;

function TslcLoadBinaryResource(module: integer; fileName, data: string): TMemoryStream;
begin
	TslcLoadResource(module, fileName, data, TLoadCallback(@ResMStream), @result);
end;

function SearchResNameProc( hMod: HMODULE; pType: pChar; pName: pChar; pSearch: pChar): BOOL; stdcall;
begin
	result := stricomp(pName, pSearch) <> 0; // we want to return false if found. This will kill enumeration; toggle in caller.
end;

function TslcResourceExists(module: integer; fileName, res: string; typ: pChar): boolean;
var
	hMod: HModule;
    freeModule: boolean;
begin
	freeModule := False;
	if module <> 0 then
    	hMod := module
	else if fileName = '' then
    	hMod := 0
    else
    begin
        hMod := LoadLibrary(pChar(fileName));
        if hMod = 0 then
	    	raise EInOutError.CreateFmt('Unable to load module %s - Error Code: %d',[fileName, GetLastError] );
		freeModule := True;
	end;

    try
		result := not EnumResourceNames( hMod, typ, ENUMRESNAMEPROC(@SearchResNameProc), integer(pChar(res)));
    finally
    	if freeModule then
        	FreeLibrary(hMod);
    end;
end;

end.
