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

///////////////////////////////////////////////////////////////////////////////
//
//  TslcPlat.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.
//
//  Purpose:
//    This file provides for platform specific operations.
//

interface

type
    TIsTslcModProcs = function(p: pointer): integer; cdecl;

const
	cIsTslcModProcs = 'IsTslcModProcs';


function TslcApplicationPath: string;
function TslcGetShortPath(path: string): string;
function TslcLoadStr(Ident: integer): string;
function TslcSetEnvVar(envVar, value: string): boolean;
function TslcTextEqual(const S1, S2: string): boolean;
function TslcTickCount: integer;
procedure TslcPrepareCritical; // call in initialization
procedure TslcDoneCritical; // call in finalization
procedure TslcEnterCritical; // <--| use an exception block for these two.
procedure TslcLeaveCritical; // <--|
function TslcAlloc(bytes: integer): pointer;
function TslcFree(p: pointer): integer;
procedure TslcSleep(milli: cardinal);
function TslcGetUserName: string;
function TslcGetConfigStr(user, key, value: string; var data: string): boolean;
function TslcSetConfigStr(user, key, value, data: string): boolean;
function TslcGetConfigInt(user, key, value: string; var data: integer): boolean;
function TslcSetConfigInt(user, key, value: string; data: integer): boolean;
function TslcWalkForCommand(p, p2: pointer): boolean;

implementation
uses Windows, SysUtils, Tslc;

{$I TslcErr.inc}

exports
	Tslc.IsTslcModProcs;

var
	TslcCriticalSection: TRTLCriticalSection;
	TslcCriticalCount: integer;

procedure TslcPrepareCritical;
begin
	if TslcCriticalCount = 0 then
	    InitializeCriticalSection(TslcCriticalSection);
    inc(TslcCriticalCount);
end;

procedure TslcDoneCritical;
begin
	dec(TslcCriticalCount);
    if TslcCriticalCount = 0 then
		DeleteCriticalSection(TslcCriticalSection);
end;

procedure TslcEnterCritical;
begin
	EnterCriticalSection(TslcCriticalSection);
end;

procedure TslcLeaveCritical;
begin
	LeaveCriticalSection(TslcCriticalSection);
end;

function TslcAlloc(bytes: integer): pointer; // minimal usage as of v1.0
begin
	Result := pointer(LocalAlloc(LPTR, bytes));
end;

function TslcFree(p: pointer): integer;
begin
	result := LocalFree(HLOCAL(p));
end;

procedure TslcSleep(milli: cardinal);
begin
	Sleep(milli);
end;

function TslcApplicationPath: string;
begin
	result := ParamStr(0);
end;

function TslcGetShortPath(path: string): string;
var
    len: integer;
begin
	len := GetShortPathName(pChar(path), nil, 0);
    SetString(result, nil, len - 1);
    GetShortPathName(pChar(path), pChar(result), len);
end;

function TslcLoadStr(Ident: integer): string;
begin
	result := LoadStr(Ident);
end;

function TslcSetEnvVar(envVar, value: string): boolean;
begin
	result := SetEnvironmentVariable(pChar(envVar), pChar(value));
end;

function TslcTickCount: integer;
begin
	result := GetTickCount;
end;

// mainly SysUtil.CompareText
function TslcTextEqual(const S1, S2: string): boolean; assembler;
asm
        PUSH    ESI
        PUSH    EDI
        PUSH    EBX
        MOV     ESI,EAX
        MOV     EDI,EDX
        OR      EAX,EAX
        JE      @@0
        MOV     EAX,[EAX-4]
@@0:    OR      EDX,EDX
        JE      @@1
        MOV     EDX,[EDX-4]
@@1:    MOV     ECX,EAX
        CMP     ECX,EDX
        JBE     @@2
        MOV     ECX,EDX
@@2:    CMP     ECX,ECX
@@3:    REPE    CMPSB
        JE      @@6
        MOV     BL,BYTE PTR [ESI-1]
        CMP     BL,'a'
        JB      @@4
        CMP     BL,'z'
        JA      @@4
        SUB     BL,20H
@@4:    MOV     BH,BYTE PTR [EDI-1]
        CMP     BH,'a'
        JB      @@5
        CMP     BH,'z'
        JA      @@5
        SUB     BH,20H
@@5:    CMP     BL,BH
        JE      @@3
        MOVZX   EAX,BL
        MOVZX   EDX,BH
@@6:    SUB     EAX,EDX
	    OR		EAX,EAX
        JE		@@7
        XOR		EAX,EAX
        JMP		@@8
@@7:
		MOV		EAX,1
@@8:
        POP     EBX
        POP     EDI
        POP     ESI
end;


function TslcGetUserName: string;
const
	cBufSize = 255;
var
	buf: array[0..cBufSize] of char;
    len: DWORD;
begin
	len := cBufSize - 1;
	result := '';
    if GetUserName(@buf[0], len) then
    	result := buf;
end;

const
	cRoot = 'Software\Byrne Litho\Tslc\1.0';

function GetPath(key: string): string;
var
	path: string;
    p: pChar;
begin
	if pChar(key)^ in ['\', '/'] then
    	path := Copy(key, 2, length(key))
    else if key <> '' then
    	path := cRoot + '\' + key
    else
    	path := cRoot;

	p := pChar(path);
    while p^ <> #0 do
    begin
    	if p^ = '/' then
        	p^ := '\';
        inc(p);
    end;
    result := path;
end;

function TslcGetConfigStr(user, key, value: string; var data: string): boolean;
const
	cMaxBuf = 2;
var
	hk: HKey;
    buf: array[0..cMaxBuf] of char;
    regType, len: DWORD;
    path: string;
    retval: integer;
begin
    path := GetPath(key);

	if user = '' then
		retval := RegOpenKeyEx(HKEY_LOCAL_MACHINE, pChar(path), 0, KEY_READ, hk)
    else
		retval := RegOpenKeyEx(HKEY_CURRENT_USER, pChar(path), 0, KEY_READ, hk);
    result := retval = ERROR_SUCCESS;
    if result then
    try
    	regType := REG_EXPAND_SZ;
        len := cMaxBuf;
		case RegQueryValueEx(hk, pChar(value), nil, @regType, @buf[0], @len) of
        	ERROR_SUCCESS:
            	SetString(data, buf, len);
            ERROR_MORE_DATA:
	            begin
					SetString(data, nil, len + 1);
					result := RegQueryValueEx(hk, pChar(value), nil, @regType, pByte(pChar(data)), @len) = ERROR_SUCCESS;
                end;
        else
        	result := False;
        end;
    finally
        RegCloseKey(hk);
    end;
end;


function TslcSetConfigStr(user, key, value: string; data: string): boolean;
var
	hk: HKey;
    path: string;
    retval: integer;
    disp: DWORD;
begin

    path := GetPath(key);

	if user = '' then
		result := RegCreateKeyEx(HKEY_LOCAL_MACHINE, pChar(path), 0, nil, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, nil, hk, @disp) = ERROR_SUCCESS
    else
		result := RegCreateKeyEx(HKEY_CURRENT_USER, pChar(path), 0, nil, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, nil, hk, @disp) = ERROR_SUCCESS;
    result := retval = ERROR_SUCCESS;
    if result then
    try
        result := RegSetValueEx(hk, pChar(value), 0, REG_SZ, pChar(data), strlen(pChar(data)) + 1) = ERROR_SUCCESS;
    finally
        RegCloseKey(hk);
    end;
end;

{$IFNDEF WIN32}
 ?PRAGMA? Must be 32bit OS
 {$ENDIF}

function TslcGetConfigInt(user, key, value: string; var data: integer): boolean;
var
	hk: HKey;
    regType, len: DWORD;
    path: string;
    retval: integer;
begin

    path := GetPath(key);

	if user = '' then
		retval := RegOpenKeyEx(HKEY_LOCAL_MACHINE, pChar(path), 0, KEY_READ, hk)
    else
		retval := RegOpenKeyEx(HKEY_CURRENT_USER, pChar(path), 0, KEY_READ, hk);
    result := retval = ERROR_SUCCESS;
    if result then
    try
    	regType := REG_DWORD;
        len := sizeof(integer);
		result := RegQueryValueEx(hk, pChar(value), nil, @regType, @data, @len) = ERROR_SUCCESS;
    finally
        RegCloseKey(hk);
    end;
end;

function TslcSetConfigInt(user, key, value: string; data: integer): boolean;
var
	hk: HKey;
    path: string;
    disp: DWORD;
    retval: integer;
begin

    path := GetPath(key);

	if user = '' then
		result := RegCreateKeyEx(HKEY_LOCAL_MACHINE, pChar(path), 0, nil, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, nil, hk, @disp) = ERROR_SUCCESS
    else
		result := RegCreateKeyEx(HKEY_CURRENT_USER, pChar(path), 0, nil, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, nil, hk, @disp) = ERROR_SUCCESS;
    result := retval = ERROR_SUCCESS;
    if result then
    try
        result := RegSetValueEx(hk, pChar(value), 0, REG_DWORD, @data, sizeof(integer)) = ERROR_SUCCESS;
    finally
        RegCloseKey(hk);
    end;
end;

// Borrowed from ToolHelp - want dynamic loading since WinNT doesn't export/support
const
  MAX_MODULE_NAME32 = 255;
  TH32CS_SNAPMODULE   = $00000008;

type
  TModuleEntry32 = record
    dwSize: DWORD;
    th32ModuleID: DWORD;  // This module
    th32ProcessID: DWORD; // owning process
    GlblcntUsage: DWORD;  // Global usage count on the module
    ProccntUsage: DWORD;  // Module usage count in th32ProcessID's context
    modBaseAddr: PBYTE;   // Base address of module in th32ProcessID's context
    modBaseSize: DWORD;   // Size in bytes of module starting at modBaseAddr
    hModule: HMODULE;     // The hModule of this module in th32ProcessID's context
    szModule: array[0..MAX_MODULE_NAME32 + 1] of Char;
    szExePath: array[0..MAX_PATH - 1] of Char;
  end;
	TCreateToolhelp32Snapshot = function(dwFlags, th32ProcessID: DWORD): THandle; stdcall;
	TModule32First = function(hSnapshot: THandle; var lpme: TModuleEntry32): BOOL; stdcall;
	TModule32Next = function(hSnapshot: THandle; var lpme: TModuleEntry32): BOOL; stdcall;


    TEnumProcessModules = function(hProcess: THANDLE; var hModules: HMODULE; cb: DWORD; var cbNeeded: DWORD): BOOL; stdcall;

const
	cNTWalker: HMODULE = 0;

function TslcWalkForCommand(p, p2: pointer): boolean;
const
	cVersion: integer = -1;
    cLibInit: boolean = False;
    cCreateToolhelp32Snapshot: TCreateToolhelp32Snapshot = nil;
    cModule32First: TModule32First = nil;
    cModule32Next: TModule32Next = nil;
    cEnumProcessModules: TEnumProcessModules = nil;
    cMaxModules = 1024;
var
	entry: TModuleEntry32;
    h: THandle;
    proc: TIsTslcModProcs;
    osvInfo: TOSVersionInfo;
    modules: array[0..cMaxModules-1] of HMODULE;
    needed: DWORD;
    x: integer;
begin
	result := False;
    if cVersion < -1 then
    	exit;

	TslcEnterCritical;
	try
	    if cVersion = -1 then
	    begin
	    	osvInfo.dwOSVersionInfoSize := sizeof(TOSVersionInfo);
	    	if GetVersionEx(osvInfo) then
				cVersion := osvInfo.dwPlatformId
	        else
	        	cVersion := -2;
		end;

	    if cVersion = VER_PLATFORM_WIN32_WINDOWS then
	    begin
			if not cLibInit then
	        begin
				h := GetModuleHandle('KERNEL32.DLL');
				cCreateToolhelp32Snapshot := GetProcAddress(h, 'CreateToolhelp32Snapshot');
	            cModule32First := GetProcAddress(h, 'Module32First');
	            cModule32Next := GetProcAddress(h, 'Module32Next');
	            cLibInit := (@cCreateToolhelp32Snapshot <> nil) and (@cModule32First <> nil) and (@cModule32Next <> nil);
    			h := THandle(-1);
	            if not cLibInit then
	            	cVersion := -2
                else
			        h := cCreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0);
	        end else
		        h := cCreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0);

			if h <> -1 then
            begin
		        entry.dwSize := sizeof(TModuleEntry32);
			    if cModule32First(h, entry) then
		    	repeat
					proc := TIsTslcModProcs(GetProcAddress(entry.hModule, cIsTslcModProcs));
			//        if @proc = nil then
			//        	proc := TIsTslcModProcs(GetProcAddress(entry.hModule, '_' + cIsTslcModProcs));

					result := (@proc <> nil) and (proc(p) <> 0);
		        	if result then
                    begin
						pTModuleCmdInfo(p2)^.handle := entry.hModule;
		        		break;
                    end;
				until not cModule32Next(h, entry);
				CloseHandle(h);
            end;
	    end;
	    if cVersion = VER_PLATFORM_WIN32_NT then
	    begin
			if not cLibInit then
	        begin
				h := LoadLibrary('PSAPI.DLL');
				if h <> 0 then
	                cEnumProcessModules := GetProcAddress(h, 'EnumProcessModules');
	            cLibInit := (h <> 0) and (@cEnumProcessModules <> nil);
	            if not cLibInit then
	            	cVersion := -2;
	        end;

			if cLibInit then
            begin
            	if cEnumProcessModules(GetCurrentProcess, modules[0], sizeof(modules), needed) then
                begin
                    for x:= 0 to needed div sizeof(HMODULE) - 1 do
                    begin
						proc := TIsTslcModProcs(GetProcAddress(modules[x], cIsTslcModProcs));
						result := (@proc <> nil) and (proc(p) <> 0);
			        	if result then
    	                begin
							pTModuleCmdInfo(p2)^.handle := entry.hModule;
		    	    		break;
                	    end;
            		end;
                end;
            end;
        end;
    finally
    	TslcLeaveCritical;
    end;
end;


initialization
	TslcPrepareCritical;

finalization
	TslcDoneCritical;
    FreeLibrary(cNTWalker);
end.
