diff --git a/build/windows-full-release.bat b/build/windows-full-release.bat index 90772474b..ff9ca8166 100644 --- a/build/windows-full-release.bat +++ b/build/windows-full-release.bat @@ -25,9 +25,9 @@ call build\windows-fhirserver.bat %tmp% pause -rem exec\64\fhirserver.exe -tests -test-settings exec\64\fhir-tests.ini +exec\64\fhirserver.exe -tests -test-settings exec\64\fhir-tests.ini -mode brief -rem if errorlevel 1 goto Quit +if errorlevel 1 goto Quit pause diff --git a/install/install-tk.iss b/install/install-tk.iss index 0044ca3c4..18e9fdfda 100644 --- a/install/install-tk.iss +++ b/install/install-tk.iss @@ -3,11 +3,11 @@ ; AppID can never be changed as subsequent installations require the same installation ID each time AppID=FHIRToolkit AppName=Health Intersections FHIR Toolkit -AppVerName=FHIRToolkit v3.1.11 +AppVerName=FHIRToolkit v3.1.12 ; compilation control OutputDir=..\install\build -OutputBaseFilename=fhirtoolkit-win64-3.1.11 +OutputBaseFilename=fhirtoolkit-win64-3.1.12 Compression=lzma2/ultra64 ; 64 bit @@ -32,11 +32,11 @@ UninstallFilesDir={app}\uninstall ; win2000+ add/remove programs support AppPublisher=Health Intersections P/L AppPublisherURL=http://www.healthintersections.com.au -AppVersion=3.1.11 +AppVersion=3.1.12 AppSupportURL=https://github.com/grahamegrieve/fhirserver AppUpdatesURL=https://github.com/grahamegrieve/fhirserver AppCopyright=Copyright (c) Health Intersections Pty Ltd 2020+ -VersionInfoVersion=3.1.11.0 +VersionInfoVersion=3.1.12.0 ; dialog support LicenseFile=..\license diff --git a/install/install.iss b/install/install.iss index fce7bb91d..7a669dcca 100644 --- a/install/install.iss +++ b/install/install.iss @@ -3,11 +3,11 @@ ; AppID can never be changed as subsequent installations require the same installation ID each time AppID=FHIRServer AppName=Health Intersections FHIR Server -AppVerName=FHIRServer v3.1.11 +AppVerName=FHIRServer v3.1.12 ; compilation control OutputDir=..\install\build -OutputBaseFilename=fhirserver-win64-3.1.11 +OutputBaseFilename=fhirserver-win64-3.1.12 Compression=lzma2/ultra64 ; 64 bit @@ -34,11 +34,11 @@ UninstallFilesDir={app}\uninstall ; win2000+ add/remove programs support AppPublisher=Health Intersections P/L AppPublisherURL=http://www.healthintersections.com.au -AppVersion=3.1.11 +AppVersion=3.1.12 AppSupportURL=https://github.com/grahamegrieve/fhirserver AppUpdatesURL=https://github.com/grahamegrieve/fhirserver AppCopyright=Copyright (c) Health Intersections Pty Ltd 2011+ -VersionInfoVersion=3.1.11.0 +VersionInfoVersion=3.1.12.0 ; dialog support LicenseFile=..\license diff --git a/library/fhir-dev.inc b/library/fhir-dev.inc index a17814ff3..a03a8826a 100644 --- a/library/fhir-dev.inc +++ b/library/fhir-dev.inc @@ -6,9 +6,21 @@ // do not make changes in the file fhir-status.inc - it is overwritten by either fhir-dev.inc or fhir-prod.inc by the build scripts +// THIS IS DEVELOPMENT MODE + {$C+} // assertions on - this is the important one - turns object tracking on and off consistently {$I+} // IO checking on - though this is probably useless? {$Q-} // overflow checking off - these are always off; doesn't run with them on {$R-} // range checking off - these are always off; doesn't run with them on -{$OPTIMIZATION OFF} // all optimizations off for production +{$OPTIMIZATION OFF} // all optimizations off for development {$D+} // debugging info on for development + +{ +The base class TFslObject can track all instantiated objects. +Doing so is useful for leak hunting in production, but is also a little costly. +Enable it with this define +} +{$DEFINE OBJECT_TRACKING} + + + diff --git a/library/fhir-prod.inc b/library/fhir-prod.inc index 4a809a60f..5024cb2a3 100644 --- a/library/fhir-prod.inc +++ b/library/fhir-prod.inc @@ -6,9 +6,18 @@ // do not make changes in the file fhir-status.inc - it is overwritten by either fhir-dev.inc or fhir-prod.inc by the build scripts +// THIS IS PRODUCTION MODE + {$C-} // assertions off - this is the important one - turns object tracking off consistently {$I-} // IO checking off {$Q-} // overflow checking off - these are always off; doesn't run with them on {$R-} // range checking off - these are always off; doesn't run with them on {$OPTIMIZATION LEVEL3} // level 3 optimizations for production {$D-} // debugging info off for production + +{ +The base class TFslObject can track all instantiated objects. +Doing so is useful for leak hunting in production, but is also a little costly. +Enable it with this define +} +{.$.DEFINE OBJECT_TRACKING} \ No newline at end of file diff --git a/library/fhir-status.inc b/library/fhir-status.inc index 4a809a60f..5024cb2a3 100644 --- a/library/fhir-status.inc +++ b/library/fhir-status.inc @@ -6,9 +6,18 @@ // do not make changes in the file fhir-status.inc - it is overwritten by either fhir-dev.inc or fhir-prod.inc by the build scripts +// THIS IS PRODUCTION MODE + {$C-} // assertions off - this is the important one - turns object tracking off consistently {$I-} // IO checking off {$Q-} // overflow checking off - these are always off; doesn't run with them on {$R-} // range checking off - these are always off; doesn't run with them on {$OPTIMIZATION LEVEL3} // level 3 optimizations for production {$D-} // debugging info off for production + +{ +The base class TFslObject can track all instantiated objects. +Doing so is useful for leak hunting in production, but is also a little costly. +Enable it with this define +} +{.$.DEFINE OBJECT_TRACKING} \ No newline at end of file diff --git a/library/fhir.inc b/library/fhir.inc index 7843cb77c..57b082df5 100644 --- a/library/fhir.inc +++ b/library/fhir.inc @@ -65,14 +65,6 @@ Or in the case of FPC compiled applications, statically bound } {$DEFINE STATICLOAD_OPENSSL} -{$I fhir-status.inc} // see notes there +{$i fhir-status.inc} // see notes there -{ -The base class TFslObject can track all instantiated objects. -Doing so is useful for leak hunting in production, but is also a little costly. -Enable it with this define -} -{$IFOPT D+} -{$DEFINE OBJECT_TRACKING} -{$ENDIF} diff --git a/library/fhir4b/fhir4b_profiles.pas b/library/fhir4b/fhir4b_profiles.pas index 20bcbaf94..5ff25986c 100644 --- a/library/fhir4b/fhir4b_profiles.pas +++ b/library/fhir4b/fhir4b_profiles.pas @@ -1676,7 +1676,7 @@ function TBaseWorkerContextR4B.getStructure(ns, name: String): TFHIRStructureDef list : TFslList; sd : TFhirStructureDefinition; sns : String; - url : string; + url, u : string; begin list := TFslList.Create; try @@ -1687,7 +1687,8 @@ function TBaseWorkerContextR4B.getStructure(ns, name: String): TFHIRStructureDef url := 'http://hl7.org/fhir/StructureDefinition/'+name; for sd in list do begin - if (sd.url = url) then + u := sd.url; + if (u = url) then exit(sd); end; end; diff --git a/library/fsl/fsl_base.pas b/library/fsl/fsl_base.pas index fcec67fbe..d5177df33 100644 --- a/library/fsl/fsl_base.pas +++ b/library/fsl/fsl_base.pas @@ -44,9 +44,7 @@ interface {$ENDIF} EMPTY_HASH = -1; -{.$.DEFINE TRACK_CLASSES } - -{$IFDEF TRACK_CLASSES} +{$IFDEF OBJECT_TRACKING} const CLASS_NAME_OF_INTEREST = 'TFhirString'; ID_OF_INTEREST = -1; @@ -171,19 +169,15 @@ EJsonException = class (EFslException); // error reading or writing Json FTagObject : TObject; FOwningThread : TThreadId; FMagic : integer; - {$IFDEF TRACK_CLASSES} - FNamedInstance : string; - {$ENDIF} - {$IFOPT D+} + {$IFDEF OBJECT_TRACKING} // This is a workaround for the delphi debugger not showing the actual class of an object that is polymorphic // It's sole purpose is to be visible in the debugger. No other functionality should depend on it FNamedClass : TNameString; FDebugInfo : String; - {$ENDIF} - {$IFDEF OBJECT_TRACKING} FSerial : integer; FNext, FPrev : TFslObject; // same class type FThreadName : String; + FNamedInstance : string; {$ENDIF} function ObjectCrossesThreads : boolean; @@ -214,7 +208,7 @@ EJsonException = class (EFslException); // error reading or writing Json Function ErrorClass : EFslExceptionClass; Overload; Virtual; function sizeInBytesV(magic : integer) : cardinal; virtual; - {$IFDEF TRACK_CLASSES} + {$IFDEF OBJECT_TRACKING} procedure freeNotification(done : boolean); virtual; {$ENDIF} Public @@ -244,13 +238,9 @@ EJsonException = class (EFslException); // error reading or writing Json Property FslObjectReferenceCount : TFslReferenceCount Read FFslObjectReferenceCount; property TagObject : TObject read FTagObject write FTagObject; // no ownership.... - {$IFDEF TRACK_CLASSES} + {$IFDEF OBJECT_TRACKING} property NamedInstance : string read FNamedInstance write FNamedInstance; - {$ENDIF} - {$IFOPT D+} property NamedClass : TNameString read FNamedClass; - {$ENDIF} - {$IFDEF OBJECT_TRACKING} property SerialNumber : integer read FSerial; {$ENDIF} function debugInfo : String; virtual; // what's visible to the debugger @@ -1047,17 +1037,13 @@ constructor TFslObject.Create; {$ENDIF} Begin Inherited; - {$IFOPT D+} - FNamedClass := copy(ClassName, 1, 16); - {$ENDIF} FOwningThread := GetCurrentThreadId; - {$IFDEF TRACK_CLASSES} + {$IFDEF OBJECT_TRACKING} if (className = CLASS_NAME_OF_INTEREST) then freeNotification(false); - {$ENDIF} - {$IFDEF OBJECT_TRACKING} + FNamedClass := copy(ClassName, 1, 16); if not GInited then initUnit; if Assigned(GetThreadNameStatusDelegate) then @@ -1079,7 +1065,7 @@ constructor TFslObject.Create; inc(t.deltaCount); inc(t.serial); FSerial := t.serial; - {$IFDEF TRACK_CLASSES} + {$IFDEF OBJECT_TRACKING} if (t.serial = ID_OF_INTEREST) and (className = CLASS_NAME_OF_INTEREST) then NamedInstance := '!'; {$ENDIF} @@ -1207,7 +1193,7 @@ procedure TFslObject.Free; clsName := 'n/a'; nmCls := 'n/a'; try - {$IFOPT D+} + {$IFDEF OBJECT_TRACKING} nmCls := FNamedClass; {$ENDIF} except @@ -1235,7 +1221,7 @@ clsName := className; dec(FFslObjectReferenceCount); done := FFslObjectReferenceCount < 0; end; - {$IFDEF TRACK_CLASSES} + {$IFDEF OBJECT_TRACKING} if (classname = CLASS_NAME_OF_INTEREST) then self.freeNotification(done); {$ENDIF} @@ -1352,7 +1338,7 @@ function TFslObject.Link: TFslObject; InterlockedIncrement(FFslObjectReferenceCount) else inc(FFslObjectReferenceCount); - {$IFDEF TRACK_CLASSES} + {$IFDEF OBJECT_TRACKING} if self.classname = CLASS_NAME_OF_INTEREST then freeNotification(false); {$ENDIF} @@ -1525,7 +1511,7 @@ function TFslObject.debugInfo: String; procedure TFslObject.updateDebugInfo; begin - {$IFOPT D+} + {$IFDEF OBJECT_TRACKING} FDebugInfo := debugInfo; {$ENDIF} end; @@ -1548,19 +1534,16 @@ function TFslObject.ObjectCrossesThreads: boolean; function TFslObject.dumpSummary: String; begin result := inttostr(FFslObjectReferenceCount+1); - {$IFDEF TRACK_CLASSES} + {$IFDEF OBJECT_TRACKING} if FNamedInstance <> '' then result := result + FNamedInstance - {$ELSE} - if false then - {$ENDIF} - {$IFDEF OBJECT_TRACKING} else if (updatedDebugInfo <> '?') then result := result +'(^'+FDebugInfo+')' else if (FSerial > 0) then result := result +'(#'+inttostr(FSerial)+')' + else {$ENDIF} - else if FMagic <> 0 then + if FMagic <> 0 then result := result +'($'+inttostr(FMagic)+')'; end; @@ -1570,7 +1553,7 @@ function TFslObject.updatedDebugInfo: String; updateDebugInfo; except end; - result := {$IFOPT D+}FDebugInfo{$ELSE}''{$ENDIF}; + result := {$IFDEF OBJECT_TRACKING}FDebugInfo{$ELSE}''{$ENDIF}; end; function TFslObject.CheckCondition(bCorrect: Boolean; const sMethod, sMessage: String): Boolean; @@ -1652,15 +1635,13 @@ function TFslObject.sizeInBytes(magic : integer) : cardinal; function TFslObject.sizeInBytesV(magic : integer) : cardinal; begin result := sizeof(self); - {$IFOPT D+} - inc(result, (length(FNamedClass))+2); - {$ENDIF} {$IFDEF OBJECT_TRACKING} + inc(result, (length(FNamedClass))+2); inc(result, length(FThreadName)+12); {$ENDIF} end; -{$IFDEF TRACK_CLASSES} +{$IFDEF OBJECT_TRACKING} procedure noop(done : boolean); begin // nothing; diff --git a/library/fsl/fsl_collections.pas b/library/fsl/fsl_collections.pas index b31b979fb..bda743701 100644 --- a/library/fsl/fsl_collections.pas +++ b/library/fsl/fsl_collections.pas @@ -29,6 +29,7 @@ } {$I fhir.inc} + Interface @@ -1750,7 +1751,6 @@ TFslObjectListIterator = class(TFslObjectIterator) uses fsl_stream; - Procedure TFslCollection.BeforeDestruction; Begin InternalClear; @@ -5525,7 +5525,6 @@ function TFslObjectList.ExistsByDefault(oValue: TFslObject): boolean; Result := ExistsByIndex(IndexByDefault(oValue)); end; - function TFslObjectList.Add(oValue: TFslObject): integer; begin Assert(ValidateItem('Add', oValue, 'oValue')); diff --git a/library/fsl/tests/fsl_tests.pas b/library/fsl/tests/fsl_tests.pas index 266e39316..fcc8d06a0 100644 --- a/library/fsl/tests/fsl_tests.pas +++ b/library/fsl/tests/fsl_tests.pas @@ -5137,8 +5137,11 @@ procedure TFslCollectionsTests.testAdd; end; procedure TFslCollectionsTests.executeFail(context : TObject); +var + o : TFslTestObjectList; begin - list.Add(TFslTestObjectList.create); + o:= TFslTestObjectList.create; + list.Add(o); end; procedure TFslCollectionsTests.testAddFail; diff --git a/library/version.inc b/library/version.inc index d047c9079..0c319d5f9 100644 --- a/library/version.inc +++ b/library/version.inc @@ -1,3 +1,3 @@ - FHIR_CODE_FULL_VERSION = '3.1.11'; + FHIR_CODE_FULL_VERSION = '3.1.12'; FHIR_CODE_RELEASE_DATE = '2024-03-09'; - FHIR_CODE_RELEASE_DATETIME = '20240309051040.707Z'; + FHIR_CODE_RELEASE_DATETIME = '20240309120644.755Z'; diff --git a/packages/fhir_fsl.lpk b/packages/fhir_fsl.lpk index c13416328..68caf151e 100644 --- a/packages/fhir_fsl.lpk +++ b/packages/fhir_fsl.lpk @@ -1,178 +1,178 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/server/fhirconsole.lpi b/server/fhirconsole.lpi index 8d6953449..5a32e1fb2 100644 --- a/server/fhirconsole.lpi +++ b/server/fhirconsole.lpi @@ -17,7 +17,7 @@ - + diff --git a/server/fhirserver.dproj b/server/fhirserver.dproj index 54d9ce5dc..24a16005b 100644 --- a/server/fhirserver.dproj +++ b/server/fhirserver.dproj @@ -92,7 +92,7 @@ true 3 1 - 11 + 12 false @@ -167,7 +167,7 @@ true false 3 - 11 + 12 none 1 false diff --git a/server/fhirserver.lpi b/server/fhirserver.lpi index e09cb8ab0..da8dd538f 100644 --- a/server/fhirserver.lpi +++ b/server/fhirserver.lpi @@ -19,7 +19,7 @@ - + @@ -815,7 +815,7 @@ - + @@ -870,7 +870,6 @@ - @@ -938,7 +937,6 @@ - @@ -997,6 +995,15 @@ + + + + + + + + + diff --git a/server/server_testing.pas b/server/server_testing.pas index c74eae8fd..6d9563e72 100644 --- a/server/server_testing.pas +++ b/server/server_testing.pas @@ -94,13 +94,23 @@ procedure RunTestConsole(ini : TFHIRServerConfigFile; params : TCommandLineParam {$IFDEF FPC} var app : TIdeTesterConsoleRunner; + mode : String; begin Logging.Log('Run Tests (Console)'); ShowObjectLeaks := hasCommandLineParam('leak-report'); app := TIdeTesterConsoleRunner.Create(nil); app.Initialize; - app.Title := 'FPCUnit Console test runner'; + app.Title := 'FPCUnit Console test runner'; app.Mode := cpmVerbose; + if (params.get('mode', mode)) then + begin + if (mode = 'verbose') then + app.Mode := cpmVerbose + else if (mode = 'brief') then + app.Mode := cpmBrief + else if (mode = 'none') then + app.Mode := cpmNone + end; app.sparse := true; app.Run; app.free; diff --git a/server/test_registry.pas b/server/test_registry.pas index e07c7e108..ccfdbb72d 100644 --- a/server/test_registry.pas +++ b/server/test_registry.pas @@ -156,8 +156,8 @@ procedure registerTests(params : TCommandLineParameters); fhir4_tests_graphql.registerTests; fhir4_tests_diff.registerTests; - fhir4b_tests_Parser.registerTests; - fhir5_tests_Parser.registerTests; +// fhir4b_tests_Parser.registerTests; +// fhir5_tests_Parser.registerTests; tests_cpt.registerTests; fxver_tests.registerTests; diff --git a/toolkit2/fhirtoolkit.lpi b/toolkit2/fhirtoolkit.lpi index 338fba880..b42e6e912 100644 --- a/toolkit2/fhirtoolkit.lpi +++ b/toolkit2/fhirtoolkit.lpi @@ -17,7 +17,7 @@ - +