delover
Advanced Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Код: program undeb32;
{$APPTYPE CONSOLE}
{%File 'build.bat'}
uses
Windows,
SysUtils,
Classes,
TlHelp32,
ImageHlp,
JclPeImage;
{$R *.res}
const
PackageInfoResName = 'PACKAGEINFO';
var
DebugPause: Boolean = False;
ExeFile: string = '';
ReportFile: string = '';
SetChecksum: Boolean = False;
ShowingFlag: Boolean = False;
ShowMessages: Boolean = True;
UseReport: Boolean = False;
procedure ShowCopyright;
begin
if ShowingFlag then Exit;
ShowingFlag := True;
Writeln('UNDEB32 (C) subreal.PIN Check Utility. Version 1.03 13-04-2007');
Writeln('Copr. 2006-2007 Roman Silin. All Rights Reserved. Freeware Version');
Writeln;
end;
procedure ShowUsage;
begin
ShowCopyright;
Writeln('Usage: UNDEB32 exefile [/p | /n] [/c | /m [reportfile]]');
end;
procedure Pause;
begin
if not DebugPause then exit;
if not ShowMessages then exit;
Writeln('Press enter...');
Readln;
end;
procedure ShowError(const Msg: string; const Args: array of const);
begin
ShowUsage;
Writeln;
Writeln('Error: ', Format(Msg, Args));
Pause;
Halt(0);
end;
procedure GetParameters;
var
I: Integer;
S: string;
begin
ExeFile := ExpandFileName(ParamStr(1));
I := 2;
repeat
S := ParamStr(I);
if S = '' then Break;
if (S[1] <> '/') and (S[1] <> '-') then
ShowError('Unknown parameter "%s"', [S]);
Delete(S, 1, 1);
if S = '' then Break;
case UpCase(S[1]) of
'P': DebugPause := True;
'N': ShowMessages := False;
'C': SetChecksum := True;
'M': UseReport := True;
end;
Inc(I);
if UseReport then
begin
ReportFile := ParamStr(I);
if ReportFile = '' then
ReportFile := ChangeFileExt(ExeFile, '.rep') else
if ExtractFileName(ReportFile) = ReportFile then
ReportFile := ExtractFilePath(ExeFile) + ReportFile else
ReportFile := ExpandFileName(ReportFile);
Break;
end;
until 0 <> 0;
if not FileExists(ExeFile) then
ShowError('File not found "%s"', [ExeFile]);
end;
{$IFDEF REGION}{$REGION ' [ TJclPeBorInfo ] '}{$ENDIF}
type
TJclPeBorInfoProgress = procedure(Position: DWORD);
TJclPeBorInfo = class(TJclPeBorImage)
private
FBaseOfCode: DWORD;
FEntryImport: DWORD;
FExcludeUnits: TStringList;
FMainUnit: string;
FOnProgress: TJclPeBorInfoProgress;
FPackageInfoData: DWORD;
FPackageInfoSize: DWORD;
FSearchResult: TStringList;
FShortString: Boolean;
FTempContains: TStringList;
function GetFileName: TFileName;
function GetOffset(OffseToData: DWORD): DWORD;
function GetSearchCount: Integer;
function GetSearchData(Index: Integer): DWORD;
function GetSearchNames(Index: Integer): string;
procedure SetFileName(const Value: TFileName);
protected
procedure ClearSearch;
function DoSearch(const StartSearch, EndSearch: DWORD): Boolean;
public
constructor Create(ANoExceptions: Boolean = False); override;
destructor Destroy; override;
function CodeSearch: Boolean;
function HasPackages: Boolean;
function PackageInfoSearch: DWORD;
property BaseOfCode: DWORD read FBaseOfCode;
property EntryImport: DWORD read FEntryImport;
property ExcludeUnits: TStringList read FExcludeUnits;
property FileName: TFileName read GetFileName write SetFileName;
property MainUnit: string read FMainUnit;
property OnProgress: TJclPeBorInfoProgress read FOnProgress write FOnProgress;
property PackageInfoData: DWORD read FPackageInfoData;
property PackageInfoSize: DWORD read FPackageInfoSize;
property SearchCount: Integer read GetSearchCount;
property SearchData[Index: Integer]: DWORD read GetSearchData;
property SearchNames[Index: Integer]: string read GetSearchNames;
end;
{ TJclPeBorInfo }
procedure TJclPeBorInfo.ClearSearch;
var
I: Integer;
begin
FMainUnit := '';
for I := 0 to FTempContains.Count - 1 do
FreeMem(Pointer(FTempContains.Objects[I]));
FTempContains.Clear;
FSearchResult.Clear;
end;
function TJclPeBorInfo.CodeSearch: Boolean;
begin
FShortString := True;
Result := DoSearch(BaseOfCode, EntryImport);
end;
constructor TJclPeBorInfo.Create(ANoExceptions: Boolean);
begin
inherited Create(ANoExceptions);
FExcludeUnits := TStringList.Create;
FSearchResult := TStringList.Create;
FTempContains := TStringList.Create;
end;
destructor TJclPeBorInfo.Destroy;
begin
ClearSearch;
FTempContains.Free;
FSearchResult.Free;
FExcludeUnits.Free;
inherited Destroy;
end;
function TJclPeBorInfo.DoSearch(const StartSearch, EndSearch: DWORD): Boolean;
function DoTempContains: Integer;
var
I, L: Integer;
S: ShortString;
P: PShortString;
begin
Result := 0;
ClearSearch;
if FindResource(LibHandle, PackageInfoResName, RT_RCDATA) <> 0 then
begin
FTempContains.AddStrings(PackageInfo.Contains);
for I := 0 to FTempContains.Count - 1 do
if (PackageInfo.ContainsFlags[I] and ufMainUnit) <> 0 then
begin
FMainUnit := FTempContains[I];
Break;
end;
if FShortString then
for I := 0 to ExcludeUnits.Count - 1 do
begin
L := FTempContains.IndexOf(ExcludeUnits[I]);
if L >= 0 then FTempContains.Delete(L);
end;
for I := 0 to FTempContains.Count - 1 do
begin
S := FTempContains[I];
L := Length(S) + 1;
GetMem(P, L);
if FShortString then
P^ := S else
Move(PChar(FTempContains[I])^, P^, L);
FTempContains.Objects[I] := Pointer(P);
if Result < L then Result := L;
end;
end;
if MainUnit = '' then
FMainUnit := ChangeFileExt(ExtractFileName(FileName), '');
end;
var
I: DWORD;
J, L, M, Step: Integer;
P: Pointer;
A: Byte;
T, S: PShortString;
begin
Result := False;
M := DoTempContains;
P := RawToVa(0);
I := StartSearch + 2;
Inc(DWORD(P), I);
T := nil;
repeat
Step := 1;
A := Byte(P^);
if (A <> 0) and ((A < M) or not FShortString) then
for J := 0 to FTempContains.Count - 1 do
begin
S := Pointer(FTempContains.Objects[J]);
if FShortString then
L := Length(S^) else
L := StrLen(PChar(S));
if not CompareMem(P, @S^[0], L + 1) then Continue;
if FShortString then
FSearchResult.AddObject(S^, TObject(I)) else
FSearchResult.AddObject(PChar(S), TObject(I));
if (T = nil) then T := S else
if (T <> S) then
begin
FreeMem(T);
FTempContains.Delete(FTempContains.IndexOfObject(Pointer(T)));
T := S;
end;
Inc(Step, L);
Result := True;
if Assigned(FOnProgress) then
FOnProgress(I);
Break;
end;
Inc(I, Step); Inc(DWORD(P), Step);
until I >= EndSearch - 2;
if Assigned(FOnProgress) then
FOnProgress(EndSearch);
end;
function TJclPeBorInfo.GetFileName: TFileName;
begin
Result := inherited FileName;
end;
function TJclPeBorInfo.GetOffset(OffseToData: DWORD): DWORD;
var
I: Int64;
begin
I := DWORD(RvaToVa(OffsetoData)) -
DWORD(LoadedImage.MappedAddress);
Result := I;
end;
function TJclPeBorInfo.GetSearchCount: Integer;
begin
Result := FSearchResult.Count;
end;
function TJclPeBorInfo.GetSearchData(Index: Integer): DWORD;
begin
if (Index >=0) and (Index < SearchCount) then
Result := DWORD(FSearchResult.Objects[Index]) else
Result := 0;
end;
function TJclPeBorInfo.GetSearchNames(Index: Integer): string;
begin
if (Index >=0) and (Index < SearchCount) then
Result := FSearchResult[Index] else
Result := '';
end;
function TJclPeBorInfo.HasPackages: Boolean;
var
I: Integer;
begin
for I := 0 to ImportList.Count - 1 do
begin
Result := SameText(ExtractFileExt(
ImportList[i].Name), '.bpl');
if Result then Exit;
end;
Result := False;
end;
function TJclPeBorInfo.PackageInfoSearch: DWORD;
var
I: Integer;
SaveOnProgress: TJclPeBorInfoProgress;
begin
Result := 0;
SaveOnProgress := FOnProgress;
FOnProgress := nil;
FShortString := False;
if DoSearch(PackageInfoData, PackageInfoData + PackageInfoSize) then
begin
I := FSearchResult.IndexOf(MainUnit);
if I = 0 then
Result := SearchData[I];
end;
FOnProgress := SaveOnProgress;
end;
procedure TJclPeBorInfo.SetFileName(const Value: TFileName);
var
ResItem: TJclPeResourceItem;
begin
inherited FileName := Value;
//get start..end of Code
FBaseOfCode := GetOffset(StrToInt('$' +
HeaderValues[JclPeHeader_BaseOfCode]));
FEntryImport := GetOffset(Directories[
IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress);
//get start..end of PackageInfo
ResItem := ResourceList.FindResource(rtRCData, PackageInfoResName);
if ResItem <> nil then
begin
FPackageInfoData := GetOffset(ResItem.List[0].DataEntry.OffsetToData);
FPackageInfoSize := ResItem.List[0].DataEntry.Size - 1;
end else
begin
FPackageInfoData := 0;
FPackageInfoSize := 0;
end;
end;
{$IFDEF REGION}{$ENDREGION}{$ENDIF}
var
BorInfo: TJclPeBorInfo;
MemoryStream: TMemoryStream;
ReportList: TStringList;
SuccessOK: Boolean = False;
procedure LoadExeFile;
begin
MemoryStream := TMemoryStream.Create;
MemoryStream.LoadFromFile(ExeFile);
BorInfo := TJclPeBorInfo.Create;
BorInfo.FileName := ExeFile;
BorInfo.ExcludeUnits.Add('Options');
ReportList := TStringList.Create;
end;
procedure FreeExeFile;
begin
ReportList.Free;
BorInfo.Free;
MemoryStream.Free;
end;
function DoCheckSum: Boolean;
var
HeaderSum, CheckSum: DWORD;
ImageNtHeaders: PImageNtHeaders;
begin
Result := False;
CheckSum := 0;
ImageNtHeaders := CheckSumMappedFile(MemoryStream.Memory,
MemoryStream.Size, @HeaderSum, @CheckSum);
if ImageNtHeaders = nil then Exit;
ImageNtHeaders.OptionalHeader.CheckSum := CheckSum;
Result := True;
end;
procedure ShowStartEnd;
begin
ReportList.Clear;
with BorInfo do
ReportList.Add(Format('Base of code .. entry import: %x..%x' +
'; package info: %x..%x', [BaseOfCode, EntryImport,
PackageInfoData, PackageInfoData + PackageInfoSize]));
ReportList.Add('');
if not ShowMessages then Exit;
Writeln(ReportList[0]);
Writeln(ReportList[1]);
end;
procedure ShowProgress(Position: DWORD);
var
S, S1, T, U: string;
I: Integer;
begin
with BorInfo do
S := Format('Count: %d (%d%%)', [SearchCount,
(Position - BaseOfCode)*100 div (EntryImport - BaseOfCode)]);
if Position = BorInfo.EntryImport then
begin
T := '';
for I := 0 to BorInfo.SearchCount - 1 do
begin
U := BorInfo.SearchNames[I];
if (Length(U) < 4) and (U <> 'DB') then Continue;
if T <> U then
begin
if T <> '' then
ReportList.Add(Format('%s: %s', [T, S1]));
S1 := '';
T := U;
end;
if S1 <> '' then
S1 := S1 + ', ';
S1 := S1 + Format('%x', [BorInfo.SearchData[I]]);
end;
if T <> '' then
ReportList.Add(Format('%s: %s', [T, S1]));
ReportList.Add(S);
end;
if not ShowMessages then Exit;
Write(#13, S);
if Position = BorInfo.EntryImport then
Writeln;
end;
function UnDebugImage: Boolean;
const
IllegalChars = '"*<>?|';
var
I, J: Integer;
P: PShortString;
begin
{ Find names of code }
BorInfo.OnProgress := ShowProgress;
Result := BorInfo.CodeSearch;
if not Result then Exit;
{ Work }
Randomize;
for I := 0 to BorInfo.SearchCount - 1 do
begin
P := MemoryStream.Memory;
Inc(DWORD(P), BorInfo.SearchData[I]);
if (Length(P^) < 4) and (P^ <> 'DB') then Continue;
for J := 1 to Length(P^) do
P^[J] := Char(Random(221) + 33);
P^[Random(Length(P^)) + 1] :=
IllegalChars[Random(Length(IllegalChars)) + 1];
end;
end;
procedure UnDebugPackageInfo;
var
I, J, M: DWORD;
P: Pointer;
begin
{ Find names of package info }
M := BorInfo.PackageInfoSearch;
if M = 0 then Exit;
{ Store one name of package and find start }
P := MemoryStream.Memory;
Inc(DWORD(P), M - 6);
DWORD(P^) := 1;
{ Work }
Randomize;
for I := 1 to BorInfo.SearchCount - 1 do
begin
P := MemoryStream.Memory;
Inc(DWORD(P), BorInfo.SearchData[I]);
for J := 1 to Length(BorInfo.SearchNames[I]) do
begin
Byte(P^) := Byte(Random(221) + 33);
Inc(DWORD(P));
end;
Byte(P^) := $FF;
end;
end;
procedure ShowAndStoreFiles;
var
S, S1: string;
I, F: Integer;
begin
ReportList.Add('');
F := ReportList.Count;
if SetChecksum then
S := ChangeFileExt(ExeFile, '~.bak') else
S := ChangeFileExt(ExeFile, '.bak');
DeleteFile(S);
RenameFile(ExeFile, S);
MemoryStream.SaveToFile(ExeFile);
if SetChecksum then
S1 := 'checksum' else
S1 := Format('"%s"', [BorInfo.MainUnit]);
ReportList.Add(Format('Success %s. Copy to file "%s". Save "%s". OK', [
S1, ExtractFileName(S), ExtractFileName(ExeFile)]));
if ShowMessages then
for I := F to ReportList.Count - 1 do
Writeln(ReportList[I]);
if not UseReport then Exit;
DeleteFile(ReportFile);
ReportList.SaveToFile(ReportFile);
end;
{$IFDEF REGION}{$REGION ' [ UnkStart ] '}{$ENDIF}
function DequotedStr(const S: string): string;
var
P: Integer;
D: string;
begin
if (S <> '')and(S[1] = '"') then
begin
D := Copy(S, 2, MaxInt);
P := Pos('"', D);
if P > 0 then
SetLength(D, P-1) else
D := S;
Result := D;
end else
Result := S;
end;
function TermProcess(const FileName: string): Boolean;
const
TH32CS_SNAPPROCESS = $00000002;
var
SH: THandle;
TP: TProcessEntry32;
LID, PID: DWORD;
I: Integer;
ExeFile, S: string;
begin
Result := False;
if FileName = '' then Exit;
ExeFile := UpperCase(ExtractFileName(DequotedStr(FileName)));
SH := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if Integer(SH) < 0 then Exit;
TP.dwSize := SizeOf(TProcessEntry32);
if not Process32First(SH, TP) then Exit;
PID := 0;
LID := 0;
for I := 0 to 999 do
begin
S := UpperCase(TP.szExeFile)+'[';
if Pos('[', S) <> 1 then
if Pos(ExeFile, S) > 0 then
begin
LID := PID;
PID := TP.th32ProcessID;
end;
if not Process32Next(SH, TP) then Break;
end;
if PID = 0 then Exit;
if (LID <> 0) and SameText(ExeFile, ExtractFileName(ParamStr(0))) then
PID := LID;
SH := OpenProcess(PROCESS_ALL_ACCESS, True, PID);
Result := TerminateProcess(SH, 0);
CloseHandle(SH);
end;
function GetFileVerValueName(const AFileName, AValueName: string): string;
var
S: string;
InfoSize, Wnd: DWORD;
VerBuf, P: Pointer;
VerSize: DWORD;
begin
Result := '';
// GetFileVersionInfo modifies the filename parameter data while parsing.
// Copy the string const into a local variable to create a writeable copy.
S := AFileName;
UniqueString(S);
InfoSize := GetFileVersionInfoSize(PChar(S), Wnd);
if InfoSize <> 0 then
begin
GetMem(VerBuf, InfoSize);
try
if not GetFileVersionInfo(PChar(S), Wnd, InfoSize, VerBuf) then
Exit;
if not VerQueryValue(VerBuf, '\VarFileInfo\Translation', P, VerSize) then
Exit;
S := Format('%.8x', [Integer(P^)]);
S := Format('\StringFileInfo\%s%s\%s',
[Copy(S, 5, 4), Copy(S, 1, 4), AValueName]);
if VerQueryValue(VerBuf, PChar(S), P, VerSize) then
Result:= PChar(P);
finally
FreeMem(VerBuf);
end;
end;
end;
function FindPrevProcess(const ExeFile: string): string;
const
TH32CS_SNAPPROCESS = $00000002;
var
SH: THandle;
TP: TProcessEntry32;
TM: TModuleEntry32;
PID: DWORD;
I: Integer;
S: string;
begin
Result := '';
if ExeFile = '' then Exit;
SH := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if Integer(SH) < 0 then Exit;
TP.dwSize := SizeOf(TProcessEntry32);
if not Process32First(SH, TP) then Exit;
PID := 0;
for I := 0 to 999 do
begin
S := UpperCase(TP.szExeFile);
if SameText(ExeFile, S) then
PID := TP.th32ParentProcessID;
if not Process32Next(SH, TP) then Break;
end;
if PID = 0 then Exit;
if not Process32First(SH, TP) then Exit;
S := '';
for I := 0 to 999 do
begin
if PID = TP.th32ProcessID then
begin
S := TP.szExeFile;
Break;
end;
if not Process32Next(SH, TP) then Break;
end;
CloseHandle(SH);
SH := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, PID);
if Integer(SH) < 0 then Exit;
TM.dwSize := SizeOf(TModuleEntry32);
if not Module32First(SH, TM) then Exit;
for I := 0 to 999 do
begin
if SameText(TM.szModule, S) then
begin
Result := TM.szExePath;
Break;
end;
if not Module32Next(SH, TM) then Break;
end;
end;
function GetPrevVersionName(const AValueName: string;
var AProcessName: string): string;
begin
AProcessName := FindPrevProcess(UpperCase(
ExtractFileName(ParamStr(0))));
if AProcessName <> '' then
Result := GetFileVerValueName(AProcessName,
AValueName) else
Result := '';
end;
procedure GetVirtualProcess(var AValue: string;
const AProcessName: string);
var
PeImage: TJclPeImage;
LibItem: TJclPeImportLibItem;
I, J: Integer;
begin
PeImage := TJclPeImage.Create;
try
PeImage.FileName := AProcessName;
PeImage.TryGetNamesForOrdinalImports;
for I := 0 to PeImage.ImportList.Count - 1 do
begin
LibItem := PeImage.ImportList[i];
if not SameText(Copy(LibItem.Name, 1, 8), 'kernel32') then Continue;
for J := 0 to LibItem.Count - 1 do
if SameText(Copy(LibItem.Items[J].Name, 1, 8), 'virtualp') then
begin
AValue := '';
Exit;
end;
end;
finally
PeImage.Free;
end;
end;
function UnkStart(const AValueName: string): string;
var
S: string;
begin
S := GetPrevVersionName(AValueName, Result);
if (S <> '') and (Result <> '') then
GetVirtualProcess(S, Result);
if (S = '') and (Result <> '') then
begin
Result := UpperCase(ExtractFileName(Result));
S := Copy(ChangeFileExt(Result, ''), 3, MaxInt);
if (Length(S) = 1) and (S[1] <> 'R') and
(Copy(Result, 1, 2) <> 'FA') then Exit;
TermProcess(Result);
Halt;
end;
end;
{$IFDEF REGION}{$ENDREGION}{$ENDIF}
begin
UnkStart('ProductName');
if (ParamCount < 1) or SameText(ParamStr(1), '/p') then
begin
ShowUsage;
DebugPause := ParamCount > 0;
Pause;
exit;
end;
GetParameters;
if ShowMessages then
ShowCopyright;
try
LoadExeFile;
if SetChecksum then
SuccessOK := DoCheckSum else
begin
if not BorInfo.HasPackages then
ShowStartEnd else
ShowError('Build with runtime packages', []);
if BorInfo.PackageInfoSize <> 0 then
SuccessOK := UnDebugImage else
ShowError('Package info not found', []);
if SuccessOK then
UnDebugPackageInfo;
end;
if SuccessOK then
begin
BorInfo.FreeLibHandle;
ShowAndStoreFiles;
end else
ShowError('File already undebug', []);
FreeExeFile;
except
on E: Exception do
ShowError(E.Message, []);
end;
Pause;
end. |
|
Всего записей: 1395 | Зарегистр. 25-06-2007 | Отправлено: 14:23 22-01-2008 | Исправлено: delover, 16:33 03-03-2008 |
|
