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: 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   P := nil;
 221   Strs := nil;
 222   Mutex := GetMutex(GetMutexName(Target));
 223   if Mutex = 0 then
 224     raise ESakuraSeekerError.Create('Mutex\83n\83\93\83h\83\8b\82ð\8eæ\93¾\82Å\82«\82Ü\82¹\82ñ\82Å\82µ\82½');
 225   if WaitForSingleObject(Mutex, 3000) = WAIT_TIMEOUT then
 226     raise ESakuraSeekerError.Create('Mutex\93¯\8aú\83^\83C\83\80\83A\83E\83g');
 227   try
 228     MappingHandle := OpenFileMapping(FILE_MAP_READ, false, PChar(Target));
 229     try
 230       if MappingHandle = 0 then begin
 231         SourceStr := '';
 232       end else begin
 233         P := MapViewOfFile(MappingHandle, FILE_MAP_READ, 0, 0, 0);
 234         if P <> nil then begin
 235           CopyMemory(@Size, P, SizeOf(integer));
 236           Inc(PChar(P), SizeOf(integer));
 237           SourceStr := PChar(P);
 238           if Length(SourceStr) > Size then
 239             raise ESakuraSeekerError.Create('FMO\82ð\8eæ\93¾\82Å\82«\82Ü\82¹\82ñ\82Å\82µ\82½');
 240         end;
 241       end;
 242     finally
 243       //\83I\83u\83W\83F\83N\83g\82Ì\94j\8aü
 244       if P <> nil then UnmapViewOfFile(P);
 245       if MappingHandle <> 0 then CloseHandle(MappingHandle);
 246     end;
 247   finally
 248     ReleaseMutex(Mutex);
 249   end;
 250
 251   //\83f\81[\83^\82ð\89ð\90Í
 252   try
 253     try
 254       Strs := TStringList.Create;
 255       Strs.Text := SourceStr;
 256       for i := 0 to Strs.Count-1 do begin
 257         j := Pos('.', Strs[i]);
 258         ID := Copy(Strs[i], 1, j-1);
 259         Entry := Copy(Strs[i], j+1, Pos(#1, Strs[i])-j-1);
 260         Data := Copy(Strs[i], Pos(#1, Strs[i])+1, High(integer));
 261         Pro := GetProcessByID(ID);
 262         if Pro = nil then begin
 263           Pro := TSakuraProcess.Create(self);
 264           Pro.ProcessID := ID;
 265           Pro.FMOName := Target; // FMO\8e¯\95Ê\96¼
 266           FList.Add(Pro);
 267         end;
 268         Pro.AppendData(Entry, Data);
 269       end;
 270     except
 271     end;
 272   finally
 273     Strs.Free;
 274   end;
 275   FSourceResult := FSourceResult + SourceStr;
 276 end;
 277
 278 procedure TSakuraSeeker.ClearList;
 279 begin
 280   FList.Clear;
 281 end;
 282
 283 constructor TSakuraSeeker.Create(AOwner: TComponent);
 284 begin
 285   inherited;
 286   FAutoDetect := true;
 287   FList := TObjectList.Create;
 288   FFileMappingTarget := TStringList.Create;
 289   FFileMappingTarget.Add('Sakura');
 290   FMutexPool := TStringList.Create;
 291 end;
 292
 293 destructor TSakuraSeeker.Destroy;
 294 var i: integer;
 295 begin
 296   ClearList;
 297   FList.Free;
 298   FFileMappingTarget.Free;
 299   for i := 0 to FMutexPool.Count-1 do
 300   begin
 301     CloseHandle(StrToInt(Copy(FMutexPool[i], Pos('=', FMutexPool[i])+1, High(integer))));
 302   end;
 303   FreeAndNil(FMutexPool);
 304 end;
 305
 306 function TSakuraSeeker.GetCount: integer;
 307 begin
 308   Result := FList.Count;
 309 end;
 310
 311 function TSakuraSeeker.GetMutex(const Name: String): THandle;
 312 begin
 313   if FMutexPool.Values[Name] <> '' then
 314   begin
 315     Result := THandle(StrToInt(FMutexPool.Values[Name]));
 316   end else
 317   begin
 318     Result := CreateMutex(nil, false, PChar(Name));
 319     if Result <> 0 then
 320       FMutexPool.Values[Name] := IntToStr(Result);
 321   end;
 322 end;
 323
 324 function TSakuraSeeker.GetMutexName(const Target: String): String;
 325 begin
 326   if Assigned(FOnGetMutexName) then
 327   begin
 328     Result := Target;
 329     FOnGetMutexName(self, Result);
 330   end else
 331     Result := Target + 'FMO';
 332 end;
 333
 334 function TSakuraSeeker.GetProcess(Index: integer): TSakuraProcess;
 335 begin
 336   Result := FList[Index] as TSakuraProcess;
 337 end;
 338
 339 function TSakuraSeeker.GetProcessByID(ID: String): TSakuraProcess;
 340 var i: integer;
 341 begin
 342   Result := nil;
 343   for i := 0 to FList.Count-1 do begin
 344     if TSakuraProcess(FList[i]).ProcessID = ID then begin
 345       Result := FList[i] as TSakuraProcess;
 346       Exit;
 347     end;
 348   end;
 349 end;
 350
 351 function TSakuraSeeker.GetProcessByName(Name: String): TSakuraProcess;
 352 var i: integer;
 353 begin
 354   Result := nil;
 355   for i := 0 to FList.Count-1 do begin
 356     if (FList[i] as TSakuraProcess).Name = Name then begin
 357       Result := FList[i] as TSakuraProcess;
 358       Exit;
 359     end;
 360   end;
 361 end;
 362
 363 function TSakuraSeeker.GetProcessBySetName(Name: String): TSakuraProcess;
 364 var i: integer;
 365 begin
 366   Result := nil;
 367   for i := 0 to FList.Count-1 do begin
 368     if (FList[i] as TSakuraProcess).SetName = Name then begin
 369       Result := FList[i] as TSakuraProcess;
 370       Exit;
 371     end;
 372   end;
 373 end;
 374
 375 function TSakuraSeeker.KillFMO(const TargetFMOName, TargetID: String): boolean;
 376 var MappingHandle, Mutex: THandle;
 377     P: pointer;
 378     SourceStr, ID: String;
 379     Size: integer;
 380     Strs: TStringList;
 381     i, j: integer;
 382 begin
 383   //\83t\83@\83C\83\8b\83}\83b\83s\83\93\83O\83I\83u\83W\83F\83N\83g\82Ì\8eæ\93¾
 384   Result := false;
 385   P := nil;
 386   Mutex := GetMutex(GetMutexName(TargetFMOName));
 387   if Mutex = 0 then
 388     raise ESakuraSeekerError.Create('Mutex\83n\83\93\83h\83\8b\82ð\8eæ\93¾\82Å\82«\82Ü\82¹\82ñ\82Å\82µ\82½');
 389   if WaitForSingleObject(Mutex, 3000) = WAIT_TIMEOUT then
 390     raise ESakuraSeekerError.Create('Mutex\93¯\8aú\83^\83C\83\80\83A\83E\83g');
 391   try
 392     MappingHandle := OpenFileMapping(FILE_MAP_WRITE, false, PChar(TargetFMOName));
 393     if MappingHandle = 0 then Exit;
 394     try
 395       SourceStr := '';
 396       P := MapViewOfFile(MappingHandle, FILE_MAP_WRITE, 0, 0, 0);
 397       if P <> nil then begin
 398         CopyMemory(@Size, P, SizeOf(integer));
 399         Inc(PChar(P), SizeOf(integer));
 400         SourceStr := PChar(P);
 401         if Length(SourceStr) > Size then
 402           raise ESakuraSeekerError.Create('FMO\82ð\8eæ\93¾\82Å\82«\82Ü\82¹\82ñ\82Å\82µ\82½');
 403       end;
 404
 405       //\83f\81[\83^\82ð\89ð\90Í
 406       Strs := TStringList.Create;
 407       try
 408         Strs.Text := SourceStr;
 409         for i := Strs.Count-1 downto 0 do begin
 410           j := Pos('.', Strs[i]);
 411           ID := Copy(Strs[i], 1, j-1);
 412           if ID = TargetID then begin
 413             Strs.Delete(i); // \97v\82ç\82È\82¢\83G\83\93\83g\83\8a\82ð\8dí\8f\9c
 414             Result := true;
 415           end;
 416         end;
 417         SourceStr := Strs.Text;
 418       finally
 419         Strs.Free;
 420       end;
 421
 422       if Result then begin
 423         CopyMemory(P, PChar(SourceStr), Length(SourceStr)+1);
 424         Dec(PChar(P), SizeOf(integer));
 425       end;
 426     finally
 427       //\83I\83u\83W\83F\83N\83g\82Ì\94j\8aü
 428       if P <> nil then UnmapViewOfFile(P);
 429       CloseHandle(MappingHandle);
 430     end;
 431   finally
 432     ReleaseMutex(Mutex);
 433   end;
 434 end;
 435
 436 procedure TSakuraSeeker.Loaded;
 437 begin
 438   inherited;
 439   if FAutoDetect and not (csDesigning in ComponentState) then BeginDetect;
 440 end;
 441
 442 procedure TSakuraSeeker.SetAutoDetect(const Value: boolean);
 443 begin
 444   FAutoDetect := Value;
 445 end;
 446
 447 procedure TSakuraSeeker.SetFileMappingTarget(const Value: TStrings);
 448 begin
 449   FFileMappingTarget.Assign(Value);
 450 end;
 451
 452 procedure TSakuraSeeker.SetOnAfterDetection(const Value: TNotifyEvent);
 453 begin
 454   FOnAfterDetection := Value;
 455 end;
 456
 457 procedure TSakuraSeeker.SetOnDetectResultChanged(
 458   const Value: TNotifyEvent);
 459 begin
 460   FOnDetectResultChanged := Value;
 461 end;
 462
 463 procedure TSakuraSeeker.SetOnGetMutexName(
 464   const Value: TSakuraSeekerGetMutexNameEvent);
 465 begin
 466   FOnGetMutexName := Value;
 467 end;
 468
 469 end.
 470