paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-08 01:27:59 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Apply one JSON to another JSON object

Browse Source 
git-svn-id: trunk@49557 -
This commit is contained in:
michael 2021-06-24 12:37:47 +00:00
parent 5eac35664f
commit d56ddc28e8
5 changed files with 467 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -3810,6 +3810,8 @@ packages/fcl-json/examples/demoformat.pp svneol=native#text/plain
packages/fcl-json/examples/demortti.pp svneol=native#text/plain
packages/fcl-json/examples/ini2json.pp svneol=native#text/plain
packages/fcl-json/examples/j2y.pp svneol=native#text/plain
packages/fcl-json/examples/jsonmerge.lpi svneol=native#text/plain
packages/fcl-json/examples/jsonmerge.pp svneol=native#text/plain
packages/fcl-json/examples/parsedemo.lpi svneol=native#text/plain
packages/fcl-json/examples/parsedemo.pp svneol=native#text/plain
packages/fcl-json/examples/simpledemo.lpi svneol=native#text/plain
@ -3818,6 +3820,7 @@ packages/fcl-json/fpmake.pp svneol=native#text/plain
packages/fcl-json/src/README.txt svneol=native#text/plain
packages/fcl-json/src/fcl-json.inc svneol=native#text/plain
packages/fcl-json/src/fpjson.pp svneol=native#text/plain
packages/fcl-json/src/fpjsonapply.pp svneol=native#text/plain
packages/fcl-json/src/fpjsonrtti.pp svneol=native#text/plain
packages/fcl-json/src/fpjsontopas.pp svneol=native#text/plain
packages/fcl-json/src/json2yaml.pp svneol=native#text/plain

65
packages/fcl-json/examples/jsonmerge.lpi Normal file
View File

@ -0,0 +1,65 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="JSON merge tool"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<BuildModes>
<Item Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<Units>
<Unit>
<Filename Value="jsonmerge.pp"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="../src/fpjsonapply.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="jsonmerge"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<UseHeaptrc Value="True"/>
</Debugging>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions>
<Item>
<Name Value="EAbort"/>
</Item>
<Item>
<Name Value="ECodetoolError"/>
</Item>
<Item>
<Name Value="EFOpenError"/>
</Item>
</Exceptions>
</Debugging>
</CONFIG>

117
packages/fcl-json/examples/jsonmerge.pp Normal file
View File

@ -0,0 +1,117 @@
{
This file is part of the Free Component Library
Merge 2 JSON files.
Copyright (c) 2021 by Michael Van Canneyt michael@freepascal.org
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
program jsonmerge;
{$mode objfpc}{$H+}
uses
Classes, SysUtils, CustApp, fpJSON, jsonparser, fpjsonapply;
type
{ TJSONMergeApplication }
TJSONMergeApplication = class(TCustomApplication)
private
function ParseOptions: string;
protected
FApplier : TJSONApplier;
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure Usage(const aErrorMsg: String); virtual;
end;
{ TJSONMergeApplication }
Function TJSONMergeApplication.ParseOptions : string;
begin
Result:='';
FApplier.SourceFileName:=GetOptionValue('s','source');
FApplier.ApplyFileName:=GetOptionValue('a','apply');
FApplier.DestFileName:=GetOptionValue('d','destination');
FApplier.CaseInsensitive:=HasOption('i','ignorecase');
FApplier.RemoveNonExisting:=HasOption('r','remove');
FApplier.Formatted:=HasOption('f','format');
FApplier.SourcePath:=GetOptionValue('p','path');
FApplier.ApplyPath:=GetOptionValue('y','apply-path');
if (FApplier.SourceFileName='') then
Result:='Missing source filename'
else if (FApplier.ApplyFileName='') then
Result:='Missing apply filename';
if (Result='') and (FApplier.DestFileName='') then
FApplier.DestFileName:=FApplier.SourceFileName;
end;
procedure TJSONMergeApplication.DoRun;
var
ErrorMsg: String;
begin
Terminate;
ErrorMsg:=CheckOptions('hs:a:d:irfp:y:', ['help','source:','apply:','destination:','ignorecase','remove','format','path:','apply-path:']);
if (ErrorMsg='') and not HasOption('h','help') then
ErrorMsg:=ParseOptions;
if (ErrorMsg<>'') or HasOption('h','help') then
begin
Usage(ErrorMsg);
Exit;
end;
FApplier.Execute;
end;
constructor TJSONMergeApplication.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException:=True;
FApplier:=TJSONApplier.Create(Self);
end;
destructor TJSONMergeApplication.Destroy;
begin
FreeAndNil(FApplier);
inherited Destroy;
end;
procedure TJSONMergeApplication.Usage(const aErrorMsg: String);
begin
if (aErrorMsg<>'') then
Writeln(aErrorMsg);
writeln('Usage: ', ExeName, ' -h');
writeln('where');
writeln('-a --apply=FILE File with JSON to apply to input.');
writeln('-d --destination=FILE File to write resulting JSON to (defaults to input)');
writeln('-f --format Format destination JSON.');
writeln('-h --help This help message.');
writeln('-i --ignorecase Ignore case when looking for element names.');
writeln('-p --path=PATH Start applying at element at PATH in source.');
writeln('-r --remove Remove elements in source not existing in apply file.');
writeln('-s --source=FILE File with JSON input.');
writeln('-y --apply-path=PATH Start applying at element at PATH in apply.');
ExitCode:=Ord(aErrorMsg<>'');
end;
var
Application: TJSONMergeApplication;
begin
Application:=TJSONMergeApplication.Create(nil);
Application.Title:='JSON merge tool';
Application.Run;
Application.Free;
end.

11
packages/fcl-json/fpmake.pp
View File

@ -83,12 +83,19 @@ begin
begin
AddUnit('fpjson');
AddUnit('jsonparser');
end;
end;
T:=P.Targets.AddUnit('json2yaml.pp');
with T.Dependencies do
begin
AddUnit('fpjson');
end;
end;
T:=P.Targets.AddUnit('fpjsonapply.pp');
with T.Dependencies do
begin
AddUnit('fpjson');
end;
T.ResourceStrings:=true;
P.ExamplePath.Add('examples');
T:=P.Targets.AddExampleProgram('confdemo.pp');

273
packages/fcl-json/src/fpjsonapply.pp Normal file
View File

@ -0,0 +1,273 @@
{
This file is part of the Free Component Library
Apply elements from one JSON object to another.
Copyright (c) 2021 by Michael Van Canneyt michael@freepascal.org
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit fpjsonapply;
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils, fpJSON;
Type
TOwnsJSON = (ojSource,ojApply);
TOwnsJSONs = set of TOwnsJSON;
{ TJSONApplier }
TJSONApplier = class(TComponent)
private
FApplyFileName: String;
FApplyJSON: TJSONObject;
FApplyPath: String;
FCaseInsensitive: Boolean;
FCloneSource: boolean;
FDestFileName: String;
FDestJSON: TJSONObject;
FForceCorrectType: Boolean;
FFormatted: Boolean;
FOwnsJSON: TOwnsJSONs;
FRemoveNonExisting: Boolean;
FSourceFileName: String;
FSourceJSON: TJSONObject;
FSourcePath: String;
procedure MaybeLoadApply;
procedure MaybeLoadSource;
procedure SetApplyJSON(AValue: TJSONObject);
procedure SetSourceJSON(AValue: TJSONObject);
Protected
procedure Apply(aSrc, aApply: TJSONObject); virtual;
procedure SaveDestJSON(aFileName : string);
procedure SaveDestJSON(aStream : TStream);
Public
destructor destroy; override;
// apply ApplyJSON to SourceJSON, set result in DestJSON
Procedure Execute; virtual;
// Source JSON. If not set, load from SourceFileName
Property SourceJSON : TJSONObject Read FSourceJSON Write SetSourceJSON;
// JSON to apply. If not set, load from ApplyFileName
Property ApplyJSON : TJSONObject Read FApplyJSON Write SetApplyJSON;
// Destination JSON. Can be equal to SourceJSON if CloneSource is not True.
Property DestJSON : TJSONObject Read FDestJSON;
// Are SourceJSON, ApplyJSON owned by the component ? Are set when loading from file.
Property OwnsJSON : TOwnsJSONs Read FOwnsJSON Write FOwnsJSON;
Published
// File to load SourceJSON from if it is not set.
Property SourceFileName : String Read FSourceFileName Write FSourceFileName;
// JSON path in source JSON where to start merging. Must exist and be an object!
Property SourcePath : String Read FSourcePath Write FSourcePath;
// File to load ApplyJSON from if it is not set.
Property ApplyFileName : String Read FApplyFileName Write FApplyFileName;
// JSON path in apply JSON where to start merging. Must exist and be an object!
Property ApplyPath : String Read FApplyPath Write FApplyPath;
// file to write DestJSON to after merging. Can be empty
Property DestFileName : String Read FDestFileName Write FDestFileName;
// Make a clone copy of SourceJSON before applying ApplyJSON ?
Property CloneSource : boolean Read FCloneSource Write FCloneSource;
// Search names case insensitively ?
Property CaseInsensitive : Boolean Read FCaseInsensitive Write FCaseInsensitive;
// If the type of an entry is different in Source and Apply, overwrite the entry with the value in Apply
Property ForceCorrectType : Boolean Read FForceCorrectType Write FForceCorrectType;
// After adding new entries from Apply, remove entries in Source that are not in apply.
property RemoveNonExisting : Boolean Read FRemoveNonExisting Write FRemoveNonExisting;
// Write formatted output in Destfilename (or not)
Property Formatted : Boolean Read FFormatted Write FFormatted;
end;
implementation
Resourcestring
SErrSourceEmpty = 'Cannot apply to empty source object';
SErrApplyEmpty = 'Cannot apply empty object';
SErrSourceIsNotObject = 'JSON source file does not contain a JSON object';
SErrApplyIsNotObject = 'JSON apply file does not contain a JSON object';
SErrPathNotFound = 'Path "%s" in %s JSON not found';
{ TJSONApplier }
procedure TJSONApplier.SetApplyJSON(AValue: TJSONObject);
begin
if FApplyJSON=AValue then Exit;
if ojApply in FOwnsJSON then
FreeAndNil(FApplyJSON);
FApplyJSON:=AValue;
end;
procedure TJSONApplier.SetSourceJSON(AValue: TJSONObject);
begin
if FSourceJSON=AValue then Exit;
if ojSource in FOwnsJSON then
FreeAndNil(FSourceJSON);
FSourceJSON:=AValue;
end;
procedure TJSONApplier.MaybeLoadSource;
Var
D : TJSONData;
F : TFileStream;
begin
If (FSourceJSON=Nil) and (SourceFileName<>'') then
begin
F:=TFileStream.Create(SourceFileName, fmOpenRead or fmShareDenyWrite);
try
D:=GetJSON(F);
if D.JSONType<>jtObject then
begin
D.Free;
Raise EJSON.Create(SErrSourceIsNotObject)
end;
finally
F.Free;
end;
SourceJSON:=D as TJSONObject;
Include(FOwnsJSON,ojSource);
end;
end;
procedure TJSONApplier.MaybeLoadApply;
Var
D : TJSONData;
F : TFileStream;
begin
If (ApplyFileName<>'') then
begin
F:=TFileStream.Create(ApplyFileName, fmOpenRead or fmShareDenyWrite);
try
D:=GetJSON(F);
if D.JSONType<>jtObject then
begin
D.Free;
Raise EJSON.Create(SErrApplyIsNotObject)
end;
finally
F.Free;
end;
ApplyJSON:=D as TJSONObject;
Include(FOwnsJSON,ojApply);
end;
end;
procedure TJSONApplier.Apply(aSrc, aApply : TJSONObject);
Var
aEnum : TJSONEnum;
aIdx : Integer;
begin
for aEnum in aApply do
begin
aIdx:=aSrc.IndexOfName(aEnum.Key,CaseInsensitive);
if (aIdx<>-1) and FForceCorrectType and (aSrc.Items[aIdx].JSONType<>aEnum.Value.JSONType) then
begin
aSrc.Delete(aIdx);
aIdx:=-1;
end;
if aIdx=-1 then
aSrc.Add(aEnum.Key,aEnum.Value.Clone)
else
if (aSrc.Items[aIdx].JSONType=jtObject) and (aEnum.Value.JSONType=jtObject) then
Apply(aSrc.Items[aIdx] as TJSONObject,aEnum.Value as TJSONObject);
end;
if RemoveNonExisting then
begin
for aIdx:=aSrc.Count-1 downto 0 do
if aApply.IndexOfName(aSrc.Names[aIdx],CaseInsensitive)=-1 then
aSrc.Delete(aIdx);
end;
end;
procedure TJSONApplier.SaveDestJSON(aFileName: string);
Var
F : TFileStream;
begin
F:=TFileStream.Create(aFileName,fmCreate);
try
SaveDestJSON(F);
finally
F.Free;
end;
end;
procedure TJSONApplier.SaveDestJSON(aStream: TStream);
Var
S : TJSONStringType;
begin
if Formatted then
S:=DestJSON.FormatJSON()
else
S:=DestJSON.AsJSON;
aStream.WriteBuffer(S[1],Length(S)*SizeOf(TJSONCharType));
end;
destructor TJSONApplier.destroy;
begin
if FDestJSON<>FSourceJSON then
FreeAndNil(FDestJSON);
// Will free if needed
SourceJSON:=Nil;
ApplyJSON:=Nil;
Inherited;
end;
procedure TJSONApplier.Execute;
Function FindStart(aJSON : TJSONObject; aPath,aDesc : String) : TJSONObject;
Var
D : TJSONData;
begin
Result:=aJSON;
if aPath='' then
exit;
D:=Result.FindPath(aPath);
if Assigned(D) then
Writeln('Have : ',D.ClassName)
else
Writeln('No D');
if (D=Nil) or Not (D is TJSONObject) then
Raise EJSON.CreateFmt(SErrPathNotFound,[aPath,aDesc]);
Result:=D as TJSONObject;
end;
begin
MaybeLoadSource;
MaybeLoadApply;
if (SourceJSON=Nil) then
Raise EJSON.Create(SErrSourceEmpty);
if (ApplyJSON=Nil) then
Raise EJSON.Create(SErrApplyEmpty);
if CloneSource then
FDestJSON:=SourceJSON.Clone as TJSONObject
else
FDestJSON:=SourceJSON;
Apply(FindStart(FDestJSON,SourcePath,'Source'),FindStart(ApplyJSON,ApplyPath,'Apply'));
if (DestFileName<>'') then
SaveDestJSON(DestFileName);
end;
end.