/uXMLConfig.pas

  1unit uXMLConfig;
  2
  3interface
  4
  5uses
  6  Classes, XMLIntf;
  7
  8type
  9  EncryptedString = class(TCustomAttribute);
 10
 11  TXMLConfigNode  = class(TPersistent);
 12
 13  TXMLConfigNodes = class
 14  private
 15    FClass: TClass;
 16    FList: TList;
 17    function GetXMLConfigNode(const Index: integer): TXMLConfigNode;
 18    function GetCount: integer;
 19  public
 20    constructor Create(const ItemClass: TClass);
 21    destructor Destroy; override;
 22
 23    function Add(const XMLConfigNode: TXMLConfigNode): TXMLConfigNode;
 24
 25    procedure Clear;
 26
 27    property Items[const Index: integer]: TXMLConfigNode read GetXMLConfigNode;
 28    property Count: integer read GetCount;
 29  end;
 30
 31  TXMLConfig = class(TXMLConfigNode)
 32  private
 33    FXMLFilePath: string;
 34    FApplicationName: string;
 35    FRootNodeName: string;
 36    FVersion: byte;
 37
 38    function isEncryptedString(const oObject: TObject; const Propertie: string): boolean;
 39
 40    function EncryptString(const sInput: string): string;
 41    function DecryptString(const sInput: string): string;
 42  protected
 43    procedure SaveClass(oObject: TObject; Node: IXMLNode);
 44    procedure LoadClass(oObject: TObject; Node: IXMLNode);
 45
 46    procedure SaveObjects(oObject: TXMLConfigNodes; Node: IXMLNode);
 47    procedure LoadObjects(oObject: TXMLConfigNodes; Node: IXMLNode);
 48  public
 49    constructor Create(const AppName, XMLFilePath: string; RootNodeName: string = 'config');
 50
 51    procedure Initialize; virtual; abstract;
 52
 53    procedure Load;
 54    procedure Save;
 55
 56    procedure LoadDefaults; virtual; abstract;
 57
 58    property ApplicationName: string read FApplicationName write FApplicationName;
 59    property RootNodeName: string read FRootNodeName;
 60    property Version: byte read FVersion write FVersion default 1;
 61  end;
 62
 63implementation
 64
 65uses
 66  TypInfo, XMLDoc, SysUtils, Windows, Rtti, EncdDecd;
 67
 68resourcestring
 69  rsApplication = 'app';
 70  rsFormat = 'ver';
 71  rsPasswordField = 'password';
 72
 73{ TXMLConfig }
 74
 75{$REGION 'Initialization'}
 76constructor TXMLConfig.Create(const AppName, XMLFilePath: string; RootNodeName: string = 'config');
 77begin
 78  Initialize;
 79
 80  FApplicationName := AppName;
 81  FXMLFilePath := XMLFilePath;
 82  FRootNodeName := RootNodeName;
 83
 84  LoadDefaults;
 85end;
 86
 87procedure TXMLConfig.LoadObjects(oObject: TXMLConfigNodes; Node: IXMLNode);
 88var
 89  i: integer;
 90  TempObject: TXMLConfigNode;
 91begin
 92  oObject.Clear;
 93
 94  for i := 0 to Node.ChildNodes.Count - 1 do
 95  begin
 96    TempObject := TXMLConfigNode(AllocMem(oObject.FClass.InstanceSize));
 97    oObject.FClass.InitInstance(TempObject);
 98
 99    LoadClass(TempObject, Node.ChildNodes.Nodes[i]);
100
101    oObject.Add(TempObject);
102  end;
103end;
104{$ENDREGION}
105
106{$REGION 'Loading'}
107procedure TXMLConfig.LoadClass(oObject: TObject; Node: IXMLNode);
108
109  procedure GetProperty(PropInfo: PPropInfo);
110  var
111    sValue: string;
112    TempNode: IXMLNode;
113    LObject: TObject;
114  begin
115    TempNode := Node.ChildNodes.FindNode(String(PropInfo.Name));
116    if TempNode = nil then
117      exit;
118
119    if PropInfo.PropType^.Kind <> tkClass then
120      sValue := TempNode.Text;
121
122    case PropInfo.PropType^.Kind of
123      tkEnumeration:
124        if GetTypeData(PropInfo.PropType^).BaseType = TypeInfo(Boolean)
125          then SetPropValue(oObject, PropInfo, Boolean(StrToBool(sValue)))
126          else SetPropValue(oObject, PropInfo, StrToInt(sValue));
127      tkInteger, tkChar, tkWChar, tkSet:
128        SetPropValue(oObject, PropInfo, StrToInt(sValue));
129      tkFloat:
130        SetPropValue(oObject, PropInfo, StrToFloat(sValue));
131      tkString, tkUString, tkLString, tkWString:
132        if isEncryptedString(oObject, String(PropInfo.Name))
133          then SetPropValue(oObject, PropInfo, DecryptString(sValue))
134          else SetPropValue(oObject, PropInfo, sValue);
135      tkClass:
136        begin
137          LObject := GetObjectProp(oObject, PropInfo);
138          if LObject <> nil then
139            LoadClass(LObject, TempNode);
140        end;
141    end;
142  end;
143
144var
145  i, iCount: integer;
146  PropInfo: PPropInfo;
147  PropList: PPropList;
148begin
149  if not (oObject is TXMLConfigNodes) then
150  begin
151    iCount := GetTypeData(oObject.ClassInfo).PropCount;
152
153    if iCount > 0 then
154    begin
155      GetMem(PropList, iCount * SizeOf(Pointer));
156
157      GetPropInfos(oObject.ClassInfo, PropList);
158      try
159        for i := 0 to iCount - 1 do
160        begin
161          PropInfo := PropList[i];
162          if PropInfo = nil then
163            break;
164
165          GetProperty(PropInfo);
166        end;
167      finally
168        FreeMem(PropList, iCount * SizeOf(Pointer));
169      end;
170    end;
171  end else
172    LoadObjects(oObject as TXMLConfigNodes, Node);
173end;
174
175function getEncryptionKey: word;
176var
177  Count: dword;
178  sName: string;
179  i: integer;
180begin
181  Result := 0;
182
183  Count := 257;
184  SetLength(sName, Count);
185  if not GetUserName(PChar(sName), Count) then
186    sName := 'fakekey';
187
188  for i := 1 to Length(sName) do
189  begin
190    if sName[i] = #0 then
191      break;
192
193    Result := Abs(Result - Ord(sName[i]));
194  end;
195end;
196
197function TXMLConfig.DecryptString(const sInput: string): string;
198begin
199  Result := EncdDecd.DecodeString(sInput);
200end;
201
202function TXMLConfig.EncryptString(const sInput: string): string;
203begin
204  Result := EncdDecd.EncodeString(sInput);
205end;
206
207function TXMLConfig.isEncryptedString(const oObject: TObject;
208  const Propertie: string): boolean;
209var
210  ctx: TRttiContext;
211  ctt: TRttiType;
212  ctp: TRttiProperty;
213  cta: TCustomAttribute;
214begin
215  Result := false;
216
217  ctx := TRttiContext.Create;
218  try
219    ctt := ctx.GetType(oObject.ClassType);
220
221    for ctp in ctt.GetProperties do
222      if ctp.Name = Propertie then
223      begin
224        for cta in ctp.GetAttributes do
225          if cta is EncryptedString then
226          begin
227            Result := true;
228
229            break;
230          end;
231
232        break;
233      end;
234  finally
235    ctx.Free;
236  end;
237end;
238
239procedure TXMLConfig.Load;
240var
241  XMLRoot: IXMLNode;
242  XML: IXMLDocument;
243begin
244  LoadDefaults;
245  if not FileExists(FXMLFilePath) then
246    exit;
247
248  try
249    XML := LoadXMLDocument(FXMLFilePath);
250    XMLRoot := XML.DocumentElement;
251
252    if (XMLRoot.NodeName <> FRootNodeName) or
253       (XMLRoot.Attributes[rsApplication] <> FApplicationName) then
254      exit;
255
256    FVersion := XMLRoot.Attributes[rsFormat];
257
258    LoadClass(Self, XMLRoot);
259  except
260    LoadDefaults;
261  end;
262end;
263{$ENDREGION}
264
265{$REGION 'Saving'}
266procedure TXMLConfig.SaveClass(oObject: TObject; Node: IXMLNode);
267
268  procedure WriteProperty(PropInfo: PPropInfo);
269  var
270    sValue: string;
271    LObject: TObject;
272    TempNode: IXMLNode;
273  begin
274    case PropInfo.PropType^.Kind of
275      tkEnumeration:
276        if GetTypeData(PropInfo.PropType^).BaseType = TypeInfo(Boolean)
277          then sValue := BoolToStr(Boolean(GetOrdProp(oObject, PropInfo)), true)
278          else sValue := IntToStr(GetOrdProp(oObject, PropInfo));
279      tkInteger, tkChar, tkWChar, tkSet:
280        sValue := IntToStr(GetOrdProp(oObject, PropInfo));
281      tkFloat:
282        sValue := FloatToStr(GetFloatProp(oObject, PropInfo));
283      tkString, tkUString, tkLString, tkWString:
284        begin
285          if isEncryptedString(oObject, String(PropInfo.Name))
286            then sValue := EncryptString(GetUnicodeStrProp(oObject, PropInfo))
287            else sValue := GetUnicodeStrProp(oObject, PropInfo);
288        end;
289      tkClass:
290        if Assigned(PropInfo.GetProc) and Assigned(PropInfo.SetProc) then
291        begin
292          LObject := GetObjectProp(oObject, PropInfo);
293          if LObject <> nil then
294          begin
295            TempNode := Node.AddChild(String(PropInfo.Name));
296
297            SaveClass(LObject, TempNode);
298          end;
299        end;
300    end;
301
302    if PropInfo.PropType^.Kind <> tkClass then
303      with Node.AddChild(String(PropInfo.Name)) do
304        Text := sValue;
305  end;
306
307var
308  PropInfo: PPropInfo;
309  PropList: PPropList;
310  i, iCount: integer;
311begin
312  if not (oObject is TXMLConfigNodes) then
313  begin
314    iCount := GetTypeData(oObject.ClassInfo).PropCount;
315
316    if iCount > 0 then
317    begin
318      GetMem(PropList, iCount * SizeOf(Pointer));
319      try
320        GetPropInfos(oObject.ClassInfo, PropList);
321
322        for i := 0 to iCount - 1 do
323        begin
324          PropInfo := PropList[i];
325          if PropInfo = nil then
326            Break;
327
328          WriteProperty(PropInfo);
329        end;
330      finally
331        FreeMem(PropList, iCount * SizeOf(Pointer));
332      end;
333    end;
334  end else
335    SaveObjects(oObject as TXMLConfigNodes, Node);
336end;
337
338procedure TXMLConfig.SaveObjects(oObject: TXMLConfigNodes; Node: IXMLNode);
339var
340  i: integer;
341  TempNode: IXMLNode;
342begin
343  for i := 0 to oObject.Count - 1 do
344  begin
345    TempNode := Node.AddChild('Item');
346    TempNode.Attributes['id'] := i;
347
348    SaveClass(oObject.Items[i], TempNode);
349  end;
350end;
351
352procedure TXMLConfig.Save;
353var
354  FRootNode: IXMLNode;
355  FBackFileName: string;
356  XML: IXMLDocument;
357begin
358  FBackFileName := ChangeFileExt(FXMLFilePath, '.bak');
359  try
360    if FileExists(FXMLFilePath) then
361      DeleteFile(PChar(FXMLFilePath));
362
363    try
364      XML := NewXMLDocument;
365
366      with XML do
367      begin
368        Encoding := 'UTF-8';
369        Version := '1.0';
370      end;
371
372      FRootNode := XML.AddChild(FRootNodeName);
373      FRootNode.Attributes[rsApplication] := FApplicationName;
374      FRootNode.Attributes[rsFormat] := FVersion;
375
376      SaveClass(Self, FRootNode);
377
378      XML.SaveToFile(FXMLFilePath);
379    except
380      if FileExists(FBackFileName) then
381        RenameFile(FBackFileName, FXMLFilePath);
382    end;
383  finally
384    if FileExists(FBackFileName) then
385      DeleteFile(PChar(FBackFileName));
386  end;
387end;
388{$ENDREGION}
389
390{ TXMLConfigNodes }
391
392function TXMLConfigNodes.Add(const XMLConfigNode: TXMLConfigNode): TXMLConfigNode;
393begin
394  FList.Add(XMLConfigNode);
395
396  Result := XMLConfigNode;
397end;
398
399procedure TXMLConfigNodes.Clear;
400begin
401  while Count > 0 do
402    FList.Delete(0);
403end;
404
405constructor TXMLConfigNodes.Create(const ItemClass: TClass);
406begin
407  FList := TList.Create;
408  FClass := ItemClass;
409end;
410
411destructor TXMLConfigNodes.Destroy;
412begin
413  if Assigned(FList) then
414  begin
415    Clear;
416    FList.Free;
417  end;
418
419  inherited;
420end;
421
422function TXMLConfigNodes.GetCount: integer;
423begin
424  Result := FList.Count;
425end;
426
427function TXMLConfigNodes.GetXMLConfigNode(const Index: integer): TXMLConfigNode;
428begin
429  Result := TXMLConfigNode(FList.Items[Index]);
430end;
431
432end.