sakurasuite/SakuraSeeker.pas

   1 (*********************************************************
   2
   3   SakuraSeeker Component - Listups Existing Sakura.exe
   4   (C)2001-2002 naruto/CANO-Lab  All Rights Reserved.
   5
   6   \95K\82¸\8eg\97p\8fð\8c\8f\82É\82µ\82½\82ª\82Á\82Ä\82¨\8eg\82¢\82\82¾\82³\82¢\81B
   7   \81\9a\82±\82Ì\83R\83\93\83|\81[\83l\83\93\83g\82ð\8eg\97p\82µ\82½\83v\83\8d\83O\83\89\83\80\82ð\8cö\8aJ\82·\82é\8fê\8d\87\82Í\81A
   8 \81@\81@\8dì\8eÒ\82É\88ê\95ñ\82·\82é\95K\97v\82ª\82 \82è\82Ü\82·\81B\8fÚ\82µ\82\82Í\90à\96¾\8f\91\82ð\81B
   9
  10 **********************************************************)
  11
  12 unit SakuraSeeker;
  13
  14 interface
  15
  16 uses
  17   Windows, SysUtils, Classes, Contnrs;
  18
  19 type
  20   ESakuraSeekerError = class(Exception);
  21
  22   TSakuraSeeker = class;
  23
  24   TSakuraProcess = class(TObject)
  25   private
  26     FHash: TStringList;
  27     FProcessID: String;
  28     FFMOName: String;
  29     FOwner: TSakuraSeeker;
  30     procedure SetProcessID(const Value: String);
  31     function GetHWnd: THandle;
  32     function GetName: String;
  33     function GetData(Key: String): String;
  34     function GetKeroName: String;
  35     function GetSetName: String;
  36     procedure SetFMOName(const Value: String);
  37     function GetDataAt(Index: integer): String;
  38     function GetCount: integer;
  39     function GetKeyAt(Index: integer): String;
  40   public
  41     constructor Create(AOwner: TSakuraSeeker);
  42     destructor Destroy; override;
  43     procedure AppendData(const Key, Value: String);
  44     property ProcessID: String read FProcessID write SetProcessID;
  45     property FMOName: String read FFMOName write SetFMOName;
  46     property HWnd: THandle read GetHWnd;
  47     property Name: String read GetName;
  48     property KeroName: String read GetKeroName;
  49     property SetName: String read GetSetName;
  50     property Data[Key: String]: String read GetData;
  51     property Count: integer read GetCount;
  52     property DataAt[Index: integer]: String read GetDataAt;
  53     property KeyAt[Index: integer]: String read GetKeyAt;
  54   end;
  55
  56   TSakuraSeeker = class(TComponent)
  57   private
  58     { Private \90é\8c¾ }
  59     FList: TObjectList;
  60     FAutoDetect: boolean;
  61     FOnAfterDetection: TNotifyEvent;
  62     FLastSeekResult: String; //\91O\89ñ\82Ì\8eæ\93¾\8c\8b\89Ê\81B\94ä\8ar\97p
  63     FSourceResult: String;   //\8d¡\89ñ\82Ì\8eæ\93¾\8c\8b\89Ê\81B\94ä\8ar\97p
  64     FOnDetectResultChanged: TNotifyEvent;
  65     FFileMappingTarget: TStrings;
  66     function GetProcess(Index: integer): TSakuraProcess;
  67     procedure SetAutoDetect(const Value: boolean);
  68     function GetProcessByName(Name: String): TSakuraProcess;
  69     function GetProcessByID(ID: String): TSakuraProcess;
  70     function GetCount: integer;
  71     procedure SetOnAfterDetection(const Value: TNotifyEvent);
  72     procedure SetOnDetectResultChanged(const Value: TNotifyEvent);
  73     procedure SetFileMappingTarget(const Value: TStrings);
  74     function GetProcessBySetName(Name: String): TSakuraProcess;
  75   protected
  76     { Protected \90é\8c¾ }
  77     //FSakuraAPI: integer;
  78     procedure Loaded; override;
  79     procedure ClearList;
  80     procedure BeginDetectOne(const Target: String);
  81   public
  82     { Public \90é\8c¾ }
  83     procedure BeginDetect;
  84     property Count: integer read GetCount;
  85     property Process[Index: integer]: TSakuraProcess read GetProcess; default;
  86     property ProcessByName[Name: String]: TSakuraProcess read GetProcessByName;
  87     property ProcessBySetName[Name: String]: TSakuraProcess read GetProcessBySetName;
  88     property ProcessByID[ID: String]: TSakuraProcess read GetProcessByID;
  89     function KillFMO(const TargetFMOName, TargetID: String): boolean;
  90     constructor Create(AOwner: TComponent); override;
  91     destructor Destroy; override;
  92   published
  93     { Published \90é\8c¾ }
  94     property AutoDetect: boolean read FAutoDetect write SetAutoDetect default true;
  95     property OnAfterDetection: TNotifyEvent read FOnAfterDetection write SetOnAfterDetection;
  96     property OnDetectResultChanged: TNotifyEvent read FOnDetectResultChanged write SetOnDetectResultChanged;
  97     property FileMappingTarget: TStrings read FFileMappingTarget write SetFileMappingTarget;
  98   end;
  99
 100 procedure Register;
 101
 102 implementation
 103
 104 procedure Register;
 105 begin
 106   RegisterComponents('Samples', [TSakuraSeeker]);
 107 end;
 108
 109 { TSakuraProcess }
 110
 111 procedure TSakuraProcess.AppendData(const Key, Value: String);
 112 begin
 113   FHash.Values[Key] := Value;
 114 end;
 115
 116 constructor TSakuraProcess.Create(AOwner: TSakuraSeeker);
 117 begin
 118   FHash := TStringList.Create;
 119   FOwner := AOwner;
 120 end;
 121
 122 destructor TSakuraProcess.Destroy;
 123 begin
 124   inherited;
 125   FHash.Free;
 126 end;
 127
 128 function TSakuraProcess.GetCount: integer;
 129 begin
 130   Result := FHash.Count;
 131 end;
 132
 133 function TSakuraProcess.GetData(Key: String): String;
 134 var i: integer;
 135 begin
 136   Result := FHash.Values[Key];
 137 end;
 138
 139 function TSakuraProcess.GetDataAt(Index: integer): String;
 140 begin
 141   Result := FHash.ValueFromIndex[Index];
 142 end;
 143
 144 function TSakuraProcess.GetHWnd: THandle;
 145 begin
 146   Result := StrToIntDef(GetData('hwnd'), 0);
 147 end;
 148
 149 function TSakuraProcess.GetKeroName: String;
 150 begin
 151   Result := GetData('keroname');
 152 end;
 153
 154 function TSakuraProcess.GetKeyAt(Index: integer): String;
 155 begin
 156   Result := FHash.Names[Index];
 157 end;
 158
 159 function TSakuraProcess.GetName: String;
 160 begin
 161   Result := GetData('name');
 162 end;
 163
 164
 165 function TSakuraProcess.GetSetName: String;
 166 begin
 167   Result := GetName + ',' + GetKeroName;
 168 end;
 169
 170 procedure TSakuraProcess.SetFMOName(const Value: String);
 171 begin
 172   FFMOName := Value;
 173 end;
 174
 175 procedure TSakuraProcess.SetProcessID(const Value: String);
 176 begin
 177   FProcessID := Value;
 178 end;
 179
 180 { TSakuraSeeker }
 181
 182 procedure TSakuraSeeker.BeginDetect;
 183 var i: integer;
 184 begin
 185   if [csDesigning, csLoading] * ComponentState <> [] then Exit;
 186   ClearList;
 187
 188   FSourceResult := '';
 189   for i := 0 to FFileMappingTarget.Count-1 do begin
 190     BeginDetectOne(FFileMappingTarget[i]); //1\82Â\82ÌFile-mapping Object\82ð\8eæ\93¾
 191   end;
 192
 193   if Assigned(OnDetectResultChanged) and (FLastSeekResult <> FSourceResult) then begin
 194     FLastSeekResult := FSourceResult;
 195     OnDetectResultChanged(Self);
 196   end else begin
 197     FLastSeekResult := FSourceResult;
 198   end;
 199
 200   if Assigned(OnAfterDetection) then OnAfterDetection(Self);
 201 end;
 202
 203 procedure TSakuraSeeker.BeginDetectOne(const Target: String);
 204 var MappingHandle: THandle;
 205     P: pointer;
 206     SourceStr, ID, Entry, Data: String;
 207     Size: integer;
 208     Strs: TStringList;
 209     Pro: TSakuraProcess;
 210     i, j: integer;
 211 begin
 212   //\83t\83@\83C\83\8b\83}\83b\83s\83\93\83O\83I\83u\83W\83F\83N\83g\82Ì\8eæ\93¾
 213   P := nil; Strs := nil;
 214   MappingHandle := OpenFileMapping(FILE_MAP_READ, false, PChar(Target));
 215   try
 216     if MappingHandle = 0 then begin
 217       SourceStr := '';
 218     end else begin
 219       P := MapViewOfFile(MappingHandle, FILE_MAP_READ, 0, 0, 0);
 220       if P <> nil then begin
 221         CopyMemory(@Size, P, SizeOf(integer));
 222         Inc(PChar(P), SizeOf(integer));
 223         SourceStr := PChar(P);
 224         if Length(SourceStr) > Size then
 225           raise ESakuraSeekerError.Create('FMO\82ð\8eæ\93¾\82Å\82«\82Ü\82¹\82ñ\82Å\82µ\82½');
 226       end;
 227     end;
 228   finally
 229     //\83I\83u\83W\83F\83N\83g\82Ì\94j\8aü
 230     if P <> nil then UnmapViewOfFile(P);
 231     if MappingHandle <> 0 then CloseHandle(MappingHandle);
 232   end;
 233
 234   //\83f\81[\83^\82ð\89ð\90Í
 235   try
 236     try
 237       Strs := TStringList.Create;
 238       Strs.Text := SourceStr;
 239       for i := 0 to Strs.Count-1 do begin
 240         j := Pos('.', Strs[i]);
 241         ID := Copy(Strs[i], 1, j-1);
 242         Entry := Copy(Strs[i], j+1, Pos(#1, Strs[i])-j-1);
 243         Data := Copy(Strs[i], Pos(#1, Strs[i])+1, High(integer));
 244         //ShowMessage(ID + '/' + Entry + '/' + Data);
 245         Pro := GetProcessByID(ID);
 246         if Pro = nil then begin
 247           Pro := TSakuraProcess.Create(self);
 248           Pro.ProcessID := ID;
 249           Pro.FMOName := Target; // FMO\8e¯\95Ê\96¼
 250           FList.Add(Pro);
 251         end;
 252         Pro.AppendData(Entry, Data);
 253       end;
 254     except
 255     end;
 256   finally
 257     Strs.Free;
 258   end;
 259   FSourceResult := FSourceResult + SourceStr;
 260 end;
 261
 262 procedure TSakuraSeeker.ClearList;
 263 var i: integer;
 264 begin
 265   FList.Clear;
 266 end;
 267
 268 constructor TSakuraSeeker.Create(AOwner: TComponent);
 269 begin
 270   inherited;
 271   FAutoDetect := true;
 272   FList := TObjectList.Create;
 273   FFileMappingTarget := TStringList.Create;
 274   FFileMappingTarget.Add('Sakura');
 275   //
 276   //FSakuraAPI := RegisterWindowMessage('Sakura');
 277 end;
 278
 279 destructor TSakuraSeeker.Destroy;
 280 begin
 281   ClearList;
 282   FList.Free;
 283   FFileMappingTarget.Free;
 284 end;
 285
 286 function TSakuraSeeker.GetCount: integer;
 287 begin
 288   Result := FList.Count;
 289 end;
 290
 291 function TSakuraSeeker.GetProcess(Index: integer): TSakuraProcess;
 292 begin
 293   try
 294     Result := FList[Index] as TSakuraProcess;
 295   except
 296     raise ESakuraSeekerError.Create('\83\8a\83X\83g\82Ì\97L\8cø\94Í\88Í\82Ì\83C\83\93\83f\83b\83N\83X\82ª\8ew\92è\82³\82ê\82Ü\82µ\82½');
 297   end;
 298 end;
 299
 300 function TSakuraSeeker.GetProcessByID(ID: String): TSakuraProcess;
 301 var i: integer;
 302 begin
 303   Result := nil;
 304   for i := 0 to FList.Count-1 do begin
 305     if TSakuraProcess(FList[i]).ProcessID = ID then begin
 306       Result := FList[i] as TSakuraProcess;
 307       Exit;
 308     end;
 309   end;
 310 end;
 311
 312 function TSakuraSeeker.GetProcessByName(Name: String): TSakuraProcess;
 313 var i: integer;
 314 begin
 315   Result := nil;
 316   for i := 0 to FList.Count-1 do begin
 317     if (FList[i] as TSakuraProcess).Name = Name then begin
 318       Result := FList[i] as TSakuraProcess;
 319       Exit;
 320     end;
 321   end;
 322 end;
 323
 324 function TSakuraSeeker.GetProcessBySetName(Name: String): TSakuraProcess;
 325 var i: integer;
 326 begin
 327   Result := nil;
 328   for i := 0 to FList.Count-1 do begin
 329     if (FList[i] as TSakuraProcess).SetName = Name then begin
 330       Result := FList[i] as TSakuraProcess;
 331       Exit;
 332     end;
 333   end;
 334 end;
 335
 336 function TSakuraSeeker.KillFMO(const TargetFMOName, TargetID: String): boolean;
 337 var MappingHandle: THandle;
 338     P: pointer;
 339     SourceStr, ID, Entry, Data: String;
 340     Size: integer;
 341     Strs: TStringList;
 342     Pro: TSakuraProcess;
 343     i, j: integer;
 344 begin
 345   //\83t\83@\83C\83\8b\83}\83b\83s\83\93\83O\83I\83u\83W\83F\83N\83g\82Ì\8eæ\93¾
 346   Result := false;
 347   P := nil; Strs := nil;
 348   MappingHandle := OpenFileMapping(FILE_MAP_WRITE, false, PChar(TargetFMOName));
 349   if MappingHandle = 0 then Exit;
 350   try
 351     SourceStr := '';
 352     P := MapViewOfFile(MappingHandle, FILE_MAP_WRITE, 0, 0, 0);
 353     if P <> nil then begin
 354       CopyMemory(@Size, P, SizeOf(integer));
 355       Inc(PChar(P), SizeOf(integer));
 356       SourceStr := PChar(P);
 357       if Length(SourceStr) > Size then
 358         raise ESakuraSeekerError.Create('FMO\82ð\8eæ\93¾\82Å\82«\82Ü\82¹\82ñ\82Å\82µ\82½');
 359     end;
 360
 361     //\83f\81[\83^\82ð\89ð\90Í
 362     Strs := TStringList.Create;
 363     try
 364       Strs.Text := SourceStr;
 365       for i := Strs.Count-1 downto 0 do begin
 366         j := Pos('.', Strs[i]);
 367         ID := Copy(Strs[i], 1, j-1);
 368         if ID = TargetID then begin
 369           Strs.Delete(i); // \97v\82ç\82È\82¢\83G\83\93\83g\83\8a\82ð\8dí\8f\9c
 370           Result := true;
 371         end;
 372       end;
 373       SourceStr := Strs.Text;
 374     finally
 375       Strs.Free;
 376     end;
 377
 378     if Result then begin
 379       CopyMemory(P, PChar(SourceStr), Length(SourceStr)+1);
 380       Dec(PChar(P), SizeOf(integer));
 381     end;
 382   finally
 383     //\83I\83u\83W\83F\83N\83g\82Ì\94j\8aü
 384     if P <> nil then UnmapViewOfFile(P);
 385     CloseHandle(MappingHandle);
 386   end;
 387 end;
 388
 389 procedure TSakuraSeeker.Loaded;
 390 begin
 391   inherited;
 392   if FAutoDetect and not (csDesigning in ComponentState) then BeginDetect;
 393 end;
 394
 395 procedure TSakuraSeeker.SetAutoDetect(const Value: boolean);
 396 begin
 397   FAutoDetect := Value;
 398 end;
 399
 400 procedure TSakuraSeeker.SetFileMappingTarget(const Value: TStrings);
 401 begin
 402   FFileMappingTarget.Assign(Value);
 403 end;
 404
 405 procedure TSakuraSeeker.SetOnAfterDetection(const Value: TNotifyEvent);
 406 begin
 407   FOnAfterDetection := Value;
 408 end;
 409
 410 procedure TSakuraSeeker.SetOnDetectResultChanged(
 411   const Value: TNotifyEvent);
 412 begin
 413   FOnDetectResultChanged := Value;
 414 end;
 415
 416 end.
 417