File: jsonpropstorage.pas

package info (click to toggle)
lazarus 2.0.10%2Bdfsg-4
  • links: PTS, VCS
  • area: main
  • in suites: bullseye
  • size: 219,188 kB
  • sloc: pascal: 1,867,962; xml: 265,716; cpp: 56,595; sh: 3,005; java: 609; makefile: 568; perl: 297; sql: 222; ansic: 137
file content (157 lines) | stat: -rw-r--r-- 4,253 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
{  $Id: $  }
{
 *****************************************************************************
  This file is part of the Lazarus Component Library (LCL)

  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
 *****************************************************************************
}
unit JSONPropStorage;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, JSONConf, LazUTF8;

type
{ TCustomJSONPropStorage }
  TCustomJSONPropStorage = class(TFormPropertyStorage)
  private
    FCount : Integer;
    FJSONFileName: string;
    FRootObjectPath: String;
    FJSONConf: TJSONConfig;
    FFormatted: Boolean;
  protected
    function GetJSONFileName: String; virtual;
    function RootSection: String; override;
    function GetFormatted: Boolean;
    procedure SetFormatted(Value: Boolean);
    function FixPath(const APath: String): String; virtual;

    property JSONConf: TJSONConfig read FJSONConf;
  public
    procedure StorageNeeded(ReadOnly: Boolean); override;
    procedure FreeStorage; override;
    function  DoReadString(const Section, Ident, Default: String): String; override;
    procedure DoWriteString(const Section, Ident, Value: String); override;
    procedure DoEraseSections(const ARootObjectPath : String);override;
  public
    property JSONFileName: String read FJSONFileName write FJSONFileName;
    property RootObjectPath: String read FRootObjectPath write FRootObjectPath;
    property Formatted: Boolean read GetFormatted write SetFormatted;
  end;

{ TJSONPropStorage }
  TJSONPropStorage = class(TCustomJSONPropStorage)
  published
    property StoredValues;
    property JSONFileName;
    property Formatted;
    property Active;
    property OnSavingProperties;
    property OnSaveProperties;
    property OnRestoringProperties;
    property OnRestoreProperties;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Misc',[TJSONPropStorage]);
end;

{ TCustomJSONPropStorage }

function TCustomJSONPropStorage.GetJSONFileName: String;
begin
  If (FJSONFileName<>'') then
    Result:=FJSONFileName
  else if csDesigning in ComponentState then
    raise Exception.Create('TCustomJSONPropStorage.GetJSONFileName: missing Filename')
  else
{$ifdef unix}
    Result:=IncludeTrailingPathDelimiter(GetEnvironmentVariableUTF8('HOME'))
            +'.'+ExtractFileName(Application.ExeName);

{$else}
    Result:=ChangeFileExt(Application.ExeName,'.json');
{$endif}
end;

function TCustomJSONPropStorage.RootSection: String;
begin
  if (FRootObjectPath<>'') then
    Result := FRootObjectPath
  else
    Result := inherited RootSection;
  Result := FixPath(Result);
end;

function TCustomJSONPropStorage.GetFormatted: Boolean;
begin
  Result := FFormatted;
end;

procedure TCustomJSONPropStorage.SetFormatted(Value: Boolean);
begin
  FFormatted := Value;
  {$IF FPC_FULLVERSION >= 30000}
  if (FJSONConf<>nil) then
    FJSONConf.Formatted := Value;
  {$ENDIF}
end;

function TCustomJSONPropStorage.FixPath(const APath: String): String;
begin
  Result:=StringReplace(APath,'.','/',[rfReplaceAll]);
end;

procedure TCustomJSONPropStorage.StorageNeeded(ReadOnly: Boolean);
begin
  if (FJSONConf=nil) and not (csDesigning in ComponentState) then
  begin
    FJSONConf := TJSONConfig.Create(nil);
    {$IF FPC_FULLVERSION >= 30000}
    FJSONConf.Formatted := FFormatted;
    {$ENDIF}
    FJSONConf.Filename := GetJSONFileName;
  end;
  Inc(FCount);
end;

procedure TCustomJSONPropStorage.FreeStorage;
begin
  Dec(FCount);
  if (FCount<=0) then
  begin
    FCount:=0;
    FreeAndNil(FJSONConf);
  end;
end;

function TCustomJSONPropStorage.DoReadString(const Section, Ident,
  Default: String): String;
begin
  Result := UTF16ToUTF8(FJSONConf.GetValue(UTF8ToUTF16(FixPath(Section)+'/'+FixPath(Ident)),
                                           UTF8ToUTF16(Default)));
end;

procedure TCustomJSONPropStorage.DoWriteString(const Section, Ident,
  Value: String);
begin
  FJSONConf.SetValue(UTF8ToUTF16(FixPath(Section)+'/'+FixPath(Ident)), UTF8ToUTF16(Value));
end;

procedure TCustomJSONPropStorage.DoEraseSections(const ARootObjectPath: String);
begin
  FJSONConf.DeletePath(UTF8ToUTF16(FixPath(ARootObjectPath)));
end;

end.