* Apply one JSON to another JSON object

git-svn-id: trunk@49557 -

.gitattributes

@@ -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

packages/fcl-json/examples/jsonmerge.lpi

@@ -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>

packages/fcl-json/examples/jsonmerge.pp

@@ -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.
+

packages/fcl-json/fpmake.pp

@@ -89,6 +89,13 @@ begin
       begin
       AddUnit('fpjson');
       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');

packages/fcl-json/src/fpjsonapply.pp

@@ -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.
+