» Вопросы по Embarcadero RAD Studio XE5-XE8,10.x(Seattle, Berl

выходит, они даже такие базовые вещи (дженерики) не покрыли тестами :/ что же говорит о менее важных, ой вей

Есть ли у кого информация для новичков по тестированию в делфи xe?

Цитата:

Кто-нибудь работает с XE8 (vcl32) + AbsoluteDatabase 7

Я закинул вопрос в поддержку, обещали исправить

уважаемые коллеги
подскажите как проще всего покрыть прогу тестами, каким инструментом?

"Из критериев Скорость, Стоимость, Качество одновременно можно оптимизировать не более двух."

Если быстро и качественно, то можно попробовать TestComplete
_ttp://smartbear.com/product/testcomplete/overview/

Если быстро и дёшево, так DUnit входит же в RAD Studio...
New Project - Unit Test
и вперёд.

KDPoid
спасибо, начну с DUnit, просто теперь пишу единое ядро к программам, а модули разные и начинаются баги то там то тут, поэтому пора уже вводить тесты и при перекомпиляции чтобы проверки проходили.

Что-то в ХЕ8 при переключении между вкладками модулей иногда жутко тупит.
Когда-то было, кажется, в ХЕ2 или ХЕ3, если проект не сохранен, то при переключении с модуля на форму очень долго тупила среда.
Ну не могут они без приключений. Или специально так делают, чтобы было, что исправлять?

Цитата:

Что-то в ХЕ8 при переключении между вкладками модулей иногда жутко тупит.
Когда-то было, кажется, в ХЕ2 или ХЕ3, если проект не сохранен, то при переключении с модуля на форму очень долго тупила среда.
Ну не могут они без приключений. Или специально так делают, чтобы было, что исправлять?

мало того что тупит, но иногда зависает наглухо БЕЗ СОХРАНЕНИЯ последнего редактирования(((

Цитата:

Что-то в ХЕ8 при переключении между вкладками модулей иногда жутко тупит.

MGAlex castalia? Не пробовал отключать?

>> castalia? Не пробовал отключать?

а как её отключить кстати? ))

Где-то здесь пробегало решение по отключению castalia, на сколько я помню, есть ключ командной строки /NOCASTALIA, либо отключить с помощью какого-нибудь менеджера экспертов.

Добавлено:
Added:

В этой теме, сообщение от doxtur:


Цитата:

если запускать IDE XE8 с ключом /nocastalia - то запуск среды будет быстрее и меньше шансов зависнуть с потерей редактируемого кода

NeoAnomaly
Я в реестре просто убрал строку и нет касталии.

bds.exe -pDelphi /nocastalia не помогает что-то.

>> ChSerg
а что и где убирали поточней не помните?

stanzdor
*Castalia*.bpl в bin "потеряй как-нибудь", среда должна разок ругнуться, ты скажешь "Нет", и все.

Цитата:

а что и где убирали поточней не помните?

В этой ветке (у меня)
HKEY_CURRENT_USER\Software\Embarcadero\BDS\16.0\Known IDE Packages\Delphi
удаляете строку с Castalia220.bpl

или вот два скриптика:

Этот удаляет:

Код: Windows Registry Editor Version 5.00

[HKEY_CURRENT_USER\Software\Embarcadero\BDS\16.0\Known IDE Packages\Delphi]
"$(BDS)\\Bin\\Castalia220.bpl"=-

"C:\Program Files (x86)\Embarcadero\Studio\16.0\bin\bds.exe" -pDelphi /nocastalia - у меня точно работает, при загрузки нет надписи Касталия и в меню тоже нету

для IDE есть FIXPack (http://andy.jgknet.de/blog/ide-tools/ide-fix-pack/) - в том числе делает "Added: Castalia XE8 startup optimization (XE8)"

MGAlex
Получилось? Тормоза пропали?

IDE Fix Pack 5.92 released
_ttp://andy.jgknet.de/blog/2015/05/ide-fix-pack-5-92-released/


Код: Fixed: TStringList.IndexOfName optimization broke UniDAC’s designtime editor
Fixed: “Find References” shortcut was assigned to “Find Local References” unless the search menu was opened
Added: “Find Local References” shortcut Shift+Ctrl+Alt+Enter

Почему при заходе на сайт http://tv.domru.ru/ через компонент TWebBrowser, из всей страницы отображается только фон. JavaScript почему то неисполняются. В чем может быть проблема?

в винде настройки IE проверь

Без Castalia вроде бы тормоза не наблюдаются.
Лучше бы они интегрировали CnPack. Хотя, с другой стороны, поставить CnPack - минутное дело, а если бы, к примеру, купили права и начали интегрировать, накосячили бы, они могут.

а я наоборот Castalia вернул пока, с IDE Fix Pack. Нравится как разрисовываются блоки begin-end

Народ, никто не занимался разработкой сервисов на делфи XE7/XE8?
Что меня конкретно интересует - как правильно работать с формами (отображать их, добавлять trayicon) в сервисе? Сервису разрешение взаимодействовать с рабочим столом дано, форма на создание (.Create) и отображение (.Show) ошибок не выдает, но при этом фактически на десктопе не появляется.
Куда копать?

doxtur

Цитата:

Нравится как разрисовываются блоки begin-end

Ты cnPack видел ? Там по-круче, мне кажется, разрисовка блоков сделана.

asutp2
На Vista и выше сам сервис доступа к десктопу иметь не будет.
https://msdn.microsoft.com/en-us/library/windows/desktop/ms683502(v=vs.85).aspx

Цитата:

Important Services cannot directly interact with a user as of Windows Vista. Therefore, the techniques mentioned in the section titled Using an Interactive Service should not be used in new code.

Обновление undeb32 до "нового" RTTI.

[more]
Код: [no]
{********
{ Software distributed under the License is distributed on an "AS IS"
{
{ $Id: undeb32.dpr $
{ $Date: 2015/05/20 14:07:20 $xpin
}

program undeb32;

{$APPTYPE CONSOLE}

{%File 'build.bat'}

uses
Windows,
SysUtils,
Classes,
TlHelp32,
ImageHlp,
JclPeImage;

{%File *.res}

const
PackageInfoResName = 'PACKAGEINFO';

var
DebugPause: Boolean = False;
ExeFile: string = '';
ExeFileDate: Integer;
ReportFile: string = '';
SetChecksum: Boolean = False;
ShowingFlag: Boolean = False;
ShowMessages: Boolean = True;
UseReport: Boolean = False;
RttiInclude: Boolean = False;

procedure ShowCopyright;
begin
if ShowingFlag then Exit;
ShowingFlag := True;
Writeln('UNDEB32 (C) subreal.PIN Check Utility. Version 1.15 20-05-2015');
Writeln('Copr. 2006-2015 Roman Silin. All Rights Reserved. Freeware Version');
Writeln;
end;

procedure ShowUsage;
begin
ShowCopyright;
Writeln('Usage: UNDEB32 exefile [/p | /n] [/r] [/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;
D: TDateTime;
begin
ExeFile := ExpandFileName(ParamStr(1));
ExeFileDate := 0;
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;
'R': RttiInclude := 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]) else
begin
FileAge(ExeFile, D);
ExeFileDate := DateTimeToFileDate(D);
end;
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 ResourceData(const Name: string; var Size: DWORD): DWORD;
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 and not RttiInclude then
for I := FTempContains.Count - 1 downto 0 do
if FMainUnit <> FTempContains[I] then
if Pos('System.', FTempContains[I]) = 1 then
FTempContains.Delete(I);
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;

function TJclPeBorInfo.ResourceData(const Name: string; var Size: DWORD): DWORD;
var
ResItem: TJclPeResourceItem;
begin
ResItem := ResourceList.FindResource(rtRCData, UpperCase(Name));
if ResItem <> nil then
begin
Result := GetOffset(ResItem.List[0].DataEntry.OffsetToData);
Size := ResItem.List[0].DataEntry.Size - 1;
end else
begin
Result := 0;
Size := 0;
end;
end;

procedure TJclPeBorInfo.SetFileName(const Value: TFileName);
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
FPackageInfoData := ResourceData(PackageInfoResName, FPackageInfoSize);
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');
BorInfo.ExcludeUnits.Add('Provider');
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] := AnsiChar(Random(221) + 33);
P^[Random(Length(P^)) + 1] :=
AnsiString(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 UnDebugModuleInfo;
begin
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);
Sleep(123);
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 UseReport then
begin
DeleteFile(ReportFile);
ReportList.SaveToFile(ReportFile);
end;
if ExeFileDate <> 0 then
FileSetDate(ExeFile, ExeFileDate);
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
{$IFDEF REGION}{$REGION ' [ UnkStart ] '}{$ENDIF}
{$IFDEF UNKSTART_INCLUDE}
//UnkStart('ProductName');
{$ENDIF}
{$IFDEF REGION}{$ENDREGION}{$ENDIF}

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;
if SuccessOK then
UnDebugModuleInfo;
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.[/no]

xpin2013
Как насчет хотя бы краткого описания ?

asutp2
В современных виндах надо разбивать на два екзешника. Первый это собственно сервис без гуя, а второй чисто гуй, который запускается под юзером, и управляет сервисом.

del)

dred2k
А аватарку надо описывать?

ps
Контент переехал сюда, обновлено до 20.05.2015.
Линк на предыдущий контент попытаюсь, конечно, поднять но не обещаю.

Цитата:

В современных виндах надо разбивать на два екзешника. Первый это собственно сервис без гуя, а второй чисто гуй, который запускается под юзером, и управляет сервисом.

Т.е., надо разбивать на негуёвый сервис и гуёвое приложение...