bottleclient/Plugins.pas

   1 {
   2 SPP\83v\83\89\83O\83C\83\93\82ð\88µ\82¤\82½\82ß\82Ì\83N\83\89\83X
   3 }
   4
   5 unit Plugins;
   6
   7 interface
   8
   9 uses Windows, SysUtils, Classes, Graphics;
  10
  11 type
  12   ESppException = class(Exception);
  13
  14   TPluginFunction = (pfConfigure, pfSurfaceImage, pfSurfaceList);
  15   TPluginFunctions = set of TPluginFunction;
  16
  17   TScope = 0..1; // \83S\81[\83X\83g\83X\83R\81[\83v
  18   TScopes = set of TScope;
  19
  20   TSppGetVersionFunc = function(Name: PChar; NameLen: integer;
  21     var Version: integer; var CanConfigure: boolean): integer; cdecl;
  22
  23   // \83L\83\83\83b\83V\83\85\83f\81[\83^\82Æ\82È\82é1\96\87\82Ì\83T\81[\83t\83B\83X\83v\83\8c\83r\83\85\81[\89æ\91\9c\82ð
  24   // \95Û\8e\9d\82·\82é\83N\83\89\83X
  25   // \89æ\91\9c\82»\82Ì\82à\82Ì\82Æ\81A\82»\82ê\82Ì\83S\81[\83X\83g\96¼\81ASurfaceKey\82ð\95Û\8e\9d\82·\82é
  26   TSppImage = class(TObject)
  27   private
  28     FBitmap: TBitmap;
  29     FSurfaceKey: String;
  30     FGhost: String;
  31     procedure SetBitmap(const Value: TBitmap);
  32     procedure SetGhost(const Value: String);
  33     procedure SetSurfaceKey(const Value: String);
  34   protected
  35     function SurfaceKeyMatchTest(Surface: integer; AScope: TScope): boolean;
  36   public
  37     constructor Create;
  38     destructor Destroy; override;
  39     function KeyMatchTest(const Ghost: String;
  40       Surface: integer; Scope: TScope): boolean;
  41     property Ghost: String read FGhost write SetGhost;
  42     property SurfaceKey: String read FSurfaceKey write SetSurfaceKey;
  43     property Bitmap: TBitmap read FBitmap write SetBitmap;
  44   end;
  45
  46   TSppImplementation = class;
  47
  48   // \83v\83\89\83O\83C\83\93\82ð\95\\82·\83N\83\89\83X
  49   // \83v\83\89\83O\83C\83\93\82ðLoadModule\82µ\81A\8eí\97Þ\82â\83o\81[\83W\83\87\83\93\82ð\94»\95Ê\82µ\82Ä
  50   // \93K\90Ø\82ÉTSppImplementation(\82ð\8cp\8f³\82µ\82½\82¢\82¸\82ê\82©\82Ì\8bï\8fÛ\83N\83\89\83X)\82ð
  51   // \90¶\90¬\82·\82é
  52   TSppPlugin = class(TObject)
  53   private
  54     FPluginName: String; // \83v\83\89\83O\83C\83\93\82Ì\96¼\91O(## Loader)
  55     FModuleName: String; // DLL\82Ì\96¼\91O(*.dll)
  56     FImplementation: TSppImplementation; // \83v\83\89\83O\83C\83\93\82Ì\8eÀ\91\95
  57     FHandle: THandle;
  58     FPluginFunctions: TPluginFunctions;
  59   protected
  60     procedure CreateImplementation;
  61   public
  62     constructor Create(const ModuleName: String);
  63     destructor Destroy; override;
  64     property ModuleName: String read FModuleName;
  65     property PluginName: String read FPluginName;
  66     function GetImage(const Ghost: String;
  67       Surface: integer; Scope: TScope): TSppImage;
  68     property Handle: THandle read FHandle;
  69     property PluginFunctions: TPluginFunctions read FPluginFunctions;
  70     procedure Configure;
  71   end;
  72
  73   // \83v\83\89\83O\83C\83\93\8eÀ\91\95\82Ì\83x\81[\83X\83N\83\89\83X(\92\8a\8fÛ\83N\83\89\83X)
  74   // \82±\82Ì\95\94\95ª\82ÅSPP1.0\82ÆSPP2.0\82ÌAPI\82Ì\88á\82¢\82ð\92\8a\8fÛ\89»\82·\82é
  75   TSppImplementation = class(TObject)
  76   private
  77     FOwner: TSppPlugin;
  78   public
  79     constructor Create(Owner: TSppPlugin); virtual;
  80     procedure Load; virtual; abstract;
  81     function GetImage(const Ghost: String;
  82       Surface: integer; Scope: TScope): TSppImage; virtual; abstract;
  83     procedure Unload; virtual; abstract;
  84     property Owner: TSppPlugin read FOwner;
  85     procedure Configure; virtual; abstract;
  86   end;
  87
  88   { SPP Version1\97p\82Ì\8c^ }
  89   TSpp1LoadProc = procedure(Path: PChar); cdecl;
  90   TSpp1UnloadProc = procedure; cdecl;
  91   TSpp1GetImageFunc = function(Ghost: PChar; Surface: integer;
  92     H: HBITMAP): integer; cdecl;
  93   TSpp1GetImageSizeFunc = function(Ghost: PChar; Surface: integer;
  94     var w, h: integer): integer; cdecl;
  95   TSpp1ConfigureProc = procedure; cdecl;
  96
  97   TSppImplementation1 = class(TSppImplementation)
  98   private
  99     // \8aÖ\90\94\81E\8eè\91±\82«\95Ï\90\94
 100     FSppLoad: TSpp1LoadProc;
 101     FSppUnload: TSpp1UnloadProc;
 102     FSppGetImage: TSpp1GetImageFunc;
 103     FSppGetImageSize: TSpp1GetImageSizeFunc;
 104     FSppConfigure: TSpp1ConfigureProc;
 105     procedure InitProcs;
 106     function DoGetImage(const Ghost: String;
 107       const Surface: integer; Bitmap: TBitmap): boolean;
 108   public
 109     constructor Create(Owner: TSppPlugin); override;
 110     procedure Load; override;
 111     function GetImage(const Ghost: String;
 112       Surface: integer; Scope: TScope): TSppImage; override;
 113     procedure Unload; override;
 114     procedure Configure; override;
 115   end;
 116
 117 implementation
 118
 119
 120 { TSppPlugin }
 121
 122 procedure TSppPlugin.Configure;
 123 begin
 124   FImplementation.Configure;
 125 end;
 126
 127 constructor TSppPlugin.Create(const ModuleName: String);
 128 begin
 129   FModuleName := ModuleName;
 130   FHandle := LoadLibrary(PChar(FModuleName));
 131   if FHandle = 0 then
 132     raise ESppException.CreateFmt('Error loading %s', [FModuleName])
 133   else
 134   begin
 135     CreateImplementation;
 136     FImplementation.Load;
 137   end;
 138 end;
 139
 140 procedure TSppPlugin.CreateImplementation;
 141 var GetVersion: TSppGetVersionFunc;
 142     DLLName: array [0..255] of char;
 143     Version: integer;
 144     CanConfigure: boolean;
 145 begin
 146   GetVersion := GetProcAddress(FHandle, 'GetVersion');
 147   if (@GetVersion = nil) then
 148     raise ESppException.CreateFmt('%s is not a valid SPP module', [FModuleName]);
 149
 150   GetVersion(@DLLName, sizeof(DLLName), Version, CanConfigure);
 151   case Version of
 152     1: FImplementation := TSppImplementation1.Create(Self);
 153     // 2: FImplementation := TSppImplementation.Create(Self);
 154     else
 155       raise ESppException.CreateFmt('Module %s returned '+
 156         'unsupported version number(%d)', [FModuleName, Version]);
 157   end;
 158   FPluginName := DLLName;
 159   if CanConfigure then
 160     FPluginFunctions := [pfConfigure]
 161   else
 162     FPluginFunctions := [];
 163 end;
 164
 165 destructor TSppPlugin.Destroy;
 166 begin
 167   if FImplementation <> nil then
 168     FImplementation.UnLoad;
 169   FImplementation.Free;
 170   if not FreeLibrary(FHandle) then
 171     raise ESppException.CreateFmt('Error unloading module %s', [FModuleName]);
 172   inherited;
 173 end;
 174
 175 function TSppPlugin.GetImage(const Ghost: String;
 176   Surface: integer; Scope: TScope): TSppImage;
 177 begin
 178   Result := FImplementation.GetImage(Ghost, Surface, Scope);
 179 end;
 180
 181 { TSppImplementation }
 182
 183 constructor TSppImplementation.Create(Owner: TSppPlugin);
 184 begin
 185   FOwner := Owner;
 186 end;
 187
 188 { TSppImage }
 189
 190 constructor TSppImage.Create;
 191 begin
 192   FBitmap := TBitmap.Create;
 193 end;
 194
 195 destructor TSppImage.Destroy;
 196 begin
 197   FBitmap.Free;
 198   inherited;
 199 end;
 200
 201 function TSppImage.KeyMatchTest(const Ghost: String; Surface: integer;
 202   Scope: TScope): boolean;
 203 begin
 204   // \8ew\92è\82³\82ê\82½\83S\81[\83X\83g\81E\83T\81[\83t\83B\83XID\81E\83X\83R\81[\83v\82Ì
 205   // \83T\81[\83t\83B\83X\82Ì\83v\83\8c\83r\83\85\81[\82É\81A\82±\82Ì\89æ\91\9c\82ª\8eg\82¦\82é\82©?
 206   Result := (Self.Ghost = Ghost) and SurfaceKeyMatchTest(Surface, Scope);
 207 end;
 208
 209 procedure TSppImage.SetBitmap(const Value: TBitmap);
 210 begin
 211   FBitmap.Assign(Value);
 212 end;
 213
 214 procedure TSppImage.SetGhost(const Value: String);
 215 begin
 216   FGhost := Value;
 217 end;
 218
 219 procedure TSppImage.SetSurfaceKey(const Value: String);
 220 begin
 221   FSurfaceKey := Value;
 222 end;
 223
 224 function TSppImage.SurfaceKeyMatchTest(Surface: integer;
 225   AScope: TScope): boolean;
 226 var i, p: integer;
 227     Tokens: TStringList;
 228     Token, SurfaceIDList, ScopeKey: String;
 229     FromID, ToID: integer;
 230 const SyntaxError = 'Syntax error found in SurfaceKey "%s"';
 231 begin
 232   Result := false;
 233   p := Pos(',', SurfaceKey);
 234   if p <= 0 then
 235     raise ESppException.CreateFmt(SyntaxError, [SurfaceKey]);
 236   SurfaceIDList := Copy(SurfaceKey, 1, p-1);
 237   ScopeKey := Copy(SurfaceKey, p+1, High(integer));
 238   if (ScopeKey <> '*') and (ScopeKey <> IntToStr(AScope)) then
 239     Exit;
 240   if SurfaceIDList = '*' then
 241   begin
 242     Result := true;
 243     Exit;
 244   end;
 245   Tokens := TStringList.Create;
 246   try
 247     try
 248       Tokens.Delimiter := '&';
 249       Tokens.DelimitedText := SurfaceIDList;
 250       for i := 0 to Tokens.Count-1 do
 251       begin
 252         Token := Tokens[i];
 253         p := Pos('-', Token);
 254         if p > 0 then
 255         begin
 256           FromID := StrToInt(Copy(Token, 1, p));
 257           ToID := StrToInt(Copy(Token, p+1, High(integer)));
 258         end else
 259         begin
 260           FromID := StrToInt(Token);
 261           ToID := FromID;
 262         end;
 263         if (FromID <= Surface) and (Surface <= ToID) then
 264         begin
 265           Result := true;
 266           Exit;
 267         end;
 268       end;
 269     except
 270       on EConvertError do
 271         raise ESppException.CreateFmt(SyntaxError, [SurfaceKey]);
 272     end;
 273   finally
 274     Tokens.Free;
 275   end;
 276 end;
 277
 278 { TSppImplementation1 }
 279
 280 procedure TSppImplementation1.Configure;
 281 begin
 282   inherited;
 283   FSppConfigure;
 284 end;
 285
 286 constructor TSppImplementation1.Create(Owner: TSppPlugin);
 287 begin
 288   inherited;
 289   InitProcs;
 290 end;
 291
 292 function TSppImplementation1.DoGetImage(const Ghost: String;
 293   const Surface: integer; Bitmap: TBitmap): boolean;
 294 var H: HBITMAP;
 295 begin
 296   H := Bitmap.ReleaseHandle;
 297   Result := FSppGetImage(PChar(Ghost), Surface, H) = 0;
 298   Bitmap.Handle := H;
 299 end;
 300
 301 function TSppImplementation1.GetImage(const Ghost: String;
 302   Surface: integer; Scope: TScope): TSppImage;
 303 var Width, Height: integer;
 304     TmpBitmap: TBitmap;
 305 begin
 306   Result := nil;
 307   Width  := 0;
 308   Height := 0;
 309   if Surface < 0 then Exit;
 310   if FSppGetImageSize(PChar(Ghost), Surface, Width, Height) <> 0 then
 311     Exit;
 312   TmpBitmap := TBitmap.Create;
 313   try
 314     TmpBitmap.Width  := Width;
 315     TmpBitmap.Height := Height;
 316     if DoGetImage(Ghost, Surface, TmpBitmap) then
 317     begin
 318       Result := TSppImage.Create;
 319       Result.Bitmap := TmpBitmap;
 320       Result.Ghost := Ghost;
 321       Result.SurfaceKey := Format('%d,*', [Surface]); // Any scope
 322     end;
 323   finally
 324     TmpBitmap.Free;
 325   end;
 326 end;
 327
 328 procedure TSppImplementation1.InitProcs;
 329 const
 330   SSppLoad = 'Load';
 331   SSppUnload = 'Unload';
 332   SSppGetVersion = 'GetVersion';
 333   SSppGetImage = 'GetImage';
 334   SSppGetImageSize = 'GetImageSize';
 335   SSppConfigure = 'Configure';
 336 begin
 337   // Load DLL procedures
 338   FSppLoad := GetProcAddress(Owner.Handle, SSppLoad);
 339   FSppUnload := GetProcAddress(Owner.Handle, SSppUnload);
 340   FSppGetImage := GetProcAddress(Owner.Handle, SSppGetImage);
 341   FSppGetImageSize := GetProcAddress(Owner.Handle, SSppGetImageSize);
 342   FSppConfigure := GetProcAddress(Owner.Handle, SSppConfigure);
 343
 344   if (@FSppLoad = nil) or (@FSppUnload = nil) or (@FSppGetImage = nil) or
 345      (@FSppGetImageSize = nil) or (@FSppConfigure = nil) then
 346   begin
 347     raise ESppException.Create('Error Getting Procedure Address');
 348   end;
 349 end;
 350
 351 procedure TSppImplementation1.Load;
 352 begin
 353   inherited;
 354   FSppLoad(PChar(ExtractFilePath(Owner.ModuleName)));
 355 end;
 356
 357 procedure TSppImplementation1.Unload;
 358 begin
 359   inherited;
 360   FSppUnload;
 361 end;
 362
 363 end.