1 {********************************************************}
2 { SakuraSeeker Component - Listups Existing SSTP Servers }
4 { Copyright (c) 2001-2003 naruto/CANO-Lab }
5 {********************************************************}
12 Windows, SysUtils, Classes, Contnrs;
15 ESakuraSeekerError = class(Exception);
17 TSakuraSeeker = class;
19 TSakuraSeekerGetMutexNameEvent = procedure (Sender: TObject;
20 var Name: String) of object;
22 TSakuraProcess = class(TObject)
27 FOwner: TSakuraSeeker;
28 procedure SetProcessID(const Value: String);
29 function GetHWnd: THandle;
30 function GetName: String;
31 function GetData(Key: String): String;
32 function GetKeroName: String;
33 function GetSetName: String;
34 procedure SetFMOName(const Value: String);
35 function GetDataAt(Index: integer): String;
36 function GetCount: integer;
37 function GetKeyAt(Index: integer): String;
39 procedure AppendData(const Key, Value: String);
41 constructor Create(AOwner: TSakuraSeeker);
42 destructor Destroy; override;
43 property ProcessID: String read FProcessID write SetProcessID;
44 property FMOName: String read FFMOName write SetFMOName;
45 property HWnd: THandle read GetHWnd;
46 property Name: String read GetName;
47 property KeroName: String read GetKeroName;
48 property SetName: String read GetSetName;
49 property Data[Key: String]: String read GetData;
50 property Count: integer read GetCount;
51 property DataAt[Index: integer]: String read GetDataAt;
52 property KeyAt[Index: integer]: String read GetKeyAt;
55 TSakuraSeeker = class(TComponent)
60 FOnAfterDetection: TNotifyEvent;
61 FLastSeekResult: String; //
\91O
\89ñ
\82Ì
\8eæ
\93¾
\8c\8b\89Ê
\81B
\94ä
\8ar
\97p
62 FSourceResult: String; //
\8d¡
\89ñ
\82Ì
\8eæ
\93¾
\8c\8b\89Ê
\81B
\94ä
\8ar
\97p
63 FOnDetectResultChanged: TNotifyEvent;
64 FFileMappingTarget: TStrings;
65 FOnGetMutexName: TSakuraSeekerGetMutexNameEvent;
66 FMutexPool: TStringList;
67 function GetProcess(Index: integer): TSakuraProcess;
68 procedure SetAutoDetect(const Value: boolean);
69 function GetProcessByName(Name: String): TSakuraProcess;
70 function GetProcessByID(ID: String): TSakuraProcess;
71 function GetCount: integer;
72 procedure SetOnAfterDetection(const Value: TNotifyEvent);
73 procedure SetOnDetectResultChanged(const Value: TNotifyEvent);
74 procedure SetFileMappingTarget(const Value: TStrings);
75 function GetProcessBySetName(Name: String): TSakuraProcess;
76 procedure SetOnGetMutexName(
77 const Value: TSakuraSeekerGetMutexNameEvent);
79 { Protected
\90é
\8c¾ }
80 procedure Loaded; override;
82 procedure BeginDetectOne(const Target: String);
83 function GetMutexName(const Target: String): String;
84 function GetMutex(const Name: String): THandle;
87 procedure BeginDetect;
88 property Count: integer read GetCount;
89 property Process[Index: integer]: TSakuraProcess read GetProcess; default;
90 property ProcessByName[Name: String]: TSakuraProcess read GetProcessByName;
91 property ProcessBySetName[Name: String]: TSakuraProcess read GetProcessBySetName;
92 property ProcessByID[ID: String]: TSakuraProcess read GetProcessByID;
93 function KillFMO(const TargetFMOName, TargetID: String): boolean;
94 constructor Create(AOwner: TComponent); override;
95 destructor Destroy; override;
97 { Published
\90é
\8c¾ }
98 property AutoDetect: boolean read FAutoDetect write SetAutoDetect default true;
99 property OnAfterDetection: TNotifyEvent read FOnAfterDetection write SetOnAfterDetection;
100 property OnDetectResultChanged: TNotifyEvent read FOnDetectResultChanged write SetOnDetectResultChanged;
101 property FileMappingTarget: TStrings read FFileMappingTarget write SetFileMappingTarget;
102 property OnGetMutexName: TSakuraSeekerGetMutexNameEvent read FOnGetMutexName write SetOnGetMutexName;
111 RegisterComponents('Samples', [TSakuraSeeker]);
116 procedure TSakuraProcess.AppendData(const Key, Value: String);
118 FHash.Values[Key] := Value;
121 constructor TSakuraProcess.Create(AOwner: TSakuraSeeker);
123 FHash := TStringList.Create;
127 destructor TSakuraProcess.Destroy;
133 function TSakuraProcess.GetCount: integer;
135 Result := FHash.Count;
138 function TSakuraProcess.GetData(Key: String): String;
140 Result := FHash.Values[Key];
143 function TSakuraProcess.GetDataAt(Index: integer): String;
146 Result := Copy(FHash[Index], Length(FHash.Names[Index]) + 2, High(integer))
151 function TSakuraProcess.GetHWnd: THandle;
153 Result := StrToIntDef(GetData('hwnd'), 0);
156 function TSakuraProcess.GetKeroName: String;
158 Result := GetData('keroname');
161 function TSakuraProcess.GetKeyAt(Index: integer): String;
163 Result := FHash.Names[Index];
166 function TSakuraProcess.GetName: String;
168 Result := GetData('name');
172 function TSakuraProcess.GetSetName: String;
174 Result := GetName + ',' + GetKeroName;
177 procedure TSakuraProcess.SetFMOName(const Value: String);
182 procedure TSakuraProcess.SetProcessID(const Value: String);
189 procedure TSakuraSeeker.BeginDetect;
192 if [csDesigning, csLoading] * ComponentState <> [] then Exit;
196 for i := 0 to FFileMappingTarget.Count-1 do begin
197 BeginDetectOne(FFileMappingTarget[i]); //1
\82Â
\82ÌFile-mapping Object
\82ð
\8eæ
\93¾
200 if Assigned(OnDetectResultChanged) and (FLastSeekResult <> FSourceResult) then begin
201 FLastSeekResult := FSourceResult;
202 OnDetectResultChanged(Self);
204 FLastSeekResult := FSourceResult;
207 if Assigned(OnAfterDetection) then OnAfterDetection(Self);
210 procedure TSakuraSeeker.BeginDetectOne(const Target: String);
211 var MappingHandle, Mutex: THandle;
213 SourceStr, ID, Entry, Data: String;
219 //
\83t
\83@
\83C
\83\8b\83}
\83b
\83s
\83\93\83O
\83I
\83u
\83W
\83F
\83N
\83g
\82Ì
\8eæ
\93¾
224 Mutex := GetMutex(GetMutexName(Target));
226 raise ESakuraSeekerError.Create('Mutex
\83n
\83\93\83h
\83\8b\82ð
\8eæ
\93¾
\82Å
\82«
\82Ü
\82¹
\82ñ
\82Å
\82µ
\82½');
227 if WaitForSingleObject(Mutex, 3000) = WAIT_TIMEOUT then
228 raise ESakuraSeekerError.Create('Mutex
\93¯
\8aú
\83^
\83C
\83\80\83A
\83E
\83g');
230 MappingHandle := OpenFileMapping(FILE_MAP_READ, false, PChar(Target));
232 if MappingHandle = 0 then begin
235 PSaved := MapViewOfFile(MappingHandle, FILE_MAP_READ, 0, 0, 0);
237 if P <> nil then begin
238 CopyMemory(@Size, P, SizeOf(integer));
239 Inc(PChar(P), SizeOf(integer));
240 SourceStr := PChar(P);
241 if Length(SourceStr) > Size then
242 raise ESakuraSeekerError.Create('FMO
\82ð
\8eæ
\93¾
\82Å
\82«
\82Ü
\82¹
\82ñ
\82Å
\82µ
\82½');
246 //
\83I
\83u
\83W
\83F
\83N
\83g
\82Ì
\94j
\8aü
247 if PSaved <> nil then UnmapViewOfFile(PSaved);
250 if MappingHandle <> 0 then CloseHandle(MappingHandle);
254 //
\83f
\81[
\83^
\82ð
\89ð
\90Í
257 Strs := TStringList.Create;
258 Strs.Text := SourceStr;
259 for i := 0 to Strs.Count-1 do begin
260 j := Pos('.', Strs[i]);
261 ID := Copy(Strs[i], 1, j-1);
262 Entry := Copy(Strs[i], j+1, Pos(#1, Strs[i])-j-1);
263 Data := Copy(Strs[i], Pos(#1, Strs[i])+1, High(integer));
264 Pro := GetProcessByID(ID);
265 if Pro = nil then begin
266 Pro := TSakuraProcess.Create(self);
268 Pro.FMOName := Target; // FMO
\8e¯
\95Ê
\96¼
271 Pro.AppendData(Entry, Data);
278 FSourceResult := FSourceResult + SourceStr;
281 procedure TSakuraSeeker.ClearList;
286 constructor TSakuraSeeker.Create(AOwner: TComponent);
290 FList := TObjectList.Create;
291 FFileMappingTarget := TStringList.Create;
292 FFileMappingTarget.Add('Sakura');
293 FMutexPool := TStringList.Create;
296 destructor TSakuraSeeker.Destroy;
301 FFileMappingTarget.Free;
302 for i := 0 to FMutexPool.Count-1 do
304 CloseHandle(StrToInt(Copy(FMutexPool[i], Pos('=', FMutexPool[i])+1, High(integer))));
306 FreeAndNil(FMutexPool);
309 function TSakuraSeeker.GetCount: integer;
311 Result := FList.Count;
314 function TSakuraSeeker.GetMutex(const Name: String): THandle;
316 if FMutexPool.Values[Name] <> '' then
318 Result := THandle(StrToInt(FMutexPool.Values[Name]));
321 Result := CreateMutex(nil, false, PChar(Name));
323 FMutexPool.Values[Name] := IntToStr(Result);
327 function TSakuraSeeker.GetMutexName(const Target: String): String;
329 if Assigned(FOnGetMutexName) then
332 FOnGetMutexName(self, Result);
334 Result := Target + 'FMO';
337 function TSakuraSeeker.GetProcess(Index: integer): TSakuraProcess;
339 Result := FList[Index] as TSakuraProcess;
342 function TSakuraSeeker.GetProcessByID(ID: String): TSakuraProcess;
346 for i := 0 to FList.Count-1 do begin
347 if TSakuraProcess(FList[i]).ProcessID = ID then begin
348 Result := FList[i] as TSakuraProcess;
354 function TSakuraSeeker.GetProcessByName(Name: String): TSakuraProcess;
358 for i := 0 to FList.Count-1 do begin
359 if (FList[i] as TSakuraProcess).Name = Name then begin
360 Result := FList[i] as TSakuraProcess;
366 function TSakuraSeeker.GetProcessBySetName(Name: String): TSakuraProcess;
370 for i := 0 to FList.Count-1 do begin
371 if (FList[i] as TSakuraProcess).SetName = Name then begin
372 Result := FList[i] as TSakuraProcess;
378 function TSakuraSeeker.KillFMO(const TargetFMOName, TargetID: String): boolean;
379 var MappingHandle, Mutex: THandle;
381 SourceStr, ID: String;
386 //
\83t
\83@
\83C
\83\8b\83}
\83b
\83s
\83\93\83O
\83I
\83u
\83W
\83F
\83N
\83g
\82Ì
\8eæ
\93¾
389 Mutex := GetMutex(GetMutexName(TargetFMOName));
391 raise ESakuraSeekerError.Create('Mutex
\83n
\83\93\83h
\83\8b\82ð
\8eæ
\93¾
\82Å
\82«
\82Ü
\82¹
\82ñ
\82Å
\82µ
\82½');
392 if WaitForSingleObject(Mutex, 3000) = WAIT_TIMEOUT then
393 raise ESakuraSeekerError.Create('Mutex
\93¯
\8aú
\83^
\83C
\83\80\83A
\83E
\83g');
395 MappingHandle := OpenFileMapping(FILE_MAP_WRITE, false, PChar(TargetFMOName));
396 if MappingHandle = 0 then Exit;
399 P := MapViewOfFile(MappingHandle, FILE_MAP_WRITE, 0, 0, 0);
400 if P <> nil then begin
401 CopyMemory(@Size, P, SizeOf(integer));
402 Inc(PChar(P), SizeOf(integer));
403 SourceStr := PChar(P);
404 if Length(SourceStr) > Size then
405 raise ESakuraSeekerError.Create('FMO
\82ð
\8eæ
\93¾
\82Å
\82«
\82Ü
\82¹
\82ñ
\82Å
\82µ
\82½');
408 //
\83f
\81[
\83^
\82ð
\89ð
\90Í
409 Strs := TStringList.Create;
411 Strs.Text := SourceStr;
412 for i := Strs.Count-1 downto 0 do begin
413 j := Pos('.', Strs[i]);
414 ID := Copy(Strs[i], 1, j-1);
415 if ID = TargetID then begin
416 Strs.Delete(i); //
\97v
\82ç
\82È
\82¢
\83G
\83\93\83g
\83\8a\82ð
\8dí
\8f\9c
420 SourceStr := Strs.Text;
426 CopyMemory(P, PChar(SourceStr), Length(SourceStr)+1);
427 Dec(PChar(P), SizeOf(integer));
430 //
\83I
\83u
\83W
\83F
\83N
\83g
\82Ì
\94j
\8aü
431 if P <> nil then UnmapViewOfFile(P);
432 CloseHandle(MappingHandle);
439 procedure TSakuraSeeker.Loaded;
442 if FAutoDetect and not (csDesigning in ComponentState) then BeginDetect;
445 procedure TSakuraSeeker.SetAutoDetect(const Value: boolean);
447 FAutoDetect := Value;
450 procedure TSakuraSeeker.SetFileMappingTarget(const Value: TStrings);
452 FFileMappingTarget.Assign(Value);
455 procedure TSakuraSeeker.SetOnAfterDetection(const Value: TNotifyEvent);
457 FOnAfterDetection := Value;
460 procedure TSakuraSeeker.SetOnDetectResultChanged(
461 const Value: TNotifyEvent);
463 FOnDetectResultChanged := Value;
466 procedure TSakuraSeeker.SetOnGetMutexName(
467 const Value: TSakuraSeekerGetMutexNameEvent);
469 FOnGetMutexName := Value;