sakurasuite/SakuraSeeker.pas

   1 {********************************************************}
   2 { SakuraSeeker Component - Listups Existing SSTP Servers }
   3 {                                                        }
   4 {       Copyright (c) 2001-2003 naruto/CANO-Lab          }
   5 {********************************************************}
   6
   7 unit SakuraSeeker;
   8
   9 interface
  10
  11 uses
  12   Windows, SysUtils, Classes, Contnrs;
  13
  14 type
  15   ESakuraSeekerError = class(Exception);
  16
  17   TSakuraSeeker = class;
  18
  19   TSakuraSeekerGetMutexNameEvent = procedure (Sender: TObject;
  20     var Name: String) of object;
  21
  22   TSakuraProcess = class(TObject)
  23   private
  24     FHash: TStringList;
  25     FProcessID: String;
  26     FFMOName: String;
  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;
  38   protected
  39     procedure AppendData(const Key, Value: String);
  40   public
  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;
  53   end;
  54
  55   TSakuraSeeker = class(TComponent)
  56   private
  57     { Private \90é\8c¾ }
  58     FList: TObjectList;
  59     FAutoDetect: boolean;
  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);
  78   protected
  79     { Protected \90é\8c¾ }
  80     procedure Loaded; override;
  81     procedure ClearList;
  82     procedure BeginDetectOne(const Target: String);
  83     function GetMutexName(const Target: String): String;
  84     function GetMutex(const Name: String): THandle;
  85   public
  86     { Public \90é\8c¾ }
  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;
  96   published
  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;
 103   end;
 104
 105 procedure Register;
 106
 107 implementation
 108
 109 procedure Register;
 110 begin
 111   RegisterComponents('Samples', [TSakuraSeeker]);
 112 end;
 113
 114 { TSakuraProcess }
 115
 116 procedure TSakuraProcess.AppendData(const Key, Value: String);
 117 begin
 118   FHash.Values[Key] := Value;
 119 end;
 120
 121 constructor TSakuraProcess.Create(AOwner: TSakuraSeeker);
 122 begin
 123   FHash := TStringList.Create;
 124   FOwner := AOwner;
 125 end;
 126
 127 destructor TSakuraProcess.Destroy;
 128 begin
 129   inherited;
 130   FHash.Free;
 131 end;
 132
 133 function TSakuraProcess.GetCount: integer;
 134 begin
 135   Result := FHash.Count;
 136 end;
 137
 138 function TSakuraProcess.GetData(Key: String): String;
 139 begin
 140   Result := FHash.Values[Key];
 141 end;
 142
 143 function TSakuraProcess.GetDataAt(Index: integer): String;
 144 begin
 145   if Index >= 0 then
 146     Result := Copy(FHash[Index], Length(FHash.Names[Index]) + 2, High(integer))
 147   else
 148     Result := '';
 149 end;
 150
 151 function TSakuraProcess.GetHWnd: THandle;
 152 begin
 153   Result := StrToIntDef(GetData('hwnd'), 0);
 154 end;
 155
 156 function TSakuraProcess.GetKeroName: String;
 157 begin
 158   Result := GetData('keroname');
 159 end;
 160
 161 function TSakuraProcess.GetKeyAt(Index: integer): String;
 162 begin
 163   Result := FHash.Names[Index];
 164 end;
 165
 166 function TSakuraProcess.GetName: String;
 167 begin
 168   Result := GetData('name');
 169 end;
 170
 171
 172 function TSakuraProcess.GetSetName: String;
 173 begin
 174   Result := GetName + ',' + GetKeroName;
 175 end;
 176
 177 procedure TSakuraProcess.SetFMOName(const Value: String);
 178 begin
 179   FFMOName := Value;
 180 end;
 181
 182 procedure TSakuraProcess.SetProcessID(const Value: String);
 183 begin
 184   FProcessID := Value;
 185 end;
 186
 187 { TSakuraSeeker }
 188
 189 procedure TSakuraSeeker.BeginDetect;
 190 var i: integer;
 191 begin
 192   if [csDesigning, csLoading] * ComponentState <> [] then Exit;
 193   ClearList;
 194
 195   FSourceResult := '';
 196   for i := 0 to FFileMappingTarget.Count-1 do begin
 197     BeginDetectOne(FFileMappingTarget[i]); //1\82Â\82ÌFile-mapping Object\82ð\8eæ\93¾
 198   end;
 199
 200   if Assigned(OnDetectResultChanged) and (FLastSeekResult <> FSourceResult) then begin
 201     FLastSeekResult := FSourceResult;
 202     OnDetectResultChanged(Self);
 203   end else begin
 204     FLastSeekResult := FSourceResult;
 205   end;
 206
 207   if Assigned(OnAfterDetection) then OnAfterDetection(Self);
 208 end;
 209
 210 procedure TSakuraSeeker.BeginDetectOne(const Target: String);
 211 var MappingHandle, Mutex: THandle;
 212     P, PSaved: pointer;
 213     SourceStr, ID, Entry, Data: String;
 214     Size: integer;
 215     Strs: TStringList;
 216     Pro: TSakuraProcess;
 217     i, j: integer;
 218 begin
 219   //\83t\83@\83C\83\8b\83}\83b\83s\83\93\83O\83I\83u\83W\83F\83N\83g\82Ì\8eæ\93¾
 220   PSaved := nil;
 221   Strs := nil;
 222   MappingHandle := 0;
 223
 224   Mutex := GetMutex(GetMutexName(Target));
 225   if Mutex = 0 then
 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');
 229   try
 230     MappingHandle := OpenFileMapping(FILE_MAP_READ, false, PChar(Target));
 231     try
 232       if MappingHandle = 0 then begin
 233         SourceStr := '';
 234       end else begin
 235         PSaved := MapViewOfFile(MappingHandle, FILE_MAP_READ, 0, 0, 0);
 236         P := PSaved;
 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½');
 243         end;
 244       end;
 245     finally
 246       //\83I\83u\83W\83F\83N\83g\82Ì\94j\8aü
 247       if PSaved <> nil then UnmapViewOfFile(PSaved);
 248     end;
 249   finally
 250     if MappingHandle <> 0 then CloseHandle(MappingHandle);
 251     ReleaseMutex(Mutex);
 252   end;
 253
 254   //\83f\81[\83^\82ð\89ð\90Í
 255   try
 256     try
 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);
 267           Pro.ProcessID := ID;
 268           Pro.FMOName := Target; // FMO\8e¯\95Ê\96¼
 269           FList.Add(Pro);
 270         end;
 271         Pro.AppendData(Entry, Data);
 272       end;
 273     except
 274     end;
 275   finally
 276     Strs.Free;
 277   end;
 278   FSourceResult := FSourceResult + SourceStr;
 279 end;
 280
 281 procedure TSakuraSeeker.ClearList;
 282 begin
 283   FList.Clear;
 284 end;
 285
 286 constructor TSakuraSeeker.Create(AOwner: TComponent);
 287 begin
 288   inherited;
 289   FAutoDetect := true;
 290   FList := TObjectList.Create;
 291   FFileMappingTarget := TStringList.Create;
 292   FFileMappingTarget.Add('Sakura');
 293   FMutexPool := TStringList.Create;
 294 end;
 295
 296 destructor TSakuraSeeker.Destroy;
 297 var i: integer;
 298 begin
 299   ClearList;
 300   FList.Free;
 301   FFileMappingTarget.Free;
 302   for i := 0 to FMutexPool.Count-1 do
 303   begin
 304     CloseHandle(StrToInt(Copy(FMutexPool[i], Pos('=', FMutexPool[i])+1, High(integer))));
 305   end;
 306   FreeAndNil(FMutexPool);
 307 end;
 308
 309 function TSakuraSeeker.GetCount: integer;
 310 begin
 311   Result := FList.Count;
 312 end;
 313
 314 function TSakuraSeeker.GetMutex(const Name: String): THandle;
 315 begin
 316   if FMutexPool.Values[Name] <> '' then
 317   begin
 318     Result := THandle(StrToInt(FMutexPool.Values[Name]));
 319   end else
 320   begin
 321     Result := CreateMutex(nil, false, PChar(Name));
 322     if Result <> 0 then
 323       FMutexPool.Values[Name] := IntToStr(Result);
 324   end;
 325 end;
 326
 327 function TSakuraSeeker.GetMutexName(const Target: String): String;
 328 begin
 329   if Assigned(FOnGetMutexName) then
 330   begin
 331     Result := Target;
 332     FOnGetMutexName(self, Result);
 333   end else
 334     Result := Target + 'FMO';
 335 end;
 336
 337 function TSakuraSeeker.GetProcess(Index: integer): TSakuraProcess;
 338 begin
 339   Result := FList[Index] as TSakuraProcess;
 340 end;
 341
 342 function TSakuraSeeker.GetProcessByID(ID: String): TSakuraProcess;
 343 var i: integer;
 344 begin
 345   Result := nil;
 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;
 349       Exit;
 350     end;
 351   end;
 352 end;
 353
 354 function TSakuraSeeker.GetProcessByName(Name: String): TSakuraProcess;
 355 var i: integer;
 356 begin
 357   Result := nil;
 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;
 361       Exit;
 362     end;
 363   end;
 364 end;
 365
 366 function TSakuraSeeker.GetProcessBySetName(Name: String): TSakuraProcess;
 367 var i: integer;
 368 begin
 369   Result := nil;
 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;
 373       Exit;
 374     end;
 375   end;
 376 end;
 377
 378 function TSakuraSeeker.KillFMO(const TargetFMOName, TargetID: String): boolean;
 379 var MappingHandle, Mutex: THandle;
 380     P: pointer;
 381     SourceStr, ID: String;
 382     Size: integer;
 383     Strs: TStringList;
 384     i, j: integer;
 385 begin
 386   //\83t\83@\83C\83\8b\83}\83b\83s\83\93\83O\83I\83u\83W\83F\83N\83g\82Ì\8eæ\93¾
 387   Result := false;
 388   P := nil;
 389   Mutex := GetMutex(GetMutexName(TargetFMOName));
 390   if Mutex = 0 then
 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');
 394   try
 395     MappingHandle := OpenFileMapping(FILE_MAP_WRITE, false, PChar(TargetFMOName));
 396     if MappingHandle = 0 then Exit;
 397     try
 398       SourceStr := '';
 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½');
 406       end;
 407
 408       //\83f\81[\83^\82ð\89ð\90Í
 409       Strs := TStringList.Create;
 410       try
 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
 417             Result := true;
 418           end;
 419         end;
 420         SourceStr := Strs.Text;
 421       finally
 422         Strs.Free;
 423       end;
 424
 425       if Result then begin
 426         CopyMemory(P, PChar(SourceStr), Length(SourceStr)+1);
 427         Dec(PChar(P), SizeOf(integer));
 428       end;
 429     finally
 430       //\83I\83u\83W\83F\83N\83g\82Ì\94j\8aü
 431       if P <> nil then UnmapViewOfFile(P);
 432       CloseHandle(MappingHandle);
 433     end;
 434   finally
 435     ReleaseMutex(Mutex);
 436   end;
 437 end;
 438
 439 procedure TSakuraSeeker.Loaded;
 440 begin
 441   inherited;
 442   if FAutoDetect and not (csDesigning in ComponentState) then BeginDetect;
 443 end;
 444
 445 procedure TSakuraSeeker.SetAutoDetect(const Value: boolean);
 446 begin
 447   FAutoDetect := Value;
 448 end;
 449
 450 procedure TSakuraSeeker.SetFileMappingTarget(const Value: TStrings);
 451 begin
 452   FFileMappingTarget.Assign(Value);
 453 end;
 454
 455 procedure TSakuraSeeker.SetOnAfterDetection(const Value: TNotifyEvent);
 456 begin
 457   FOnAfterDetection := Value;
 458 end;
 459
 460 procedure TSakuraSeeker.SetOnDetectResultChanged(
 461   const Value: TNotifyEvent);
 462 begin
 463   FOnDetectResultChanged := Value;
 464 end;
 465
 466 procedure TSakuraSeeker.SetOnGetMutexName(
 467   const Value: TSakuraSeekerGetMutexNameEvent);
 468 begin
 469   FOnGetMutexName := Value;
 470 end;
 471
 472 end.
 473