/packages/fcl-res/src/resfactory.pp

  1{
  2    This file is part of the Free Pascal run time library.
  3    Copyright (c) 2008 by Giulio Bernardi
  4
  5    Factory class for resources
  6
  7    See the file COPYING.FPC, included in this distribution,
  8    for details about the copyright.
  9
 10    This program is distributed in the hope that it will be useful,
 11    but WITHOUT ANY WARRANTY; without even the implied warranty of
 12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 13
 14 **********************************************************************}
 15
 16unit resfactory;
 17
 18{$MODE OBJFPC}
 19
 20interface
 21
 22uses
 23  Classes, SysUtils, resource;
 24
 25type
 26  EResourceFactoryException = class(EResourceException);
 27  EResourceClassAlreadyRegisteredException = class(EResourceFactoryException);
 28  
 29resourcestring
 30  SAlreadyRegistered = 'A resource class for the type %s is already registered.';
 31  
 32type
 33
 34  { TResourceFactory }
 35
 36  TResourceFactory = class
 37  private
 38    class procedure InitResTypeList;
 39    class procedure DisposeResTypeList;
 40    class function FindResourceClass(aType : TResourceDesc) : TResourceClass;
 41  protected
 42  public
 43    class procedure RegisterResourceClass(aType : TResID; aClass : TResourceClass); overload;
 44    class procedure RegisterResourceClass(aType : TResName; aClass : TResourceClass); overload;
 45    class procedure RegisterResourceClass(aType : TResourceDesc; aClass : TResourceClass); overload;
 46    class function CreateResource(aType, aName : TResourceDesc) : TAbstractResource;
 47  end;
 48
 49implementation
 50
 51type
 52  TRegisteredResourceEntry = record
 53    _type : TResourceDesc;
 54    _class : TResourceClass;
 55  end;
 56  PRegisteredResourceEntry = ^TRegisteredResourceEntry;
 57  
 58var
 59  ResTypeList : TFPList = nil;
 60
 61
 62{ TResourceFactory }
 63
 64class procedure TResourceFactory.InitResTypeList;
 65begin
 66  if ResTypeList=nil then
 67    ResTypeList:=TFPList.Create;
 68end;
 69
 70class procedure TResourceFactory.DisposeResTypeList;
 71var i : integer;
 72    p : PRegisteredResourceEntry;
 73begin
 74  if ResTypeList=nil then exit;
 75  for i:=0 to ResTypeList.Count-1 do
 76  begin
 77    p:=PRegisteredResourceEntry(ResTypeList[i]);
 78    p^._type.Free;
 79    FreeMem(p);
 80  end;
 81  FreeAndNil(ResTypeList);
 82end;
 83
 84class function TResourceFactory.FindResourceClass(aType: TResourceDesc
 85  ): TResourceClass;
 86var i : integer;
 87    p : PRegisteredResourceEntry;
 88begin
 89  InitResTypeList;
 90  for i:=0 to ResTypeList.Count-1 do
 91  begin
 92    p:=PRegisteredResourceEntry(ResTypeList[i]);
 93    if p^._type.Equals(aType) then
 94    begin
 95      Result:=p^._class;
 96      exit;
 97    end;
 98  end;
 99  Result:=nil;
100end;
101
102class procedure TResourceFactory.RegisterResourceClass(aType : TResID;
103  aClass : TResourceClass); overload;
104var t : TResourceDesc;
105begin
106  t:=TResourceDesc.Create(aType);
107  try
108    RegisterResourceClass(t,aClass);
109  finally
110    t.Free;
111  end;
112end;
113
114class procedure TResourceFactory.RegisterResourceClass(aType : TResName;
115  aClass : TResourceClass); overload;
116var t : TResourceDesc;
117begin
118  t:=TResourceDesc.Create(aType);
119  try
120    RegisterResourceClass(t,aClass);
121  finally
122    t.Free;
123  end;
124end;
125
126class procedure TResourceFactory.RegisterResourceClass(aType: TResourceDesc;
127  aClass: TResourceClass);
128var p : PRegisteredResourceEntry;
129begin
130  if FindResourceClass(aType)<>nil then
131    raise EResourceClassAlreadyRegisteredException.CreateFmt(SAlreadyRegistered,[aType.Name]);
132  p:=GetMem(sizeof(TRegisteredResourceEntry));
133  p^._type:=TResourceDesc.Create;
134  p^._type.Assign(aType);
135  p^._class:=aClass;
136  ResTypeList.Add(p);
137end;
138
139class function TResourceFactory.CreateResource(aType, aName: TResourceDesc
140  ): TAbstractResource;
141var theclass : TResourceClass;
142begin
143  theclass:=FindResourceClass(aType);
144  if theclass=nil then theclass:=TGenericResource;
145  Result:=theclass.Create(aType,aName);
146end;
147
148finalization
149  TResourceFactory.DisposeResTypeList;
150
151end.