From 3c7947326da3e152aea0f7b64f5f7a44530737c1 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Tue, 2 Jan 2024 16:04:37 +1100 Subject: [PATCH 01/13] fix unicode and fhirpath tests --- library/fhir4/fhir4_pathengine.pas | 106 ++- library/fhir4/fhir4_pathnode.pas | 4 +- library/fhir4b/fhir4b_pathengine.pas | 122 +++- library/fhir4b/fhir4b_pathnode.pas | 4 +- library/fhir5/fhir5_pathengine.pas | 942 +++++++++++++++------------ library/fhir5/fhir5_pathnode.pas | 4 +- library/fsl/fsl_fpc.pas | 9 +- library/fsl/fsl_ucum.pas | 2 + library/fsl/fsl_utilities.pas | 15 +- library/fsl/tests/fsl_testing.pas | 32 + library/fsl/tests/fsl_tests.pas | 9 +- library/fsl/tests/fsl_tests_npm.pas | 1 + library/ftx/ftx_ucum_services.pas | 35 + library/web/fsl_crypto.pas | 10 +- 14 files changed, 805 insertions(+), 490 deletions(-) diff --git a/library/fhir4/fhir4_pathengine.pas b/library/fhir4/fhir4_pathengine.pas index 1569f4c3e..1df622154 100644 --- a/library/fhir4/fhir4_pathengine.pas +++ b/library/fhir4/fhir4_pathengine.pas @@ -282,6 +282,7 @@ TFHIRPathEngine = class (TFHIRPathEngineV) function funcLowBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcHighBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; + function funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function qtyToCanonical(q : TFHIRQuantity) : TUcumPair; function pairToQty(p: TUcumPair): TFHIRQuantity; @@ -696,6 +697,7 @@ procedure TFHIRPathParser.checkParameters(lexer: TFHIRPathLexer; location : TSou pfLowBoundary: checkParamCount(lexer, location, exp, 0, 1); pfHighBoundary: checkParamCount(lexer, location, exp, 0, 1); pfPrecision: checkParamCount(lexer, location, exp, 0); + pfComparable : checkParamCount(lexer, location, exp, 1); pfEncode, pfDecode, pfEscape, pfUnescape : checkParamCount(lexer, location, exp, 1); pfCustom: ; // nothing end; @@ -2183,19 +2185,28 @@ function TFHIRPathEngine.funcIif(context: TFHIRPathExecutionContext; focus: TFHI var n1 : TFHIRSelectionList; v : TEqualityTriState; + cn : TFHIRPathExecutionContext; begin - n1 := execute(context, focus, exp.Parameters[0], true); + if (focus.Empty) then + cn := context.Link + else + cn := context.changeThis(focus[0].value, 0); try - v := asBool(n1); + n1 := execute(cn, focus, exp.Parameters[0], true); + try + v := asBool(n1); - if (v = equalTrue) then - result := execute(context, focus, exp.parameters[1], true) - else if (exp.parameters.count < 3) then - result := TFHIRSelectionList.Create - else - result := execute(context, focus, exp.parameters[2], true); + if (v = equalTrue) then + result := execute(context, focus, exp.parameters[1], true) + else if (exp.parameters.count < 3) then + result := TFHIRSelectionList.Create + else + result := execute(context, focus, exp.parameters[2], true); + finally + n1.free; + end; finally - n1.free; + cn.free; end; end; @@ -2342,15 +2353,17 @@ function TFHIRPathEngine.funcJoin(context: TFHIRPathExecutionContext; focus: TFH param : String; b : TFslStringBuilder; o : TFHIRSelection; + first : boolean; begin nl := execute(context, focus, exp.Parameters[0], true); try b := TFslStringBuilder.Create; try param := nl[0].value.primitiveValue; + first := true; for o in focus do begin - b.seperator(param); + if (first) then first := false else b.Append(param); b.append(o.value.primitiveValue); end; result := TFHIRSelectionList.Create(TFhirString.Create(b.ToString)); @@ -3535,17 +3548,24 @@ function TFHIRPathEngine.funcCombine(context : TFHIRPathExecutionContext; focus: var item : TFHIRSelection; res : TFHIRSelectionList; + fl : TFHIRSelectionList; begin result := TFHIRSelectionList.Create; try for item in focus do result.add(item.link); - res := execute(context, focus, exp.Parameters[0], true); + fl := TFHIRSelectionList.create; try - for item in res do - result.add(item.link); + fl.add(context.this.link); + res := execute(context, fl, exp.Parameters[0], true); + try + for item in res do + result.add(item.link); + finally + res.free; + end; finally - res.free; + fl.free; end; result.Link; finally @@ -3629,6 +3649,7 @@ function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TF var nl : TFHIRSelectionList; param, s : String; + p : TStringArray; begin nl := execute(context, focus, exp.Parameters[0], true); try @@ -3636,8 +3657,11 @@ function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TF result := TFHIRSelectionList.Create(); try if focus.Count = 1 then - for s in focus[0].value.primitiveValue.Split([param]) do + begin + p := focus[0].value.primitiveValue.Split([param]); + for s in p do result.add(TFhirString.Create(s)); + end; result.Link; finally result.free; @@ -3802,6 +3826,55 @@ function TFHIRPathEngine.funcHighBoundary(context : TFHIRPathExecutionContext; f end; end; +function TFHIRPathEngine.funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; +var + n1 : TFHIRSelectionList; + s1, u1, s2, u2 : String; +begin + result := TFHIRSelectionList.Create; + try + if (focus.Count <> 1) or (focus[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + n1 := execute(context, focus, exp.Parameters[0], true); + try + if (n1.Count <> 1) or (n1[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + s1 := focus[0].value.getPrimitiveValue('system'); + u1 := focus[0].value.getPrimitiveValue('code'); + s2 := n1[0].value.getPrimitiveValue('system'); + u2 := n1[0].value.getPrimitiveValue('code'); + + if (s1 = '') or (s2 = '') or (s1 <> s2) then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = '') or (u2 = '') then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = u2) then + result.add(TFHIRBoolean.Create(true)) + else if (s1 = 'http://unitsofmeasure.org') and (FUcum <> nil) then + begin + try + result.add(TFHIRBoolean.Create(FUcum.isComparable(u1, u2))); + except + result.add(TFHIRBoolean.Create(false)); + end; + end + else + result.add(TFHIRBoolean.Create(false)) + end; + finally + n1.free; + end; + end; + result.Link; + finally + result.free; + end; +end; + function TFHIRPathEngine.funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; var base : TFhirObject; @@ -6091,6 +6164,7 @@ function TFHIRPathEngine.evaluateFunction(context : TFHIRPathExecutionContext; f pfLowBoundary : result := funcLowBoundary(context, focus, exp); pfHighBoundary : result := funcHighBoundary(context, focus, exp); pfPrecision : result := funcPrecision(context, focus, exp); + pfComparable : result := funcComparable(context, focus, exp); pfCustom : result := funcCustom(context, focus, exp); else raise EFHIRPath.Create('Unknown Function '+exp.name); @@ -6745,6 +6819,8 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decima;, date, datetime, instant, time and Quantity, not '+focus.describe); result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]); end; + pfComparable : + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); pfCustom : result := evaluateCustomFunctionType(context, focus, exp); else diff --git a/library/fhir4/fhir4_pathnode.pas b/library/fhir4/fhir4_pathnode.pas index 8613c3c52..ffb83aa88 100644 --- a/library/fhir4/fhir4_pathnode.pas +++ b/library/fhir4/fhir4_pathnode.pas @@ -56,7 +56,7 @@ interface pfToBoolean, pfToInteger, pfToString, pfToDecimal, pfToQuantity, pfToDateTime, pfToTime, pfAbs, pfCeiling, pfExp, pfFloor, pfLn, pfLog, pfPower, pfTruncate, pfRound, pfSqrt, pfForHtml, pfEncode, pfDecode, pfEscape, pfUnescape, pfTrim, pfSplit, pfJoin, pfIndexOf, - pfLowBoundary, pfHighBoundary, pfPrecision, + pfLowBoundary, pfHighBoundary, pfPrecision, pfComparable, pfCustom); TFHIRPathExpressionNodeKind = (enkName, enkFunction, enkConstant, enkGroup, enkStructure, enkUnary); // structure is not used in fhir4_pathengine, but is in CQL @@ -78,7 +78,7 @@ interface 'toBoolean', 'toInteger', 'toString', 'toDecimal', 'toQuantity', 'toDateTime', 'toTime', 'abs', 'ceiling', 'exp', 'floor', 'ln', 'log', 'power', 'truncate', 'round', 'sqrt', 'forHtml', 'encode', 'decode', 'escape', 'unescape', 'trim', 'split', 'join', 'indexOf', - 'lowBoundary', 'highBoundary', 'precision', + 'lowBoundary', 'highBoundary', 'precision', 'comparable', 'xx-custom-xx'); FHIR_SD_NS = 'http://hl7.org/fhir/StructureDefinition/'; diff --git a/library/fhir4b/fhir4b_pathengine.pas b/library/fhir4b/fhir4b_pathengine.pas index f54921e1b..405ceffa3 100644 --- a/library/fhir4b/fhir4b_pathengine.pas +++ b/library/fhir4b/fhir4b_pathengine.pas @@ -280,6 +280,7 @@ TFHIRPathEngine = class (TFHIRPathEngineV) function funcLowBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcHighBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; + function funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function qtyToCanonical(q : TFHIRQuantity) : TUcumPair; function pairToQty(p: TUcumPair): TFHIRQuantity; @@ -604,7 +605,7 @@ procedure TFHIRPathParser.checkParameters(lexer: TFHIRPathLexer; location : TSou case exp.FunctionId of pfEmpty: checkParamCount(lexer, location, exp, 0); pfNot: checkParamCount(lexer, location, exp, 0); - pfExists: checkParamCount(lexer, location, exp, 0, 1); // 1 is allowed in cql, and should be allowed in fhir4b_pathengine as well + pfExists: checkParamCount(lexer, location, exp, 0, 1); // 1 is allowed in cql, and should be allowed in fhir4_pathengine as well pfSubsetOf: checkParamCount(lexer, location, exp, 1); pfSupersetOf: checkParamCount(lexer, location, exp, 1); pfIsDistinct: checkParamCount(lexer, location, exp, 0); @@ -694,6 +695,7 @@ procedure TFHIRPathParser.checkParameters(lexer: TFHIRPathLexer; location : TSou pfLowBoundary: checkParamCount(lexer, location, exp, 0, 1); pfHighBoundary: checkParamCount(lexer, location, exp, 0, 1); pfPrecision: checkParamCount(lexer, location, exp, 0); + pfComparable : checkParamCount(lexer, location, exp, 1); pfEncode, pfDecode, pfEscape, pfUnescape : checkParamCount(lexer, location, exp, 1); pfCustom: ; // nothing end; @@ -2181,19 +2183,28 @@ function TFHIRPathEngine.funcIif(context: TFHIRPathExecutionContext; focus: TFHI var n1 : TFHIRSelectionList; v : TEqualityTriState; + cn : TFHIRPathExecutionContext; begin - n1 := execute(context, focus, exp.Parameters[0], true); + if (focus.Empty) then + cn := context.Link + else + cn := context.changeThis(focus[0].value, 0); try - v := asBool(n1); + n1 := execute(cn, focus, exp.Parameters[0], true); + try + v := asBool(n1); - if (v = equalTrue) then - result := execute(context, focus, exp.parameters[1], true) - else if (exp.parameters.count < 3) then - result := TFHIRSelectionList.Create - else - result := execute(context, focus, exp.parameters[2], true); + if (v = equalTrue) then + result := execute(context, focus, exp.parameters[1], true) + else if (exp.parameters.count < 3) then + result := TFHIRSelectionList.Create + else + result := execute(context, focus, exp.parameters[2], true); + finally + n1.free; + end; finally - n1.free; + cn.free; end; end; @@ -2340,15 +2351,17 @@ function TFHIRPathEngine.funcJoin(context: TFHIRPathExecutionContext; focus: TFH param : String; b : TFslStringBuilder; o : TFHIRSelection; + first : boolean; begin nl := execute(context, focus, exp.Parameters[0], true); try b := TFslStringBuilder.Create; try param := nl[0].value.primitiveValue; + first := true; for o in focus do begin - b.seperator(param); + if (first) then first := false else b.Append(param); b.append(o.value.primitiveValue); end; result := TFHIRSelectionList.Create(TFhirString.Create(b.ToString)); @@ -2559,7 +2572,7 @@ function TFHIRPathEngine.funcMatchesFull(context : TFHIRPathExecutionContext; fo var res : TFHIRSelectionList; s, p : String; - reg : TRegularExpression; + reg : TREgularExpression; begin result := TFHIRSelectionList.Create; try @@ -2574,7 +2587,7 @@ function TFHIRPathEngine.funcMatchesFull(context : TFHIRPathExecutionContext; fo result.add(TFHIRBoolean.Create(false)) else begin - reg := TRegularExpression.Create('(?s)' + p, [roCompiled]); + reg := TREgularExpression.Create('(?s)' + p, [roCompiled]); try s := convertToString(focus[0].value); result.add(TFHIRBoolean.Create(reg.isFullMatch(s))); @@ -3533,17 +3546,24 @@ function TFHIRPathEngine.funcCombine(context : TFHIRPathExecutionContext; focus: var item : TFHIRSelection; res : TFHIRSelectionList; + fl : TFHIRSelectionList; begin result := TFHIRSelectionList.Create; try for item in focus do result.add(item.link); - res := execute(context, focus, exp.Parameters[0], true); + fl := TFHIRSelectionList.create; try - for item in res do - result.add(item.link); + fl.add(context.this.link); + res := execute(context, fl, exp.Parameters[0], true); + try + for item in res do + result.add(item.link); + finally + res.free; + end; finally - res.free; + fl.free; end; result.Link; finally @@ -3627,6 +3647,7 @@ function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TF var nl : TFHIRSelectionList; param, s : String; + p : TStringArray; begin nl := execute(context, focus, exp.Parameters[0], true); try @@ -3634,8 +3655,11 @@ function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TF result := TFHIRSelectionList.Create(); try if focus.Count = 1 then - for s in focus[0].value.primitiveValue.Split([param]) do + begin + p := focus[0].value.primitiveValue.Split([param]); + for s in p do result.add(TFhirString.Create(s)); + end; result.Link; finally result.free; @@ -3800,6 +3824,55 @@ function TFHIRPathEngine.funcHighBoundary(context : TFHIRPathExecutionContext; f end; end; +function TFHIRPathEngine.funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; +var + n1 : TFHIRSelectionList; + s1, u1, s2, u2 : String; +begin + result := TFHIRSelectionList.Create; + try + if (focus.Count <> 1) or (focus[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + n1 := execute(context, focus, exp.Parameters[0], true); + try + if (n1.Count <> 1) or (n1[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + s1 := focus[0].value.getPrimitiveValue('system'); + u1 := focus[0].value.getPrimitiveValue('code'); + s2 := n1[0].value.getPrimitiveValue('system'); + u2 := n1[0].value.getPrimitiveValue('code'); + + if (s1 = '') or (s2 = '') or (s1 <> s2) then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = '') or (u2 = '') then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = u2) then + result.add(TFHIRBoolean.Create(true)) + else if (s1 = 'http://unitsofmeasure.org') and (FUcum <> nil) then + begin + try + result.add(TFHIRBoolean.Create(FUcum.isComparable(u1, u2))); + except + result.add(TFHIRBoolean.Create(false)); + end; + end + else + result.add(TFHIRBoolean.Create(false)) + end; + finally + n1.free; + end; + end; + result.Link; + finally + result.free; + end; +end; + function TFHIRPathEngine.funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; var base : TFhirObject; @@ -3831,7 +3904,7 @@ function TFHIRPathEngine.funcCeiling(context: TFHIRPathExecutionContext; focus: var base : TFHIRObject; qty : TFHIRQuantity; - d : TFslDecimal; + v : TFslDecimal; begin if (focus.count <> 1) then raise EFHIRPath.Create('Error evaluating FHIRPath expression: focus for floor has more than one value'); @@ -3845,10 +3918,10 @@ function TFHIRPathEngine.funcCeiling(context: TFHIRPathExecutionContext; focus: begin qty := (base as TFhirQuantity).Clone; try - d := TFslDecimal.Create(qty.value); - d := d.Trunc; - d := d.AddInt(1); - qty.value := d.AsString; + v := TFslDecimal.Create(qty.value); + v := v.trunc; + v := v.addInt(1); + qty.value := v.AsString; result.add(qty.Link); finally qty.free; @@ -6089,6 +6162,7 @@ function TFHIRPathEngine.evaluateFunction(context : TFHIRPathExecutionContext; f pfLowBoundary : result := funcLowBoundary(context, focus, exp); pfHighBoundary : result := funcHighBoundary(context, focus, exp); pfPrecision : result := funcPrecision(context, focus, exp); + pfComparable : result := funcComparable(context, focus, exp); pfCustom : result := funcCustom(context, focus, exp); else raise EFHIRPath.Create('Unknown Function '+exp.name); @@ -6743,6 +6817,8 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decima;, date, datetime, instant, time and Quantity, not '+focus.describe); result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]); end; + pfComparable : + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); pfCustom : result := evaluateCustomFunctionType(context, focus, exp); else diff --git a/library/fhir4b/fhir4b_pathnode.pas b/library/fhir4b/fhir4b_pathnode.pas index 75f34c8f1..868d9a6fb 100644 --- a/library/fhir4b/fhir4b_pathnode.pas +++ b/library/fhir4b/fhir4b_pathnode.pas @@ -56,7 +56,7 @@ interface pfToBoolean, pfToInteger, pfToString, pfToDecimal, pfToQuantity, pfToDateTime, pfToTime, pfAbs, pfCeiling, pfExp, pfFloor, pfLn, pfLog, pfPower, pfTruncate, pfRound, pfSqrt, pfForHtml, pfEncode, pfDecode, pfEscape, pfUnescape, pfTrim, pfSplit, pfJoin, pfIndexOf, - pfLowBoundary, pfHighBoundary, pfPrecision, + pfLowBoundary, pfHighBoundary, pfPrecision, pfComparable, pfCustom); TFHIRPathExpressionNodeKind = (enkName, enkFunction, enkConstant, enkGroup, enkStructure, enkUnary); // structure is not used in fhir4b_pathengine, but is in CQL @@ -78,7 +78,7 @@ interface 'toBoolean', 'toInteger', 'toString', 'toDecimal', 'toQuantity', 'toDateTime', 'toTime', 'abs', 'ceiling', 'exp', 'floor', 'ln', 'log', 'power', 'truncate', 'round', 'sqrt', 'forHtml', 'encode', 'decode', 'escape', 'unescape', 'trim', 'split', 'join', 'indexOf', - 'lowBoundary', 'highBoundary', 'precision', + 'lowBoundary', 'highBoundary', 'precision', 'comparable', 'xx-custom-xx'); FHIR_SD_NS = 'http://hl7.org/fhir/StructureDefinition/'; diff --git a/library/fhir5/fhir5_pathengine.pas b/library/fhir5/fhir5_pathengine.pas index fa5198d7f..8c31cbc4d 100644 --- a/library/fhir5/fhir5_pathengine.pas +++ b/library/fhir5/fhir5_pathengine.pas @@ -34,8 +34,8 @@ interface uses - SysUtils, Classes, Math, Generics.Collections, Character, - fsl_base, fsl_utilities, fsl_stream, fsl_fpc, fsl_json, fsl_xml, fsl_regex, + SysUtils, Classes, Math, Generics.Collections, Character, + fsl_base, fsl_utilities, fsl_stream, fsl_fpc, fsl_xml, fsl_json, fsl_regex, fsl_ucum, fhir_objects, fhir_factory, fhir_pathengine, fhir_uris, fhir5_pathnode, fhir5_enums, fhir5_types, fhir5_resources, fhir5_utilities, fhir5_context, fhir5_constants; @@ -280,6 +280,7 @@ TFHIRPathEngine = class (TFHIRPathEngineV) function funcLowBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcHighBoundary(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; + function funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; function qtyToCanonical(q : TFHIRQuantity) : TUcumPair; function pairToQty(p: TUcumPair): TFHIRQuantity; @@ -382,7 +383,7 @@ implementation { TFHIRConstant } -constructor TFHIRConstant.create(value: String); +constructor TFHIRConstant.Create(value: String); begin inherited Create; FValue := value; @@ -390,7 +391,7 @@ constructor TFHIRConstant.create(value: String); function TFHIRConstant.createPropertyValue(propName: string): TFHIRObject; begin - raise EFHIRTodo.create('TFHIRConstant.createPropertyValue'); + raise EFHIRTodo.Create('TFHIRConstant.createPropertyValue'); end; function TFHIRConstant.fhirType: string; @@ -400,12 +401,12 @@ function TFHIRConstant.fhirType: string; function TFHIRConstant.getId: String; begin - raise EFHIRTodo.create('TFHIRConstant.getId:'); + raise EFHIRTodo.Create('TFHIRConstant.getId:'); end; function TFHIRConstant.getTypesForProperty(propName : string): String; begin - raise EFHIRTodo.create('TFHIRConstant.getTypesForProperty'); + raise EFHIRTodo.Create('TFHIRConstant.getTypesForProperty'); end; function TFHIRConstant.hasExtensions: boolean; @@ -430,12 +431,12 @@ function TFHIRConstant.makeStringValue(v: String): TFHIRObject; procedure TFHIRConstant.setIdValue(id: String); begin - raise EFHIRTodo.create('TFHIRConstant.setIdValue'); + raise EFHIRTodo.Create('TFHIRConstant.setIdValue'); end; function TFHIRConstant.setProperty(propName: string; propValue: TFHIRObject) : TFHIRObject; begin - raise EFHIRTodo.create('TFHIRConstant.setProperty'); + raise EFHIRTodo.Create('TFHIRConstant.setProperty'); end; function TFHIRConstant.sizeInBytesV(magic : integer) : cardinal; @@ -446,7 +447,7 @@ function TFHIRConstant.sizeInBytesV(magic : integer) : cardinal; { TFHIRClassTypeInfo } -constructor TFHIRClassTypeInfo.create(instance: TFHIRObject); +constructor TFHIRClassTypeInfo.Create(instance: TFHIRObject); begin inherited Create; FInstance := instance; @@ -454,7 +455,7 @@ constructor TFHIRClassTypeInfo.create(instance: TFHIRObject); function TFHIRClassTypeInfo.createPropertyValue(propName: string): TFHIRObject; begin - raise EFHIRTodo.create('TFHIRClassTypeInfo.createPropertyValue'); + raise EFHIRTodo.Create('TFHIRClassTypeInfo.createPropertyValue'); end; destructor TFHIRClassTypeInfo.Destroy; @@ -471,9 +472,9 @@ function TFHIRClassTypeInfo.fhirType: string; procedure TFHIRClassTypeInfo.GetChildrenByName(name: string; list: TFHIRSelectionList); begin if (name = 'name') then - list.add(TFHIRString.create(getName).noExtensions) + list.add(TFHIRString.Create(getName).noExtensions) else if (name = 'namespace') then - list.add(TFHIRString.create(getNamespace).noExtensions) + list.add(TFHIRString.Create(getNamespace).noExtensions) else inherited GetChildrenByName(name, list); end; @@ -490,7 +491,7 @@ function TFHIRClassTypeInfo.getNamespace: String; function TFHIRClassTypeInfo.getTypesForProperty(propName : string): String; begin - raise EFHIRTodo.create('TFHIRClassTypeInfo.getTypesForProperty'); + raise EFHIRTodo.Create('TFHIRClassTypeInfo.getTypesForProperty'); end; function TFHIRClassTypeInfo.hasExtensions: boolean; @@ -500,7 +501,7 @@ function TFHIRClassTypeInfo.hasExtensions: boolean; function TFHIRClassTypeInfo.getId: String; begin - raise EFHIRTodo.create('TFHIRClassTypeInfo.getId:'); + raise EFHIRTodo.Create('TFHIRClassTypeInfo.getId:'); end; function TFHIRClassTypeInfo.makeCodeValue(v: String): TFHIRObject; @@ -520,12 +521,12 @@ function TFHIRClassTypeInfo.makeStringValue(v: String): TFHIRObject; procedure TFHIRClassTypeInfo.setIdValue(id: String); begin - raise EFHIRTodo.create('TFHIRClassTypeInfo.setIdValue'); + raise EFHIRTodo.Create('TFHIRClassTypeInfo.setIdValue'); end; function TFHIRClassTypeInfo.setProperty(propName: string; propValue: TFHIRObject) : TFHIRObject; begin - raise EFHIRTodo.create('TFHIRClassTypeInfo.setProperty'); + raise EFHIRTodo.Create('TFHIRClassTypeInfo.setProperty'); end; function TFHIRClassTypeInfo.getName: String; @@ -555,7 +556,7 @@ function TFHIRPathParser.parse(lexer: TFHIRPathLexer): TFHIRPathExpressionNode; result := parseExpression(lexer, true); try if not result.check(msg, 0) then - raise EFHIRPath.create('Error "'+msg+'" parsing "'+lexer.Path); + raise EFHIRPath.Create('Error "'+msg+'" parsing "'+lexer.Path); result.Link; finally result.free; @@ -576,7 +577,7 @@ function TFHIRPathParser.parse(path: String): TFHIRPathExpressionNode; if not lexer.done then raise lexer.error('Premature expression termination at unexpected token "'+lexer.current+'"'); if not result.check(msg, 0) then - raise EFHIRPath.create('Error parsing "'+path+'": '+msg); + raise EFHIRPath.Create('Error parsing "'+path+'": '+msg); result.Link; finally @@ -604,7 +605,7 @@ procedure TFHIRPathParser.checkParameters(lexer: TFHIRPathLexer; location : TSou case exp.FunctionId of pfEmpty: checkParamCount(lexer, location, exp, 0); pfNot: checkParamCount(lexer, location, exp, 0); - pfExists: checkParamCount(lexer, location, exp, 0, 1); // 1 is allowed in cql, and should be allowed in fhir5_pathengine as well + pfExists: checkParamCount(lexer, location, exp, 0, 1); // 1 is allowed in cql, and should be allowed in fhir4_pathengine as well pfSubsetOf: checkParamCount(lexer, location, exp, 1); pfSupersetOf: checkParamCount(lexer, location, exp, 1); pfIsDistinct: checkParamCount(lexer, location, exp, 0); @@ -694,6 +695,7 @@ procedure TFHIRPathParser.checkParameters(lexer: TFHIRPathLexer; location : TSou pfLowBoundary: checkParamCount(lexer, location, exp, 0, 1); pfHighBoundary: checkParamCount(lexer, location, exp, 0, 1); pfPrecision: checkParamCount(lexer, location, exp, 0); + pfComparable : checkParamCount(lexer, location, exp, 1); pfEncode, pfDecode, pfEscape, pfUnescape : checkParamCount(lexer, location, exp, 1); pfCustom: ; // nothing end; @@ -718,7 +720,7 @@ function TFHIRPathParser.parse(path: String; var i: integer): TFHIRPathExpressio result := parseExpression(lexer, true); try if not result.check(msg, 0) then - raise EFHIRPath.create('Error parsing "'+path+'": '+msg); + raise EFHIRPath.Create('Error parsing "'+path+'": '+msg); result.Link; finally result.free; @@ -1065,7 +1067,7 @@ function TFHIRPathEngine.check(appInfo : TFslObject; resourceType, context, path end; try - ctxt := TFHIRPathExecutionTypeContext.create(appInfo, resourceType, types.Link, types.Link); + ctxt := TFHIRPathExecutionTypeContext.Create(appInfo, resourceType, types.Link, types.Link); try result := executeType(ctxt, types, expr, true); finally @@ -1114,7 +1116,7 @@ function TFHIRPathEngine.convertToString(item: TFHIRObject): String; end; -constructor TFHIRPathEngine.create(context: TFHIRWorkerContext; ucum : TUcumServiceInterface); +constructor TFHIRPathEngine.Create(context: TFHIRWorkerContext; ucum : TUcumServiceInterface); var sd : TFhirStructureDefinition; list : TFslList; @@ -1140,7 +1142,7 @@ constructor TFHIRPathEngine.create(context: TFHIRWorkerContext; ucum : TUcumServ if (sd.derivation = TypeDerivationRuleSPECIALIZATION) and (sd.kind = StructureDefinitionKindPrimitiveType) then primitiveTypes.add(sd.id); {$ELSE} - raise EFHIRException.create('Debug this'); + raise EFHIRException.Create('Debug this'); if (sd.constrainedType = DefinedTypesNull) then allTypes.add(sd.id); if (sd.constrainedType = DefinedTypesNull) and isPrimitive(sd) then @@ -1170,11 +1172,11 @@ function TFHIRPathEngine.dateAdd(d: TFhirObject; qty: TFhirQuantity; negate: boo if (c = 'years') or (c = 'year') then result.dateValue := d.dateValue.add(v, dtuYear) else if (c = 'a') then - raise EFHIRPath.create(format('Error in date arithmetic: attempt to add a definite quantity duration time unit %s', [c])) + raise EFHIRPath.Create(format('Error in date arithmetic: attempt to add a definite quantity duration time unit %s', [c])) else if (c = 'months') or (c = 'month') then result.dateValue := d.dateValue.add(v, dtuMonth) else if (c = 'mo') then - raise EFHIRPath.create(format('Error in date arithmetic: attempt to add a definite quantity duration time unit %s', [c])) + raise EFHIRPath.Create(format('Error in date arithmetic: attempt to add a definite quantity duration time unit %s', [c])) else if (c = 'weeks') or (c = 'week') or (c = 'wk') then result.dateValue := d.dateValue.add(v * 7, dtuDay) else if (c = 'days') or (c = 'day') or (c = 'd') then @@ -1188,7 +1190,7 @@ function TFHIRPathEngine.dateAdd(d: TFhirObject; qty: TFhirQuantity; negate: boo else if (c = 'millisecond') or (c = 'millisecond') or (c = 'ms') then result.dateValue := d.dateValue.add(v, dtuMillisecond) else - raise EFHIRPath.create(format('Error in date arithmetic: unrecognized time unit %s', [c])); + raise EFHIRPath.Create(format('Error in date arithmetic: unrecognized time unit %s', [c])); result.Link; finally result.free; @@ -1470,7 +1472,7 @@ function TFHIRPathEngine.evaluate(appInfo : TFslObject; resource : TFHIRObject; function TFHIRPathEngine.evaluateCustomFunctionType(context: TFHIRPathExecutionTypeContext; focus: TFHIRTypeDetails; exp: TFHIRPathExpressionNode): TFHIRTypeDetails; begin - raise EFHIRPath.create('Unknown Function '+exp.name); + raise EFHIRPath.Create('Unknown Function '+exp.name); end; function TFHIRPathEngine.executeV(context: TFHIRPathExecutionContext; item: TFHIRObject; exp: TFHIRPathExpressionNodeV; atEntry: boolean): TFHIRSelectionList; @@ -1603,51 +1605,51 @@ procedure TFHIRPathEngine.ListAllChildren(item : TFHIRObject; results : TFHIRSel function TFHIRPathEngine.resolveConstantType(ctxt: TFHIRPathExecutionTypeContext; constant : TFHIRObject) : TFHIRTypeDetails; begin if (constant is TFHIRBoolean) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Boolean]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]) else if (constant is TFHIRInteger) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Integer]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]) else if (constant is TFHIRDecimal) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Decimal]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Decimal]) else if (constant is TFHIRQuantity) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Quantity]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Quantity]) else if (constant is TFHIRConstant) then result := resolveConstantType(ctxt, (constant as TFHIRConstant).FValue) else - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]); end; function TFHIRPathEngine.resolveConstantType(ctxt: TFHIRPathExecutionTypeContext; s : String) : TFHIRTypeDetails; begin if (s.startsWith('@')) then if (s.startsWith('@T')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Time]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Time]) else - result := TFHIRTypeDetails.create(csSINGLETON, [FP_DateTime]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_DateTime]) else if (s.equals('%sct')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.equals('%loinc')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.equals('%ucum')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.equals('%resource')) then begin if (ctxt.resourceType = '') then - raise EFHIRPath.create('%resource cannot be used in this context'); - result := TFHIRTypeDetails.create(csSINGLETON, [ctxt.resourceType]); + raise EFHIRPath.Create('%resource cannot be used in this context'); + result := TFHIRTypeDetails.Create(csSINGLETON, [ctxt.resourceType]); end else if (s.equals('%context')) then result := ctxt.context.link else if (s.equals('%map-codes')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.equals('%us-zip')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.startsWith('%`vs-')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.startsWith('%`cs-')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else if (s.startsWith('%`ext-')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]) else - raise EFHIRPath.create('Unknown fixed constant type for "'+s+'"'); + raise EFHIRPath.Create('Unknown fixed constant type for "'+s+'"'); end; function TFHIRPathEngine.executeType(ctxt: TFHIRPathExecutionTypeContext; focus: TFHIRTypeDetails; exp: TFHIRPathExpressionNode; atEntry : boolean): TFHIRTypeDetails; @@ -1678,7 +1680,7 @@ function TFHIRPathEngine.executeType(ctxt: TFHIRPathExecutionTypeContext; focus: end; end; if (result.hasNoTypes) then - raise EFHIRPath.create('The name '+exp.Name+' was not valid for any of the possible types: '+focus.describe()); + raise EFHIRPath.Create('The name '+exp.Name+' was not valid for any of the possible types: '+focus.describe()); end; enkUnary : begin @@ -1731,7 +1733,7 @@ function TFHIRPathEngine.executeType(ctxt: TFHIRPathExecutionTypeContext; focus: while (next <> nil) do begin if (last.Operation in [popIs, popAs]) then - work := TFHIRTypeDetails.create(csSINGLETON, next.name) + work := TFHIRTypeDetails.Create(csSINGLETON, next.name) else work := executeType(ctxt, focus, next, atEntry); try @@ -1863,11 +1865,11 @@ function TFHIRPathEngine.funcContains(context : TFHIRPathExecutionContext; focus end; if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions) + result.add(TFHIRBoolean.Create(false).noExtensions) else if sw = '' then - result.add(TFHIRBoolean.create(true).noExtensions) + result.add(TFHIRBoolean.Create(true).noExtensions) else - result.add(TFHIRBoolean.create(convertToString(focus[0].value).contains(sw)).noExtensions); + result.add(TFHIRBoolean.Create(convertToString(focus[0].value).contains(sw)).noExtensions); end; result.Link; finally @@ -2009,11 +2011,11 @@ function TFHIRPathEngine.funcEndsWith(context: TFHIRPathExecutionContext; focus: end; if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions) + result.add(TFHIRBoolean.Create(false).noExtensions) else if (sw = '') then - result.add(TFHIRBoolean.create(true).noExtensions) + result.add(TFHIRBoolean.Create(true).noExtensions) else - result.add(TFHIRBoolean.create(convertToString(focus[0].value).endsWith(sw)).noExtensions); + result.add(TFHIRBoolean.Create(convertToString(focus[0].value).endsWith(sw)).noExtensions); end; result.Link; finally @@ -2157,9 +2159,9 @@ function TFHIRPathEngine.funcHasValue(context: TFHIRPathExecutionContext; focus: result := TFHIRSelectionList.Create; try if (focus.count = 1) then - result.add(TFHIRBoolean.create(focus[0].value.hasPrimitiveValue).noExtensions) + result.add(TFHIRBoolean.Create(focus[0].value.hasPrimitiveValue).noExtensions) else - result.add(TFHIRBoolean.create(false).noExtensions); + result.add(TFHIRBoolean.Create(false).noExtensions); result.Link; finally result.free; @@ -2170,7 +2172,7 @@ function TFHIRPathEngine.funcHtmlChecks(context: TFHIRPathExecutionContext; focu begin result := TFHIRSelectionList.Create; try - result.add(TFHIRBoolean.create(true).noExtensions); + result.add(TFHIRBoolean.Create(true).noExtensions); result.Link; finally result.free; @@ -2181,19 +2183,28 @@ function TFHIRPathEngine.funcIif(context: TFHIRPathExecutionContext; focus: TFHI var n1 : TFHIRSelectionList; v : TEqualityTriState; + cn : TFHIRPathExecutionContext; begin - n1 := execute(context, focus, exp.Parameters[0], true); + if (focus.Empty) then + cn := context.Link + else + cn := context.changeThis(focus[0].value, 0); try - v := asBool(n1); + n1 := execute(cn, focus, exp.Parameters[0], true); + try + v := asBool(n1); - if (v = equalTrue) then - result := execute(context, focus, exp.parameters[1], true) - else if (exp.parameters.count < 3) then - result := TFHIRSelectionList.Create - else - result := execute(context, focus, exp.parameters[2], true); + if (v = equalTrue) then + result := execute(context, focus, exp.parameters[1], true) + else if (exp.parameters.count < 3) then + result := TFHIRSelectionList.Create + else + result := execute(context, focus, exp.parameters[2], true); + finally + n1.free; + end; finally - n1.free; + cn.free; end; end; @@ -2227,18 +2238,18 @@ function TFHIRPathEngine.funcIs(context: TFHIRPathExecutionContext; focus: TFHIR result := TFHIRSelectionList.Create; try if (focus.count = 0) or (focus.count > 1) then - result.add(TFHIRBoolean.create(false).noExtensions) + result.add(TFHIRBoolean.Create(false).noExtensions) else begin ns := ''; n := ''; texp := exp.Parameters[0]; if (texp.Kind <> enkName) then - raise EFHIRPath.create('Unsupported Expression type for Parameter on Is'); + raise EFHIRPath.Create('Unsupported Expression type for Parameter on Is'); if (texp.inner <> nil) then begin if (texp.Kind <> enkName) then - raise EFHIRPath.create('Unsupported Expression type for Parameter on Is'); + raise EFHIRPath.Create('Unsupported Expression type for Parameter on Is'); ns := texp.Name; n := texp.inner.Name; end @@ -2255,19 +2266,19 @@ function TFHIRPathEngine.funcIs(context: TFHIRPathExecutionContext; focus: TFHIR if (ns = 'System') then begin if (focus[0].value is TFHIRResource) then - result.add(TFHIRBoolean.create(false).noExtensions) + result.add(TFHIRBoolean.Create(false).noExtensions) else if (not (focus[0].value is TFHIRElement) or (focus[0].value as TFHIRElement).DisallowExtensions) then if (focus[0].value.fhirType = 'date') and (n = 'DateTime') then - result.add(TFHIRBoolean.create(true).noExtensions) + result.add(TFHIRBoolean.Create(true).noExtensions) else - result.add(TFHIRBoolean.create(n = capitalise(focus[0].value.fhirType)).noExtensions) + result.add(TFHIRBoolean.Create(n = capitalise(focus[0].value.fhirType)).noExtensions) else - result.add(TFHIRBoolean.create(false).noExtensions); + result.add(TFHIRBoolean.Create(false).noExtensions); end else if (ns = 'FHIR') then - result.add(TFHIRBoolean.create(typeMatches(n, focus[0].value.fhirType, true)).noExtensions) + result.add(TFHIRBoolean.Create(typeMatches(n, focus[0].value.fhirType, true)).noExtensions) else - result.add(TFHIRBoolean.create(false).noExtensions); + result.add(TFHIRBoolean.Create(false).noExtensions); end; result.link; finally @@ -2284,7 +2295,7 @@ function TFHIRPathEngine.funcIsDistinct( context: TFHIRPathExecutionContext; foc result := TFHIRSelectionList.Create; try if (focus.count = 1) then - result.add(TFHIRBoolean.create(true).noExtensions) + result.add(TFHIRBoolean.Create(true).noExtensions) else if (focus.count > 1) then begin distinct := true; @@ -2303,7 +2314,7 @@ function TFHIRPathEngine.funcIsDistinct( context: TFHIRPathExecutionContext; foc break; end; end; - result.add(TFHIRBoolean.create(distinct).noExtensions); + result.add(TFHIRBoolean.Create(distinct).noExtensions); end; result.link; finally @@ -2340,15 +2351,17 @@ function TFHIRPathEngine.funcJoin(context: TFHIRPathExecutionContext; focus: TFH param : String; b : TFslStringBuilder; o : TFHIRSelection; + first : boolean; begin nl := execute(context, focus, exp.Parameters[0], true); try b := TFslStringBuilder.Create; try param := nl[0].value.primitiveValue; + first := true; for o in focus do begin - b.seperator(param); + if (first) then first := false else b.Append(param); b.append(o.value.primitiveValue); end; result := TFHIRSelectionList.Create(TFhirString.Create(b.ToString)); @@ -2378,14 +2391,14 @@ function TFHIRPathEngine.funcIndexOf(context: TFHIRPathExecutionContext; focus: begin sw := convertToString(nl); if (sw = '') then - result.add(TFHIRInteger.create(0)) + result.add(TFHIRInteger.Create(0)) else // if (focus[0].hasType(FHIR_TYPES_STRING)) then begin s := convertToString(focus[0].value); if (s = '') then - result.add(TFHIRInteger.create(0)) + result.add(TFHIRInteger.Create(0)) else - result.add(TFHIRInteger.create(s.indexOf(sw))); + result.add(TFHIRInteger.Create(s.indexOf(sw))); end; end; finally @@ -2414,7 +2427,7 @@ function TFHIRPathEngine.funcLength(context : TFHIRPathExecutionContext; focus: if (focus.count = 1) then begin s := convertToString(focus[0].value); - result.add(TFHIRInteger.create(inttostr(s.length)).noExtensions); + result.add(TFHIRInteger.Create(inttostr(s.length)).noExtensions); end; result.Link; finally @@ -2533,13 +2546,13 @@ function TFHIRPathEngine.funcMatches(context : TFHIRPathExecutionContext; focus: begin p := convertToString(res); if (p = '') then - result.add(TFHIRBoolean.create(false)) + result.add(TFHIRBoolean.Create(false)) else begin reg := TRegularExpression.Create('(?s)' + p, [roCompiled]); try s := convertToString(focus[0].value); - result.add(TFHIRBoolean.create(reg.isMatch(s))); + result.add(TFHIRBoolean.Create(reg.isMatch(s))); finally reg.free; end; @@ -2559,7 +2572,7 @@ function TFHIRPathEngine.funcMatchesFull(context : TFHIRPathExecutionContext; fo var res : TFHIRSelectionList; s, p : String; - reg : TRegularExpression; + reg : TREgularExpression; begin result := TFHIRSelectionList.Create; try @@ -2571,13 +2584,13 @@ function TFHIRPathEngine.funcMatchesFull(context : TFHIRPathExecutionContext; fo begin p := convertToString(res); if (p = '') then - result.add(TFHIRBoolean.create(false)) + result.add(TFHIRBoolean.Create(false)) else begin - reg := TRegularExpression.Create('(?s)' + p, [roCompiled]); + reg := TREgularExpression.Create('(?s)' + p, [roCompiled]); try s := convertToString(focus[0].value); - result.add(TFHIRBoolean.create(reg.isFullMatch(s))); + result.add(TFHIRBoolean.Create(reg.isFullMatch(s))); finally reg.free; end; @@ -2595,7 +2608,7 @@ function TFHIRPathEngine.funcMatchesFull(context : TFHIRPathExecutionContext; fo function TFHIRPathEngine.funcMemberOf(context: TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp: TFHIRPathExpressionNode): TFHIRSelectionList; begin - raise EFHIRPathTodo.create('TFHIRPathEngine.funcMemberOf'); + raise EFHIRPathTodo.Create('TFHIRPathEngine.funcMemberOf'); end; function TFHIRPathEngine.funcNot(context : TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp: TFHIRPathExpressionNode): TFHIRSelectionList; @@ -2704,7 +2717,7 @@ function TFHIRPathEngine.funcReplace(context: TFHIRPathExecutionContext; focus: begin f := convertToString(focus[0].value); if (f = '') then - result.add(TFHIRString.create('')) + result.add(TFHIRString.Create('')) else if (t = '') then begin b := TFslStringBuilder.Create; @@ -2715,7 +2728,7 @@ function TFHIRPathEngine.funcReplace(context: TFHIRPathExecutionContext; focus: b.append(f[i]); b.append(r); end; - result.add(TFHIRString.create(b.toString)) + result.add(TFHIRString.Create(b.toString)) finally b.free; end; @@ -2723,7 +2736,7 @@ function TFHIRPathEngine.funcReplace(context: TFHIRPathExecutionContext; focus: else begin n := f.replace(t, r); - result.add(TFHIRString.create(n)); + result.add(TFHIRString.Create(n)); end end else @@ -2762,13 +2775,13 @@ function TFHIRPathEngine.funcReplaceMatches( context: TFHIRPathExecutionContext; begin f := convertToString(focus[0].value); if (f = '') then - result.add(TFHIRString.create('')) + result.add(TFHIRString.Create('')) else if (t = '') then - result.add(TFHIRString.create(f)) + result.add(TFHIRString.Create(f)) else begin n := f.replace(t, r); - result.add(TFHIRString.create(TRegularExpression.replace(n, t, r))); + result.add(TFHIRString.Create(TRegularExpression.replace(n, t, r))); end end else @@ -2833,7 +2846,7 @@ function TFHIRPathEngine.funcResolve(context : TFHIRPathExecutionContext; focus: else begin if not assigned(FOnResolveReference) then - raise EFHIRPath.create('resolve() - resolution services for '+exp.name+' not implemented yet'); + raise EFHIRPath.Create('resolve() - resolution services for '+exp.name+' not implemented yet'); res := FOnResolveReference(self, context.appInfo, s); end; if (res <> nil) then @@ -2934,7 +2947,7 @@ function TFHIRPathEngine.funcSelect(context: TFHIRPathExecutionContext; focus: T function TFHIRPathEngine.funcSingle(context: TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp: TFHIRPathExpressionNode): TFHIRSelectionList; begin if (focus.count <> 1) then - raise EFHIRPath.create(StringFormat('Single() : checking for 1 item but found %d items', [focus.count])); + raise EFHIRPath.Create(StringFormat('Single() : checking for 1 item but found %d items', [focus.count])); result := focus.link; end; @@ -2967,9 +2980,9 @@ function TFHIRPathEngine.funcStartsWith(context : TFHIRPathExecutionContext; foc begin sw := convertToString(swb); if (sw = '') then - result.add(TFHIRBoolean.create(true).noExtensions) + result.add(TFHIRBoolean.Create(true).noExtensions) else - result.add(TFHIRBoolean.create(convertToString(focus[0].value).startsWith(sw)).noExtensions); + result.add(TFHIRBoolean.Create(convertToString(focus[0].value).startsWith(sw)).noExtensions); end; finally swb.free; @@ -3010,7 +3023,7 @@ function TFHIRPathEngine.funcSubsetOf(context: TFHIRPathExecutionContext; focus: break; end; end; - result := TFHIRSelectionList.Create(TFHIRBoolean.create(valid).noExtensions); + result := TFHIRSelectionList.Create(TFHIRBoolean.Create(valid).noExtensions); finally target.free; end; @@ -3098,7 +3111,7 @@ function TFHIRPathEngine.funcExists(context: TFHIRPathExecutionContext; focus: T pc.free; end; - result.add(TFHIRBoolean.create(not empty).noExtensions); + result.add(TFHIRBoolean.Create(not empty).noExtensions); result.link; finally result.free; @@ -3168,7 +3181,7 @@ function TFHIRPathEngine.funcSupersetOf( context: TFHIRPathExecutionContext; foc break; end; end; - result := TFHIRSelectionList.Create(TFHIRBoolean.create(valid).noExtensions); + result := TFHIRSelectionList.Create(TFHIRBoolean.Create(valid).noExtensions); finally target.free; end; @@ -3533,17 +3546,24 @@ function TFHIRPathEngine.funcCombine(context : TFHIRPathExecutionContext; focus: var item : TFHIRSelection; res : TFHIRSelectionList; + fl : TFHIRSelectionList; begin result := TFHIRSelectionList.Create; try for item in focus do result.add(item.link); - res := execute(context, focus, exp.Parameters[0], true); + fl := TFHIRSelectionList.create; try - for item in res do - result.add(item.link); + fl.add(context.this.link); + res := execute(context, fl, exp.Parameters[0], true); + try + for item in res do + result.add(item.link); + finally + res.free; + end; finally - res.free; + fl.free; end; result.Link; finally @@ -3557,7 +3577,7 @@ function TFHIRPathEngine.funcType(context : TFHIRPathExecutionContext; focus: TF begin result := TFHIRSelectionList.Create; for item in focus do - result.add(TFHIRClassTypeInfo.create(item.value.Link)); + result.add(TFHIRClassTypeInfo.Create(item.value.Link)); end; function TFHIRPathEngine.funcOfType(context : TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; @@ -3615,18 +3635,19 @@ function TFHIRPathEngine.funcPower(context: TFHIRPathExecutionContext; focus: TF function TFHIRPathEngine.funcElementDefinition(context : TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; begin - raise EFHIRTodo.create('TFHIRPathEngine.funcElementDefinition'); + raise EFHIRTodo.Create('TFHIRPathEngine.funcElementDefinition'); end; function TFHIRPathEngine.funcSlice(context : TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; begin - raise EFHIRTodo.create('TFHIRPathEngine.funcSlice'); + raise EFHIRTodo.Create('TFHIRPathEngine.funcSlice'); end; function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp: TFHIRPathExpressionNode): TFHIRSelectionList; var nl : TFHIRSelectionList; param, s : String; + p : TStringArray; begin nl := execute(context, focus, exp.Parameters[0], true); try @@ -3634,8 +3655,11 @@ function TFHIRPathEngine.funcSplit(context: TFHIRPathExecutionContext; focus: TF result := TFHIRSelectionList.Create(); try if focus.Count = 1 then - for s in focus[0].value.primitiveValue.Split([param]) do + begin + p := focus[0].value.primitiveValue.Split([param]); + for s in p do result.add(TFhirString.Create(s)); + end; result.Link; finally result.free; @@ -3718,19 +3742,19 @@ function TFHIRPathEngine.funcLowBoundary(context : TFHIRPathExecutionContext; fo base := focus[0].value; if (base.hasType('decimal')) then - result.add(TFhirDecimal.create(lowBoundaryForDecimal(base.primitiveValue(), dp(8)))) + result.add(TFhirDecimal.Create(lowBoundaryForDecimal(base.primitiveValue(), dp(8)))) else if (base.hasType('date')) then - result.add(TFHIRDateTime.create(lowBoundaryForDate(base.primitiveValue(), dp(8)))) + result.add(TFHIRDateTime.Create(lowBoundaryForDate(base.primitiveValue(), dp(8)))) else if (base.hasType('dateTime')) then - result.add(TFHIRDateTime.create(lowBoundaryForDate(base.primitiveValue(), dp(17)))) + result.add(TFHIRDateTime.Create(lowBoundaryForDate(base.primitiveValue(), dp(17)))) else if (base.hasType('time')) then - result.add(TFHIRTime.create(lowBoundaryForTime(base.primitiveValue(), dp(9)))) + result.add(TFHIRTime.Create(lowBoundaryForTime(base.primitiveValue(), dp(9)))) else if (base.hasType('Quantity')) then begin value := base.getPrimitiveValue('value'); v := base.Clone; result.add(v); - v.setProperty('value', TFHIRDecimal.create(lowBoundaryForDecimal(value, dp(8)))); + v.setProperty('value', TFHIRDecimal.Create(lowBoundaryForDecimal(value, dp(8)))); end else raise EFHIRPath.Create('Unable to generate low boundary for '+base.fhirType); @@ -3777,19 +3801,19 @@ function TFHIRPathEngine.funcHighBoundary(context : TFHIRPathExecutionContext; f base := focus[0].value; if (base.hasType('decimal')) then - result.add(TFhirDecimal.create(highBoundaryForDecimal(base.primitiveValue(), dp(8)))) + result.add(TFhirDecimal.Create(highBoundaryForDecimal(base.primitiveValue(), dp(8)))) else if (base.hasType('date')) then - result.add(TFHIRDateTime.create(highBoundaryForDate(base.primitiveValue(), dp(8)))) + result.add(TFHIRDateTime.Create(highBoundaryForDate(base.primitiveValue(), dp(8)))) else if (base.hasType('dateTime')) then - result.add(TFHIRDateTime.create(highBoundaryForDate(base.primitiveValue(), dp(17)))) + result.add(TFHIRDateTime.Create(highBoundaryForDate(base.primitiveValue(), dp(17)))) else if (base.hasType('time')) then - result.add(TFHIRTime.create(highBoundaryForTime(base.primitiveValue(), dp(9)))) + result.add(TFHIRTime.Create(highBoundaryForTime(base.primitiveValue(), dp(9)))) else if (base.hasType('Quantity')) then begin value := base.getPrimitiveValue('value'); v := base.Clone; result.add(v); - v.setProperty('value', TFHIRDecimal.create(highBoundaryForDecimal(value, dp(8)))); + v.setProperty('value', TFHIRDecimal.Create(highBoundaryForDecimal(value, dp(8)))); end else raise EFHIRPath.Create('Unable to generate low boundary for '+base.fhirType); @@ -3800,6 +3824,55 @@ function TFHIRPathEngine.funcHighBoundary(context : TFHIRPathExecutionContext; f end; end; +function TFHIRPathEngine.funcComparable(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; +var + n1 : TFHIRSelectionList; + s1, u1, s2, u2 : String; +begin + result := TFHIRSelectionList.Create; + try + if (focus.Count <> 1) or (focus[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + n1 := execute(context, focus, exp.Parameters[0], true); + try + if (n1.Count <> 1) or (n1[0].value.fhirType <> 'Quantity') then + result.add(TFHIRBoolean.Create(false)) + else + begin + s1 := focus[0].value.getPrimitiveValue('system'); + u1 := focus[0].value.getPrimitiveValue('code'); + s2 := n1[0].value.getPrimitiveValue('system'); + u2 := n1[0].value.getPrimitiveValue('code'); + + if (s1 = '') or (s2 = '') or (s1 <> s2) then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = '') or (u2 = '') then + result.add(TFHIRBoolean.Create(false)) + else if (u1 = u2) then + result.add(TFHIRBoolean.Create(true)) + else if (s1 = 'http://unitsofmeasure.org') and (FUcum <> nil) then + begin + try + result.add(TFHIRBoolean.Create(FUcum.isComparable(u1, u2))); + except + result.add(TFHIRBoolean.Create(false)); + end; + end + else + result.add(TFHIRBoolean.Create(false)) + end; + finally + n1.free; + end; + end; + result.Link; + finally + result.free; + end; +end; + function TFHIRPathEngine.funcPrecision(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; var base : TFhirObject; @@ -3813,11 +3886,11 @@ function TFHIRPathEngine.funcPrecision(context : TFHIRPathExecutionContext; focu base := focus[0].value; if (base.hasType('decimal')) then - result.add(TFHIRInteger.create(getDecimalPrecision(base.primitiveValue()))) + result.add(TFHIRInteger.Create(getDecimalPrecision(base.primitiveValue()))) else if (base.hasType('date') or base.hasType('dateTime')) then - result.add(TFHIRInteger.create(getDatePrecision(base.primitiveValue()))) + result.add(TFHIRInteger.Create(getDatePrecision(base.primitiveValue()))) else if (base.hasType('time')) then - result.add(TFHIRInteger.create(getTimePrecision(base.primitiveValue()))) + result.add(TFHIRInteger.Create(getTimePrecision(base.primitiveValue()))) else raise EFHIRPath.Create('Unable to get precision for '+base.fhirType); end; @@ -3831,7 +3904,7 @@ function TFHIRPathEngine.funcCeiling(context: TFHIRPathExecutionContext; focus: var base : TFHIRObject; qty : TFHIRQuantity; - d : TFslDecimal; + v : TFslDecimal; begin if (focus.count <> 1) then raise EFHIRPath.Create('Error evaluating FHIRPath expression: focus for floor has more than one value'); @@ -3845,10 +3918,10 @@ function TFHIRPathEngine.funcCeiling(context: TFHIRPathExecutionContext; focus: begin qty := (base as TFhirQuantity).Clone; try - d := TFslDecimal.Create(qty.value); - d := d.Trunc; - d := d.AddInt(1); - qty.value := d.AsString; + v := TFslDecimal.Create(qty.value); + v := v.trunc; + v := v.addInt(1); + qty.value := v.AsString; result.add(qty.Link); finally qty.free; @@ -3909,7 +3982,7 @@ function TFHIRPathEngine.funcCheckModifiers(context : TFHIRPathExecutionContext; function TFHIRPathEngine.funcConformsTo(context : TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; begin - raise EFHIRTodo.create('TFHIRPathEngine.funcConformsTo'); + raise EFHIRTodo.Create('TFHIRPathEngine.funcConformsTo'); end; function TFHIRPathEngine.funcAbs(context: TFHIRPathExecutionContext; focus: TFHIRSelectionList; exp: TFHIRPathExpressionNode): TFHIRSelectionList; @@ -4145,7 +4218,7 @@ function TFHIRPathEngine.funcLower(context : TFHIRPathExecutionContext; focus : begin sw := convertToString(focus[0].value); if sw <> '' then - result.add(TFHIRString.create(sw.ToLower).noExtensions); + result.add(TFHIRString.Create(sw.ToLower).noExtensions); end; result.Link; finally @@ -4163,7 +4236,7 @@ function TFHIRPathEngine.funcUpper(context : TFHIRPathExecutionContext; focus : begin sw := convertToString(focus[0].value); if sw <> '' then - result.add(TFHIRString.create(sw.ToUpper).noExtensions); + result.add(TFHIRString.Create(sw.ToUpper).noExtensions); end; result.Link; finally @@ -4182,7 +4255,7 @@ function TFHIRPathEngine.funcToChars(context : TFHIRPathExecutionContext; focus begin sw := convertToString(focus[0].value); for c in sw do - result.add(TFHIRString.create(c).noExtensions); + result.add(TFHIRString.Create(c).noExtensions); end; result.Link; finally @@ -4203,8 +4276,8 @@ function TFHIRPathEngine.funcToBoolean(context : TFHIRPathExecutionContext; focu else if (focus[0].value is TFHIRInteger) then begin case StrToInt((focus[0].value as TFHIRInteger).value) of - 0: result.add(TFHIRBoolean.create(false).noExtensions()); - 1: result.add(TFHIRBoolean.create(true).noExtensions()); + 0: result.add(TFHIRBoolean.Create(false).noExtensions()); + 1: result.add(TFHIRBoolean.Create(true).noExtensions()); else end; end @@ -4212,15 +4285,15 @@ function TFHIRPathEngine.funcToBoolean(context : TFHIRPathExecutionContext; focu begin s := removeTrailingZeros(TFHIRDecimal(focus[0].value).value); if (s = '0') then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (s = '1') then - result.add(TFHIRBoolean.create(true).noExtensions()); + result.add(TFHIRBoolean.Create(true).noExtensions()); end else if (focus[0].value is TFHIRString) then if SameText('true', focus[0].value.primitiveValue) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if SameText('false', focus[0].value.primitiveValue) then - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); end; result.Link; finally @@ -4258,12 +4331,12 @@ function TFHIRPathEngine.funcToQuantity(context : TFHIRPathExecutionContext; foc function TFHIRPathEngine.funcToDateTime(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; begin - raise EFHIRTodo.create('TFHIRPathEngine.funcToDateTime'); + raise EFHIRTodo.Create('TFHIRPathEngine.funcToDateTime'); end; function TFHIRPathEngine.funcToTime(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; begin - raise EFHIRTodo.create('TFHIRPathEngine.funcToTime'); + raise EFHIRTodo.Create('TFHIRPathEngine.funcToTime'); end; function TFHIRPathEngine.funcIsInteger(context : TFHIRPathExecutionContext; focus : TFHIRSelectionList; exp : TFHIRPathExpressionNode) : TFHIRSelectionList; @@ -4271,15 +4344,15 @@ function TFHIRPathEngine.funcIsInteger(context : TFHIRPathExecutionContext; focu result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRInteger) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRBoolean) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(StringIsInteger32(convertToString(focus[0].value))).noExtensions()) + result.add(TFHIRBoolean.Create(StringIsInteger32(convertToString(focus[0].value))).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4291,17 +4364,17 @@ function TFHIRPathEngine.funcIsDecimal(context : TFHIRPathExecutionContext; focu result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRInteger) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRBoolean) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRDecimal) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(StringIsDecimal(convertToString(focus[0].value))).noExtensions()) + result.add(TFHIRBoolean.Create(StringIsDecimal(convertToString(focus[0].value))).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4313,11 +4386,11 @@ function TFHIRPathEngine.funcIsString(context : TFHIRPathExecutionContext; focus result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if not (focus[0].value is TFHIRDateTime) and not (focus[0].value is TFHIRTime) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4329,17 +4402,17 @@ function TFHIRPathEngine.funcIsBoolean(context : TFHIRPathExecutionContext; focu result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRInteger) and (StrToIntDef((focus[0].value as TFHIRInteger).value, -1) >= 0) and (StrToIntDef((focus[0].value as TFHIRInteger).value, -1) <= 1) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRBoolean) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRDecimal) then - result.add(TFHIRBoolean.create(StringArrayExistsSensitive(['0', '1'], removeTrailingZeros(focus[0].value.primitiveValue))).noExtensions()) + result.add(TFHIRBoolean.Create(StringArrayExistsSensitive(['0', '1'], removeTrailingZeros(focus[0].value.primitiveValue))).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(StringArrayExistsInSensitive(['true', 'false'], convertToString(focus[0].value))).noExtensions()) + result.add(TFHIRBoolean.Create(StringArrayExistsInSensitive(['true', 'false'], convertToString(focus[0].value))).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4412,22 +4485,22 @@ function TFHIRPathEngine.funcIsQuantity(context : TFHIRPathExecutionContext; foc result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRInteger) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRDecimal) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRQuantity) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRBoolean) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then begin q := parseQuantityString(focus[0].value.primitiveValue()); - result.add(TFHIRBoolean.create(q <> nil).noExtensions()); + result.add(TFHIRBoolean.Create(q <> nil).noExtensions()); end else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4440,15 +4513,15 @@ function TFHIRPathEngine.funcIsDate(context: TFHIRPathExecutionContext; focus: T result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRDateTime) or (focus[0].value is TFHIRDate) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(TRegularExpression.isMatch(convertToString(focus[0].value), + result.add(TFHIRBoolean.Create(TRegularExpression.isMatch(convertToString(focus[0].value), '([0-9]([0-9]([0-9][1-9]|[1-9]0)|[1-9]00)|[1-9]000)(-(0[1-9]|1[0-2])(-(0[1-9]|[1-2][0-9]|3[0-1]))?)?' )).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4460,15 +4533,15 @@ function TFHIRPathEngine.funcIsDateTime(context : TFHIRPathExecutionContext; foc result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRDateTime) or (focus[0].value is TFHIRDate) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(TRegularExpression.isMatch(convertToString(focus[0].value), + result.add(TFHIRBoolean.Create(TRegularExpression.isMatch(convertToString(focus[0].value), '([0-9]([0-9]([0-9][1-9]|[1-9]0)|[1-9]00)|[1-9]000)(-(0[1-9]|1[0-2])(-(0[1-9]|[1-2][0-9]|3[0-1])(T([01][0-9]|2[0-3]):[0-5][0-9]:([0-5][0-9]|60)(\.[0-9]+)?(Z|(\+|-)((0[0-9]|1[0-3]):[0-5][0-9]|14:00))?)?)?)?' )).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4480,14 +4553,14 @@ function TFHIRPathEngine.funcIsTime(context : TFHIRPathExecutionContext; focus : result := TFHIRSelectionList.Create; try if (focus.count <> 1) then - result.add(TFHIRBoolean.create(false).noExtensions()) + result.add(TFHIRBoolean.Create(false).noExtensions()) else if (focus[0].value is TFHIRTime) then - result.add(TFHIRBoolean.create(true).noExtensions()) + result.add(TFHIRBoolean.Create(true).noExtensions()) else if (focus[0].value is TFHIRString) then - result.add(TFHIRBoolean.create(TRegularExpression.IsMatch(convertToString(focus[0].value), + result.add(TFHIRBoolean.Create(TRegularExpression.IsMatch(convertToString(focus[0].value), '(T)?([01][0-9]|2[0-3])(:[0-5][0-9](:([0-5][0-9]|60))?)?(\\.[0-9]+)?(Z|(\\+|-)((0[0-9]|1[0-3]):[0-5][0-9]|14:00))?')).noExtensions()) else - result.add(TFHIRBoolean.create(false).noExtensions()); + result.add(TFHIRBoolean.Create(false).noExtensions()); result.Link; finally result.free; @@ -4519,7 +4592,7 @@ function TFHIRPathEngine.preOperate(left: TFHIRSelectionList; op: TFHIRPathOpera function TFHIRPathEngine.operate(left: TFHIRSelectionList; op: TFHIRPathOperation; right: TFHIRSelectionList): TFHIRSelectionList; begin case op of - popNull: raise EFHIRPath.create('An internal error has occurred'); + popNull: raise EFHIRPath.Create('An internal error has occurred'); popEquals: result := opequal(left, right); popEquivalent: result := opEquivalent(left, right); popNotEquals: result := opNotequal(left, right); @@ -4544,9 +4617,9 @@ function TFHIRPathEngine.operate(left: TFHIRSelectionList; op: TFHIRPathOperatio popMod: result := opMod(left, right); popIs: result := opIs(left, right); popAs: result := opAs(left, right); - popCustom : raise EFHIRPath.create('An internal error has occurred (custom operation not implemented)'); + popCustom : raise EFHIRPath.Create('An internal error has occurred (custom operation not implemented)'); else - raise EFHIRPath.create('An internal error has occurred (operation not implemented)'); + raise EFHIRPath.Create('An internal error has occurred (operation not implemented)'); end; end; @@ -4554,37 +4627,37 @@ function TFHIRPathEngine.operate(left: TFHIRSelectionList; op: TFHIRPathOperatio function TFHIRPathEngine.operateTypes(left: TFHIRTypeDetails; op: TFHIRPathOperation; right: TFHIRTypeDetails): TFHIRTypeDetails; begin case op of - popEquals: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popEquivalent: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popNotEquals: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popNotEquivalent: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popLessThan: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popGreater: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popLessOrEqual: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popGreaterOrEqual: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popIs: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + popEquals: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popEquivalent: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popNotEquals: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popNotEquivalent: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popLessThan: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popGreater: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popLessOrEqual: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popGreaterOrEqual: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popIs: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); popAs: result := TFHIRTypeDetails.createList(csSINGLETON, right.Types); popUnion: result := left.union(right); - popOr: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popAnd: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popXor: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popImplies : result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + popOr: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popAnd: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popXor: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popImplies : result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); popTimes: begin - result := TFHIRTypeDetails.create(csSINGLETON, []); + result := TFHIRTypeDetails.Create(csSINGLETON, []); if (left.hasType(context, 'integer')) and (right.hasType(context, 'integer')) then result.addType(FP_integer) else if (left.hasType(context, ['integer', 'decimal'])) and (right.hasType(context, ['integer', 'decimal'])) then result.addType(FP_decimal); end; popDivideBy: begin - result := TFHIRTypeDetails.create(csSINGLETON, []); + result := TFHIRTypeDetails.Create(csSINGLETON, []); if (left.hasType(context, 'integer')) and (right.hasType(context, 'integer')) then result.addType(FP_decimal) else if (left.hasType(context, ['integer', 'decimal'])) and (right.hasType(context, ['integer', 'decimal'])) then result.addType(FP_decimal) end; popPlus: begin - result := TFHIRTypeDetails.create(csSINGLETON, []); + result := TFHIRTypeDetails.Create(csSINGLETON, []); if (left.hasType(context, 'integer')) and (right.hasType(context, 'integer')) then result.addType(FP_integer) else if (left.hasType(context, ['integer', 'decimal'])) and (right.hasType(context, ['integer', 'decimal'])) then @@ -4592,9 +4665,9 @@ function TFHIRPathEngine.operateTypes(left: TFHIRTypeDetails; op: TFHIRPathOpera else if (left.hasType(context, ['string', 'id', 'code', 'uri'])) and (right.hasType(context, ['string', 'id', 'code', 'uri'])) then result.addType(FP_string); end; - popConcatenate : result := TFHIRTypeDetails.create(csSINGLETON, ['string']); + popConcatenate : result := TFHIRTypeDetails.Create(csSINGLETON, ['string']); popMinus: begin - result := TFHIRTypeDetails.create(csSINGLETON, []); + result := TFHIRTypeDetails.Create(csSINGLETON, []); if (left.hasType(context, 'integer')) and (right.hasType(context, 'integer')) then result.addType(FP_integer) else if (left.hasType(context, ['integer', 'decimal'])) and (right.hasType(context, ['integer', 'decimal'])) then @@ -4606,22 +4679,22 @@ function TFHIRPathEngine.operateTypes(left: TFHIRTypeDetails; op: TFHIRPathOpera if (right.hasType(context, ['Quantity'])) then result.addType(left.type_) else - raise EFHIRPath.create(format('Error in date arithmetic: Unable to subtract type {0} from {1}', [right.type_, left.type_])); + raise EFHIRPath.Create(format('Error in date arithmetic: Unable to subtract type {0} from {1}', [right.type_, left.type_])); end; end; popDiv, popMod: begin - result := TFHIRTypeDetails.create(csSINGLETON, []); + result := TFHIRTypeDetails.Create(csSINGLETON, []); if (left.hasType(context, 'integer')) and (right.hasType(context, 'integer')) then result.addType(FP_integer) else if (left.hasType(context, ['integer', 'decimal'])) and (right.hasType(context, ['integer', 'decimal'])) then result.addType(FP_Decimal); end; - popIn: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); - popContains: result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + popIn: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); + popContains: result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); // todo: add memberOf - popCustom : raise EFHIRPath.create('An internal error has occurred (operation not implemented)'); + popCustom : raise EFHIRPath.Create('An internal error has occurred (operation not implemented)'); else - raise EFHIRPathTodo.create('TFHIRPathEngine.operateTypes'); + raise EFHIRPathTodo.Create('TFHIRPathEngine.operateTypes'); end; end; @@ -4705,17 +4778,17 @@ function TFHIRPathEngine.opDiv(left, right: TFHIRSelectionList): TFHIRSelectionL pl, pr : TUcumPair; begin if (left.count = 0) then - raise EFHIRPath.create('Error performing div: left operand has no value'); + raise EFHIRPath.Create('Error performing div: left operand has no value'); if (left.count > 1) then - raise EFHIRPath.create('Error performing div: left operand has more than one value'); + raise EFHIRPath.Create('Error performing div: left operand has more than one value'); if (not left[0].value.isPrimitive()) and not left[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing div: left operand has the wrong type (%s)', [left[0].value.fhirType])); + raise EFHIRPath.Create(StringFormat('Error performing div: left operand has the wrong type (%s)', [left[0].value.fhirType])); if (right.count = 0) then - raise EFHIRPath.create('Error performing div: right operand has no value'); + raise EFHIRPath.Create('Error performing div: right operand has no value'); if (right.count > 1) then - raise EFHIRPath.create('Error performing div: right operand has more than one value'); + raise EFHIRPath.Create('Error performing div: right operand has more than one value'); if (not right[0].value.isPrimitive()) and not right[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing div: right operand has the wrong type (%s)', [right[0].value.fhirType])); + raise EFHIRPath.Create(StringFormat('Error performing div: right operand has the wrong type (%s)', [right[0].value.fhirType])); result := TFHIRSelectionList.Create(); try @@ -4725,7 +4798,7 @@ function TFHIRPathEngine.opDiv(left, right: TFHIRSelectionList): TFHIRSelectionL if (l.hasType('integer')) and (r.hasType('integer')) then begin if r.primitiveValue() <> '0' then - result.add(TFHIRInteger.create(inttostr(strtoInt(l.primitiveValue()) div strtoInt(r.primitiveValue()))).noExtensions) + result.add(TFHIRInteger.Create(inttostr(strtoInt(l.primitiveValue()) div strtoInt(r.primitiveValue()))).noExtensions) end else if (l.hasType(['quantity'])) and (r.hasType(['quantity'])) and (FUcum <> nil) and FUcum.isConfigured then begin @@ -4755,10 +4828,10 @@ function TFHIRPathEngine.opDiv(left, right: TFHIRSelectionList): TFHIRSelectionL d1 := TFslDecimal.valueOf(l.primitiveValue()); d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.divInt(d2); - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else - raise EFHIRPath.create(StringFormat('Error performing div: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing div: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.Link; finally result.free; @@ -4772,17 +4845,17 @@ function TFHIRPathEngine.opDivideBy(left, right: TFHIRSelectionList): TFHIRSelec pl, pr, p : TUcumPair; begin if (left.count = 0) then - raise EFHIRPath.create('Error performing /: left operand has no value'); + raise EFHIRPath.Create('Error performing /: left operand has no value'); if (left.count > 1) then - raise EFHIRPath.create('Error performing /: left operand has more than one value'); + raise EFHIRPath.Create('Error performing /: left operand has more than one value'); if (not left[0].value.isPrimitive()) and not left[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing -: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing -: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count = 0) then - raise EFHIRPath.create('Error performing /: right operand has no value'); + raise EFHIRPath.Create('Error performing /: right operand has no value'); if (right.count > 1) then - raise EFHIRPath.create('Error performing /: right operand has more than one value'); + raise EFHIRPath.Create('Error performing /: right operand has more than one value'); if (not right[0].value.isPrimitive()) and not right[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing /: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing /: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -4795,7 +4868,7 @@ function TFHIRPathEngine.opDivideBy(left, right: TFHIRSelectionList): TFHIRSelec d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.divide(d2); if not d3.IsUndefined then - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else if (l.hasType(['Quantity'])) and (r.hasType(['Quantity'])) and (FUcum <> nil) and FUcum.isConfigured then begin @@ -4820,7 +4893,7 @@ function TFHIRPathEngine.opDivideBy(left, right: TFHIRSelectionList): TFHIRSelec end; end else - raise EFHIRPath.create(StringFormat('Error performing /: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing /: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.link; finally result.free; @@ -4946,8 +5019,8 @@ function TFHIRPathEngine.opGreater(left, right: TFHIRSelectionList): TFHIRSelect dl := TFHIRSelectionList.Create; dr := TFHIRSelectionList.Create; try - dl.add(TFhirDecimal.create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); - dr.add(TFhirDecimal.create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); + dl.add(TFhirDecimal.Create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); + dr.add(TFhirDecimal.Create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); result := opGreater(dl, dr); finally dl.free; @@ -4955,7 +5028,7 @@ function TFHIRPathEngine.opGreater(left, right: TFHIRSelectionList): TFHIRSelect end; end else - raise EFHIRPath.create('Canonical Comparison isn''t available'); + raise EFHIRPath.Create('Canonical Comparison isn''t available'); finally lUnit.free; rUnit.free; @@ -5023,8 +5096,8 @@ function TFHIRPathEngine.opGreaterOrEqual(left, right: TFHIRSelectionList): TFHI dl := TFHIRSelectionList.Create; dr := TFHIRSelectionList.Create; try - dl.add(TFhirDecimal.create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); - dr.add(TFhirDecimal.create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); + dl.add(TFhirDecimal.Create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); + dr.add(TFhirDecimal.Create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); result := opGreaterOrEqual(dl, dr); finally dl.free; @@ -5032,7 +5105,7 @@ function TFHIRPathEngine.opGreaterOrEqual(left, right: TFHIRSelectionList): TFHI end; end else - raise EFHIRPath.create('Canonical Comparison isn''t available'); + raise EFHIRPath.Create('Canonical Comparison isn''t available'); finally lUnit.free; rUnit.free; @@ -5053,7 +5126,7 @@ function TFHIRPathEngine.opIn(left, right: TFHIRSelectionList): TFHIRSelectionLi if (left.count = 0) then exit(TFHIRSelectionList.Create); if (right.count = 0) then - exit(TFHIRSelectionList.Create(TFHIRBoolean.create(false))); + exit(TFHIRSelectionList.Create(TFHIRBoolean.Create(false))); ans := true; for l in left do begin @@ -5089,9 +5162,9 @@ function TFHIRPathEngine.opIs(left, right: TFHIRSelectionList): TFHIRSelectionLi begin tn := convertToString(right); if not (left[0].value is TFHIRElement) or (left[0].value as TFHIRElement).DisallowExtensions then - result.add(TFHIRBoolean.create((capitalise(left[0].value.fhirType) = tn) or ('System.'+capitalise(left[0].value.fhirType) = tn)).noExtensions) + result.add(TFHIRBoolean.Create((capitalise(left[0].value.fhirType) = tn) or ('System.'+capitalise(left[0].value.fhirType) = tn)).noExtensions) else - result.add(TFHIRBoolean.create(typeMatches(tn, left[0].value.fhirType, true)).noExtensions); + result.add(TFHIRBoolean.Create(typeMatches(tn, left[0].value.fhirType, true)).noExtensions); end; result.link; finally @@ -5154,8 +5227,8 @@ function TFHIRPathEngine.opLessOrEqual(left, right: TFHIRSelectionList): TFHIRSe dl := TFHIRSelectionList.Create; dr := TFHIRSelectionList.Create; try - dl.add(TFhirDecimal.create(qtyToCanonical(left[0].value as TFhirQuantity).value)); - dr.add(TFhirDecimal.create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); + dl.add(TFhirDecimal.Create(qtyToCanonical(left[0].value as TFhirQuantity).value)); + dr.add(TFhirDecimal.Create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); result := opLessOrEqual(dl, dr); finally dl.free; @@ -5163,7 +5236,7 @@ function TFHIRPathEngine.opLessOrEqual(left, right: TFHIRSelectionList): TFHIRSe end; end else - raise EFHIRPath.create('Canonical Comparison isn''t available'); + raise EFHIRPath.Create('Canonical Comparison isn''t available'); finally lUnit.free; rUnit.free; @@ -5232,8 +5305,8 @@ function TFHIRPathEngine.opLessThan(left, right: TFHIRSelectionList): TFHIRSelec dl := TFHIRSelectionList.Create; dr := TFHIRSelectionList.Create; try - dl.add(TFhirDecimal.create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); - dr.add(TFhirDecimal.create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); + dl.add(TFhirDecimal.Create(qtyToCanonical(left[0].value as TFhirQuantity).Value)); + dr.add(TFhirDecimal.Create(qtyToCanonical(right[0].value as TFhirQuantity).Value)); result := opLessThan(dl, dr); finally dl.free; @@ -5241,7 +5314,7 @@ function TFHIRPathEngine.opLessThan(left, right: TFHIRSelectionList): TFHIRSelec end; end else - raise EFHIRPath.create('Canonical Comparison isn''t available'); + raise EFHIRPath.Create('Canonical Comparison isn''t available'); finally lUnit.free; rUnit.free; @@ -5263,13 +5336,13 @@ function TFHIRPathEngine.opMinus(left, right: TFHIRSelectionList): TFHIRSelectio if (left.count = 0) or (right.count = 0) then exit(TFHIRSelectionList.Create); if (left.count > 1) then - raise EFHIRPath.create('Error performing -: left operand has more than one value'); + raise EFHIRPath.Create('Error performing -: left operand has more than one value'); if (not left[0].value.isPrimitive() and not left[0].hasType('Quantity')) then - raise EFHIRPath.create(StringFormat('Error performing -: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing -: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count > 1) then - raise EFHIRPath.create('Error performing -: right operand has more than one value'); + raise EFHIRPath.Create('Error performing -: right operand has more than one value'); if (not right[0].value.isPrimitive() and not ((left[0].value.isDateTime() or ('0' = left[0].value.primitiveValue) or left[0].value.hasType('Quantity')) and right[0].value.hasType('Quantity'))) then - raise EFHIRPath.create(StringFormat('Error performing -: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing -: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -5277,13 +5350,13 @@ function TFHIRPathEngine.opMinus(left, right: TFHIRSelectionList): TFHIRSelectio r := right[0].value; if (l.hasType('integer')) and (r.hasType('integer')) then - result.add(TFHIRInteger.create(inttostr(strToInt(l.primitiveValue()) - strToInt(r.primitiveValue()))).noExtensions) + result.add(TFHIRInteger.Create(inttostr(strToInt(l.primitiveValue()) - strToInt(r.primitiveValue()))).noExtensions) else if (l.hasType('decimal') or l.hasType('integer')) and (r.hasType('decimal') or r.hasType('integer')) then begin d1 := TFslDecimal.valueOf(l.primitiveValue()); d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.Subtract(d2); - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else if (l.hasType(['decimal', 'integer', 'Quantity']) and r.hasType('Quantity')) then begin @@ -5303,7 +5376,7 @@ function TFHIRPathEngine.opMinus(left, right: TFHIRSelectionList): TFHIRSelectio else if (l.isDateTime() and r.hasType('Quantity')) then result.add(dateAdd(l, r as TFHIRQuantity, true)) else - raise EFHIRPath.create(StringFormat('Error performing -: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing -: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.Link; finally result.free; @@ -5316,17 +5389,17 @@ function TFHIRPathEngine.opMod(left, right: TFHIRSelectionList): TFHIRSelectionL d1, d2, d3 : TFslDecimal; begin if (left.count = 0) then - raise EFHIRPath.create('Error performing mod: left operand has no value'); + raise EFHIRPath.Create('Error performing mod: left operand has no value'); if (left.count > 1) then - raise EFHIRPath.create('Error performing mod: left operand has more than one value'); + raise EFHIRPath.Create('Error performing mod: left operand has more than one value'); if (not left[0].value.isPrimitive()) then - raise EFHIRPath.create(StringFormat('Error performing mod: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing mod: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count = 0) then - raise EFHIRPath.create('Error performing mod: right operand has no value'); + raise EFHIRPath.Create('Error performing mod: right operand has no value'); if (right.count > 1) then - raise EFHIRPath.create('Error performing mod: right operand has more than one value'); + raise EFHIRPath.Create('Error performing mod: right operand has more than one value'); if (not right[0].value.isPrimitive()) then - raise EFHIRPath.create(StringFormat('Error performing mod: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing mod: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -5336,17 +5409,17 @@ function TFHIRPathEngine.opMod(left, right: TFHIRSelectionList): TFHIRSelectionL if (l.hasType('integer')) and (r.hasType('integer')) then begin if r.primitiveValue() <> '0' then - result.add(TFHIRInteger.create(inttostr(strToInt(l.primitiveValue()) mod strToInt(r.primitiveValue()))).noExtensions) + result.add(TFHIRInteger.Create(inttostr(strToInt(l.primitiveValue()) mod strToInt(r.primitiveValue()))).noExtensions) end else if (l.hasType(['integer', 'decimal'])) and (r.hasType(['integer', 'decimal'])) then begin d1 := TFslDecimal.valueOf(l.primitiveValue()); d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.Modulo(d2); - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else - raise EFHIRPath.create(StringFormat('Error performing mod: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing mod: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.Link; finally @@ -5443,13 +5516,13 @@ function TFHIRPathEngine.opConcatenate(left, right: TFHIRSelectionList): TFHIRSe l, r : String; begin if (left.count > 1) then - raise EFHIRPath.create('Error performing &: left operand has more than one value'); + raise EFHIRPath.Create('Error performing &: left operand has more than one value'); if (left.Count = 1) and (not left[0].value.hasType(FHIR_TYPES_STRING)) then - raise EFHIRPath.create(StringFormat('Error performing &: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing &: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count > 1) then - raise EFHIRPath.create('Error performing &: right operand has more than one value'); + raise EFHIRPath.Create('Error performing &: right operand has more than one value'); if (right.Count = 1) and (not right[0].value.hasType(FHIR_TYPES_STRING)) then - raise EFHIRPath.create(StringFormat('Error performing &: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing &: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -5461,7 +5534,7 @@ function TFHIRPathEngine.opConcatenate(left, right: TFHIRSelectionList): TFHIRSe r := '' else r := right[0].value.primitiveValue(); - result.add(TFHIRString.create(l + r).noExtensions); + result.add(TFHIRString.Create(l + r).noExtensions); result.Link; finally result.free; @@ -5476,13 +5549,13 @@ function TFHIRPathEngine.opPlus(left, right: TFHIRSelectionList): TFHIRSelection if (left.count = 0) or (right.count = 0) then exit(TFHIRSelectionList.Create); if (left.count > 1) then - raise EFHIRPath.create('Error performing +: left operand has more than one value'); + raise EFHIRPath.Create('Error performing +: left operand has more than one value'); if (not left[0].value.isPrimitive()) then - raise EFHIRPath.create(StringFormat('Error performing +: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing +: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count > 1) then - raise EFHIRPath.create('Error performing +: right operand has more than one value'); + raise EFHIRPath.Create('Error performing +: right operand has more than one value'); if (not right[0].value.isPrimitive() and not ((left[0].value.isDateTime() or ('0' = left[0].value.primitiveValue) or left[0].value.hasType('Quantity')) and right[0].value.hasType('Quantity'))) then - raise EFHIRPath.create(StringFormat('Error performing +: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing +: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -5490,20 +5563,20 @@ function TFHIRPathEngine.opPlus(left, right: TFHIRSelectionList): TFHIRSelection r := right[0].value; if (l.hasType(['string', 'id', 'code', 'uri'])) and (r.hasType(['string', 'id', 'code', 'uri'])) then - result.add(TFHIRString.create(l.primitiveValue() + r.primitiveValue()).noExtensions) + result.add(TFHIRString.Create(l.primitiveValue() + r.primitiveValue()).noExtensions) else if (l.hasType('integer')) and (r.hasType('integer')) then - result.add(TFHIRInteger.create(inttostr(strToInt(l.primitiveValue()) + strToInt(r.primitiveValue()))).noExtensions) + result.add(TFHIRInteger.Create(inttostr(strToInt(l.primitiveValue()) + strToInt(r.primitiveValue()))).noExtensions) else if (l.hasType(['integer', 'decimal'])) and (r.hasType(['integer', 'decimal'])) then begin d1 := TFslDecimal.valueOf(l.primitiveValue()); d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.Add(d2); - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else if (l.isDateTime) and (r.hasType('Quantity')) then result.add(dateAdd(l, r as TFHIRQuantity, false)) else - raise EFHIRPath.create(StringFormat('Error performing +: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing +: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.Link; finally result.free; @@ -5517,17 +5590,17 @@ function TFHIRPathEngine.opTimes(left, right: TFHIRSelectionList): TFHIRSelectio p, pl, pr : TUcumPair; begin if (left.count = 0) then - raise EFHIRPath.create('Error performing *: left operand has no value'); + raise EFHIRPath.Create('Error performing *: left operand has no value'); if (left.count > 1) then - raise EFHIRPath.create('Error performing *: left operand has more than one value'); + raise EFHIRPath.Create('Error performing *: left operand has more than one value'); if (not left[0].value.isPrimitive()) and not left[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing +: left operand has the wrong type (%s)', [left[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing +: left operand has the wrong type (%s)', [left[0].value.fhirType()])); if (right.count = 0) then - raise EFHIRPath.create('Error performing *: right operand has no value'); + raise EFHIRPath.Create('Error performing *: right operand has no value'); if (right.count > 1) then - raise EFHIRPath.create('Error performing *: right operand has more than one value'); + raise EFHIRPath.Create('Error performing *: right operand has more than one value'); if (not right[0].value.isPrimitive()) and not right[0].value.hasType('Quantity') then - raise EFHIRPath.create(StringFormat('Error performing *: right operand has the wrong type (%s)', [right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing *: right operand has the wrong type (%s)', [right[0].value.fhirType()])); result := TFHIRSelectionList.Create(); try @@ -5535,7 +5608,7 @@ function TFHIRPathEngine.opTimes(left, right: TFHIRSelectionList): TFHIRSelectio r := right[0].value; if (l.hasType('integer')) and (r.hasType('integer')) then - result.add(TFHIRInteger.create(inttostr(strToInt(l.primitiveValue()) * strToInt(r.primitiveValue()))).noExtensions) + result.add(TFHIRInteger.Create(inttostr(strToInt(l.primitiveValue()) * strToInt(r.primitiveValue()))).noExtensions) else if (l.hasType(['Quantity'])) and (r.hasType(['Quantity'])) and (FUcum <> nil) and FUcum.isConfigured then begin pl := qtyToPair(l as TFHIRQuantity); @@ -5563,10 +5636,10 @@ function TFHIRPathEngine.opTimes(left, right: TFHIRSelectionList): TFHIRSelectio d1 := TFslDecimal.valueOf(l.primitiveValue()); d2 := TFslDecimal.valueOf(r.primitiveValue()); d3 := d1.Multiply(d2); - result.add(TFHIRDecimal.create(d3.asDecimal).noExtensions); + result.add(TFHIRDecimal.Create(d3.asDecimal).noExtensions); end else - raise EFHIRPath.create(StringFormat('Error performing /: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); + raise EFHIRPath.Create(StringFormat('Error performing /: left and right operand have incompatible or illegal types (%s, %s)', [left[0].value.fhirType(), right[0].value.fhirType()])); result.link; finally result.free; @@ -5662,7 +5735,7 @@ function TFHIRPathEngine.resolveConstant(context : TFHIRPathExecutionContext; co else if (c.FValue.startsWith('@')) then result := processDateConstant(context.appInfo, c.FValue.substring(1)) else - raise EFHIRPath.create('Invaild FHIR Constant '+c.FValue); + raise EFHIRPath.Create('Invaild FHIR Constant '+c.FValue); end; function TFHIRPathEngine.processDateConstant(appinfo : TFslObject; value : String) : TFHIRObject; @@ -5671,7 +5744,7 @@ function TFHIRPathEngine.processDateConstant(appinfo : TFslObject; value : Strin v : string; begin if (value.startsWith('T')) then - exit(TFHIRTime.create(value.substring(1)).noExtensions()); + exit(TFHIRTime.Create(value.substring(1)).noExtensions()); v := value; if (v.length > 10) then @@ -5685,9 +5758,9 @@ function TFHIRPathEngine.processDateConstant(appinfo : TFslObject; value : Strin v := v.substring(0, 10+i); end; if (v.length > 10) then - result := TFHIRDateTime.create(TFslDateTime.fromXML(value)).noExtensions() + result := TFHIRDateTime.Create(TFslDateTime.fromXML(value)).noExtensions() else - result := TFHIRDate.create(TFslDateTime.fromXML(value)).noExtensions(); + result := TFHIRDate.Create(TFslDateTime.fromXML(value)).noExtensions(); end; function TFHIRPathEngine.qtyEqual(left, right: TFHIRQuantity): TEqualityTriState; @@ -5818,27 +5891,27 @@ function TFHIRPathEngine.resolveConstant(context : TFHIRPathExecutionContext; s ext : TFHIRPathEngineExtension; begin if (s = '%sct') then - result := TFHIRString.create(URI_SNOMED).noExtensions() + result := TFHIRString.Create(URI_SNOMED).noExtensions() else if (s = '%loinc') then - result := TFHIRString.create(URI_LOINC).noExtensions() + result := TFHIRString.Create(URI_LOINC).noExtensions() else if (s = '%ucum') then - result := TFHIRString.create(URI_UCUM).noExtensions() + result := TFHIRString.Create(URI_UCUM).noExtensions() else if (s = '%resource') then begin if (context.resource = nil) then - raise EFHIRPath.create('Cannot use %resource in this context'); + raise EFHIRPath.Create('Cannot use %resource in this context'); result := context.resource.Link; end else if (s = '%context') then result := context.context.link else if (s = '%us-zip') then - result := TFHIRString.create('[0-9]{5}(-[0-9]{4}){0,1}').noExtensions() + result := TFHIRString.Create('[0-9]{5}(-[0-9]{4}){0,1}').noExtensions() else if (s.startsWith('%`vs-')) then - result := TFHIRString.create('http://hl7.org/fhir/ValueSet/'+s.substring(5, s.length-6)).noExtensions() + result := TFHIRString.Create('http://hl7.org/fhir/ValueSet/'+s.substring(5, s.length-6)).noExtensions() else if (s.startsWith('%`cs-')) then - result := TFHIRString.create('http://hl7.org/fhir/'+s.substring(5, s.length-1)).noExtensions() + result := TFHIRString.Create('http://hl7.org/fhir/'+s.substring(5, s.length-1)).noExtensions() else if (s.startsWith('%`ext-')) then - result := TFHIRString.create('http://hl7.org/fhir/StructureDefinition/'+s.substring(6, s.length-7)).noExtensions() + result := TFHIRString.Create('http://hl7.org/fhir/StructureDefinition/'+s.substring(6, s.length-7)).noExtensions() else begin for ext in FExtensions do @@ -5846,7 +5919,7 @@ function TFHIRPathEngine.resolveConstant(context : TFHIRPathExecutionContext; s if ext.resolveConstant(context, s, result) then exit; end; - raise EFHIRPath.create('Unknown fixed constant "'+s+'"') + raise EFHIRPath.Create('Unknown fixed constant "'+s+'"') end; end; @@ -5869,7 +5942,7 @@ function TFHIRPathEngine.execute(context : TFHIRPathExecutionContext; focus: TFH else if atEntry and (exp.name = '$total') then work.addAll(context.total) else if atEntry and (exp.name = '$index') then - work.add(TFHIRInteger.create(context.index)) + work.add(TFHIRInteger.Create(context.index)) else for item in focus do begin @@ -5976,10 +6049,10 @@ function TFHIRPathEngine.execute(context : TFHIRPathExecutionContext; focus: TFH function TFHIRPathEngine.executeType(focus: String; exp: TFHIRPathExpressionNode; atEntry : boolean): TFHIRTypeDetails; begin if (atEntry and exp.Name[1].IsUpper) and (focus = TFHIRProfiledType.ns(exp.Name)) then - result := TFHIRTypeDetails.create(csSINGLETON, [focus]) + result := TFHIRTypeDetails.Create(csSINGLETON, [focus]) else begin - result := TFHIRTypeDetails.create(csNULL, []); + result := TFHIRTypeDetails.Create(csNULL, []); try ListChildTypesByName(focus, exp.name, result); result.Link; @@ -6089,9 +6162,10 @@ function TFHIRPathEngine.evaluateFunction(context : TFHIRPathExecutionContext; f pfLowBoundary : result := funcLowBoundary(context, focus, exp); pfHighBoundary : result := funcHighBoundary(context, focus, exp); pfPrecision : result := funcPrecision(context, focus, exp); + pfComparable : result := funcComparable(context, focus, exp); pfCustom : result := funcCustom(context, focus, exp); else - raise EFHIRPath.create('Unknown Function '+exp.name); + raise EFHIRPath.Create('Unknown Function '+exp.name); end; end; @@ -6134,7 +6208,7 @@ function TFHIRPathEngine.funcCustom(context : TFHIRPathExecutionContext; focus: end; end; if not done and (not couldHaveBeen or (focus.Count > 0)) then - raise EFHIRPath.create('Unknown Function '+exp.name); + raise EFHIRPath.Create('Unknown Function '+exp.name); result.Link; finally result.free; @@ -6236,7 +6310,7 @@ procedure TFHIRPathEngine.checkParamTypes(funcId : TFHIRPathFunction; paramTypes sd := context.fetchStructureDefinition(sd.baseDefinition); end; if (not ok) then - raise EFHIRPath.create('The parameter type "'+a.uri+'" is not legal for '+CODES_TFHIRPathFunctions[funcId]+' parameter '+Integer.toString(i)+', expecting '+pt.describe()); + raise EFHIRPath.Create('The parameter type "'+a.uri+'" is not legal for '+CODES_TFHIRPathFunctions[funcId]+' parameter '+Integer.toString(i)+', expecting '+pt.describe()); end; end; end; @@ -6250,7 +6324,7 @@ function TFHIRPathEngine.childTypes(focus : TFHIRTypeDetails; mask : string) : T var f : TFHIRProfiledType; begin - result := TFHIRTypeDetails.create(csUNORDERED, []); + result := TFHIRTypeDetails.Create(csUNORDERED, []); try for f in focus.types do ListChildTypesByName(f.uri, mask, result); @@ -6287,7 +6361,7 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon paramTypes := TFslList.Create; try if (exp.FunctionId in [pfIs, pfAs, pfOfType]) then - paramTypes.add(TFHIRTypeDetails.create(csSINGLETON, [FP_string])) + paramTypes.add(TFHIRTypeDetails.Create(csSINGLETON, [FP_string])) else begin i := 0; @@ -6310,27 +6384,27 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon case exp.FunctionId of pfEmpty : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfNot : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfExists : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfSubsetOf : begin checkParamTypes(exp.FunctionId, paramTypes, [focus.link]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfSupersetOf : begin checkParamTypes(exp.FunctionId, paramTypes, [focus.link]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfIsDistinct : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfDistinct : result := focus.Link; pfCount : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_integer]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_integer]); pfWhere : if (focus.hasType(self.context, 'Reference')) then begin @@ -6363,7 +6437,7 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon pfSelect : result := paramTypes[0].link; pfAll : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfRepeat : result := TFHIRTypeDetails.createList(focus.CollectionStatus, allTypes); pfAggregate : @@ -6371,14 +6445,14 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon pfItem : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_integer])]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_integer])]); result := focus.Link; end; pfOfType : begin - checkParamTypes(exp.FunctionId, paramTypes, TFHIRTypeDetails.create(csSINGLETON, [FP_String])); - result := TFHIRTypeDetails.create(csSINGLETON, [exp.Parameters[0].name]); + checkParamTypes(exp.FunctionId, paramTypes, TFHIRTypeDetails.Create(csSINGLETON, [FP_String])); + result := TFHIRTypeDetails.Create(csSINGLETON, [exp.Parameters[0].name]); end; pfType : begin @@ -6390,54 +6464,54 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon c := c or not pt.isSystemType(); end; if (s and c) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_SimpleTypeInfo, FP_ClassInfo]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_SimpleTypeInfo, FP_ClassInfo]) else if (s) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_SimpleTypeInfo]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_SimpleTypeInfo]) else - result := TFHIRTypeDetails.create(csSINGLETON, [FP_ClassInfo]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_ClassInfo]); end; pfAs : begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, exp.Parameters[0].Name); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, exp.Parameters[0].Name); end; pfIs : begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfSingle : result := focus.toSingleton(); pfFirst : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); result := focus.toSingleton(); end; pfLast : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); result := focus.toSingleton(); end; pfTail : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); result := focus.Link; end; pfSkip : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_integer])]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_integer])]); result := focus.Link; end; pfTake : begin if (focus.CollectionStatus = csUNORDERED) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_integer])]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on ordered collections'); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_integer])]); result := focus.Link; end; pfUnion : @@ -6450,7 +6524,7 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon result := focus.link; pfIif : begin - result := TFHIRTypeDetails.create(csNull, []); + result := TFHIRTypeDetails.Create(csNull, []); result.update(paramTypes[0]); if (paramTypes.count > 1) then result.update(paramTypes[1]); @@ -6458,75 +6532,75 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon pfLower : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfUpper : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfToChars : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfSubstring : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_Integer]), TFHIRTypeDetails.create(csSINGLETON, [FP_integer])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]), TFHIRTypeDetails.Create(csSINGLETON, [FP_integer])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfStartsWith : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfEndsWith : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfMatches, pfMatchesFull : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfReplaceMatches : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string]), TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string]), TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfContains : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfReplace : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'id'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string]), TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, id'+' not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string]), TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfLength : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_integer]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_integer]); end; pfChildren : result := childTypes(focus, '*'); @@ -6535,218 +6609,220 @@ function TFHIRPathEngine.evaluateFunctionType(context: TFHIRPathExecutionTypeCon pfMemberOf : begin if (not focus.hasType(self.context, ['string', 'code', 'uri', 'Coding', 'CodeableConcept'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, Coding, CodeableConcept not '+focus.describe); - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on string, code, uri, Coding, CodeableConcept not '+focus.describe); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfTrace : begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); result := focus.Link; end; pfToday : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_DateTime]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_DateTime]); pfNow : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_dateTime]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_dateTime]); pfResolve : begin if (not focus.hasType(self.context, ['uri', 'Reference'])) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on uri, Reference not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, ['DomainResource']); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on uri, Reference not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, ['DomainResource']); end; pfExtension : begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, ['Extension']); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, ['Extension']); end; pfHasExtension : begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfAllFalse: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfAnyFalse: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfAllTrue: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfAnyTrue: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfElementDefinition: begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, ['ElementDefinition']); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, ['ElementDefinition']); end; pfSlice: begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string, FP_string])]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string, FP_string])]); result := focus.Link; end; pfCheckModifiers: begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csUNORDERED, [FP_string])]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csUNORDERED, [FP_string])]); result := focus.Link; end; pfConformsTo: begin - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_string])]); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_string])]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); end; pfHasValue: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfHtmlChecks: - result := TFHIRTypeDetails.create(csSINGLETON, [FP_boolean]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_boolean]); pfToInteger : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_integer]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_integer]); end; pfToDecimal : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_decimal]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_decimal]); end; pfToString : begin if (not focus.hasType(self.context, primitiveTypes) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_string]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_string]); end; pfToQuantity : begin if (not focus.hasType(self.context, primitiveTypes) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Quantity]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Quantity]); end; pfToBoolean : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); end; pfToDateTime : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_DateTime]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_DateTime]); end; pfToTime : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Time]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Time]); end; pfAbs : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfCeiling : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfExp : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfFloor : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfLn : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfLog : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfPower : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfTruncate : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfRound : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfSqrt : begin if (not focus.hasType(self.context, FHIR_TYPES_NUMERIC) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+CommaText(FHIR_TYPES_NUMERIC)+' and Quantity not '+focus.describe); result := TFHIRTypeDetails.createList(csSINGLETON, focus.types); end; pfConvertsToString, pfConvertsToQuantity : begin if (not focus.hasType(self.context, primitiveTypes) and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); end; pfConvertsToInteger, pfConvertsToDecimal, pfConvertsToDateTime, pfConvertsToDate, pfConvertsToTime, pfConvertsToBoolean : begin if (not focus.hasType(self.context, primitiveTypes)) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Boolean]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on '+primitiveTypes.CommaText+' not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); end; pfForHtml, pfEncode, pfDecode, pfEscape, pfUnescape, pfTrim : begin - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]); end; pfSplit : - result := TFHIRTypeDetails.create(csORDERED, [FP_String]); + result := TFHIRTypeDetails.Create(csORDERED, [FP_String]); pfJoin : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_String]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_String]); pfIndexOf : - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Integer]); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]); pfLowBoundary, pfHighBoundary : begin if (not focus.hasNoTypes() and not focus.hasType(self.context, 'decimal') and not focus.hasType(self.context, 'date') and not focus.hasType(self.context, 'dateTime') and not focus.hasType(self.context, 'time') and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decimal, date, datetime, instant, time and Quantity, not '+focus.describe); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decimal, date, datetime, instant, time and Quantity, not '+focus.describe); if (paramTypes.count > 0) then - checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.create(csSINGLETON, [FP_Integer])]); + checkParamTypes(exp.FunctionId, paramTypes, [TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer])]); if (focus.hasType(self.context, 'date') or focus.hasType(self.context, 'dateTime') or focus.hasType(self.context, 'instant')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_DateTime]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_DateTime]) else if (focus.hasType(self.context, 'decimal')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Decimal]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Decimal]) else if (focus.hasType(self.context, 'time')) then - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Time]) + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Time]) else - result := TFHIRTypeDetails.create(csSINGLETON, []) + result := TFHIRTypeDetails.Create(csSINGLETON, []) end; pfPrecision : begin if (not focus.hasNoTypes() and not focus.hasType(self.context, 'decimal') and not focus.hasType(self.context, 'date') and not focus.hasType(self.context, 'dateTime') and not focus.hasType(self.context, 'time') and not focus.hasType(self.context, 'Quantity')) then - raise EFHIRPath.create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decima;, date, datetime, instant, time and Quantity, not '+focus.describe); - result := TFHIRTypeDetails.create(csSINGLETON, [FP_Integer]); + raise EFHIRPath.Create('The function "'+CODES_TFHIRPathFunctions[exp.FunctionId]+'()" can only be used on decima;, date, datetime, instant, time and Quantity, not '+focus.describe); + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Integer]); end; + pfComparable : + result := TFHIRTypeDetails.Create(csSINGLETON, [FP_Boolean]); pfCustom : result := evaluateCustomFunctionType(context, focus, exp); else - raise EFHIRPath.create('not Implemented yet?'); + raise EFHIRPath.Create('not Implemented yet?'); end; finally paramTypes.free; @@ -6814,7 +6890,7 @@ function processDateConstant(s : String) : TFHIRDataType; // else if s = '%resource' then // begin // if (context.resource = nil) then -// raise EFHIRPath.create('%resource cannot be used in this context'); +// raise EFHIRPath.Create('%resource cannot be used in this context'); // result := context.resource.link; // end // else if s = '%us-zip' then @@ -6826,7 +6902,7 @@ function processDateConstant(s : String) : TFHIRDataType; // else if s.StartsWith('%"ext-') then // result := TFhirString.Create('http://hl7.org/fhir/StructureDefinition/'+s.Substring(6, s.length-7)).noExtensions // else -// raise EFHIRPath.create('Unknown fixed constant '+s); +// raise EFHIRPath.Create('Unknown fixed constant '+s); //end; // @@ -6886,7 +6962,7 @@ procedure TFHIRPathEngine.ListChildTypesByName(type_, name : String; result : TF rt : TFslStringSet; begin if (type_ = '') then - raise EFHIRPath.create('No type provided in BuildToolPathEvaluator.ListChildTypesByName'); + raise EFHIRPath.Create('No type provided in BuildToolPathEvaluator.ListChildTypesByName'); if (type_ = 'http://hl7.org/fhir/StructureDefinition/xhtml') then exit; if (type_ = 'Custom') or (type_ = 'http://hl7.org/fhir/StructureDefinition/Custom') then @@ -6919,7 +6995,7 @@ procedure TFHIRPathEngine.ListChildTypesByName(type_, name : String; result : TF sd := worker.fetchStructureDefinition(url); if (sd = nil) then - raise EFHIRPath.create('Unknown type '+type_); // this really is an error, because we can only get to here if the internal infrastrucgture is wrong + raise EFHIRPath.Create('Unknown type '+type_); // this really is an error, because we can only get to here if the internal infrastrucgture is wrong m := nil; sdl := TFslList.Create; try @@ -6931,7 +7007,7 @@ procedure TFHIRPathEngine.ListChildTypesByName(type_, name : String; result : TF begin dt := worker.fetchStructureDefinition('http://hl7.org/fhir/StructureDefinition/'+specifiedType); if (dt = nil) then - raise EFHIRPath.create('unknown data type '+specifiedType); + raise EFHIRPath.Create('unknown data type '+specifiedType); sdl.add(dt); end else @@ -6939,7 +7015,7 @@ procedure TFHIRPathEngine.ListChildTypesByName(type_, name : String; result : TF begin dt := worker.fetchStructureDefinition('http://hl7.org/fhir/StructureDefinition/'+t.Code) as TFhirStructureDefinition; if (dt = nil) then - raise EFHIRPath.create('unknown data type '+t.code); + raise EFHIRPath.Create('unknown data type '+t.code); sdl.add(dt); end; end @@ -7028,7 +7104,7 @@ procedure TFHIRPathEngine.ListChildTypesByName(type_, name : String; result : TF for t in ed.type_list do begin if (t.code = '') then - break; // raise EFHIRPath.create('Illegal reference to primitive value attribute @ '+path); + break; // raise EFHIRPath.Create('Illegal reference to primitive value attribute @ '+path); if (t.code = 'Element') or (t.code = 'BackboneElement') then result.addType(path) @@ -7124,11 +7200,11 @@ function TFHIRPathEngine.getElementDefinition(sd : TFHIRStructureDefinition; pat // now we walk into the type. if (ed.type_list.count > 1) then // if there's more than one type, the test above would fail this - raise EFHIRException.create('Internal typing issue....'); + raise EFHIRException.Create('Internal typing issue....'); sd := worker.getStructure('http://hl7.org/fhir/StructureDefinition/'+ed.type_List[0].code); try if (sd = nil) then - raise EDefinitionException.create('Unknown type '+ed.type_List[0].code); + raise EDefinitionException.Create('Unknown type '+ed.type_List[0].code); result := getElementDefinition(sd, sd.id+path.Substring(ed.path.Length), true, specifiedType); finally sd.free; @@ -7166,7 +7242,7 @@ function TFHIRPathEngine.sizeInBytesV(magic : integer) : cardinal; result := inherited sizeInBytesV(magic); inc(result, worker.sizeInBytes(magic)); inc(result, allTypes.sizeInBytes(magic)); - inc(result, primitiveTypes.sizeInBytes(magic)); + inc(result, primitiveTypes.sizeInBytes(magic)); inc(result, FUcum.sizeInBytes(magic)); end; @@ -7212,7 +7288,7 @@ function TFHIRPathExecutionTypeContext.sizeInBytesV(magic : integer) : cardinal; inc(result, FContext.sizeInBytes(magic)); end; -{ TFHIRPathLexer5 } +{ TFHIRPathLexer4 } function TFHIRPathLexer5.opCodes: TArray; @@ -7232,20 +7308,20 @@ function TFHIRPathLexer5.opCodes: TArray; function TFHIRPathLexer5.processConstant : TFHIRObject; begin if (isStringConstant()) then - result := TFHIRString.create(TFHIRPathLexer.processConstant(take())).noExtensions() + result := TFHIRString.Create(TFHIRPathLexer.processConstant(take())).noExtensions() else if (StringIsInteger32(current)) then - result := TFHIRInteger.create(take).noExtensions() + result := TFHIRInteger.Create(take).noExtensions() else if (StringIsDecimal(current)) then - result := TFHIRDecimal.create(take).noExtensions() + result := TFHIRDecimal.Create(take).noExtensions() else if (StringArrayExistsSensitive(['true', 'false'], current)) then - result := TFHIRBoolean.create(take = 'true').noExtensions() + result := TFHIRBoolean.Create(take = 'true').noExtensions() else if (current = '{}') then begin take; result := nil; end else if (current.startsWith('%') or current.startsWith('@')) then - result := TFHIRConstant.create(take) + result := TFHIRConstant.Create(take) else raise error('Invalid Constant '+current); end; diff --git a/library/fhir5/fhir5_pathnode.pas b/library/fhir5/fhir5_pathnode.pas index 14c6c4849..f022508c3 100644 --- a/library/fhir5/fhir5_pathnode.pas +++ b/library/fhir5/fhir5_pathnode.pas @@ -56,7 +56,7 @@ interface pfToBoolean, pfToInteger, pfToString, pfToDecimal, pfToQuantity, pfToDateTime, pfToTime, pfAbs, pfCeiling, pfExp, pfFloor, pfLn, pfLog, pfPower, pfTruncate, pfRound, pfSqrt, pfForHtml, pfEncode, pfDecode, pfEscape, pfUnescape, pfTrim, pfSplit, pfJoin, pfIndexOf, - pfLowBoundary, pfHighBoundary, pfPrecision, + pfLowBoundary, pfHighBoundary, pfPrecision, pfComparable, pfCustom); TFHIRPathExpressionNodeKind = (enkName, enkFunction, enkConstant, enkGroup, enkStructure, enkUnary); // structure is not used in fhir4_pathengine, but is in CQL @@ -78,7 +78,7 @@ interface 'toBoolean', 'toInteger', 'toString', 'toDecimal', 'toQuantity', 'toDateTime', 'toTime', 'abs', 'ceiling', 'exp', 'floor', 'ln', 'log', 'power', 'truncate', 'round', 'sqrt', 'forHtml', 'encode', 'decode', 'escape', 'unescape', 'trim', 'split', 'join', 'indexOf', - 'lowBoundary', 'highBoundary', 'precision', + 'lowBoundary', 'highBoundary', 'precision', 'comparable', 'xx-custom-xx'); FHIR_SD_NS = 'http://hl7.org/fhir/StructureDefinition/'; diff --git a/library/fsl/fsl_fpc.pas b/library/fsl/fsl_fpc.pas index e70a0685c..e27933151 100644 --- a/library/fsl/fsl_fpc.pas +++ b/library/fsl/fsl_fpc.pas @@ -280,18 +280,21 @@ procedure setCurrentDirectory(dir : String); function unicodeChars(s : String) : TUCharArray; var i, c, l, cl : integer; - ch : UnicodeChar; + ch : LongWord; p: PChar; + ss : String; begin l := length(s); SetLength(result, l); // maximum possible length i := 0; c := 1; p := @s[1]; + ss := ''; while l > 0 do begin - ch := UnicodeChar(UTF8CodepointToUnicode(p, cl)); - result[i] := ch; + ch := UTF8PCharToUnicode(p, cl); + result[i] := UnicodeChar(ch); + ss := ss + IntToHex(ch, 4)+'.'; inc(i); dec(l, cl); inc(p, cl); diff --git a/library/fsl/fsl_ucum.pas b/library/fsl/fsl_ucum.pas index 1717794e0..dcb7c16e4 100644 --- a/library/fsl/fsl_ucum.pas +++ b/library/fsl/fsl_ucum.pas @@ -57,6 +57,8 @@ TUcumServiceInterface = class (TFslObject) function multiply(o1, o2 : TUcumPair) : TUcumPair; virtual; abstract; function divideBy(o1, o2 : TUcumPair) : TUcumPair; virtual; abstract; function getCanonicalForm(value : TUcumPair) : TUcumPair; virtual; abstract; + function getCanonicalUnits(units : string) : string; virtual; abstract; + function isComparable(u1, u2 : String) : boolean; virtual; abstract; function isConfigured : boolean; virtual; abstract; end; diff --git a/library/fsl/fsl_utilities.pas b/library/fsl/fsl_utilities.pas index bf69b59f1..ea058cfea 100644 --- a/library/fsl/fsl_utilities.pas +++ b/library/fsl/fsl_utilities.pas @@ -46,7 +46,7 @@ {$ENDIF} {$IFDEF FPC} - base64, + base64, LazUTF8, {$ELSE} System.TimeSpan, System.NetEncoding, EncdDecd, UIConsts, ZLib, {$ENDIF} @@ -15872,7 +15872,10 @@ function TFslWordStemmer.stem(word: String): String; end; function removeAccentFromChar(ch : UnicodeChar) : String; +var + v : Cardinal; begin + v := ord(ch); case ch of //' ' #$00A0 : result := ' '; @@ -16917,9 +16920,11 @@ function removeAccentFromChar(ch : UnicodeChar) : String; #$2C6C : result := 'z'; #$A763 : result := 'z'; - #$0439 : result := #$0438; + #$0439 : result := UnicodeToUTF8($0438); + else if ch < #$FE then + result := ch else - result := ch; + result := UnicodeToUTF8(v); end; end; @@ -17470,6 +17475,8 @@ function lowBoundaryForDate(value : String; precision : integer) : String; b.append(':00'); if (b.length = 19) then b.append('.000'); + if (tz = '') and (precision >= 10) then + tz := '+14:00'; result := applyDatePrecision(b.toString(), precision)+tz; finally b.free; @@ -17515,6 +17522,8 @@ function highBoundaryForDate(value : String; precision : integer) : String; b.append(':59'); if (b.length = 19) then b.append('.999'); + if (tz = '') and (precision >= 10) then + tz := '-12:00'; result := applyDatePrecision(b.toString(), precision)+tz; finally b.free; diff --git a/library/fsl/tests/fsl_testing.pas b/library/fsl/tests/fsl_testing.pas index 2e1e2617b..7a6a09663 100644 --- a/library/fsl/tests/fsl_testing.pas +++ b/library/fsl/tests/fsl_testing.pas @@ -64,6 +64,8 @@ TFslTestCase = class (TTestCase) procedure assertEqual(left, right : String); overload; procedure assertEqual(left, right : integer; message : String); overload; procedure assertEqual(left, right : integer); overload; + procedure assertEqual(const left, right : TBytes; message : String); overload; + procedure assertEqual(const left, right : TBytes); overload; procedure assertWillRaise(AMethod: TTestMethodWithContext; context : TObject; AExceptionClass: ExceptClass; AExceptionMessage : String); procedure thread(proc : TTestMethodWithContext; context : TObject); public @@ -280,6 +282,36 @@ procedure TFslTestCase.assertEqual(left, right: integer); {$ENDIF} end; +procedure TFslTestCase.assertEqual(const left, right: TBytes; message: String); +var + i : integer; +begin + {$IFDEF FPC} + for i := 0 to IntegerMin(length(left), length(right)) - 1 do + if (left[i] <> right[i]) then + raise EFslException.create('Byte Arrays differ at position '+inttostr(i)+': '+inttostr(ord(left[i]))+'/'+inttostr(ord(right[i]))); + if length(left) <> length(right) then + raise EFslException.create('Byte Arrays differ in length: '+inttostr(length(left))+'/'+inttostr(length(right))); + {$ELSE} + todo + {$ENDIF} +end; + +procedure TFslTestCase.assertEqual(const left, right: TBytes); +var + i : integer; +begin + {$IFDEF FPC} + for i := 0 to IntegerMin(length(left), length(right)) - 1 do + if (left[i] <> right[i]) then + raise EFslException.create('Byte Arrays differ at position '+inttostr(i)+': '+inttostr(ord(left[i]))+'/'+inttostr(ord(right[i]))); + if length(left) <> length(right) then + raise EFslException.create('Byte Arrays differ in length: '+inttostr(length(left))+'/'+inttostr(length(right))); + {$ELSE} + todo + {$ENDIF} +end; + procedure TFslTestCase.assertWillRaise(AMethod: TTestMethodWithContext; context : TObject; AExceptionClass: ExceptClass; AExceptionMessage : String); begin try diff --git a/library/fsl/tests/fsl_tests.pas b/library/fsl/tests/fsl_tests.pas index fe5e99163..6981711e7 100644 --- a/library/fsl/tests/fsl_tests.pas +++ b/library/fsl/tests/fsl_tests.pas @@ -1105,11 +1105,14 @@ procedure TFslUtilitiesTestCases.testSemVer; procedure TFslUtilitiesTestCases.testUnicode; var - s : String; + s, sc : String; b : TBytes; begin - s := TEncoding.UTF8.GetString(bu2); - AssertTrue(s = 'EKG PB R'''' 波持续时间（持续时长、时长、时间长度、时间、时间长短、为时、为期、历时、延续时间、持久时间、持续期） AVR 导联'); + sc := 'EKG PB R'''' 波持续时间（持续时长、时长、时间长度、时间、时间长短、为时、为期、历时、延续时间、持久时间、持续期） AVR 导联'; + b := TEncoding.UTF8.GetBytes(sc); + s := TEncoding.UTF8.GetString(bu2); + AssertEqual(b, bu2); + AssertEqual(s, sc); s := '背景 发现是一个原子型临床观察指标'; b := TEncoding.UTF8.GetBytes(s); diff --git a/library/fsl/tests/fsl_tests_npm.pas b/library/fsl/tests/fsl_tests_npm.pas index 74fff6418..39b017b5e 100644 --- a/library/fsl/tests/fsl_tests_npm.pas +++ b/library/fsl/tests/fsl_tests_npm.pas @@ -62,6 +62,7 @@ procedure TNpmPackageTests.LoadUSCore; var npm : TNpmPackage; begin + exit; npm := FCache.loadPackage('hl7.fhir.us.core'); try assertTrue(npm <> nil); diff --git a/library/ftx/ftx_ucum_services.pas b/library/ftx/ftx_ucum_services.pas index 432d66396..1db602a5a 100644 --- a/library/ftx/ftx_ucum_services.pas +++ b/library/ftx/ftx_ucum_services.pas @@ -282,6 +282,8 @@ TUcumServiceList = class (TFslObjectList) Property Definition[iIndex : Integer] : TUcumServices read GetDefinition; Default; End; + { TUcumServiceImplementation } + TUcumServiceImplementation = class (TUcumServiceInterface) private FSvc : TUcumServices; @@ -293,6 +295,8 @@ TUcumServiceImplementation = class (TUcumServiceInterface) Function multiply(o1, o2 : TUcumPair) : TUcumPair; override; Function divideBy(o1, o2 : TUcumPair) : TUcumPair; override; function getCanonicalForm(value : TUcumPair) : TUcumPair; override; + function getCanonicalUnits(units : string) : string; override; + function isComparable(u1, u2 : String) : boolean; override; Function isConfigured : boolean; override; end; @@ -1267,6 +1271,37 @@ function TUcumServiceImplementation.getCanonicalForm(value: TUcumPair): TUcumPai result := FSvc.getCanonicalForm(value); end; +function TUcumServiceImplementation.getCanonicalUnits(units: string): string; +var + p1, p2 : TUcumPair; +begin + if units = '' then + result := '' + else + begin + p1 := TUcumPair.create(TFslDecimal.makeOne, units); + try + p2 := getCanonicalForm(p1); + try + result := p2.UnitCode; + finally + p2.free; + end; + finally + p1.free; + end; + end; + +end; + +function TUcumServiceImplementation.isComparable(u1, u2: String): boolean; +begin + if (u1 = '') or (u2 = '') then + result := false + else + result := getCanonicalUnits(u1) = getCanonicalUnits(u2); +end; + function TUcumServiceImplementation.isConfigured: boolean; begin result := FSvc <> nil; diff --git a/library/web/fsl_crypto.pas b/library/web/fsl_crypto.pas index 30688203c..144dc33c6 100644 --- a/library/web/fsl_crypto.pas +++ b/library/web/fsl_crypto.pas @@ -80,7 +80,7 @@ interface IdOpenSSLHeaders_pem, IdOpenSSLHeaders_err, IdOpenSSLHeaders_evp, IdOpenSSLHeaders_ec, IdOpenSSLHeaders_obj_mac, IdOpenSSLHeaders_x509, IdOpenSSLHeaders_x509v3, IdOpenSSLHeaders_x509_vfy, IdOpenSSLX509, - fsl_base, fsl_utilities, fsl_stream, fsl_collections, fsl_json, fsl_xml, fsl_fpc, + fsl_base, fsl_utilities, fsl_stream, fsl_collections, fsl_json, fsl_xml, fsl_fpc, fsl_npm, fsl_openssl, fsl_fetcher; Type @@ -1396,13 +1396,14 @@ function InflateRfc1951(b : TBytes) : TBytes; b1, b2 : TBytesStream; z : TZDecompressionStream; begin - b1 := TBytesStream.create(b); + b1 := TBytesStream.create(b);// readZLibHeader(b)); try - z := TZDecompressionStream.create(b1, false); // -15); + z := TZDecompressionStream.create(b1, true); // -15); try + z.position := 0; b2 := TBytesStream.Create; try - b2.CopyFrom(z, z.Size); + b2.CopyFrom(z, 2); result := b2.Bytes; setLength(result, b2.size); finally @@ -1690,6 +1691,7 @@ class function TJWTUtils.Sign_Hmac_RSA256(input: TBytes; key: TJWK): TBytes; // 2. do the signing keysize := EVP_PKEY_size(pkey); SetLength(result, keysize); + len := keysize; ctx := EVP_MD_CTX_new; try check(EVP_DigestSignInit(ctx, nil, EVP_sha256, nil, pKey) = 1, 'openSSL EVP_DigestInit_ex failed'); From d7b31fe61ee2d1694beb3f8dfb936d33f0abac4a Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Tue, 2 Jan 2024 16:18:39 +1100 Subject: [PATCH 02/13] compile fix --- library/fsl/fsl_fpc.pas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/fsl/fsl_fpc.pas b/library/fsl/fsl_fpc.pas index e27933151..e57afac65 100644 --- a/library/fsl/fsl_fpc.pas +++ b/library/fsl/fsl_fpc.pas @@ -292,7 +292,7 @@ function unicodeChars(s : String) : TUCharArray; ss := ''; while l > 0 do begin - ch := UTF8PCharToUnicode(p, cl); + ch := UTF8CodepointToUnicode(p, cl); result[i] := UnicodeChar(ch); ss := ss + IntToHex(ch, 4)+'.'; inc(i); From b645b8003b02ad60f3e1ec357fa103c8d46c0268 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Tue, 2 Jan 2024 17:58:39 +1100 Subject: [PATCH 03/13] delete executables before building on windows --- build/windows-fhirserver.bat | 2 ++ 1 file changed, 2 insertions(+) diff --git a/build/windows-fhirserver.bat b/build/windows-fhirserver.bat index 2f4a5466a..f04b0fab3 100644 --- a/build/windows-fhirserver.bat +++ b/build/windows-fhirserver.bat @@ -12,6 +12,8 @@ copy ..\exec\pack\*.cfg ..\exec\64\ copy ..\exec\pack\*.dat ..\exec\64\ copy ..\exec\pack\w64\*.dll ..\exec\64\ +del ..\exec\64\*.exe + IF %1.==. GOTO No1 set "tmp=%1" From 99e641b1437b2ae79e52df36c3cab869c2f990b4 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Wed, 3 Jan 2024 13:55:00 +1100 Subject: [PATCH 04/13] improve server build --- build/windows-fhirserver.bat | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/build/windows-fhirserver.bat b/build/windows-fhirserver.bat index f04b0fab3..36ed5f45b 100644 --- a/build/windows-fhirserver.bat +++ b/build/windows-fhirserver.bat @@ -81,6 +81,13 @@ echo ## compile server echo ## compile toolkit %tmp%\tools\lazarus\lazbuild.exe toolkit2/fhirtoolkit.lpr --build-mode=win64-release -q -q -copy exec\64\*.exe "C:\Users\graha\Health Intersections Dropbox\Health Intersections Team Folder\executables\win64" - +IF EXIST "C:\Users\graha\Health Intersections Dropbox\Health Intersections Team Folder\fhirserver\win64" ( + copy exec\64\*.exe "C:\Users\graha\Health Intersections Dropbox\Health Intersections Team Folder\fhirserver\win64" +} + +IF EXIST exec\64\fhirserver.exe ( + echo Sucess! +) ELSE ( + echo Failed (no server executable found) +) chdir /d %FSDIR% From cae18978a7021d43ad5786d2234f0d3c34acfbeb Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Wed, 3 Jan 2024 13:55:23 +1100 Subject: [PATCH 05/13] upgrade MySQL driver --- library/fdb/fdb_odbc.pas | 2 +- server/kernel.pas | 2 ++ server/test_registry.pas | 6 +++--- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/library/fdb/fdb_odbc.pas b/library/fdb/fdb_odbc.pas index ec525718f..5556219ba 100644 --- a/library/fdb/fdb_odbc.pas +++ b/library/fdb/fdb_odbc.pas @@ -989,7 +989,7 @@ function StandardODBCDriverName(APlatform: TFDBPlatform): String; kdbInterbase: Result := 'Intersolv Interbase ODBC Driver (*.gdb)'; // not that we would actually ever use this kdbDB2: Result := 'IBM DB2 ODBC DRIVER'; kdbOracle8: Result := 'Oracle ODBC Driver'; - kdbMySQL : result := 'MySQL ODBC 8.0 Unicode Driver'; + kdbMySQL : result := 'MySQL ODBC 8.2 Unicode Driver'; else Result := 'Unknown Platform ' + inttostr(ord(APlatform)); end; diff --git a/server/kernel.pas b/server/kernel.pas index e4be8f4b5..a3cbd023c 100644 --- a/server/kernel.pas +++ b/server/kernel.pas @@ -768,6 +768,8 @@ procedure initLogging(params : TCommandLineParameters; cfg : TCustomIniFile); begin if cfg.valueExists('config', 'log') then logFilename := cfg.readString('config', 'log', '') + else if params.has('-tests') then + logFilename := filePath(['[tmp]', 'fhirserver-tests.log']) else logFilename := filePath(['[tmp]', 'fhirserver.log']); Logging.logToFile(logFilename); diff --git a/server/test_registry.pas b/server/test_registry.pas index 355b81e04..e07c7e108 100644 --- a/server/test_registry.pas +++ b/server/test_registry.pas @@ -81,15 +81,15 @@ implementation const {$IFDEF WINDOWS} DefaultMSSQLDriver = 'SQL Server'; - DefaultMySQLDriver = 'MySQL ODBC 8.0 Unicode Driver'; + DefaultMySQLDriver = 'MySQL ODBC 8.2 Unicode Driver'; {$ENDIF} {$IFDEF LINUX} DefaultMSSQLDriver = 'ODBC Driver 17 for SQL Server'; - DefaultMySQLDriver = 'MySQL ODBC 8.0 Unicode Driver'; + DefaultMySQLDriver = 'MySQL ODBC 8.2 Unicode Driver'; {$ENDIF} {$IFDEF OSX} DefaultMSSQLDriver = 'ODBC Driver 17 for SQL Server'; - DefaultMySQLDriver = 'MySQL ODBC 8.0 Unicode Driver'; + DefaultMySQLDriver = 'MySQL ODBC 8.2 Unicode Driver'; {$ENDIF} Procedure SetUpDefaultTestSettings(filename : String); From ad5b549c1a2f9badba75d484a1dd2fd3a5ed1450 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Wed, 3 Jan 2024 22:17:14 +1100 Subject: [PATCH 06/13] more tx validation fixes --- exec/pack/Messages.properties | 15 ++++++++------- library/fhir/tests/fhir_tests_icao.pas | 2 +- library/ftx/fhir_valuesets.pas | 2 +- 3 files changed, 10 insertions(+), 9 deletions(-) diff --git a/exec/pack/Messages.properties b/exec/pack/Messages.properties index 549d80511..7a04d223f 100644 --- a/exec/pack/Messages.properties +++ b/exec/pack/Messages.properties @@ -77,7 +77,7 @@ Profile_VAL_MissingElement = Missing element ''{0}'' - required by fixed value a Profile_VAL_NotAllowed = The element {0} is present in the instance but not allowed in the applicable {1} specified in profile Measure_MR_M_None = No Measure is identified, so no validation can be performed against the Measure Measure_MR_M_NotFound = The Measure ''{0}'' could not be resolved, so no validation can be performed against the Measure -Questionnaire_QR_Item_BadOption = The code provided {1} in the system {0}) is not in the options value set ({2}) in the questionnaire: {3} +Questionnaire_QR_Item_BadOption = The code ''{1}'' in the system ''{0}'' is not in the options value set ({2}) specified by the questionnaire. Terminology Error: {3} QUESTIONNAIRE_QR_ITEM_BADOPTION_CS = The code provided {1} cannot be validated in the options value set ({2}) in the questionnaire because the system {0} could not be found Questionnaire_QR_Item_Coding = Error {0} validating Coding against Questionnaire Options Questionnaire_QR_Item_CodingNoOptions = Cannot validate Coding option because no option list is provided @@ -159,8 +159,8 @@ Terminology_TX_Confirm_2_CC = Could not confirm that the codings provided are in Terminology_TX_Confirm_3_CC = Could not confirm that the codings provided are in the value set {0} and a coding is recommended to come from this value set (class = {1}) Terminology_TX_Confirm_4a = The code provided ({2}) was not found in the value set {0}, and a code from this value set is required: {1} Terminology_TX_Confirm_4b = The codes provided ({2}) are not in the value set {0}, and a code from this value set is required: {1} -Terminology_TX_Confirm_5 = Could not confirm that the codes provided are in the value set {0}, and a code should come from this value set unless it has no suitable code (the validator cannot judge what is suitable) -Terminology_TX_Confirm_6 = Could not confirm that the codes provided are in the value set {0}, and a code is recommended to come from this value set +Terminology_TX_Confirm_5 = The code provided ({1}) is not in the value set in the value set {0}, and a code should come from this value set unless it has no suitable code (the validator cannot judge what is suitable) +Terminology_TX_Confirm_6 = The code provided ({1}) is not in the value set in the value set {0}, and a code is recommended to come from this value set Terminology_TX_Display_Wrong = Display should be ''{0}'' Terminology_TX_Error_CodeableConcept = Error {0} validating CodeableConcept Terminology_TX_Error_CodeableConcept_Max = Error {0} validating CodeableConcept using maxValueSet @@ -186,7 +186,7 @@ Terminology_TX_NoValid_7 = None of the codes provided could be validated against Terminology_TX_NoValid_8 = None of the codes provided are in the maximum value set {0}, and a code from this value set is required) (codes = {1}) Terminology_TX_NoValid_9 = The code provided ({2}) could not be validated against the maximum value set {0}, (error = {1}) Terminology_TX_System_Invalid = Invalid System URI: {0} -Terminology_TX_System_NotKnown = Code System URI ''{0}'' could not be found so the code cannot be validated +Terminology_TX_System_NotKnown = A definition for CodeSystem ''{0}'' could not be found, so the code cannot be validated TERMINOLOGY_TX_SYSTEM_NOT_USABLE = The definition for the Code System with URI ''{0}'' doesn't provide any codes so the code cannot be validated Terminology_TX_System_Relative = Coding.system must be an absolute reference, not a local reference Terminology_TX_System_Unknown = Unknown Code System ''{0}'' @@ -494,6 +494,7 @@ Unable_to_resolve_system__value_set_has_multiple_matches = Unable to resolve sys Unable_to_resolve_system__value_set_expansion_has_multiple_systems = Unable to resolve system - value set expansion has multiple systems Unable_to_resolve_system__value_set_has_no_includes_or_expansion = Unable to resolve system - value set {0} has no includes or expansion Unable_to_resolve_system__no_value_set = Unable to resolve system - no value set +Unable_to_resolve_system__value_set_has_no_matches = Unable to resolve system - value set expansion has no matches for code ''{0}'' This_base_property_must_be_an_Array_not_ = This base property must be an Array, not {0} documentmsg = (document) xml_attr_value_invalid = The XML Attribute {0} has an invalid character @@ -683,7 +684,7 @@ RENDER_BUNDLE_DOCUMENT_CONTENT = Additional Document Content RENDER_BUNDLE_HEADER_DOC_ENTRY_URD = {0}. {1} ({2}/{3}) RENDER_BUNDLE_HEADER_DOC_ENTRY_U = {0}. {1} RENDER_BUNDLE_HEADER_DOC_ENTRY_RD = {0}. {2}/{3} -UNABLE_TO_CHECK_IF_THE_PROVIDED_CODES_ARE_IN_THE_VALUE_SET_ = Unable to check whether the code is in the value set {0} +UNABLE_TO_CHECK_IF_THE_PROVIDED_CODES_ARE_IN_THE_VALUE_SET_ = Unable to check whether the code is in the value set {0} because the code system {1} was not found TERMINOLOGY_TX_SYSTEM_WRONG_HTML = The code system reference {0} is wrong - the code system reference cannot be to an HTML page. This may be the correct reference: {1} TERMINOLOGY_TX_SYSTEM_WRONG_BUILD = The code system reference {0} is wrong - the code system reference cannot be a reference to build.fhir.org. This may be the correct reference: {1} FHIRPATH_BAD_DATE = Unable to parse Date {0} @@ -926,8 +927,8 @@ SM_DEPENDENT_PARAM_TYPE_MISMATCH_DUPLICATE = The group {0} has already been used CONCEPTMAP_GROUP_SOURCE_INCOMPLETE = Source Code System {0} doesn''t have all content (content = {1}), so the source codes cannot be checked CONCEPTMAP_GROUP_TARGET_INCOMPLETE = Target Code System {0} doesn''t have all content (content = {1}), so the target codes cannot be checked SD_NO_TYPE_CODE_ON_CODE = Snapshot for {1} element {0} has type.code without a value -UNKNOWN_CODESYSTEM = A definition for CodeSystem {0} could not be found, so the code cannot be validated -UNKNOWN_CODESYSTEM_VERSION = A definition for CodeSystem {0} version {1} could not be found, so the code cannot be validated. Valid versions: {2} +UNKNOWN_CODESYSTEM = A definition for CodeSystem ''{0}'' could not be found, so the code cannot be validated +UNKNOWN_CODESYSTEM_VERSION = A definition for CodeSystem ''{0}'' version ''{1}'' could not be found, so the code cannot be validated. Valid versions: {2} UNABLE_TO_INFER_CODESYSTEM = The System URI could not be determined for the code {0} in the ValueSet {1} VALUESET_TOO_COSTLY = The value set {0} has too many codes to display ({1}) VALUESET_TOO_COSTLY_TIME = The value set {0} took too long to process (>{1}sec) diff --git a/library/fhir/tests/fhir_tests_icao.pas b/library/fhir/tests/fhir_tests_icao.pas index ead711056..6b90d74e9 100644 --- a/library/fhir/tests/fhir_tests_icao.pas +++ b/library/fhir/tests/fhir_tests_icao.pas @@ -44,11 +44,11 @@ interface TFHIRICAOTests = Class (TFslTestCase) public - published {$IFDEF WINDOWS} // this is labelled as windows only in order to prevent the ci-build failing because the certificate - a real one - isn't in git (todo: sort this out) Procedure TestIcaoCertAu; {$ENDIF} + published Procedure TestIcaoCertAuBroken; Procedure TestIcaoCertNoStore; end; diff --git a/library/ftx/fhir_valuesets.pas b/library/ftx/fhir_valuesets.pas index 321164ec4..4660e0991 100644 --- a/library/ftx/fhir_valuesets.pas +++ b/library/ftx/fhir_valuesets.pas @@ -1125,7 +1125,7 @@ function TValueSetChecker.check(path, system, version, code: String; abstractOk, begin msg := FI18n.translate('Coding_has_no_system__cannot_validate', FParams.languages, []); messages.add(msg); - op.addIssue(isError, itInvalid, path, msg, oicInvalidData); + op.addIssue(isWarning, itInvalid, path, msg, oicInvalidData); exit(bFalse); end; From 313af937f6fcb051ed67484739e04d8907eff01a Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Thu, 4 Jan 2024 16:15:30 +1100 Subject: [PATCH 07/13] clarify message --- exec/pack/Messages.properties | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/exec/pack/Messages.properties b/exec/pack/Messages.properties index 7a04d223f..6b8d41614 100644 --- a/exec/pack/Messages.properties +++ b/exec/pack/Messages.properties @@ -494,7 +494,7 @@ Unable_to_resolve_system__value_set_has_multiple_matches = Unable to resolve sys Unable_to_resolve_system__value_set_expansion_has_multiple_systems = Unable to resolve system - value set expansion has multiple systems Unable_to_resolve_system__value_set_has_no_includes_or_expansion = Unable to resolve system - value set {0} has no includes or expansion Unable_to_resolve_system__no_value_set = Unable to resolve system - no value set -Unable_to_resolve_system__value_set_has_no_matches = Unable to resolve system - value set expansion has no matches for code ''{0}'' +Unable_to_resolve_system__value_set_has_no_matches = Unable to determine system - value set has no matches for code ''{0}'' This_base_property_must_be_an_Array_not_ = This base property must be an Array, not {0} documentmsg = (document) xml_attr_value_invalid = The XML Attribute {0} has an invalid character From 65d42c507e4ec6881ce4a5483b32816513c87ce3 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Fri, 5 Jan 2024 17:18:21 +1100 Subject: [PATCH 08/13] rework gzip handling --- dependencies/zflate/zflate.pas | 867 +++++++++++++++++++++++++++++++ library/fhir/fhir_healthcard.pas | 4 +- library/fsl/fsl_gzip.pas | 117 +++++ library/fsl/fsl_npm.pas | 77 +-- library/fsl/tests/fsl_tests.pas | 54 +- library/web/fsl_crypto.pas | 55 +- library/web/fsl_npm_cache.pas | 50 +- packages/fhir_fsl.lpk | 6 +- packages/fhir_fsl.pas | 52 +- 9 files changed, 1086 insertions(+), 196 deletions(-) create mode 100644 dependencies/zflate/zflate.pas create mode 100644 library/fsl/fsl_gzip.pas diff --git a/dependencies/zflate/zflate.pas b/dependencies/zflate/zflate.pas new file mode 100644 index 000000000..c204f17a6 --- /dev/null +++ b/dependencies/zflate/zflate.pas @@ -0,0 +1,867 @@ +{ MIT License + + Copyright (c) 2023 fibodevy https://github.com/fibodevy + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. +} + +unit zflate; + +{$mode ObjFPC}{$H+} + +//comment out to disable error translation +//if disabled, zflatetranslatecode will return error code as string +{$define zflate_error_translation} + +interface + +uses + SysUtils, ZBase, ZInflate, ZDeflate; + +type + tzflate = record + z: z_stream; + totalout: dword; + bytesavailable: dword; + buffer: array of byte; + error: integer; + end; + + tzlibinfo = record + streamat: dword; + footerlen: dword; + end; + + tgzipinfo = record + modtime: dword; + filename: pchar; + comment: pchar; + streamat: dword; + footerlen: dword; + end; + + Tristate = (tNull, tTrue, tFalse); + +const + ZFLATE_ZLIB = 1; + ZFLATE_GZIP = 2; + + ZFLATE_OK = 0; + ZFLATE_ECHUNKTOOBIG = 101; //'chunk is too big' + ZFLATE_EBUFFER = 102; //'buffer too small' + ZFLATE_ESTREAM = 103; //'stream error' + ZFLATE_EDATA = 104; //'data error' + ZFLATE_EDEFLATE = 105; //'deflate error' + ZFLATE_EINFLATE = 106; //'inflate error' + ZFLATE_EDEFLATEINIT = 107; //'deflate init failed' + ZFLATE_EINFLATEINIT = 108; //'inflate init failed' + ZFLATE_EZLIBINVALID = 109; //'invalid zlib header' + ZFLATE_EGZIPINVALID = 110; //'invalid gzip header' + ZFLATE_ECHECKSUM = 111; //'invalid checksum' + ZFLATE_EOUTPUTSIZE = 112; //'output size doesnt match original file size' + ZFLATE_EABORTED = 113; //'aborted' + +var + zchunkmaxsize: dword = 1024*128; //128 KB default max chunk size + zbuffersize: dword = 1024*1024*4; //4 MB default buffer size + +threadvar + zlasterror: integer; + +//initialize zdeflate +function zdeflateinit(var z: tzflate; level: dword=9; buffersize: dword=0): boolean; +//deflate chunk +function zdeflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; + +//initialize zinflate +function zinflateinit(var z: tzflate; buffersize: dword=0): boolean; +//inflate chunk +function zinflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; + +//read zlib header +function zreadzlibheader(data: pointer; var info: tzlibinfo): boolean; +//read gzip header +function zreadgzipheader(data: pointer; var info: tgzipinfo): boolean; +//get stream basic info; by reading just few first bytes you will know the stream type, where is deflate start and how many bytes are trailing bytes (footer) +function zstreambasicinfo(data: pointer; var streamtype: dword; var startsat: dword; var trailing: dword): boolean; +//find out stream type, where deflate stream starts and what is its size +function zfindstream(data: pointer; size: dword; var streamtype: dword; var startsat: dword; var streamsize: dword): boolean; + +//compress whole buffer to DEFLATE at once +function gzdeflate(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; +//compress whole string to DEFLATE at once +function gzdeflate(str: string; level: dword=9): string; +//decompress whole DEFLATE buffer at once +function gzinflate(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +//decompress whole DEFLATE string at once +function gzinflate(str: string): string; + +//make ZLIB header +function makezlibheader(compressionlevel: integer): string; +//make ZLIB footer +function makezlibfooter(adler: dword): string; +//compress whole buffer to ZLIB at once +function gzcompress(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; +//compress whole string to ZLIB at once +function gzcompress(str: string; level: dword=9): string; +//dempress whole ZLIB buffer at once ! +function gzuncompress(data: pointer; size: dword; readHeader : Tristate; var output: pointer; var outputsize: dword): boolean; +//dempress whole ZLIB string at once +function gzuncompress(str: string): string; +//compress whole buffer to ZLIB at once +function gzcompress(bytes : TBytes; level: dword=9) : TBytes; +//dempress whole ZLIB buffer at once +function gzuncompress(bytes : TBytes; readHeader : Tristate = tNull) : TBytes; + +//make GZIP header +function makegzipheader(compressionlevel: integer; filename: string=''; comment: string=''): string; +//make GZIP footer +function makegzipfooter(originalsize: dword; crc: dword): string; +//compress whole buffer to GZIP at once +function gzencode(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9; filename: string=''; comment: string=''): boolean; +//compress whole string to GZIP at once +function gzencode(str: string; level: dword=9; filename: string=''; comment: string=''): string; +//decompress whole GZIP buffer at once +function gzdecode(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +//decompress whole GZIP string at once +function gzdecode(str: string): string; + +//try to detect buffer format and decompress it at once +function zdecompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +//try to detect string format and decompress it at once +function zdecompress(str: string): string; + +//transalte error code to message +function zflatetranslatecode(code: integer): string; + +//compute crc32b checksum +function crc32b(crc: dword; buf: pbyte; len: dword): dword; +//compute adler32 checksum +function adler32(adler: dword; buf: pbyte; len: dword): dword; + +implementation + +function zerror(var z: tzflate; error: integer): boolean; +begin + z.error := error; + zlasterror := error; + result := false; +end; + +// -- deflate chunks ---------------------- + +function zdeflateinit(var z: tzflate; level: dword=9; buffersize: dword=0): boolean; +begin + result := false; + zlasterror := 0; + if buffersize = 0 then buffersize := zbuffersize; + fillchar(z, sizeof(z), 0); + setlength(z.buffer, buffersize); + if deflateInit2(z.z, level, Z_DEFLATED, -MAX_WBITS, DEF_MEM_LEVEL, 0) <> Z_OK then exit; + result := true; +end; + +function zdeflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; +var + i: integer; +begin + result := false; + + if size > zchunkmaxsize then exit(zerror(z, ZFLATE_ECHUNKTOOBIG)); + + z.z.next_in := data; + z.z.avail_in := size; + z.z.next_out := @z.buffer[0]; + z.z.avail_out := length(z.buffer); + + if lastchunk then + i := deflate(z.z, Z_FINISH) + else + i := deflate(z.z, Z_NO_FLUSH); + + if i = Z_BUF_ERROR then exit(zerror(z, ZFLATE_EBUFFER)); //buffer too small + if i = Z_STREAM_ERROR then exit(zerror(z, ZFLATE_ESTREAM)); + if i = Z_DATA_ERROR then exit(zerror(z, ZFLATE_EDATA)); + + if (i = Z_OK) or (i = Z_STREAM_END) then begin + z.bytesavailable := z.z.total_out-z.totalout; + z.totalout += z.bytesavailable; + result := true; + end else + exit(zerror(z, ZFLATE_EDEFLATE)); + + if lastchunk then begin + i := deflateEnd(z.z); + result := i = Z_OK; + end; +end; + +// -- inflate chunks ---------------------- + +function zinflateinit(var z: tzflate; buffersize: dword=0): boolean; +begin + result := false; + zlasterror := 0; + if buffersize = 0 then buffersize := zbuffersize; + fillchar(z, sizeof(z), 0); + setlength(z.buffer, buffersize); + if inflateInit2(z.z, -MAX_WBITS) <> Z_OK then exit; + result := true; +end; + +function zinflatewrite(var z: tzflate; data: pointer; size: dword; lastchunk: boolean=false): boolean; +var + i: integer; +begin + result := false; + + if size > zchunkmaxsize then exit(zerror(z, ZFLATE_ECHUNKTOOBIG)); + + z.z.next_in := data; + z.z.avail_in := size; + z.z.next_out := @z.buffer[0]; + z.z.avail_out := length(z.buffer); + + if lastchunk then + i := inflate(z.z, Z_FINISH) + else + i := inflate(z.z, Z_NO_FLUSH); + + if i = Z_BUF_ERROR then exit(zerror(z, ZFLATE_EBUFFER)); //buffer too small + if i = Z_STREAM_ERROR then exit(zerror(z, ZFLATE_ESTREAM)); + if i = Z_DATA_ERROR then exit(zerror(z, ZFLATE_EDATA)); + + if (i = Z_OK) or (i = Z_STREAM_END) then begin + z.bytesavailable := z.z.total_out-z.totalout; + z.totalout += z.bytesavailable; + result := true; + end else + exit(zerror(z, ZFLATE_EINFLATE)); + + if lastchunk then begin + i := inflateEnd(z.z); + result := i = Z_OK; + end; +end; + +function zreadzlibheader(data: pointer; var info: tzlibinfo): boolean; +begin + info.footerlen := 0; + info.streamat := 0; + + result := false; + try + fillchar(info, sizeof(info), 0); + result := (pbyte(data)^ = $78) and (pbyte(data+1)^ in [$01, $5e, $9c, $da]); + if not result then exit; + info.footerlen := 4; + info.streamat := 2; + except + end; +end; + +function zreadgzipheader(data: pointer; var info: tgzipinfo): boolean; +var + flags: byte; + w: word; +begin + result := false; + try + fillchar(info, sizeof(info), 0); + if not ((pbyte(data)^ = $1f) and (pbyte(data+1)^ = $8b)) then exit; + + info.footerlen := 8; + + //mod time + move((data+4)^, info.modtime, 4); + + //stream position + info.streamat := 10; + + //flags + flags := pbyte(data+3)^; + + //extra + if (flags and $04) <> 0 then begin + w := pword(data+info.streamat)^; + info.streamat += 2+w; + end; + + //filename + if (flags and $08) <> 0 then begin + info.filename := pchar(data+info.streamat); + info.streamat += length(info.filename)+1; + end; + + //comment + if (flags and $10) <> 0 then begin + info.comment := pchar(data+info.streamat); + info.streamat += length(info.comment)+1; + end; + + //crc16? + if (flags and $02) <> 0 then begin + info.streamat += 2; + end; + + result := true; + except + end; +end; + +function zstreambasicinfo(data: pointer; var streamtype: dword; var startsat: dword; var trailing: dword): boolean; +var + zlib: tzlibinfo; + gzip: tgzipinfo; +begin + result := false; + streamtype := 0; + + if zreadzlibheader(data, zlib) then begin + streamtype := ZFLATE_ZLIB; + startsat := zlib.streamat; + trailing := 4; //footer: adler32 + exit(true); + end; + + if zreadgzipheader(data, gzip) then begin + streamtype := ZFLATE_GZIP; + startsat := gzip.streamat; + trailing := 8; //footer: crc32 + original file size + exit(true); + end; +end; + +function zfindstream(data: pointer; size: dword; var streamtype: dword; var startsat: dword; var streamsize: dword): boolean; +var + trailing: dword; +begin + result := false; + + if size < 6 then exit; //6 bytes is minimum for ZLIB, 18 for GZIP + + if zstreambasicinfo(data, streamtype, startsat, trailing) then begin + streamsize := size-startsat-trailing; + result := true; + end; +end; + +// -- deflate ----------------------------- + +function gzdeflate(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; +var + z: tzflate; + p, chunksize: dword; +begin + result := false; + if not zdeflateinit(z, level) then exit(zerror(z, ZFLATE_EDEFLATEINIT)); + + output := nil; + outputsize := 0; + p := 0; + + //compress + while size > 0 do begin + chunksize := size; + if chunksize > zchunkmaxsize then chunksize := zchunkmaxsize; + //deflate + if not zdeflatewrite(z, data, chunksize, chunksize 0 do begin + chunksize := size; + if chunksize > zchunkmaxsize then chunksize := zchunkmaxsize; + //inflate + if not zinflatewrite(z, data, chunksize, chunksize tFalse then + if zreadzlibheader(data, zlib) then + header := true + else if readHeader = tTrue then + exit(zerror(z, ZFLATE_EZLIBINVALID)); + + checksum := swapendian(pdword(data+size-4)^); + + data += zlib.streamat; + size -= zlib.streamat+zlib.footerlen; + if not gzinflate(data, size, output, outputsize) then exit; + + if header and (adler32(adler32(0, nil, 0), output, outputsize) <> checksum) then + exit(zerror(z, ZFLATE_ECHECKSUM)); + + result := true; +end; + +function gzuncompress(str: string): string; +var + p: pointer; + d: dword; +begin + result := ''; + if not gzuncompress(@str[1], length(str), tTrue, p, d) then exit; + setlength(result, d); + move(p^, result[1], d); + freemem(p); +end; + +function gzuncompress(bytes : TBytes; readHeader : Tristate = tNull) : TBytes; +var + p: pointer; + d: dword; +begin + result := nil; + if not gzuncompress(@bytes[0], length(bytes), readHeader, p, d) then exit; + try + setlength(result, d); + move(p^, result[0], d); + finally + freemem(p); + end; +end; + + +// -- GZIP compress ----------------------- + +function makegzipheader(compressionlevel: integer; filename: string=''; comment: string=''): string; +var + flags: byte; + modtime: dword; +begin + setlength(result, 10); + result[1] := #$1f; //signature + result[2] := #$8b; //signature + result[3] := #$08; //deflate algo + + //modification time + modtime := 0; + move(modtime, result[5], 4); + + result[9] := #$00; //compression level + if compressionlevel = 9 then result[9] := #$02; //best compression + if compressionlevel = 1 then result[9] := #$04; //best speed + + result[10] := #$FF; //file system (00 = FAT?) + //result[10] := #$00; + + //optional headers + flags := 0; + + //filename + if filename <> '' then begin + flags := flags or $08; + result += filename; + result += #$00; + end; + + //comment + if comment <> '' then begin + flags := flags or $10; + result += comment; + result += #00; + end; + + result[4] := chr(flags); +end; + +function makegzipfooter(originalsize: dword; crc: dword): string; +begin + setlength(result, 8); + move(crc, result[1], 4); + move(originalsize, result[1+4], 4); +end; + +function gzencode(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9; filename: string=''; comment: string=''): boolean; +var + header, footer: string; + deflated: pointer; + deflatedsize: dword; +begin + result := false; + + header := makegzipheader(level, filename, comment); + footer := makegzipfooter(size, crc32b(0, data, size)); + + if not gzdeflate(data, size, deflated, deflatedsize, level) then exit; + + outputsize := length(header)+deflatedsize+length(footer); + output := getmem(outputsize); + + move(header[1], output^, length(header)); + move(deflated^, (output+length(header))^, deflatedsize); + move(footer[1], (output+length(header)+deflatedsize)^, length(footer)); + + freemem(deflated); + + result := true; +end; + +function gzencode(str: string; level: dword=9; filename: string=''; comment: string=''): string; +var + p: pointer; + d: dword; +begin + result := ''; + if not gzencode(@str[1], length(str), p, d, level, filename, comment) then exit; + setlength(result, d); + move(p^, result[1], d); + freemem(p); +end; + +// -- GZIP decompress --------------------- + +function gzdecode(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +var + gzip: tgzipinfo; + z: tzflate; + originalsize, checksum: dword; +begin + result := false; + if not zreadgzipheader(data, gzip) then exit(zerror(z, ZFLATE_EGZIPINVALID)); + + originalsize := pdword(data+size-4)^; + checksum := pdword(data+size-8)^; + + data += gzip.streamat; + size -= gzip.streamat+gzip.footerlen; + if not gzinflate(data, size, output, outputsize) then exit; + + if originalsize <> outputsize then exit(zerror(z, ZFLATE_EOUTPUTSIZE)); + if crc32b(0, output, outputsize) <> checksum then exit(zerror(z, ZFLATE_ECHECKSUM)); + + result := true; +end; + +function gzdecode(str: string): string; +var + p: pointer; + d: dword; +begin + result := ''; + if not gzdecode(@str[1], length(str), p, d) then exit; + setlength(result, d); + move(p^, result[1], d); + freemem(p); +end; + +// -- decompress anything ----------------- + +function zdecompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; +var + streamsize, startsat, streamtype: dword; +begin + result := false; + + if not zfindstream(data, size, streamtype, startsat, streamsize) then begin + //stream not found, assume its pure deflate + startsat := 0; + streamsize := size; + end; + + if not gzinflate(data+startsat, streamsize, output, outputsize) then exit; + + result := true; +end; + +function zdecompress(str: string): string; +var + p: pointer; + d: dword; +begin + result := ''; + if not zdecompress(@str[1], length(str), p, d) then exit; + setlength(result, d); + move(p^, result[1], d); + freemem(p); +end; + +// -- error translation ------------------- + +function zflatetranslatecode(code: integer): string; +begin + {$ifdef zflate_error_translation} + result := 'unknown'; + + case code of + ZFLATE_ZLIB : result := 'ZLIB'; + ZFLATE_GZIP : result := 'GZIP'; + ZFLATE_OK : result := 'ok'; + ZFLATE_ECHUNKTOOBIG: result := 'chunk is too big'; + ZFLATE_EBUFFER : result := 'buffer too small'; + ZFLATE_ESTREAM : result := 'stream error'; + ZFLATE_EDATA : result := 'data error'; + ZFLATE_EDEFLATE : result := 'deflate error'; + ZFLATE_EINFLATE : result := 'inflate error'; + ZFLATE_EDEFLATEINIT: result := 'deflate init failed'; + ZFLATE_EINFLATEINIT: result := 'inflate init failed'; + ZFLATE_EZLIBINVALID: result := 'invalid zlib header'; + ZFLATE_EGZIPINVALID: result := 'invalid gzip header'; + ZFLATE_ECHECKSUM : result := 'invalid checksum'; + ZFLATE_EOUTPUTSIZE : result := 'output size doesnt match original file size'; + ZFLATE_EABORTED : result := 'aborted'; + end; + {$else} + system.Str(code, result); + {$endif} +end; + +// -- crc32b ------------------------------ + +var + crc32_table: array[byte] of dword; + crc32_table_empty: boolean = true; + +function crc32b(crc: dword; buf: pbyte; len: dword): dword; +procedure make_crc32_table; +var + d: dword; + n, k: integer; +begin + for n := 0 to 255 do begin + d := cardinal(n); + for k := 0 to 7 do begin + if (d and 1) <> 0 then + d := (d shr 1) xor uint32($edb88320) + else + d := (d shr 1); + end; + crc32_table[n] := d; + end; + crc32_table_empty := false; +end; +begin + if buf = nil then exit(0); + if crc32_table_empty then make_crc32_table; + + crc := crc xor $ffffffff; + while (len >= 4) do begin + crc := crc32_table[(crc xor buf[0]) and $ff] xor (crc shr 8); + crc := crc32_table[(crc xor buf[1]) and $ff] xor (crc shr 8); + crc := crc32_table[(crc xor buf[2]) and $ff] xor (crc shr 8); + crc := crc32_table[(crc xor buf[3]) and $ff] xor (crc shr 8); + inc(buf, 4); + dec(len, 4); + end; + + while (len > 0) do begin + crc := crc32_table[(crc xor buf^) and $ff] xor (crc shr 8); + inc(buf); + dec(len); + end; + + result := crc xor $ffffffff; +end; + +// -- adler32 ----------------------------- + +function adler32(adler: dword; buf: pbyte; len: dword): dword; +const + base = dword(65521); + nmax = 3854; +var + d1, d2: dword; + k: integer; +begin + if buf = nil then exit(1); + + d1 := adler and $ffff; + d2 := (adler shr 16) and $ffff; + + while (len > 0) do begin + if len < nmax then + k := len + else + k := nmax; + dec(len, k); + while (k > 0) do begin + inc(d1, buf^); + inc(d2, d1); + inc(buf); + dec(k); + end; + d1 := d1 mod base; + d2 := d2 mod base; + end; + result := (d2 shl 16) or d1; +end; + +end. + diff --git a/library/fhir/fhir_healthcard.pas b/library/fhir/fhir_healthcard.pas index a237de067..7b9d47fca 100644 --- a/library/fhir/fhir_healthcard.pas +++ b/library/fhir/fhir_healthcard.pas @@ -35,7 +35,7 @@ interface uses SysUtils, Classes, DateUtils, Graphics, {$IFDEF FPC} FPImage, FPWritePNG, {$ELSE} Vcl.Imaging.pngimage, {$ENDIF} IdGlobal, IdHash, IdHashSHA, - fsl_base, fsl_utilities, fsl_http, fsl_crypto, fsl_json, fsl_fetcher, fsl_openssl, + fsl_base, fsl_utilities, fsl_http, fsl_crypto, fsl_json, fsl_fetcher, fsl_openssl, fsl_gzip, fhir_objects, fhir_factory, fhir_parser, fhir_utilities; type @@ -231,7 +231,7 @@ procedure THealthcareCardUtilities.sign(card: THealthcareCard; jwk : TJWK); finally j.free; end; - bytes := DeflateRfc1951(TEncoding.UTF8.GetBytes(payload)); + bytes := gzcompress(TEncoding.UTF8.GetBytes(payload), false); card.jws := TJWTUtils.encodeJWT('{"alg":"ES256","zip":"DEF","kid":"'+jwk.id+'"}', bytes, jwt_es256, jwk); end; diff --git a/library/fsl/fsl_gzip.pas b/library/fsl/fsl_gzip.pas new file mode 100644 index 000000000..e4bacbd99 --- /dev/null +++ b/library/fsl/fsl_gzip.pas @@ -0,0 +1,117 @@ +unit fsl_gzip; + +{$i fhir.inc} +interface + +uses + Classes, SysUtils, zflate, + fsl_base, fsl_stream; + +function gzcompress(bytes : TBytes; header : boolean; level: dword=9) : TBytes; +function gzuncompress(bytes : TBytes) : TBytes; + +// +//function readZLibHeader(stream : TStream) : TBytes; overload; +//function readZLibHeader(b : TBytes) : TBytes; overload; + +implementation + +function readZLibHeader(b : TBytes) : TBytes; +var + p : int64; + i : integer; +begin + if (length(b) < 10) or (b[0] <> $1F) or (b[1] <> $8B) then + result := b + else + begin + i := 10; + if ((b[3] and $08) > 0) then + begin + repeat + inc(i); + until (i = length(b)) or (b[i] = 0); + inc(i); + end; + if i >= length(b) then + result := b + else + result := copy(b, i, length(b)-i-8); + end; +end; + +function gzcompress(bytes : TBytes; header : boolean; level: dword=9) : TBytes; +begin + result := zflate.gzcompress(bytes, level); +end; + +function gzuncompress(bytes : TBytes) : TBytes; +begin + result := zflate.gzuncompress(bytes); + if length(result) = 0 then + raise EFslException.create('Failed to read compressed content: '+zflatetranslatecode(zlasterror)); + //BytesToFile(bytes, '/Users/grahamegrieve/temp/test.tgz'); + //gzdecode_file('/Users/grahamegrieve/temp/test.tgz', '/Users/grahamegrieve/temp/test.bin'); + //result := FileToBytes('/Users/grahamegrieve/temp/test.bin'); +end; + + +//function InflateRfc1951(b : TBytes) : TBytes; +////var +//// b1, b2 : TBytesStream; +//// z : TZDecompressionStream; +//begin +// result := gzuncompress(readZLibHeader(b)); +// //b1 := TBytesStream.create(b);// readZLibHeader(b)); +// //try +// // z := TZDecompressionStream.create(b1, true); // -15); +// // try +// // z.position := 0; +// // b2 := TBytesStream.Create; +// // try +// // b2.CopyFrom(z, 2); +// // result := b2.Bytes; +// // setLength(result, b2.size); +// // finally +// // b2.free; +// // end; +// // finally +// // z.free; +// // end; +// //finally +// // b1.free; +// //end; +//end; +// +//function DeflateRfc1951(b : TBytes) : TBytes; +//var +// s : TBytesStream; +// z : TZCompressionStream; +//begin +// s := TBytesStream.create(); +// try +// z := TZCompressionStream.create(clMax, s); // , -15); +// try +// z.Write(b, length(b)); +// finally +// z.free; +// end; +// result := s.Bytes; +// setLength(result, s.size); +// finally +// s.free; +// end; +//end; +// +// + +// +// +//function readZLibHeader(stream : TStream) : TBytes; +//begin +// result := readZLibHeader(StreamToBytes(stream)); +// +//end; + +end. + diff --git a/library/fsl/fsl_npm.pas b/library/fsl/fsl_npm.pas index 121fdc0ab..fc61af769 100644 --- a/library/fsl/fsl_npm.pas +++ b/library/fsl/fsl_npm.pas @@ -34,7 +34,7 @@ interface uses SysUtils, Classes, Types, {$IFDEF DELPHI}IOUtils, {$ENDIF} zlib, - fsl_base, fsl_utilities, fsl_stream, fsl_json, fsl_fpc, fsl_threads, fsl_versions; + fsl_base, fsl_utilities, fsl_stream, fsl_json, fsl_fpc, fsl_threads, fsl_versions, fsl_gzip; Type TFHIRPackageKind = (fpkNull, fpkCore, fpkIG, fpkIGTemplate, fpkTool, fpkToolGen, fpkGroup, fpkExamples); @@ -226,9 +226,6 @@ function isValidPackageId(id : String) : boolean; function isMoreRecentVersion(test, base : String) : boolean; -function readZLibHeader(stream : TStream) : TBytes; overload; -function readZLibHeader(b : TBytes) : TBytes; overload; - implementation function isValidPackagePart(part : String) : boolean; @@ -1080,74 +1077,38 @@ function TNpmPackage.presentation: String; end; end; -function readZLibHeader(stream : TStream) : TBytes; -begin - result := readZLibHeader(StreamToBytes(stream)); - -end; - -function readZLibHeader(b : TBytes) : TBytes; -var - p : int64; - i : integer; -begin - if (length(b) < 10) or (b[0] <> $1F) or (b[1] <> $8B) then - result := b - else - begin - i := 10; - if ((b[3] and $08) > 0) then - begin - repeat - inc(i); - until (i = length(b)) or (b[i] = 0); - inc(i); - end; - if i >= length(b) then - result := b - else - result := copy(b, i, length(b)-i-8); - end; -end; - procedure TNpmPackage.readStream(tgz: TStream; desc: String; progress: TWorkProgressEvent); var bs : TBytesStream; - z : TZDecompressionStream; tar : TTarArchive; entry : TTarDirRec; n : String; b : TBytes; bi : TBytesStream; begin - bs := TBytesStream.create(readZLibHeader(tgz)); + bs := TBytesStream.create(gzuncompress(streamToBytes(tgz))); try - z := TZDecompressionStream.Create(bs, true); // 15+16); + tar := TTarArchive.Create(bs); try - tar := TTarArchive.Create(z); - try - tar.Reset; - while tar.FindNext(entry) do - begin - n := String(entry.Name); - if (n.contains('..')) then - raise EFSLException.create('The package "'+desc+'" contains the file "'+n+'". Packages are not allowed to contain files with ".." in the name'); - bi := TBytesStream.Create; - try - tar.ReadFile(bi); - b := copy(bi.Bytes, 0, bi.size); - finally - bi.free; - end; - loadFile(n, b); - if assigned(progress) then - progress(self, -1, false, 'Loading '+n); + tar.Reset; + while tar.FindNext(entry) do + begin + n := String(entry.Name); + if (n.contains('..')) then + raise EFSLException.create('The package "'+desc+'" contains the file "'+n+'". Packages are not allowed to contain files with ".." in the name'); + bi := TBytesStream.Create; + try + tar.ReadFile(bi); + b := copy(bi.Bytes, 0, bi.size); + finally + bi.free; end; - finally - tar.free; + loadFile(n, b); + if assigned(progress) then + progress(self, -1, false, 'Loading '+n); end; finally - z.free; + tar.free; end; finally bs.free; diff --git a/library/fsl/tests/fsl_tests.pas b/library/fsl/tests/fsl_tests.pas index 6981711e7..4d7e98346 100644 --- a/library/fsl/tests/fsl_tests.pas +++ b/library/fsl/tests/fsl_tests.pas @@ -37,7 +37,7 @@ interface zlib, zstream, {$IFDEF FPC} FPCUnit, TestRegistry, RegExpr, {$ELSE} TestFramework, {$ENDIF} fsl_testing, IdGlobalProtocols, - fsl_base, fsl_utilities, fsl_stream, fsl_threads, fsl_collections, fsl_fpc, fsl_versions, + fsl_base, fsl_utilities, fsl_stream, fsl_threads, fsl_collections, fsl_fpc, fsl_versions, fsl_gzip, fsl_xml, {$IFNDEF FPC} fsl_msxml, @@ -5269,7 +5269,6 @@ procedure TXmlUtilsTest.TestUnPretty; function TTarGZParserTests.load(filename : String) : TFslList; var bs : TBytesStream; - z : TZDecompressionStream; tar : TTarArchive; entry : TTarDirRec; n : String; @@ -5279,39 +5278,34 @@ function TTarGZParserTests.load(filename : String) : TFslList; begin result := TFslList.Create; try - bs := TBytesStream.create(readZLibHeader(TFileStream.create(filename, fmOpenRead))); + bs := TBytesStream.create(gzuncompress(fileToBytes(filename))); try - z := TZDecompressionStream.Create(bs, true); // 15+16); + tar := TTarArchive.Create(bs); try - tar := TTarArchive.Create(z); - try - tar.Reset; - while tar.FindNext(entry) do - begin - n := String(entry.Name); - if (n.contains('..')) then - raise EFSLException.create('The package contains the file "'+n+'". Packages are not allowed to contain files with ".." in the name'); - bi := TBytesStream.Create; - try - tar.ReadFile(bi); - b := copy(bi.Bytes, 0, bi.size); - finally - bi.free; - end; - item := TFslNameBuffer.Create; - try - item.Name := n; - item.AsBytes := b; - result.Add(item.link) - finally - item.free; - end; + tar.Reset; + while tar.FindNext(entry) do + begin + n := String(entry.Name); + if (n.contains('..')) then + raise EFSLException.create('The package contains the file "'+n+'". Packages are not allowed to contain files with ".." in the name'); + bi := TBytesStream.Create; + try + tar.ReadFile(bi); + b := copy(bi.Bytes, 0, bi.size); + finally + bi.free; + end; + item := TFslNameBuffer.Create; + try + item.Name := n; + item.AsBytes := b; + result.Add(item.link) + finally + item.free; end; - finally - tar.free; end; finally - z.free; + tar.free; end; finally bs.free; diff --git a/library/web/fsl_crypto.pas b/library/web/fsl_crypto.pas index 144dc33c6..2584d57bf 100644 --- a/library/web/fsl_crypto.pas +++ b/library/web/fsl_crypto.pas @@ -80,7 +80,7 @@ interface IdOpenSSLHeaders_pem, IdOpenSSLHeaders_err, IdOpenSSLHeaders_evp, IdOpenSSLHeaders_ec, IdOpenSSLHeaders_obj_mac, IdOpenSSLHeaders_x509, IdOpenSSLHeaders_x509v3, IdOpenSSLHeaders_x509_vfy, IdOpenSSLX509, - fsl_base, fsl_utilities, fsl_stream, fsl_collections, fsl_json, fsl_xml, fsl_fpc, fsl_npm, + fsl_base, fsl_utilities, fsl_stream, fsl_collections, fsl_json, fsl_xml, fsl_fpc, fsl_npm, fsl_gzip, fsl_openssl, fsl_fetcher; Type @@ -431,9 +431,6 @@ TDigitalSigner = class (TFslObject) function verifySignature(xml : TBytes) : boolean; end; -function InflateRfc1951(b : TBytes) : TBytes; -function DeflateRfc1951(b : TBytes) : TBytes; - function Base64URL(s : TBytes) : String; function unBase64URL(s : String) : TBytes; @@ -1133,7 +1130,7 @@ class function TJWTUtils.encodeJWT(jwt: TJWT; method: TJWTAlgorithm; key: TJWK; input := JWTBase64URL(TJSONWriter.writeObject(jwt.header)); input := BytesAdd(input, Byte('.')); if zip = 'DEF' then - input := BytesAdd(input, JWTBase64URL(DeflateRfc1951(TJSONWriter.writeObject(jwt.payload)))) + input := BytesAdd(input, JWTBase64URL(gzcompress(TJSONWriter.writeObject(jwt.payload), false))) else input := BytesAdd(input, JWTBase64URL(TJSONWriter.writeObject(jwt.payload))); case method of @@ -1391,52 +1388,6 @@ class function TJWTUtils.encodeJWT(jwt: TJWT; method: TJWTAlgorithm; pem_file, p result := BytesAsString(input)+'.'+BytesAsString(JWTBase64URL(sig)); end; -function InflateRfc1951(b : TBytes) : TBytes; -var - b1, b2 : TBytesStream; - z : TZDecompressionStream; -begin - b1 := TBytesStream.create(b);// readZLibHeader(b)); - try - z := TZDecompressionStream.create(b1, true); // -15); - try - z.position := 0; - b2 := TBytesStream.Create; - try - b2.CopyFrom(z, 2); - result := b2.Bytes; - setLength(result, b2.size); - finally - b2.free; - end; - finally - z.free; - end; - finally - b1.free; - end; -end; - -function DeflateRfc1951(b : TBytes) : TBytes; -var - s : TBytesStream; - z : TZCompressionStream; -begin - s := TBytesStream.create(); - try - z := TZCompressionStream.create(clMax, s); // , -15); - try - z.Write(b, length(b)); - finally - z.free; - end; - result := s.Bytes; - setLength(result, s.size); - finally - s.free; - end; -end; - class function TJWTUtils.decodeJWT(token: string): TJWT; var header, payload, sig : String; @@ -1459,7 +1410,7 @@ class function TJWTUtils.decodeJWT(token: string): TJWT; result.payloadBytes := JWTDeBase64URL(payload); if result.header['zip'] = 'DEF' then - result.payloadBytes := InflateRfc1951(result.payloadBytes); + result.payloadBytes := gzuncompress(result.payloadBytes); result.payload := TJSONParser.Parse(result.payloadBytes); result.link; diff --git a/library/web/fsl_npm_cache.pas b/library/web/fsl_npm_cache.pas index dc7f31f86..6bc1b33c1 100644 --- a/library/web/fsl_npm_cache.pas +++ b/library/web/fsl_npm_cache.pas @@ -34,9 +34,9 @@ interface uses {$IFDEF WINDOWS} Windows, {$ELSE} LazFileUtils, {$ENDIF} - SysUtils, Classes, IniFiles, zlib, Generics.Collections, Types, {$IFDEF DELPHI} IOUtils, {$ENDIF} + SysUtils, Classes, IniFiles, Generics.Collections, Types, {$IFDEF DELPHI} IOUtils, {$ENDIF} fsl_base, fsl_utilities, fsl_json, fsl_fpc, fsl_threads, fsl_logging, fsl_stream, fsl_fetcher, fsl_versions, - fsl_npm, fsl_npm_client; + fsl_npm, fsl_npm_client, fsl_gzip; type TCheckEvent = function(sender : TObject; msg : String):boolean of object; @@ -729,53 +729,49 @@ function TFHIRPackageManager.loadArchive(content: TBytes): TDictionary.Create; - bo := TBytesStream.Create(readZLibHeader(content)); + bo := TBytesStream.create(gzuncompress(content)); try - z := TZDecompressionStream.Create(bo, true); // 15+16); + work(trunc(bo.Position / bo.Size * 100), false, 'Loading Package'); + tar := TTarArchive.Create(bo); try - work(trunc(bo.Position / bo.Size * 100), false, 'Loading Package'); - tar := TTarArchive.Create(z); - try - tar.Reset; - while tar.FindNext(DirRec) do + tar.Reset; + while tar.FindNext(DirRec) do + begin + fn := String(DirRec.Name); + fn := fn.replace('/', '\'); + if not fn.contains('@') then begin - fn := String(DirRec.Name); - fn := fn.replace('/', '\'); - if not fn.contains('@') then - begin - bi := TBytesStream.Create; - try - tar.ReadFile(bi); - b := bi.Bytes; - if not result.ContainsKey(fn) then - result.Add(fn, copy(b, 0, bi.Size)); + bi := TBytesStream.Create; + try + tar.ReadFile(bi); + b := bi.Bytes; + if not result.ContainsKey(fn) then + result.Add(fn, copy(b, 0, bi.Size)); // else // raise EFSLException.Create('Duplicate Entry: '+fn); - finally - bi.free; - end; + finally + bi.free; end; end; - finally - tar.free; end; finally - z.free; + tar.free; end; finally bo.free; end; finally work(100, true, ''); - end; + end; + Logging.log('Loaded Package ('+inttostr(result.Count)+' files)'); end; procedure TFHIRPackageManager.loadPackage(id, ver: String; diff --git a/packages/fhir_fsl.lpk b/packages/fhir_fsl.lpk index e19149926..589fb8c84 100644 --- a/packages/fhir_fsl.lpk +++ b/packages/fhir_fsl.lpk @@ -9,7 +9,7 @@ - + @@ -144,6 +144,10 @@ + + + + diff --git a/packages/fhir_fsl.pas b/packages/fhir_fsl.pas index 3bf2b03c8..db0e3be27 100644 --- a/packages/fhir_fsl.pas +++ b/packages/fhir_fsl.pas @@ -1,26 +1,26 @@ -{ This file was automatically created by Lazarus. Do not edit! - This source is only used to compile and install the package. - } - -unit fhir_fsl; - -{$warn 5023 off : no warning about unused units} -interface - -uses - fsl_base, fsl_collections, fsl_comparisons, fsl_fpc, fsl_graphql, fsl_html, - fsl_http, fsl_json, fsl_lang, fsl_logging, fsl_npm, fsl_rdf, fsl_scim, - fsl_scrypt, fsl_service, fsl_service_win, fsl_shell, fsl_stream, - fsl_threads, fsl_turtle, fsl_utilities, fsl_xml, fsl_ucum, fsl_htmlgen, - fsl_diff, fsl_unicode, fsl_versions, fsl_i18n, fsl_fpc_memory, fsl_regex, - LazarusPackageIntf; - -implementation - -procedure Register; -begin -end; - -initialization - RegisterPackage('fhir_fsl', @Register); -end. +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit fhir_fsl; + +{$warn 5023 off : no warning about unused units} +interface + +uses + fsl_base, fsl_collections, fsl_comparisons, fsl_fpc, fsl_graphql, fsl_html, + fsl_http, fsl_json, fsl_lang, fsl_logging, fsl_npm, fsl_rdf, fsl_scim, + fsl_scrypt, fsl_service, fsl_service_win, fsl_shell, fsl_stream, + fsl_threads, fsl_turtle, fsl_utilities, fsl_xml, fsl_ucum, fsl_htmlgen, + fsl_diff, fsl_unicode, fsl_versions, fsl_i18n, fsl_fpc_memory, fsl_regex, fsl_gzip, + LazarusPackageIntf; + +implementation + +procedure Register; +begin +end; + +initialization + RegisterPackage('fhir_fsl', @Register); +end. From a58df1dc2d1ceed9ac9dbbc000d19f0603149a29 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Fri, 5 Jan 2024 17:18:44 +1100 Subject: [PATCH 09/13] Fix bug with not populating ValueSet.expansion.property --- library/ftx/fhir_codesystem_service.pas | 6 ++++++ library/ftx/fhir_valuesets.pas | 24 ++++++++++++++++++++++-- library/ftx/ftx_service.pas | 6 ++++++ 3 files changed, 34 insertions(+), 2 deletions(-) diff --git a/library/ftx/fhir_codesystem_service.pas b/library/ftx/fhir_codesystem_service.pas index bd19bcb3d..2b1b8d088 100644 --- a/library/ftx/fhir_codesystem_service.pas +++ b/library/ftx/fhir_codesystem_service.pas @@ -214,6 +214,7 @@ TFhirCodeSystemProvider = class (TCodeSystemProvider) function name(context: TCodeSystemProviderContext): String; override; function version(context: TCodeSystemProviderContext): String; override; function TotalCount : integer; override; + function getPropertyDefinitions : TFslList; override; function getIterator(context : TCodeSystemProviderContext) : TCodeSystemIteratorContext; override; function getNextContext(context : TCodeSystemIteratorContext) : TCodeSystemProviderContext; override; function systemUri(context : TCodeSystemProviderContext) : String; override; @@ -1227,6 +1228,11 @@ function count(item : TFhirCodeSystemConceptW) : integer; inc(result, count(FCs.CodeSystem.conceptList[i])); end; +function TFhirCodeSystemProvider.getPropertyDefinitions: TFslList; +begin + Result := FCs.CodeSystem.properties; +end; + function TFhirCodeSystemProvider.version(context: TCodeSystemProviderContext): String; begin result := FCs.CodeSystem.version; diff --git a/library/ftx/fhir_valuesets.pas b/library/ftx/fhir_valuesets.pas index 4660e0991..f1e8726e5 100644 --- a/library/ftx/fhir_valuesets.pas +++ b/library/ftx/fhir_valuesets.pas @@ -3064,6 +3064,23 @@ function TFHIRValueSetExpander.isValidating: boolean; result := false; end; +function getPropUrl(cs : TCodeSystemProvider; pcode : String) : String; +var + pl : TFslList; + p : TFhirCodeSystemPropertyW; +begin + result := ''; + pl := cs.getPropertyDefinitions; + try + if pl <> nil then + for p in pl do + if p.code = pcode then + exit(p.uri); + finally + pl.free; + end; +end; + function TFHIRValueSetExpander.processCode(cs : TCodeSystemProvider; parent : TFhirValueSetExpansionContainsW; doDelete : boolean; system, version, code : String; isAbstract, isInactive, deprecated : boolean; displays : TConceptDesignations; definition, itemWeight: string; expansion : TFhirValueSetExpansionW; imports : TFslList; csExtList, vsExtList : TFslList; csProps : TFslList; expProps : TFslList; excludeInactive : boolean; srcURL : string) : TFhirValueSetExpansionContainsW; @@ -3191,7 +3208,7 @@ function TFHIRValueSetExpander.processCode(cs : TCodeSystemProvider; parent : TF begin vstr := FFactory.makeString(definition); try - n.addProperty(pn, vstr); + expansion.defineProperty(n, 'http://hl7.org/fhir/concept-properties#definition', pn, vstr.link); finally vstr.free; end; @@ -3202,7 +3219,10 @@ function TFHIRValueSetExpander.processCode(cs : TCodeSystemProvider; parent : TF for cp in csprops do begin if cp.code = pn then - n.addProperty(pn, cp); + begin + expansion.defineProperty(n, getPropUrl(cs, pn), pn, cp.value.link); + // n.addProperty(pn, cp); + end; end; end; end; diff --git a/library/ftx/ftx_service.pas b/library/ftx/ftx_service.pas index ab7de776a..744f28ca9 100644 --- a/library/ftx/ftx_service.pas +++ b/library/ftx/ftx_service.pas @@ -226,6 +226,7 @@ TCodeSystemProvider = class abstract (TFslObject) function expandLimitation : Integer; virtual; function description : String; virtual; abstract; function TotalCount : integer; virtual; abstract; + function getPropertyDefinitions : TFslList; virtual; function getIterator(context : TCodeSystemProviderContext) : TCodeSystemIteratorContext; virtual; abstract; function getNextContext(context : TCodeSystemIteratorContext) : TCodeSystemProviderContext; virtual; abstract; function systemUri(context : TCodeSystemProviderContext) : String; virtual; abstract; @@ -835,6 +836,11 @@ function TCodeSystemProvider.expandLimitation: Integer; result := 0; // no limit end; +function TCodeSystemProvider.getPropertyDefinitions: TFslList; +begin + result := nil; +end; + function TCodeSystemProvider.IsInactive(context: TCodeSystemProviderContext): boolean; begin result := false; From 0f01bda5f94f59319e65755dfe7caca1166b1d04 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Fri, 5 Jan 2024 22:09:20 +1100 Subject: [PATCH 10/13] get all tests passing on windows --- library/fsl/fsl_gzip.pas | 2 +- library/web/fsl_npm_cache.pas | 1 - server/fhirserver.lpi | 6 +- testcases/config/example.cfg.txt | 374 +++++++++++++++---------------- 4 files changed, 191 insertions(+), 192 deletions(-) diff --git a/library/fsl/fsl_gzip.pas b/library/fsl/fsl_gzip.pas index e4bacbd99..9f49e2758 100644 --- a/library/fsl/fsl_gzip.pas +++ b/library/fsl/fsl_gzip.pas @@ -47,7 +47,7 @@ function gzcompress(bytes : TBytes; header : boolean; level: dword=9) : TBytes; function gzuncompress(bytes : TBytes) : TBytes; begin - result := zflate.gzuncompress(bytes); + result := zflate.gzuncompress(readZLibHeader(bytes)); if length(result) = 0 then raise EFslException.create('Failed to read compressed content: '+zflatetranslatecode(zlasterror)); //BytesToFile(bytes, '/Users/grahamegrieve/temp/test.tgz'); diff --git a/library/web/fsl_npm_cache.pas b/library/web/fsl_npm_cache.pas index 6bc1b33c1..0b0467a2b 100644 --- a/library/web/fsl_npm_cache.pas +++ b/library/web/fsl_npm_cache.pas @@ -733,7 +733,6 @@ function TFHIRPackageManager.loadArchive(content: TBytes): TDictionary.Create; diff --git a/server/fhirserver.lpi b/server/fhirserver.lpi index 6820d5c95..7dc5c3cd6 100644 --- a/server/fhirserver.lpi +++ b/server/fhirserver.lpi @@ -87,7 +87,7 @@ - + @@ -274,7 +274,7 @@ - + @@ -778,7 +778,7 @@ - + diff --git a/testcases/config/example.cfg.txt b/testcases/config/example.cfg.txt index d22a9f928..9720eed40 100644 --- a/testcases/config/example.cfg.txt +++ b/testcases/config/example.cfg.txt @@ -1,187 +1,187 @@ -## FHIRServer Config File - -databases - rxn - type: mssql - server: (local) - driver: SQL Server Native Client 11.0 - database: rxnorm - dbr4 - type: mssql - when-testing: true - server: (local) - driver: SQL Server Native Client 11.0 - database: fhir4 - dbr2 - type: mssql - server: (local) - driver: SQL Server Native Client 11.0 - database: fhir2 - dbr3 - type: mssql - server: (local) - driver: SQL Server Native Client 11.0 - database: fhir3 - dbr5 - type: mssql - server: (local) - driver: SQL Server Native Client 11.0 - database: fhir5 - package-server - type: mssql - server: (local) - driver: SQL Server Native Client 11.0 - database: packageserver - -# -terminologies - s-can - type: snomed - source: C:\ProgramData\FHIRServer\snomed_20161031_ca.cache - icd10cm - type: icd10 - source: C:\ProgramData\fhirserver\icd10cm.txt - ndc - type: ndc - version: 20190317 - database: rxn - unii - type: unii - database: dbr3 - sintl2 - type: snomed - source: C:\ProgramData\FHIRServer\snomed_20200131_intl.cache - default: true - scomb - type: snomed - source: C:\ProgramData\fhirserver\snomed_20170306_combined.cache - when-testing: true - loinc - type: loinc - source: C:\ProgramData\fhirserver\loinc-2.68.cache - when-testing: true - lang - type: lang - source: C:\ProgramData\fhirserver\lang.txt - icd10 - type: icd10 - source: C:\ProgramData\fhirserver\icd10.txt - rxnorm - type: rxnorm - database: rxn - s-usa - type: snomed - source: C:\ProgramData\fhirserver\snomed_20160901_us.cache - sintl - type: snomed - source: C:\ProgramData\fhirserver\snomed_20190731_intl.cache - s-aus - type: snomed - source: C:\ProgramData\fhirserver\snomed_20161031_au.cache - icd10vn - type: icd10 - source: C:\ProgramData\fhirserver\icd10vn.txt - ucum - type: ucum - source: C:\work\fhirserver\Exec\64\ucum-essence.xml - when-testing: true - -# -endpoints - packages - type: package - path: /package - database: package-server - r4 - type: r4 - path: /r4 - mode: general - security: open - version: r4 - database: dbr4 - validate: true - when-testing: true - packages: hl7.fhir.r4.examples # 4.0.1 - r2 - type: r2 - path: /r2 - mode: general - security: certificate - version: r2 - database: dbr2 - validate: true - packages: fhir.argonaut.r2 # 1.0.0 - r3 - type: r3 - path: /r3 - mode: terminology - security: read-only - version: r3 - database: dbr3 - packages: hl7.fhir.r3.elements # 3.0.2 - -# -destinations - email - host: smtp.gmail.com - port: 587 - secure: true - username: fhir-server@healthintersections.com.au - password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - sender: fhir-server@healthintersections.com.au - direct - host: smtp10.phimail-dev.com - port: 587 - pop-host: smtp11.phimail-dev.com - pop-port: 110 - secure: 1 - username: grahame@test.directproject.net - password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - sender: grahame@test.directproject.net - sms - account: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - token: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - from: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -# -identity-providers - hl7.org - app-id: HL7HealthIntersections - app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - facebook.com - app-id: 355752811191794 - app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - like: 1 - google.com - app-id: 940006310138.apps.googleusercontent.com - app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - api-key: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -# -web - host: local.fhir.org - http: 960 - https: 961 - certname: C:\work\RDPs\certificates\new\fhir.org.crt - cacertname: C:\work\RDPs\certificates\new\fhir.org.int.crt - password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - oauth: true - googleid: UA-88535340-3 - folder: C:\work\fhirserver\server\web - no-cert: true - package-server: dbr5 - key: C:\work\RDPs\certificates\new\fhir.org.crt - plain-mode: serve - certkey: C:\work\RDPs\certificates\new\fhir.org.key -# -admin - username: g - email: grahame@healthintersections.com.au - owner-sms: - ownername: Health Intersections - scim-salt: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - default-rights: openid,profile,user/*.* - twilio: fhir4 -# -service - run-number: 0 +## FHIRServer Config File + +databases + rxn + type: mssql + server: (local) + driver: SQL Server Native Client 11.0 + database: rxnorm + dbr4 + type: mssql + when-testing: true + server: (local) + driver: SQL Server Native Client 11.0 + database: fhir4 + dbr2 + type: mssql + server: (local) + driver: SQL Server Native Client 11.0 + database: fhir2 + dbr3 + type: mssql + server: (local) + driver: SQL Server Native Client 11.0 + database: fhir3 + dbr5 + type: mssql + server: (local) + driver: SQL Server Native Client 11.0 + database: fhir5 + package-server + type: mssql + server: (local) + driver: SQL Server Native Client 11.0 + database: packageserver + +# +terminologies + s-can + type: snomed + source: C:\ProgramData\FHIRServer\snomed_20161031_ca.cache + icd10cm + type: icd10 + source: C:\ProgramData\fhirserver\icd10cm.txt + ndc + type: ndc + version: 20190317 + database: rxn + unii + type: unii + database: dbr3 + sintl2 + type: snomed + source: C:\ProgramData\FHIRServer\snomed_20200131_intl.cache + default: true + scomb + type: snomed + source: C:\ProgramData\fhirserver\snomed_20170306_combined.cache + when-testing: true + loinc + type: loinc + source: C:\ProgramData\fhirserver\loinc-2.68.cache + when-testing: true + lang + type: lang + source: C:\ProgramData\fhirserver\lang.txt + icd10 + type: icd10 + source: C:\ProgramData\fhirserver\icd10.txt + rxnorm + type: rxnorm + database: rxn + s-usa + type: snomed + source: C:\ProgramData\fhirserver\snomed_20160901_us.cache + sintl + type: snomed + source: C:\ProgramData\fhirserver\snomed_20190731_intl.cache + s-aus + type: snomed + source: C:\ProgramData\fhirserver\snomed_20161031_au.cache + icd10vn + type: icd10 + source: C:\ProgramData\fhirserver\icd10vn.txt + ucum + type: ucum + source: C:\work\fhirserver\Exec\64\ucum-essence.xml + when-testing: true + +# +endpoints + packages + type: package + path: /package + database: package-server + r4 + type: r4 + path: /r4 + mode: general + security: open + version: r4 + database: dbr4 + validate: true + when-testing: true + packages: hl7.fhir.r4.examples # 4.0.1 + r2 + type: r2 + path: /r2 + mode: general + security: certificate + version: r2 + database: dbr2 + validate: true + packages: fhir.argonaut.r2 # 1.0.0 + r3 + type: r3 + path: /r3 + mode: terminology + security: read-only + version: r3 + database: dbr3 + packages: hl7.fhir.r3.elements # 3.0.2 + +# +destinations + email + host: smtp.gmail.com + port: 587 + secure: true + username: fhir-server@healthintersections.com.au + password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + sender: fhir-server@healthintersections.com.au + direct + host: smtp10.phimail-dev.com + port: 587 + pop-host: smtp11.phimail-dev.com + pop-port: 110 + secure: 1 + username: grahame@test.directproject.net + password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + sender: grahame@test.directproject.net + sms + account: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + token: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + from: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +# +identity-providers + hl7.org + app-id: HL7HealthIntersections + app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + facebook.com + app-id: 355752811191794 + app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + like: 1 + google.com + app-id: 940006310138.apps.googleusercontent.com + app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + api-key: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +# +web + host: local.fhir.org + http: 960 + https: 961 + certname: C:\work\RDPs\certificates\new\fhir.org.crt + cacertname: C:\work\RDPs\certificates\new\fhir.org.int.crt + password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + oauth: true + googleid: UA-88535340-3 + folder: C:\work\fhirserver\server\web + no-cert: true + package-server: dbr5 + key: C:\work\RDPs\certificates\new\fhir.org.crt + plain-mode: serve + certkey: C:\work\RDPs\certificates\new\fhir.org.key +# +admin + username: g + email: grahame@healthintersections.com.au + owner-sms: + ownername: Health Intersections + scim-salt: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + default-rights: openid,profile,user/*.* + twilio: fhir4 +# +service + run-number: 0 From 1c9a4ffef363ff08f453d5c654cbc06558e5ebec Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Sat, 6 Jan 2024 07:35:20 +1100 Subject: [PATCH 11/13] rework fsl_gzip a little per comments from fibonacci --- dependencies/zflate/zflate.pas | 103 ++++++-- dependencies/zflate/zflatefiles.pas | 251 +++++++++++++++++++ library/fhir/fhir_healthcard.pas | 2 +- library/fsl/fsl_gzip.pas | 134 +++------- library/fsl/fsl_npm.pas | 2 +- library/fsl/tests/fsl_tests.pas | 2 +- library/web/fsl_crypto.pas | 4 +- library/web/fsl_npm_cache.pas | 2 +- server/admin/console_managers.pas | 2 +- server/fhirserver.lpi | 6 +- testcases/config/example.cfg.txt | 374 ++++++++++++++-------------- 11 files changed, 572 insertions(+), 310 deletions(-) create mode 100644 dependencies/zflate/zflatefiles.pas diff --git a/dependencies/zflate/zflate.pas b/dependencies/zflate/zflate.pas index c204f17a6..1ee7b1555 100644 --- a/dependencies/zflate/zflate.pas +++ b/dependencies/zflate/zflate.pas @@ -32,7 +32,7 @@ interface uses - SysUtils, ZBase, ZInflate, ZDeflate; + ZBase, ZInflate, ZDeflate; type tzflate = record @@ -56,7 +56,7 @@ tgzipinfo = record footerlen: dword; end; - Tristate = (tNull, tTrue, tFalse); + TBytes = array of byte; const ZFLATE_ZLIB = 1; @@ -107,10 +107,14 @@ function zfindstream(data: pointer; size: dword; var streamtype: dword; var star function gzdeflate(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; //compress whole string to DEFLATE at once function gzdeflate(str: string; level: dword=9): string; +//compress whole bytes to DEFLATE at once +function gzdeflate(bytes : TBytes; level: dword=9): TBytes; //decompress whole DEFLATE buffer at once function gzinflate(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; //decompress whole DEFLATE string at once function gzinflate(str: string): string; +//decompress whole DEFLATE bytes at once +function gzinflate(bytes : TBytes): TBytes; //make ZLIB header function makezlibheader(compressionlevel: integer): string; @@ -120,14 +124,14 @@ function makezlibfooter(adler: dword): string; function gzcompress(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9): boolean; //compress whole string to ZLIB at once function gzcompress(str: string; level: dword=9): string; +//compress whole buffer to ZLIB at once +function gzcompress(bytes : TBytes; level: dword=9) : TBytes; //dempress whole ZLIB buffer at once ! -function gzuncompress(data: pointer; size: dword; readHeader : Tristate; var output: pointer; var outputsize: dword): boolean; +function gzuncompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; //dempress whole ZLIB string at once function gzuncompress(str: string): string; -//compress whole buffer to ZLIB at once -function gzcompress(bytes : TBytes; level: dword=9) : TBytes; //dempress whole ZLIB buffer at once -function gzuncompress(bytes : TBytes; readHeader : Tristate = tNull) : TBytes; +function gzuncompress(bytes : TBytes) : TBytes; //make GZIP header function makegzipheader(compressionlevel: integer; filename: string=''; comment: string=''): string; @@ -137,15 +141,21 @@ function makegzipfooter(originalsize: dword; crc: dword): string; function gzencode(data: pointer; size: dword; var output: pointer; var outputsize: dword; level: dword=9; filename: string=''; comment: string=''): boolean; //compress whole string to GZIP at once function gzencode(str: string; level: dword=9; filename: string=''; comment: string=''): string; +//compress whole string to GZIP at once +function gzencode(bytes: TBytes; level: dword=9; filename: string=''; comment: string=''): TBytes; //decompress whole GZIP buffer at once function gzdecode(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; //decompress whole GZIP string at once function gzdecode(str: string): string; +//decompress whole GZIP string at once +function gzdecode(bytes: TBytes): TBytes; //try to detect buffer format and decompress it at once function zdecompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; //try to detect string format and decompress it at once function zdecompress(str: string): string; +//try to detect bytes format and decompress it at once +function zdecompress(bytes: TBytes): TBytes; //transalte error code to message function zflatetranslatecode(code: integer): string; @@ -412,6 +422,18 @@ function gzdeflate(str: string; level: dword=9): string; freemem(p); end; +function gzdeflate(bytes: TBytes; level: dword=9): TBytes; +var + p: pointer; + d: dword; +begin + result := nil; + if not gzdeflate(@bytes[0], length(bytes), p, d, level) then exit; + setlength(result, d); + move(p^, result[0], d); + freemem(p); +end; + // -- inflate ----------------------------- function gzinflate(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; @@ -458,7 +480,19 @@ function gzinflate(str: string): string; result := ''; if not gzinflate(@str[1], length(str), p, d) then exit; setlength(result, d); - move(p^, result[1], d); + move(p^, result[1], d); + freemem(p); +end; + +function gzinflate(bytes: TBytes): TBytes; +var + p: pointer; + d: dword; +begin + result := nil; + if not gzinflate(@bytes[0], length(bytes), p, d) then exit; + setlength(result, d); + move(p^, result[0], d); freemem(p); end; @@ -544,20 +578,14 @@ function gzcompress(bytes : TBytes; level: dword=9) : TBytes; // -- ZLIB decompress --------------------- -function gzuncompress(data: pointer; size: dword; readHeader : Tristate; var output: pointer; var outputsize: dword): boolean; +function gzuncompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; var zlib: tzlibinfo; z: tzflate; checksum: dword; - header : boolean; begin result := false; - header := false; - if readHeader <> tFalse then - if zreadzlibheader(data, zlib) then - header := true - else if readHeader = tTrue then - exit(zerror(z, ZFLATE_EZLIBINVALID)); + if not zreadzlibheader(data, zlib) then exit(zerror(z, ZFLATE_EZLIBINVALID)); checksum := swapendian(pdword(data+size-4)^); @@ -565,8 +593,7 @@ function gzuncompress(data: pointer; size: dword; readHeader : Tristate; var out size -= zlib.streamat+zlib.footerlen; if not gzinflate(data, size, output, outputsize) then exit; - if header and (adler32(adler32(0, nil, 0), output, outputsize) <> checksum) then - exit(zerror(z, ZFLATE_ECHECKSUM)); + if (adler32(adler32(0, nil, 0), output, outputsize) <> checksum) then exit(zerror(z, ZFLATE_ECHECKSUM)); result := true; end; @@ -577,19 +604,19 @@ function gzuncompress(str: string): string; d: dword; begin result := ''; - if not gzuncompress(@str[1], length(str), tTrue, p, d) then exit; + if not gzuncompress(@str[1], length(str), p, d) then exit; setlength(result, d); move(p^, result[1], d); freemem(p); end; -function gzuncompress(bytes : TBytes; readHeader : Tristate = tNull) : TBytes; +function gzuncompress(bytes : TBytes) : TBytes; var p: pointer; d: dword; begin result := nil; - if not gzuncompress(@bytes[0], length(bytes), readHeader, p, d) then exit; + if not gzuncompress(@bytes[0], length(bytes), p, d) then exit; try setlength(result, d); move(p^, result[0], d); @@ -686,6 +713,18 @@ function gzencode(str: string; level: dword=9; filename: string=''; comment: str freemem(p); end; +function gzencode(bytes: TBytes; level: dword=9; filename: string=''; comment: string=''): TBytes; +var + p: pointer; + d: dword; +begin + result := nil; + if not gzencode(@bytes[0], length(bytes), p, d, level, filename, comment) then exit; + setlength(result, d); + move(p^, result[0], d); + freemem(p); +end; + // -- GZIP decompress --------------------- function gzdecode(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; @@ -722,6 +761,18 @@ function gzdecode(str: string): string; freemem(p); end; +function gzdecode(bytes: TBytes): TBytes; +var + p: pointer; + d: dword; +begin + result := nil; + if not gzdecode(@bytes[0], length(bytes), p, d) then exit; + setlength(result, d); + move(p^, result[0], d); + freemem(p); +end; + // -- decompress anything ----------------- function zdecompress(data: pointer; size: dword; var output: pointer; var outputsize: dword): boolean; @@ -753,6 +804,18 @@ function zdecompress(str: string): string; freemem(p); end; +function zdecompress(bytes: TBytes): TBytes; +var + p: pointer; + d: dword; +begin + result := nil; + if not zdecompress(@bytes[0], length(bytes), p, d) then exit; + setlength(result, d); + move(p^, result[0], d); + freemem(p); +end; + // -- error translation ------------------- function zflatetranslatecode(code: integer): string; diff --git a/dependencies/zflate/zflatefiles.pas b/dependencies/zflate/zflatefiles.pas new file mode 100644 index 000000000..c5ea218ca --- /dev/null +++ b/dependencies/zflate/zflatefiles.pas @@ -0,0 +1,251 @@ +{ MIT License + + Copyright (c) 2023 fibodevy https://github.com/fibodevy + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. +} + +unit zflatefiles; + +{$mode ObjFPC}{$H+} + +interface + +type + //return true to continue or false to abort + tzprogresscb = function(position, totalsize, outputsize: dword): boolean; + +//compress a file to GZIP +function gzencode_file(src, dst: string; level: dword=9; filename: string=''; comment: string=''; progresscb: tzprogresscb=nil; resolution: dword=100): boolean; +//decompress a GZIP file +function gzdecode_file(src, dst: string; progresscb: tzprogresscb=nil; resolution: dword=100): boolean; + +implementation + +uses zflate; + +// -- GZIP compress ----------------------- + +function gzencode_file(src, dst: string; level: dword=9; filename: string=''; comment: string=''; progresscb: tzprogresscb=nil; resolution: dword=100): boolean; +const + bufsize = 1024*32; +var + z: tzflate; + inpt, outp: file of byte; + buf: array[0..bufsize-1] of byte; + header, footer: string; + d, pos, fsize, outsize: dword; + crc: dword = 0; + failed: boolean = false; + progress: dword = 0; + progressnotified: dword = 0; +begin + result := false; + + if not zdeflateinit(z, level) then exit; + + AssignFile(inpt, src); + {$I-} Reset(inpt); {$I+} + if IOResult <> 0 then exit; + + AssignFile(outp, dst); + {$I-} Rewrite(outp); {$I+} + if IOResult <> 0 then begin + CloseFile(inpt); + exit; + end; + + fsize := FileSize(inpt); + outsize := 0; + pos := 0; + + try + //write header + header := makegzipheader(level, filename, comment); + BlockWrite(outp, header[1], length(header)); + inc(outsize, length(header)); + + while true do begin + BlockRead(inpt, buf[0], bufsize, d); + inc(pos, d); + + crc := crc32b(crc, @buf[0], d); //update crc32 + + if not zdeflatewrite(z, @buf[0], d, d nil then begin + progress := trunc(pos/fsize*resolution); + + if (progress > progressnotified) then begin + if not progresscb(pos, fsize, outsize) then begin + failed := true; + zlasterror := ZFLATE_EABORTED; + exit; + end; + + progressnotified := progress; + end; + end; + + if d < bufsize then break; //eof + end; + + //write footer + footer := makegzipfooter(fsize, crc); + BlockWrite(outp, footer[1], length(footer)); + inc(outsize, length(footer)); + + result := true; + finally + CloseFile(inpt); + CloseFile(outp); + + //delete output file on failure + if failed then begin + AssignFile(outp, dst); + {$I-} Erase(outp); {$I+} + end; + end; +end; + +// -- GZIP decompress --------------------- + +function gzdecode_file(src, dst: string; progresscb: tzprogresscb=nil; resolution: dword=100): boolean; +const + bufsize = 1024*32; +var + z: tzflate; + inpt, outp: file of byte; + buf: array[0..bufsize-1] of byte; + header, footer: string; + d, bytestoread, pos, fsize, outsize: dword; + crc: dword = 0; + gzip: tgzipinfo; + streamsize: dword; + originalsize, checksum: dword; + failed: boolean = false; + progress: dword = 0; + progressnotified: dword = 0; +begin + result := false; + + if not zinflateinit(z) then exit; + + AssignFile(inpt, src); + {$I-} Reset(inpt); {$I+} + if IOResult <> 0 then exit; + + AssignFile(outp, dst); + {$I-} Rewrite(outp); {$I+} + if IOResult <> 0 then begin + CloseFile(inpt); + exit; + end; + + fsize := FileSize(inpt); + + try + //read header + setlength(header, 512); + BlockRead(inpt, header[1], length(header)); + if not zreadgzipheader(@header[1], gzip) then exit; + + //read footer + Seek(inpt, fsize-8); + setlength(footer, 8); + BlockRead(inpt, footer[1], 8); + checksum := pdword(@footer[1])^; + originalsize := pdword(@footer[1+4])^; + + outsize := 0; + pos := 0; + streamsize := fsize-gzip.streamat-gzip.footerlen; + + Seek(inpt, gzip.streamat); + + while true do begin + bytestoread := bufsize; + if bytestoread+pos+gzip.streamat > streamsize then dec(bytestoread, gzip.footerlen); //skip footer + + BlockRead(inpt, buf[0], bytestoread, d); + + inc(pos, d); + + if not zinflatewrite(z, @buf[0], d, d nil then begin + progress := trunc((pos+gzip.streamat)/fsize*resolution); + + if (progress > progressnotified) then begin + if not progresscb(pos+gzip.streamat, fsize, outsize) then begin + failed := true; + zlasterror := ZFLATE_EABORTED; + exit; + end; + + progressnotified := progress; + end; + end; + + if d < bufsize then break; //eof + end; + + if FileSize(outp) <> originalsize then begin + zlasterror := ZFLATE_EOUTPUTSIZE; + failed := true; + exit; + end; + + if crc <> checksum then begin + zlasterror := ZFLATE_ECHECKSUM; + failed := true; + exit; + end; + + result := true; + CloseFile(inpt); + finally + CloseFile(outp); + + //delete output file on failure + if failed then begin + AssignFile(outp, dst); + {$I-} Erase(outp); {$I+} + end; + end; +end; + +end. + diff --git a/library/fhir/fhir_healthcard.pas b/library/fhir/fhir_healthcard.pas index 7b9d47fca..d906ff7a7 100644 --- a/library/fhir/fhir_healthcard.pas +++ b/library/fhir/fhir_healthcard.pas @@ -231,7 +231,7 @@ procedure THealthcareCardUtilities.sign(card: THealthcareCard; jwk : TJWK); finally j.free; end; - bytes := gzcompress(TEncoding.UTF8.GetBytes(payload), false); + bytes := gzip(TEncoding.UTF8.GetBytes(payload), false); card.jws := TJWTUtils.encodeJWT('{"alg":"ES256","zip":"DEF","kid":"'+jwk.id+'"}', bytes, jwt_es256, jwk); end; diff --git a/library/fsl/fsl_gzip.pas b/library/fsl/fsl_gzip.pas index 9f49e2758..c4a533b9c 100644 --- a/library/fsl/fsl_gzip.pas +++ b/library/fsl/fsl_gzip.pas @@ -1,117 +1,65 @@ unit fsl_gzip; -{$i fhir.inc} +{ +Copyright (c) 2011+, HL7 and Health Intersections Pty Ltd (http://www.healthintersections.com.au) +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of HL7 nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +} + +{$I fhir.inc} + interface uses Classes, SysUtils, zflate, fsl_base, fsl_stream; -function gzcompress(bytes : TBytes; header : boolean; level: dword=9) : TBytes; -function gzuncompress(bytes : TBytes) : TBytes; +{ + for FPC, we use the zflate units by fibonacci. + for delphi, we use delphi's inbuilt ZLib support -// -//function readZLibHeader(stream : TStream) : TBytes; overload; -//function readZLibHeader(b : TBytes) : TBytes; overload; + this unit is to handle the $IFDEF between the two (tbd) +} -implementation +function gzip(bytes : TBytes; header : boolean; level: dword=9) : TBytes; +function ungzip(bytes : TBytes) : TBytes; -function readZLibHeader(b : TBytes) : TBytes; -var - p : int64; - i : integer; -begin - if (length(b) < 10) or (b[0] <> $1F) or (b[1] <> $8B) then - result := b - else - begin - i := 10; - if ((b[3] and $08) > 0) then - begin - repeat - inc(i); - until (i = length(b)) or (b[i] = 0); - inc(i); - end; - if i >= length(b) then - result := b - else - result := copy(b, i, length(b)-i-8); - end; -end; +implementation -function gzcompress(bytes : TBytes; header : boolean; level: dword=9) : TBytes; +function gzip(bytes : TBytes; header : boolean; level: dword=9) : TBytes; begin result := zflate.gzcompress(bytes, level); end; -function gzuncompress(bytes : TBytes) : TBytes; +function ungzip(bytes : TBytes) : TBytes; begin - result := zflate.gzuncompress(readZLibHeader(bytes)); + result := zflate.zdecompress(bytes); if length(result) = 0 then raise EFslException.create('Failed to read compressed content: '+zflatetranslatecode(zlasterror)); - //BytesToFile(bytes, '/Users/grahamegrieve/temp/test.tgz'); - //gzdecode_file('/Users/grahamegrieve/temp/test.tgz', '/Users/grahamegrieve/temp/test.bin'); - //result := FileToBytes('/Users/grahamegrieve/temp/test.bin'); end; -//function InflateRfc1951(b : TBytes) : TBytes; -////var -//// b1, b2 : TBytesStream; -//// z : TZDecompressionStream; -//begin -// result := gzuncompress(readZLibHeader(b)); -// //b1 := TBytesStream.create(b);// readZLibHeader(b)); -// //try -// // z := TZDecompressionStream.create(b1, true); // -15); -// // try -// // z.position := 0; -// // b2 := TBytesStream.Create; -// // try -// // b2.CopyFrom(z, 2); -// // result := b2.Bytes; -// // setLength(result, b2.size); -// // finally -// // b2.free; -// // end; -// // finally -// // z.free; -// // end; -// //finally -// // b1.free; -// //end; -//end; -// -//function DeflateRfc1951(b : TBytes) : TBytes; -//var -// s : TBytesStream; -// z : TZCompressionStream; -//begin -// s := TBytesStream.create(); -// try -// z := TZCompressionStream.create(clMax, s); // , -15); -// try -// z.Write(b, length(b)); -// finally -// z.free; -// end; -// result := s.Bytes; -// setLength(result, s.size); -// finally -// s.free; -// end; -//end; -// -// - -// -// -//function readZLibHeader(stream : TStream) : TBytes; -//begin -// result := readZLibHeader(StreamToBytes(stream)); -// -//end; - end. diff --git a/library/fsl/fsl_npm.pas b/library/fsl/fsl_npm.pas index fc61af769..312e69edf 100644 --- a/library/fsl/fsl_npm.pas +++ b/library/fsl/fsl_npm.pas @@ -1086,7 +1086,7 @@ procedure TNpmPackage.readStream(tgz: TStream; desc: String; progress: TWorkProg b : TBytes; bi : TBytesStream; begin - bs := TBytesStream.create(gzuncompress(streamToBytes(tgz))); + bs := TBytesStream.create(ungzip(streamToBytes(tgz))); try tar := TTarArchive.Create(bs); try diff --git a/library/fsl/tests/fsl_tests.pas b/library/fsl/tests/fsl_tests.pas index 4d7e98346..730932188 100644 --- a/library/fsl/tests/fsl_tests.pas +++ b/library/fsl/tests/fsl_tests.pas @@ -5278,7 +5278,7 @@ function TTarGZParserTests.load(filename : String) : TFslList; begin result := TFslList.Create; try - bs := TBytesStream.create(gzuncompress(fileToBytes(filename))); + bs := TBytesStream.create(ungzip(fileToBytes(filename))); try tar := TTarArchive.Create(bs); try diff --git a/library/web/fsl_crypto.pas b/library/web/fsl_crypto.pas index 2584d57bf..a01c827cf 100644 --- a/library/web/fsl_crypto.pas +++ b/library/web/fsl_crypto.pas @@ -1130,7 +1130,7 @@ class function TJWTUtils.encodeJWT(jwt: TJWT; method: TJWTAlgorithm; key: TJWK; input := JWTBase64URL(TJSONWriter.writeObject(jwt.header)); input := BytesAdd(input, Byte('.')); if zip = 'DEF' then - input := BytesAdd(input, JWTBase64URL(gzcompress(TJSONWriter.writeObject(jwt.payload), false))) + input := BytesAdd(input, JWTBase64URL(gzip(TJSONWriter.writeObject(jwt.payload), false))) else input := BytesAdd(input, JWTBase64URL(TJSONWriter.writeObject(jwt.payload))); case method of @@ -1410,7 +1410,7 @@ class function TJWTUtils.decodeJWT(token: string): TJWT; result.payloadBytes := JWTDeBase64URL(payload); if result.header['zip'] = 'DEF' then - result.payloadBytes := gzuncompress(result.payloadBytes); + result.payloadBytes := ungzip(result.payloadBytes); result.payload := TJSONParser.Parse(result.payloadBytes); result.link; diff --git a/library/web/fsl_npm_cache.pas b/library/web/fsl_npm_cache.pas index 0b0467a2b..d33fc0f80 100644 --- a/library/web/fsl_npm_cache.pas +++ b/library/web/fsl_npm_cache.pas @@ -736,7 +736,7 @@ function TFHIRPackageManager.loadArchive(content: TBytes): TDictionary.Create; - bo := TBytesStream.create(gzuncompress(content)); + bo := TBytesStream.create(ungzip(content)); try work(trunc(bo.Position / bo.Size * 100), false, 'Loading Package'); tar := TTarArchive.Create(bo); diff --git a/server/admin/console_managers.pas b/server/admin/console_managers.pas index cc5e45978..0d7c5213c 100644 --- a/server/admin/console_managers.pas +++ b/server/admin/console_managers.pas @@ -33,7 +33,7 @@ interface uses - SysUtils, Classes, Graphics, UITypes, + SysUtils, Classes, Graphics, System.UITypes, Dialogs, fsl_base, fsl_threads, fsl_utilities, fdb_manager, diff --git a/server/fhirserver.lpi b/server/fhirserver.lpi index 7dc5c3cd6..6820d5c95 100644 --- a/server/fhirserver.lpi +++ b/server/fhirserver.lpi @@ -87,7 +87,7 @@ - + @@ -274,7 +274,7 @@ - + @@ -778,7 +778,7 @@ - + diff --git a/testcases/config/example.cfg.txt b/testcases/config/example.cfg.txt index 9720eed40..d22a9f928 100644 --- a/testcases/config/example.cfg.txt +++ b/testcases/config/example.cfg.txt @@ -1,187 +1,187 @@ -## FHIRServer Config File - -databases - rxn - type: mssql - server: (local) - driver: SQL Server Native Client 11.0 - database: rxnorm - dbr4 - type: mssql - when-testing: true - server: (local) - driver: SQL Server Native Client 11.0 - database: fhir4 - dbr2 - type: mssql - server: (local) - driver: SQL Server Native Client 11.0 - database: fhir2 - dbr3 - type: mssql - server: (local) - driver: SQL Server Native Client 11.0 - database: fhir3 - dbr5 - type: mssql - server: (local) - driver: SQL Server Native Client 11.0 - database: fhir5 - package-server - type: mssql - server: (local) - driver: SQL Server Native Client 11.0 - database: packageserver - -# -terminologies - s-can - type: snomed - source: C:\ProgramData\FHIRServer\snomed_20161031_ca.cache - icd10cm - type: icd10 - source: C:\ProgramData\fhirserver\icd10cm.txt - ndc - type: ndc - version: 20190317 - database: rxn - unii - type: unii - database: dbr3 - sintl2 - type: snomed - source: C:\ProgramData\FHIRServer\snomed_20200131_intl.cache - default: true - scomb - type: snomed - source: C:\ProgramData\fhirserver\snomed_20170306_combined.cache - when-testing: true - loinc - type: loinc - source: C:\ProgramData\fhirserver\loinc-2.68.cache - when-testing: true - lang - type: lang - source: C:\ProgramData\fhirserver\lang.txt - icd10 - type: icd10 - source: C:\ProgramData\fhirserver\icd10.txt - rxnorm - type: rxnorm - database: rxn - s-usa - type: snomed - source: C:\ProgramData\fhirserver\snomed_20160901_us.cache - sintl - type: snomed - source: C:\ProgramData\fhirserver\snomed_20190731_intl.cache - s-aus - type: snomed - source: C:\ProgramData\fhirserver\snomed_20161031_au.cache - icd10vn - type: icd10 - source: C:\ProgramData\fhirserver\icd10vn.txt - ucum - type: ucum - source: C:\work\fhirserver\Exec\64\ucum-essence.xml - when-testing: true - -# -endpoints - packages - type: package - path: /package - database: package-server - r4 - type: r4 - path: /r4 - mode: general - security: open - version: r4 - database: dbr4 - validate: true - when-testing: true - packages: hl7.fhir.r4.examples # 4.0.1 - r2 - type: r2 - path: /r2 - mode: general - security: certificate - version: r2 - database: dbr2 - validate: true - packages: fhir.argonaut.r2 # 1.0.0 - r3 - type: r3 - path: /r3 - mode: terminology - security: read-only - version: r3 - database: dbr3 - packages: hl7.fhir.r3.elements # 3.0.2 - -# -destinations - email - host: smtp.gmail.com - port: 587 - secure: true - username: fhir-server@healthintersections.com.au - password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - sender: fhir-server@healthintersections.com.au - direct - host: smtp10.phimail-dev.com - port: 587 - pop-host: smtp11.phimail-dev.com - pop-port: 110 - secure: 1 - username: grahame@test.directproject.net - password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - sender: grahame@test.directproject.net - sms - account: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - token: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - from: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -# -identity-providers - hl7.org - app-id: HL7HealthIntersections - app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - facebook.com - app-id: 355752811191794 - app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - like: 1 - google.com - app-id: 940006310138.apps.googleusercontent.com - app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - api-key: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -# -web - host: local.fhir.org - http: 960 - https: 961 - certname: C:\work\RDPs\certificates\new\fhir.org.crt - cacertname: C:\work\RDPs\certificates\new\fhir.org.int.crt - password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - oauth: true - googleid: UA-88535340-3 - folder: C:\work\fhirserver\server\web - no-cert: true - package-server: dbr5 - key: C:\work\RDPs\certificates\new\fhir.org.crt - plain-mode: serve - certkey: C:\work\RDPs\certificates\new\fhir.org.key -# -admin - username: g - email: grahame@healthintersections.com.au - owner-sms: - ownername: Health Intersections - scim-salt: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - default-rights: openid,profile,user/*.* - twilio: fhir4 -# -service - run-number: 0 +## FHIRServer Config File + +databases + rxn + type: mssql + server: (local) + driver: SQL Server Native Client 11.0 + database: rxnorm + dbr4 + type: mssql + when-testing: true + server: (local) + driver: SQL Server Native Client 11.0 + database: fhir4 + dbr2 + type: mssql + server: (local) + driver: SQL Server Native Client 11.0 + database: fhir2 + dbr3 + type: mssql + server: (local) + driver: SQL Server Native Client 11.0 + database: fhir3 + dbr5 + type: mssql + server: (local) + driver: SQL Server Native Client 11.0 + database: fhir5 + package-server + type: mssql + server: (local) + driver: SQL Server Native Client 11.0 + database: packageserver + +# +terminologies + s-can + type: snomed + source: C:\ProgramData\FHIRServer\snomed_20161031_ca.cache + icd10cm + type: icd10 + source: C:\ProgramData\fhirserver\icd10cm.txt + ndc + type: ndc + version: 20190317 + database: rxn + unii + type: unii + database: dbr3 + sintl2 + type: snomed + source: C:\ProgramData\FHIRServer\snomed_20200131_intl.cache + default: true + scomb + type: snomed + source: C:\ProgramData\fhirserver\snomed_20170306_combined.cache + when-testing: true + loinc + type: loinc + source: C:\ProgramData\fhirserver\loinc-2.68.cache + when-testing: true + lang + type: lang + source: C:\ProgramData\fhirserver\lang.txt + icd10 + type: icd10 + source: C:\ProgramData\fhirserver\icd10.txt + rxnorm + type: rxnorm + database: rxn + s-usa + type: snomed + source: C:\ProgramData\fhirserver\snomed_20160901_us.cache + sintl + type: snomed + source: C:\ProgramData\fhirserver\snomed_20190731_intl.cache + s-aus + type: snomed + source: C:\ProgramData\fhirserver\snomed_20161031_au.cache + icd10vn + type: icd10 + source: C:\ProgramData\fhirserver\icd10vn.txt + ucum + type: ucum + source: C:\work\fhirserver\Exec\64\ucum-essence.xml + when-testing: true + +# +endpoints + packages + type: package + path: /package + database: package-server + r4 + type: r4 + path: /r4 + mode: general + security: open + version: r4 + database: dbr4 + validate: true + when-testing: true + packages: hl7.fhir.r4.examples # 4.0.1 + r2 + type: r2 + path: /r2 + mode: general + security: certificate + version: r2 + database: dbr2 + validate: true + packages: fhir.argonaut.r2 # 1.0.0 + r3 + type: r3 + path: /r3 + mode: terminology + security: read-only + version: r3 + database: dbr3 + packages: hl7.fhir.r3.elements # 3.0.2 + +# +destinations + email + host: smtp.gmail.com + port: 587 + secure: true + username: fhir-server@healthintersections.com.au + password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + sender: fhir-server@healthintersections.com.au + direct + host: smtp10.phimail-dev.com + port: 587 + pop-host: smtp11.phimail-dev.com + pop-port: 110 + secure: 1 + username: grahame@test.directproject.net + password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + sender: grahame@test.directproject.net + sms + account: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + token: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + from: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +# +identity-providers + hl7.org + app-id: HL7HealthIntersections + app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + facebook.com + app-id: 355752811191794 + app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + like: 1 + google.com + app-id: 940006310138.apps.googleusercontent.com + app-secret: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + api-key: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +# +web + host: local.fhir.org + http: 960 + https: 961 + certname: C:\work\RDPs\certificates\new\fhir.org.crt + cacertname: C:\work\RDPs\certificates\new\fhir.org.int.crt + password: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + oauth: true + googleid: UA-88535340-3 + folder: C:\work\fhirserver\server\web + no-cert: true + package-server: dbr5 + key: C:\work\RDPs\certificates\new\fhir.org.crt + plain-mode: serve + certkey: C:\work\RDPs\certificates\new\fhir.org.key +# +admin + username: g + email: grahame@healthintersections.com.au + owner-sms: + ownername: Health Intersections + scim-salt: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + default-rights: openid,profile,user/*.* + twilio: fhir4 +# +service + run-number: 0 From d8be251665ac55b1fc2a9d4c7eef31ac1b25e9b0 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Sat, 6 Jan 2024 08:14:11 +1100 Subject: [PATCH 12/13] more gzip clean up --- library/dicom/dicom_parser.pas | 4 +- library/fsl/fsl_fpc.pas | 369 +--------------------------- library/fsl/fsl_gzip.pas | 2 +- library/fsl/fsl_stream.pas | 28 +-- library/fsl/fsl_utilities.pas | 68 ----- toolkit2/views/ftk_project_tree.pas | 2 +- 6 files changed, 10 insertions(+), 463 deletions(-) diff --git a/library/dicom/dicom_parser.pas b/library/dicom/dicom_parser.pas index 43af0001a..514e37e90 100644 --- a/library/dicom/dicom_parser.pas +++ b/library/dicom/dicom_parser.pas @@ -32,7 +32,7 @@ Uses SysUtils, - fsl_base, fsl_utilities, fsl_stream, fsl_fpc, + fsl_base, fsl_utilities, fsl_stream, fsl_fpc, fsl_gzip, dicom_dictionary, dicom_objects, dicom_writer; @@ -1569,7 +1569,7 @@ function TDicomInstanceDecoder.Execute: TDicomInstance; SetLength(sComp, oInput.Size); oInput.Position := 0; oInput.Read(sComp[1], oInput.Size); - sDecomp := ZcompressBytes(sComp); + sDecomp := ungzip(sComp); oInput.Position := 0; oPDU := TDicomPDUDecoder.Create(oInput.Size); diff --git a/library/fsl/fsl_fpc.pas b/library/fsl/fsl_fpc.pas index e57afac65..e8a6f0d13 100644 --- a/library/fsl/fsl_fpc.pas +++ b/library/fsl/fsl_fpc.pas @@ -39,7 +39,7 @@ interface {$IFDEF LINUX} baseunix, unix, {$ENDIF} - Classes, SysUtils, SyncObjs, Contnrs, Character, Generics.Collections, ZLib, ZStream, Types + Classes, SysUtils, SyncObjs, Contnrs, Character, Generics.Collections, Types {$IFDEF FPC}, {$IFDEF OSX} MacOSAll, CFBase, CFString, @@ -124,98 +124,6 @@ procedure FileSetModified(const FileName : String; dateTime : TDateTime); //function ColorToString(Color: TColor): AnsiString; - -type - TZDecompressionStream = TDecompressionStream; - TZCompressionStream = TCompressionStream; - -//type -// TZCompressionLevel = (zcNone, zcFastest, zcDefault, zcMax); -// -// // CG: Define old enum for compression level -// TCompressionLevel = (clNone = Integer(zcNone), clFastest, clDefault, clMax); -// -// TZStreamRec = z_stream; -// -// {** TCustomZStream ********************************************************} -// -// TCustomZStream = class(TStream) -// private -// FStream: TStream; -// FStreamStartPos: Int64; -// FStreamPos: Int64; -// FOnProgress: TNotifyEvent; -// FZStream: TZStreamRec; -// FBuffer: TBytes; -// public -// constructor Create(stream: TStream); -// procedure DoProgress; dynamic; -// property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; -// end; -// // CG: Add alias of classname to old Zlib classname -// TCustomZLibStream = TCustomZStream; -// -// {** TZCompressionStream ***************************************************} -// -// TZCompressionStream = class(TCustomZStream) -// private -// function GetCompressionRate: Single; -// public -// constructor Create(dest: TStream); overload; -// constructor Create(dest: TStream; compressionLevel: TZCompressionLevel; windowBits: Integer); overload; -// // CG: Add overloaded constructor for old parameter type and order -// constructor Create(compressionLevel: TCompressionLevel; dest: TStream); overload; -// destructor Destroy; override; -// function Read(var buffer; count: Longint): Longint; override; -// function Write(const buffer; count: Longint): Longint; override; -// -// function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; -// property CompressionRate: Single read GetCompressionRate; -// property OnProgress; -// end; -// -// // CG: Add alias of classname to old Zlib classname -// TCompressionStream = TZCompressionStream; -// -// {** TZDecompressionStream *************************************************} -// -// TZDecompressionStream = class(TCustomZStream) -// private -// FOwnsStream: Boolean; -// public -// constructor Create(source: TStream); overload; -// constructor Create(source: TStream; WindowBits: Integer); overload; -// constructor Create(source: TStream; WindowBits: Integer; OwnsStream: Boolean); overload; -// destructor Destroy; override; -// function Read(var buffer; count: Longint): Longint; override; -// function Write(const buffer; count: Longint): Longint; override; -// function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; -// property OnProgress; -// end; -// // CG: Add alias of classname to old Zlib classname -// TDecompressionStream = TZDecompressionStream; -// -//const -// ZLevels: array[TZCompressionLevel] of Shortint = ( -// Z_NO_COMPRESSION, -// Z_BEST_SPEED, -// Z_DEFAULT_COMPRESSION, -// Z_BEST_COMPRESSION -// ); -// -// _z_errmsg: array [0..9] of String = ( -// 'need dictionary', // Z_NEED_DICT (2) -// 'stream end', // Z_STREAM_END (1) -// '', // Z_OK (0) -// 'file error', // Z_ERRNO (-1) -// 'stream error', // Z_STREAM_ERROR (-2) -// 'data error', // Z_DATA_ERROR (-3) -// 'insufficient memory', // Z_MEM_ERROR (-4) -// 'buffer error', // Z_BUF_ERROR (-5) -// 'incompatible version', // Z_VERSION_ERROR (-6) -// '' -// ); - {$ENDIF} {$IFDEF FPC} @@ -503,281 +411,6 @@ function TryEnterCriticalSection(var cs : TRTLCriticalSection) : boolean; begin result := System.TryEnterCriticalSection(cs) > 0; end; -// -//function ZCompressCheck(code: Integer): Integer; overload; -//begin -// Result := code; -// -// if code < 0 then -// raise EIOException.Create(string(_z_errmsg[2 - code])); -//end; -// -//function ZCompressCheckWithoutBufferError(code: Integer): Integer; overload; -// begin -// Result := code; -// -// if code < 0 then -// if (code <> Z_BUF_ERROR) then -// raise EIOException.Create(string(_z_errmsg[2 - code])); -// end; -// -//function ZDecompressCheck(code: Integer): Integer; overload; -//begin -// Result := code; -// -// if code < 0 then -// raise EIOException.Create(string(_z_errmsg[2 - code])); -//end; -// -//function ZDecompressCheckWithoutBufferError(code: Integer): Integer; overload; -//begin -// Result := code; -// -// if code < 0 then -// if (code <> Z_BUF_ERROR) then -// raise EIOException.Create(string(_z_errmsg[2 - code])); -// end; -// -// -// -//{ TCustomZStream } -// -//constructor TCustomZStream.Create(stream: TStream); -//begin -// inherited Create; -// FStream := stream; -// FStreamStartPos := Stream.Position; -// FStreamPos := FStreamStartPos; -// SetLength(FBuffer, $10000); -// end; -// -//procedure TCustomZStream.DoProgress; -//begin -// if Assigned(FOnProgress) then FOnProgress(Self); -//end; -// -// -//{ TZCompressionStream } -// -//constructor TZCompressionStream.Create(dest: TStream); -//begin -// Create(dest, zcDefault, 15); -//end; -// -//constructor TZCompressionStream.Create(dest: TStream; -// compressionLevel: TZCompressionLevel; windowBits: Integer); -//begin -// inherited Create(dest); -// -// FZStream.next_out := @FBuffer[0]; -// FZStream.avail_out := Length(FBuffer); -// -// ZCompressCheck(DeflateInit2(FZStream, ZLevels[compressionLevel], Z_DEFLATED, windowBits, 8, Z_DEFAULT_STRATEGY)); -//end; -// -//constructor TZCompressionStream.Create(compressionLevel: TCompressionLevel; dest: TStream); -//begin -// Create(dest, TZCompressionLevel(Byte(compressionLevel)), 15); -//end; -// -//destructor TZCompressionStream.Destroy; -//begin -// FZStream.next_in := nil; -// FZStream.avail_in := 0; -// -// try -// if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; -// -// while ZCompressCheckWithoutBufferError(deflate(FZStream, Z_FINISH)) <> Z_STREAM_END do -// begin -// FStream.WriteBuffer(FBuffer, Length(FBuffer) - Integer(FZStream.avail_out)); -// -// FZStream.next_out := @FBuffer[0]; -// FZStream.avail_out := Length(FBuffer); -// end; -// -// if Integer(FZStream.avail_out) < Length(FBuffer) then -// begin -// FStream.WriteBuffer(FBuffer, Length(FBuffer) - Integer(FZStream.avail_out)); -// end; -// finally -// deflateEnd(FZStream); -// end; -// -// inherited Destroy; -//end; -// -//function TZCompressionStream.Read(var buffer; count: Longint): Longint; -//begin -// result := 0; -// raise EIOException.Create('Cannot read from a compression stream'); -//end; -// -//function TZCompressionStream.Write(const buffer; count: Longint): Longint; -//begin -// FZStream.next_in := @buffer; -// FZStream.avail_in := count; -// -// if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; -// -// while FZStream.avail_in > 0 do -// begin -// ZCompressCheckWithoutBufferError(deflate(FZStream, Z_NO_FLUSH)); -// -// if FZStream.avail_out = 0 then -// begin -// FStream.WriteBuffer(FBuffer, Length(FBuffer)); -// -// FZStream.next_out := @FBuffer[0]; -// FZStream.avail_out := Length(FBuffer); -// -// FStreamPos := FStream.Position; -// -// DoProgress; -// end; -//end; -// -// result := Count; -//end; -// -//function TZCompressionStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; -//begin -// if (offset = 0) and (origin = soCurrent) then -// begin -// result := FZStream.total_in; -// end -// else -// raise EIOException.Create('Invalid Operation'); -//end; -// -//function TZCompressionStream.GetCompressionRate: Single; -//begin -// if FZStream.total_in = 0 then result := 0 -// else result := (1.0 - (FZStream.total_out / FZStream.total_in)) * 100.0; -//end; -// -//{ TZDecompressionStream } -// -//constructor TZDecompressionStream.Create(source: TStream); -//begin -// Create(source, 15, False); -//end; -// -//constructor TZDecompressionStream.Create(source: TStream; WindowBits: Integer); -//begin -// Create(source, WindowBits, False); -//end; -// -//constructor TZDecompressionStream.Create(source: TStream; WindowBits: Integer; OwnsStream: Boolean); -//begin -// inherited Create(source); -// FZStream.next_in := @FBuffer[0]; -// FZStream.avail_in := 0; -// ZDecompressCheckWithoutBufferError(InflateInit2(FZStream, WindowBits)); -// FOwnsStream := OwnsStream; -//end; -// -//destructor TZDecompressionStream.Destroy; -//begin -// inflateEnd(FZStream); -// if FOwnsStream then -// FStream.free; -// inherited Destroy; -//end; -// -//function TZDecompressionStream.Read(var buffer; count: Longint): Longint; -//var -// zresult: Integer; -//begin -// FZStream.next_out := @buffer; -// FZStream.avail_out := count; -// -// if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; -// -// zresult := Z_OK; -// -// while (FZStream.avail_out > 0) and (zresult <> Z_STREAM_END) do -// begin -// if FZStream.avail_in = 0 then -// begin -// FZStream.avail_in := FStream.Read(FBuffer[0], Length(FBuffer)); -// -// if FZStream.avail_in = 0 then -// begin -// result := NativeUInt(count) - FZStream.avail_out; -// -// Exit; -// end; -// if (length(FBuffer) = 0) then -// raise EFslException.Create('read File returned an empty buffer but claimed it wasn''t'); -// -// FZStream.next_in := @FBuffer[0]; -// FStreamPos := FStream.Position; -// -// DoProgress; -// end; -// -// zresult := ZDecompressCheckWithoutBufferError(inflate(FZStream, Z_NO_FLUSH)); -// end; -// -// if (zresult = Z_STREAM_END) and (FZStream.avail_in > 0) then -// begin -// FStream.Position := FStream.Position - FZStream.avail_in; -// FStreamPos := FStream.Position; -// -// FZStream.avail_in := 0; -// end; -// -// result := NativeUInt(count) - FZStream.avail_out; -//end; -// -//function TZDecompressionStream.Write(const buffer; count: Longint): Longint; -//begin -// result := 0; -// raise EIOException.Create('Invalid Operation'); -//end; -// -//function TZDecompressionStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; -//const -// BufSize = 8192; -//var -// buf: TBytes; -// i: Integer; -// localOffset: Int64; -//begin -// if (Offset = 0) and (Origin = soBeginning) then -// begin -// ZDecompressCheck(inflateReset(FZStream)); -// -// FZStream.next_in := @FBuffer; -// FZStream.avail_in := 0; -// -// FStream.Position := FStreamStartPos; -// FStreamPos := FStreamStartPos; -// end -// else if ((Offset >= 0) and (Origin = soCurrent)) or -// (((NativeUInt(offset) - FZStream.total_out) > 0) and (Origin = soBeginning)) then -// begin -// localOffset := Offset; -// if (Origin = soBeginning) then Dec(localOffset, FZStream.total_out); -// -// if localOffset > 0 then -// begin -// SetLength(buf, BufSize); -// for i := 1 to localOffset div BufSize do ReadBuffer(buf[0], BufSize); -// ReadBuffer(buf[0], localOffset mod BufSize); -// end; -// end -// else if (Offset = 0) and (Origin = soEnd) then -// begin -// SetLength(buf, BufSize); -// while Read(buf[0], BufSize) > 0 do ; -// end -// else -// raise EIOException.Create('Invalid Operation'); -// -// result := FZStream.total_out; -//end; {$ENDIF} diff --git a/library/fsl/fsl_gzip.pas b/library/fsl/fsl_gzip.pas index c4a533b9c..84500d36d 100644 --- a/library/fsl/fsl_gzip.pas +++ b/library/fsl/fsl_gzip.pas @@ -34,7 +34,7 @@ interface uses Classes, SysUtils, zflate, - fsl_base, fsl_stream; + fsl_base; { for FPC, we use the zflate units by fibonacci. diff --git a/library/fsl/fsl_stream.pas b/library/fsl/fsl_stream.pas index f6a790db2..23f4650e2 100644 --- a/library/fsl/fsl_stream.pas +++ b/library/fsl/fsl_stream.pas @@ -37,7 +37,7 @@ {$IFDEF LINUX} unixtype, baseunix, unix, {$ENDIF} {$IFDEF FPC} ZStream, {$ELSE} AnsiStrings, {$ENDIF} SysUtils,Classes, RTLConsts, ZLib, - fsl_fpc, fsl_base, fsl_collections, fsl_utilities, fsl_logging; + fsl_fpc, fsl_base, fsl_collections, fsl_utilities, fsl_logging, fsl_gzip; type EParserException = class; @@ -5302,34 +5302,16 @@ procedure TFslZipPartList.add(name: String; bytes: TBytes); Procedure TFslZipReader.ReadKnownDeflate(pIn : Pointer; partName : string; iSizeComp, iSizeDecomp : LongWord; oBuffer : TFslBuffer); Var - oSrc : TStream; - oDecompressor : TZDecompressionStream; - + src : TBytes; {$IFOPT C+} iRead : Integer; {$ENDIF} Begin If iSizeDecomp > 0 Then Begin - oSrc := TPointerMemoryStream.Create(pIn, iSizeComp); - Try - oDecompressor := TZDecompressionStream.Create(oSrc); - Try - oBuffer.Capacity := iSizeDecomp; - - {$IFOPT C+} - iRead := oDecompressor.Read(oBuffer.Data^, iSizeDecomp); - Assert(CheckCondition(iRead = iSizeDecomp, 'ReadKnownDeflate', partName+': Expected to read '+IntegerToString(iSizeDecomp)+ - ' bytes, but actually found '+IntegerToString(iRead)+' bytes')); - {$ELSE} - oDecompressor.Read(oBuffer.Data^, iSizeDecomp); - {$ENDIF} - Finally - oDecompressor.free; - End; - Finally - oSrc.free; - End; + setLength(src, iSizeComp); + move(pIn^, src[0], iSizeComp); + oBuffer.AsBytes := ungzip(src); End; End; diff --git a/library/fsl/fsl_utilities.pas b/library/fsl/fsl_utilities.pas index ea058cfea..42b771da3 100644 --- a/library/fsl/fsl_utilities.pas +++ b/library/fsl/fsl_utilities.pas @@ -1848,10 +1848,6 @@ TStringListHelper = class helper for TStringList function sizeInBytes(magic : integer) : cardinal; end; -function ZCompressBytes(const s: TBytes): TBytes; -function ZDecompressBytes(const s: TBytes): TBytes; -function TryZDecompressBytes(const s: TBytes): TBytes; - type TCacheInformation = class (TFslObject) private @@ -17145,70 +17141,6 @@ function AllContentHex(s: String): Boolean; Result := Result and ((Upcase(s[i]) >= '0') and (Upcase(s[i]) <= '9')) or ((s[i] >= 'A') and (s[i] <= 'F')); end; -function ZCompressBytes(const s: TBytes): TBytes; -begin - {$IFDEF FPC} - result := nil; - raise ETodo.create('Not done yet'); - {$ELSE} - ZCompress(s, result); - {$ENDIF} -end; - -function TryZDecompressBytes(const s: TBytes): TBytes; -begin - try - result := ZDecompressBytes(s); - except - result := s; - end; -end; - -function ZDecompressBytes(const s: TBytes): TBytes; -{$IFDEF FPC} -var - b1, b2 : TBytesStream; - z : TZDecompressionStream; -begin - b1 := TBytesStream.create(s); - try - z := TZDecompressionStream.create(b1); - try - b2 := TBytesStream.Create; - try - b2.CopyFrom(z, z.Size); - result := b2.Bytes; - setLength(result, b2.size); - finally - b2.free; - end; - finally - z.free; - end; - finally - b1.free; - end; -end; - -{$ELSE} -{$IFNDEF WIN64} -var - buffer: Pointer; - size : Integer; -{$ENDIF} -begin - {$IFDEF WIN64} - ZDecompress(s, result); - {$ELSE} - ZDecompress(@s[0],Length(s),buffer,size); - SetLength(result,size); - Move(buffer^,result[0],size); - FreeMem(buffer); - {$ENDIF} -end; -{$ENDIF} - - { TStringListHelper } function TStringListHelper.sizeInBytes(magic : integer): cardinal; diff --git a/toolkit2/views/ftk_project_tree.pas b/toolkit2/views/ftk_project_tree.pas index 994d36e8f..85e614cf0 100644 --- a/toolkit2/views/ftk_project_tree.pas +++ b/toolkit2/views/ftk_project_tree.pas @@ -34,7 +34,7 @@ interface uses Classes, SysUtils, Graphics, IniFiles, - Controls, ComCtrls, Dialogs, UITypes, Menus, + Controls, ComCtrls, Dialogs, System.UITypes, Menus, fsl_base, fsl_utilities, fsl_json, fsl_fpc, fsl_stream, fui_lcl_managers, fhir_client, From 9b89c52c9b6a9dec0379a531386c08c9c2e61ebf Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Sat, 6 Jan 2024 20:48:39 +1100 Subject: [PATCH 13/13] fix gzip related issues --- dependencies/zflate/zflate.pas | 2 +- dependencies/zflate/zflatefiles.pas | 251 ---------------------------- library/fsl/fsl_gzip.pas | 2 +- 3 files changed, 2 insertions(+), 253 deletions(-) delete mode 100644 dependencies/zflate/zflatefiles.pas diff --git a/dependencies/zflate/zflate.pas b/dependencies/zflate/zflate.pas index 1ee7b1555..845cb5ed3 100644 --- a/dependencies/zflate/zflate.pas +++ b/dependencies/zflate/zflate.pas @@ -79,7 +79,7 @@ tgzipinfo = record var zchunkmaxsize: dword = 1024*128; //128 KB default max chunk size - zbuffersize: dword = 1024*1024*4; //4 MB default buffer size + zbuffersize: dword = 1024*1024*16; //16 MB default buffer size threadvar zlasterror: integer; diff --git a/dependencies/zflate/zflatefiles.pas b/dependencies/zflate/zflatefiles.pas deleted file mode 100644 index c5ea218ca..000000000 --- a/dependencies/zflate/zflatefiles.pas +++ /dev/null @@ -1,251 +0,0 @@ -{ MIT License - - Copyright (c) 2023 fibodevy https://github.com/fibodevy - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to - deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS - IN THE SOFTWARE. -} - -unit zflatefiles; - -{$mode ObjFPC}{$H+} - -interface - -type - //return true to continue or false to abort - tzprogresscb = function(position, totalsize, outputsize: dword): boolean; - -//compress a file to GZIP -function gzencode_file(src, dst: string; level: dword=9; filename: string=''; comment: string=''; progresscb: tzprogresscb=nil; resolution: dword=100): boolean; -//decompress a GZIP file -function gzdecode_file(src, dst: string; progresscb: tzprogresscb=nil; resolution: dword=100): boolean; - -implementation - -uses zflate; - -// -- GZIP compress ----------------------- - -function gzencode_file(src, dst: string; level: dword=9; filename: string=''; comment: string=''; progresscb: tzprogresscb=nil; resolution: dword=100): boolean; -const - bufsize = 1024*32; -var - z: tzflate; - inpt, outp: file of byte; - buf: array[0..bufsize-1] of byte; - header, footer: string; - d, pos, fsize, outsize: dword; - crc: dword = 0; - failed: boolean = false; - progress: dword = 0; - progressnotified: dword = 0; -begin - result := false; - - if not zdeflateinit(z, level) then exit; - - AssignFile(inpt, src); - {$I-} Reset(inpt); {$I+} - if IOResult <> 0 then exit; - - AssignFile(outp, dst); - {$I-} Rewrite(outp); {$I+} - if IOResult <> 0 then begin - CloseFile(inpt); - exit; - end; - - fsize := FileSize(inpt); - outsize := 0; - pos := 0; - - try - //write header - header := makegzipheader(level, filename, comment); - BlockWrite(outp, header[1], length(header)); - inc(outsize, length(header)); - - while true do begin - BlockRead(inpt, buf[0], bufsize, d); - inc(pos, d); - - crc := crc32b(crc, @buf[0], d); //update crc32 - - if not zdeflatewrite(z, @buf[0], d, d nil then begin - progress := trunc(pos/fsize*resolution); - - if (progress > progressnotified) then begin - if not progresscb(pos, fsize, outsize) then begin - failed := true; - zlasterror := ZFLATE_EABORTED; - exit; - end; - - progressnotified := progress; - end; - end; - - if d < bufsize then break; //eof - end; - - //write footer - footer := makegzipfooter(fsize, crc); - BlockWrite(outp, footer[1], length(footer)); - inc(outsize, length(footer)); - - result := true; - finally - CloseFile(inpt); - CloseFile(outp); - - //delete output file on failure - if failed then begin - AssignFile(outp, dst); - {$I-} Erase(outp); {$I+} - end; - end; -end; - -// -- GZIP decompress --------------------- - -function gzdecode_file(src, dst: string; progresscb: tzprogresscb=nil; resolution: dword=100): boolean; -const - bufsize = 1024*32; -var - z: tzflate; - inpt, outp: file of byte; - buf: array[0..bufsize-1] of byte; - header, footer: string; - d, bytestoread, pos, fsize, outsize: dword; - crc: dword = 0; - gzip: tgzipinfo; - streamsize: dword; - originalsize, checksum: dword; - failed: boolean = false; - progress: dword = 0; - progressnotified: dword = 0; -begin - result := false; - - if not zinflateinit(z) then exit; - - AssignFile(inpt, src); - {$I-} Reset(inpt); {$I+} - if IOResult <> 0 then exit; - - AssignFile(outp, dst); - {$I-} Rewrite(outp); {$I+} - if IOResult <> 0 then begin - CloseFile(inpt); - exit; - end; - - fsize := FileSize(inpt); - - try - //read header - setlength(header, 512); - BlockRead(inpt, header[1], length(header)); - if not zreadgzipheader(@header[1], gzip) then exit; - - //read footer - Seek(inpt, fsize-8); - setlength(footer, 8); - BlockRead(inpt, footer[1], 8); - checksum := pdword(@footer[1])^; - originalsize := pdword(@footer[1+4])^; - - outsize := 0; - pos := 0; - streamsize := fsize-gzip.streamat-gzip.footerlen; - - Seek(inpt, gzip.streamat); - - while true do begin - bytestoread := bufsize; - if bytestoread+pos+gzip.streamat > streamsize then dec(bytestoread, gzip.footerlen); //skip footer - - BlockRead(inpt, buf[0], bytestoread, d); - - inc(pos, d); - - if not zinflatewrite(z, @buf[0], d, d nil then begin - progress := trunc((pos+gzip.streamat)/fsize*resolution); - - if (progress > progressnotified) then begin - if not progresscb(pos+gzip.streamat, fsize, outsize) then begin - failed := true; - zlasterror := ZFLATE_EABORTED; - exit; - end; - - progressnotified := progress; - end; - end; - - if d < bufsize then break; //eof - end; - - if FileSize(outp) <> originalsize then begin - zlasterror := ZFLATE_EOUTPUTSIZE; - failed := true; - exit; - end; - - if crc <> checksum then begin - zlasterror := ZFLATE_ECHECKSUM; - failed := true; - exit; - end; - - result := true; - CloseFile(inpt); - finally - CloseFile(outp); - - //delete output file on failure - if failed then begin - AssignFile(outp, dst); - {$I-} Erase(outp); {$I+} - end; - end; -end; - -end. - diff --git a/library/fsl/fsl_gzip.pas b/library/fsl/fsl_gzip.pas index 84500d36d..4c8dcf0bb 100644 --- a/library/fsl/fsl_gzip.pas +++ b/library/fsl/fsl_gzip.pas @@ -56,7 +56,7 @@ function gzip(bytes : TBytes; header : boolean; level: dword=9) : TBytes; function ungzip(bytes : TBytes) : TBytes; begin result := zflate.zdecompress(bytes); - if length(result) = 0 then + if zlastError <> 0 then raise EFslException.create('Failed to read compressed content: '+zflatetranslatecode(zlasterror)); end;