Softwarová Záchrana 3/Softwarova-zachrana-3.bin/ArsClip/source.zip/UnitMisc.pas

Pascal/Delphi Source File | 2003-10-03 | 6KB | 260 lines

unit UnitMisc;
{
    Purpose:
        "Put all the orphans in one bed"

    Updates:
        Handle error case for WindowHandleToEXEName
        Routine to save the debug log

}

{ TODO: Further optimize log usage - possibly to file }
interface

uses Windows;

procedure MyFree(var o);
function WindowHandleToEXEName(handle : THandle) : string;
function DupHandle(h : Thandle; var sizeh : cardinal; SizeLimit : boolean = false) : Thandle;
procedure AppendLog( s : string; IncludeLastError : boolean = false);
procedure DumpLog(filename : string);
procedure FlushLog;
procedure MyDestroyIcon(h : HICON);
procedure TimerStart;
procedure TimerEndAt(milliseconds : cardinal);

function GetCliptypeSymbol( Format: Cardinal ) : string;

const EXENAME_ERROR = '[error]';
implementation


uses Tlhelp32, UnitFrmMainPopup, SysUtils, Classes, Forms,
  UnitFrmClipboardManager;
var AppendCount : cardinal;
var AppendStr : string;
var TimerSnapshot : cardinal;



procedure TimerStart;
begin
    TimerSnapshot := Windows.GetTickCount;
end;

procedure TimerEndAt(milliseconds : cardinal);
begin
    while (Windows.GetTickCount - TimerSnapshot) < milliseconds do begin
        // this procedures purposely stalls the program, so ProcessMessages
        // is NOT used here
    end;
end;

//
// I want "free" object references to be nil for easy testing
// Notes: The .Free documenation is very misleading, this function
// make it 100% clear
//
// - Free only if not null
// - Make null when freed
//

procedure MyFree(var o);
begin
    if (Pointer(o) <> nil) then begin
        TObject(o).free;
        Pointer(o) := nil;
    end;
end;


procedure MyDestroyIcon(h : HICON);
begin
    if (h <> 0) then begin
        UnitMisc.AppendLog('^DestroyIcon^');
        if not Windows.DestroyIcon(h) then begin
            UnitMisc.AppendLog('Icon not destroyed', true);
        end;
    end;
end;


//
// Only returns Empty String when the handle is not found,
// not on an error
//
function WindowHandleToEXEName(handle : THandle) : string;
var snap : THandle;
    pe : tagPROCESSENTRY32;
    pid : THandle;
    found : boolean;
begin
    Windows.SetLastError(ERROR_SUCCESS);

    result := '';
    if (handle = 0) then begin
        EXIT;
    end;
    snap := TLHelp32.CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
    if (snap = Cardinal(-1)) then begin
        result := EXENAME_ERROR;
        EXIT;
    end;

    Windows.GetWindowThreadProcessId(handle, pid);
    pe.dwSize := Sizeof(pe);
    found := TLHelp32.Process32First(snap, pe);

    while found do begin
        if (pe.th32ProcessID = pid) then begin
            result := String(pe.szExeFile);
            break;
        end;

        found := TLHelp32.Process32Next(snap, pe);
    end;
    CloseHandle(snap);
end;


function DupHandle(h : Thandle; var sizeh : cardinal; SizeLimit : boolean = false) : Thandle;
var sz : Cardinal;
    newh : Thandle;
    p1, p2 : pointer;
    b : boolean;
begin
    Windows.SetLastError(ERROR_SUCCESS);

    result := 0;
    if (h = 0) then begin
        AppendLog('<DupHandle - Empty handle>');
        EXIT;
    end;
    //
    // make sure size is non-zero
    // and not bigger than size restrictions
    //
    sz := Windows.GlobalSize(h);
    if (sz = 0) then begin
        AppendLog('<DupHandle - GlobalSize failed >', true);
        sizeh := 0;
        EXIT;
    end;

    // abort if too big
    // make sure to return size of item
    if (SizeLimit) and (sz > sizeh) then begin
        AppendLog('<DupHandle - too big, size limit>');
        sizeh := sz;
        EXIT;
    end else begin
        sizeh := sz;
    end;

    //
    // Lock and copy
    //

    newh := Windows.GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT, sizeh);
    if (newh=0) then begin
        AppendLog('<DupHandle - GlobalAlloc failed >', true);
        EXIT;
    end;
    p1 := Windows.GlobalLock(newh);
    if (p1=nil) then begin
        AppendLog('<DupHandle lock1 >', true);
        EXIT;
    end;

    p2 := Windows.GlobalLock(h);
    if (p2=nil) then begin
        Windows.GlobalUnlock(newh);
        AppendLog('<DupHandle lock2 >', true);
        EXIT;
    end;

    MoveMemory(p1, p2, sizeh);

    //
    // This should never occur, maybe hardware failure might cause this
    //
    b := CompareMem(p1, p2, sizeh);
    AppendLog('<DupHandle compare=>' + BoolToStr(b));
    if ( not b) then begin
        Application.ShowException(Exception.Create('DupHandle - Failed to copy memory'));
        Application.Terminate;
    end;


    Windows.GlobalUnlock(h);
    Windows.GlobalUnlock(newh);

    result := newh;
end;

procedure AppendLog( s : string; IncludeLastError : boolean = false);
begin
    if (IncludeLastError) then begin
        s := s + ' : ' + SysErrorMessage(GetLastError);
    end;
    if (AppendStr = '') then begin
        AppendStr := TimeToStr(Now) + ': ' + s;
    end else begin
        AppendStr :=  TimeToStr(Now) + ': ' + s +  #13#10 + AppendStr;
    end;


    AppendCount := (AppendCount + 1) mod 5;
    if (AppendCount = 0) then begin
        FrmMainPopup.AppendLog(AppendStr);
        AppendStr := '';
    end;
end;
procedure FlushLog;
begin
    FrmMainPopup.AppendLog(AppendStr);
    AppendCount := 0;
end;


procedure DumpLog(filename : string);
begin
    FlushLog;
    filename := IncludeTrailingPathDelimiter(
            ExtractFilePath(Application.ExeName)
        ) + filename;

    FrmMainPopup.Memo1.Lines.SaveToFile(filename);
end;


function GetCliptypeSymbol(Format : Cardinal) : string;
begin
    case Format of
        CF_UNICODETEXT : begin
            result := '[U]';
        end;
        CF_HDROP : begin
            result := '[F]' ;
        end;
        CF_TEXT : begin
            result := '[T]' ;
        end;
        CF_DIB : begin
            result := '[P]' ;
        end;
    end;
    if (Format = frmClipboardManager.CF_RICHTEXT) then begin
        result := '[R]' ;
    end else if (Format = frmClipboardManager.CF_HTML) then begin
        result := '[H]' ;
    end;
end;

initialization
begin
    AppendCount := 1;
end;
end.