1 { $Id: $ }
2 {
3 *****************************************************************************
4 This file is part of the Lazarus Component Library (LCL)
5
6 See the file COPYING.modifiedLGPL.txt, included in this distribution,
7 for details about the license.
8 *****************************************************************************
9 }
10 unit JSONPropStorage;
11
12 {$mode objfpc}{$H+}
13
14 interface
15
16 uses
17 Classes, SysUtils, Forms, JSONConf, LazUTF8;
18
19 type
20 { TCustomJSONPropStorage }
21 TCustomJSONPropStorage = class(TFormPropertyStorage)
22 private
23 FCount : Integer;
24 FJSONFileName: string;
25 FRootObjectPath: String;
26 FJSONConf: TJSONConfig;
27 FFormatted: Boolean;
28 protected
GetJSONFileNamenull29 function GetJSONFileName: String; virtual;
RootSectionnull30 function RootSection: String; override;
GetFormattednull31 function GetFormatted: Boolean;
32 procedure SetFormatted(Value: Boolean);
FixPathnull33 function FixPath(const APath: String): String; virtual;
34
35 property JSONConf: TJSONConfig read FJSONConf;
36 public
37 procedure StorageNeeded(ReadOnly: Boolean); override;
38 procedure FreeStorage; override;
DoReadStringnull39 function DoReadString(const Section, Ident, Default: String): String; override;
40 procedure DoWriteString(const Section, Ident, Value: String); override;
41 procedure DoEraseSections(const ARootObjectPath : String);override;
42 public
43 property JSONFileName: String read FJSONFileName write FJSONFileName;
44 property RootObjectPath: String read FRootObjectPath write FRootObjectPath;
45 property Formatted: Boolean read GetFormatted write SetFormatted;
46 end;
47
48 { TJSONPropStorage }
49 TJSONPropStorage = class(TCustomJSONPropStorage)
50 published
51 property StoredValues;
52 property JSONFileName;
53 property Formatted;
54 property Active;
55 property OnSavingProperties;
56 property OnSaveProperties;
57 property OnRestoringProperties;
58 property OnRestoreProperties;
59 end;
60
61 procedure Register;
62
63 implementation
64
65 procedure Register;
66 begin
67 RegisterComponents('Misc',[TJSONPropStorage]);
68 end;
69
70 { TCustomJSONPropStorage }
71
GetJSONFileNamenull72 function TCustomJSONPropStorage.GetJSONFileName: String;
73 begin
74 If (FJSONFileName<>'') then
75 Result:=FJSONFileName
76 else if csDesigning in ComponentState then
77 raise Exception.Create('TCustomJSONPropStorage.GetJSONFileName: missing Filename')
78 else
79 {$ifdef unix}
80 Result:=IncludeTrailingPathDelimiter(GetEnvironmentVariableUTF8('HOME'))
81 +'.'+ExtractFileName(Application.ExeName);
82
83 {$else}
84 Result:=ChangeFileExt(Application.ExeName,'.json');
85 {$endif}
86 end;
87
RootSectionnull88 function TCustomJSONPropStorage.RootSection: String;
89 begin
90 if (FRootObjectPath<>'') then
91 Result := FRootObjectPath
92 else
93 Result := inherited RootSection;
94 Result := FixPath(Result);
95 end;
96
GetFormattednull97 function TCustomJSONPropStorage.GetFormatted: Boolean;
98 begin
99 Result := FFormatted;
100 end;
101
102 procedure TCustomJSONPropStorage.SetFormatted(Value: Boolean);
103 begin
104 FFormatted := Value;
105 if (FJSONConf<>nil) then
106 FJSONConf.Formatted := Value;
107 end;
108
TCustomJSONPropStorage.FixPathnull109 function TCustomJSONPropStorage.FixPath(const APath: String): String;
110 begin
111 Result:=StringReplace(APath,'.','/',[rfReplaceAll]);
112 end;
113
114 procedure TCustomJSONPropStorage.StorageNeeded(ReadOnly: Boolean);
115 begin
116 if (FJSONConf=nil) and not (csDesigning in ComponentState) then
117 begin
118 FJSONConf := TJSONConfig.Create(nil);
119 FJSONConf.Formatted := FFormatted;
120 FJSONConf.Filename := GetJSONFileName;
121 end;
122 Inc(FCount);
123 end;
124
125 procedure TCustomJSONPropStorage.FreeStorage;
126 begin
127 Dec(FCount);
128 if (FCount<=0) then
129 begin
130 FCount:=0;
131 FreeAndNil(FJSONConf);
132 end;
133 end;
134
DoReadStringnull135 function TCustomJSONPropStorage.DoReadString(const Section, Ident,
136 Default: String): String;
137 begin
138 Result := UTF16ToUTF8(FJSONConf.GetValue(UTF8ToUTF16(FixPath(Section)+'/'+FixPath(Ident)),
139 UTF8ToUTF16(Default)));
140 end;
141
142 procedure TCustomJSONPropStorage.DoWriteString(const Section, Ident,
143 Value: String);
144 begin
145 FJSONConf.SetValue(UTF8ToUTF16(FixPath(Section)+'/'+FixPath(Ident)), UTF8ToUTF16(Value));
146 end;
147
148 procedure TCustomJSONPropStorage.DoEraseSections(const ARootObjectPath: String);
149 begin
150 FJSONConf.DeletePath(UTF8ToUTF16(FixPath(ARootObjectPath)));
151 end;
152
153 end.
154