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 FPC_FULLVERSION >= 30000}
106 if (FJSONConf<>nil) then
107 FJSONConf.Formatted := Value;
108 {$ENDIF}
109 end;
110
TCustomJSONPropStorage.FixPathnull111 function TCustomJSONPropStorage.FixPath(const APath: String): String;
112 begin
113 Result:=StringReplace(APath,'.','/',[rfReplaceAll]);
114 end;
115
116 procedure TCustomJSONPropStorage.StorageNeeded(ReadOnly: Boolean);
117 begin
118 if (FJSONConf=nil) and not (csDesigning in ComponentState) then
119 begin
120 FJSONConf := TJSONConfig.Create(nil);
121 {$IF FPC_FULLVERSION >= 30000}
122 FJSONConf.Formatted := FFormatted;
123 {$ENDIF}
124 FJSONConf.Filename := GetJSONFileName;
125 end;
126 Inc(FCount);
127 end;
128
129 procedure TCustomJSONPropStorage.FreeStorage;
130 begin
131 Dec(FCount);
132 if (FCount<=0) then
133 begin
134 FCount:=0;
135 FreeAndNil(FJSONConf);
136 end;
137 end;
138
DoReadStringnull139 function TCustomJSONPropStorage.DoReadString(const Section, Ident,
140 Default: String): String;
141 begin
142 Result := UTF16ToUTF8(FJSONConf.GetValue(UTF8ToUTF16(FixPath(Section)+'/'+FixPath(Ident)),
143 UTF8ToUTF16(Default)));
144 end;
145
146 procedure TCustomJSONPropStorage.DoWriteString(const Section, Ident,
147 Value: String);
148 begin
149 FJSONConf.SetValue(UTF8ToUTF16(FixPath(Section)+'/'+FixPath(Ident)), UTF8ToUTF16(Value));
150 end;
151
152 procedure TCustomJSONPropStorage.DoEraseSections(const ARootObjectPath: String);
153 begin
154 FJSONConf.DeletePath(UTF8ToUTF16(FixPath(ARootObjectPath)));
155 end;
156
157 end.
158