Currency (native type) support.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@979 8e941d3f-bd1b-0410-a28a-d453659cc2b4

wst/trunk/base_service_intf.pas

@@ -720,6 +720,18 @@ type
     property Value : Single read FValue write FValue;
   end;
 
+  { TComplexCurrencyContentRemotable }
+
+  TComplexCurrencyContentRemotable = class(TBaseComplexSimpleContentRemotable)
+  private
+    FValue: Currency;
+  protected
+    class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
+    class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
+  public
+    property Value : Currency read FValue write FValue;
+  end;  
+    
   TComplexAnsiCharContentRemotable = class(TBaseComplexSimpleContentRemotable)
   private
     FValue: AnsiChar;
@@ -5911,6 +5923,28 @@ begin
   (AObject as TComplexFloatSingleContentRemotable).Value := i;
 end;
 
+{ TComplexCurrencyContentRemotable }
+
+class procedure TComplexCurrencyContentRemotable.SaveValue(
+  AObject : TBaseRemotable;
+  AStore  : IFormatterBase
+);
+begin
+  AStore.PutScopeInnerValue(TypeInfo(Currency),(AObject as TComplexCurrencyContentRemotable).Value);   
+end;
+
+class procedure TComplexCurrencyContentRemotable.LoadValue(
+  var AObject : TObject;
+      AStore  : IFormatterBase
+);
+var
+  i : Currency;
+begin
+  i := 0;
+  AStore.GetScopeInnerValue(TypeInfo(Currency),i);
+  (AObject as TComplexCurrencyContentRemotable).Value := i;
+end;
+
 { TComplexInt64SContentRemotable }
 
 class procedure TComplexInt64SContentRemotable.SaveValue(
@@ -6943,6 +6977,7 @@ begin
   Result := xsd_TimeToStr(AValue);
 end;
 
+
 initialization
   initialize_base_service_intf();
 

wst/trunk/tests/test_suite/files/class_currency_property.wsdl

@@ -0,0 +1,22 @@
+<?xml version="1.0"?>
+<definitions name="wst_test" 
+   xmlns="http://schemas.xmlsoap.org/wsdl/" 
+   xmlns:tns="class_currency_property" 
+   xmlns:xsd="http://www.w3.org/2001/XMLSchema" 
+   xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/" 
+   targetNamespace="class_currency_property"
+   xmlns:wst="urn:wst_base">
+
+  <types>
+    <xsd:schema xmlns="http://www.w3.org/2001/XMLSchema" targetNamespace="class_currency_property">
+      <xsd:complexType name="TSampleClass">
+        <xsd:sequence>
+          <xsd:element name="elementProp" type="xsd:decimal" wst:TypeHint="Currency"/>
+        </xsd:sequence>
+        <xsd:attribute use="required" name="elementAtt" type="xsd:decimal" wst:TypeHint="Currency"/>
+      </xsd:complexType>        
+    </xsd:schema>
+  </types>
+  
+
+</definitions>

wst/trunk/tests/test_suite/files/class_currency_property.xsd

@@ -0,0 +1,8 @@
+<schema targetNamespace="class_currency_property" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:tns="class_currency_property" xmlns:wst="urn:wst_base">
+  <xsd:complexType name="TSampleClass">
+    <xsd:sequence>
+      <xsd:element name="elementProp" type="xsd:decimal" wst:TypeHint="Currency"/>
+    </xsd:sequence>
+    <xsd:attribute name="elementAtt" type="xsd:decimal" wst:TypeHint="Currency" use="required"/>
+  </xsd:complexType>
+</schema>

wst/trunk/tests/test_suite/test_generators.pas

@@ -44,6 +44,7 @@ type
 {$ENDIF WST_UNICODESTRING}
     procedure class_ansichar_property();
     procedure class_widechar_property();
+    procedure class_currency_property();
     
     procedure array_sequence_collection();
     procedure class_sequence_open_type_any();
@@ -1112,6 +1113,67 @@ begin
   end;
 end;
 
+procedure TTest_CustomXsdGenerator.class_currency_property(); 
+var
+  tr : TwstPasTreeContainer;
+  mdl : TPasModule;
+  cltyp : TPasClassType;
+
+  procedure AddProperty(
+    const AName,
+          ATypeName,
+          ADefault   : string;
+    const AKind      : TPropertyType
+  );
+  var
+    p : TPasProperty;
+  begin
+    p := TPasProperty(tr.CreateElement(TPasProperty,AName,cltyp,visDefault,'',0));
+    cltyp.Members.Add(p);
+    p.ReadAccessorName := 'F' + AName;
+    p.WriteAccessorName := 'F' + AName;
+    p.VarType := tr.FindElement(ATypeName) as TPasType;
+    Check( (p.VarType <> nil), Format('Type not found : "%s".',[ATypeName]));
+    p.VarType.AddRef();
+    p.DefaultValue := ADefault;
+    p.Visibility := visPublished;
+    p.StoredAccessorName := 'True';
+    if ( AKind = ptAttribute ) then
+      tr.SetPropertyAsAttribute(p,True);
+  end;
+
+var
+  g : IGenerator;
+  locDoc, locExistDoc : TXMLDocument;
+begin
+  locDoc := nil;
+  locExistDoc := nil;
+  tr := TwstPasTreeContainer.Create();
+  try
+    CreateWstInterfaceSymbolTable(tr);
+    mdl := TPasModule(tr.CreateElement(TPasModule,'class_currency_property',tr.Package,visDefault,'',0));
+    tr.Package.Modules.Add(mdl);
+    mdl.InterfaceSection := TPasSection(tr.CreateElement(TPasSection,'',mdl,visDefault,'',0));
+    cltyp := TPasClassType(tr.CreateElement(TPasClassType,'TSampleClass',mdl.InterfaceSection,visDefault,'',0));
+      cltyp.ObjKind := okClass;
+      mdl.InterfaceSection.Declarations.Add(cltyp);
+      mdl.InterfaceSection.Types.Add(cltyp);
+      AddProperty('elementProp','Currency','',ptField);
+      AddProperty('elementAtt','Currency','',ptAttribute);
+
+    locDoc := CreateDoc();
+    g := CreateGenerator(locDoc);
+    g.Execute(tr,mdl.Name);
+    //WriteXMLFile(locDoc,'.\class_currency_property.xsd');
+    locExistDoc := LoadXmlFromFilesList('class_currency_property.xsd');
+    Check(CompareNodes(locExistDoc.DocumentElement,locDoc.DocumentElement),'generated document differs from the existent one.');
+  finally
+    ReleaseDomNode(locExistDoc);
+    ReleaseDomNode(locDoc);
+    FreeAndNil(tr);
+  end;  
+end;
+
 { TTest_XsdGenerator }
 
 function TTest_XsdGenerator.CreateGenerator(const ADoc: TXMLDocument): IXsdGenerator;

wst/trunk/tests/test_suite/test_parsers.pas

@@ -60,6 +60,7 @@ type
     function load_class_widestring_property() : TwstPasTreeContainer;virtual;abstract;
     function load_class_ansichar_property() : TwstPasTreeContainer;virtual;abstract;
     function load_class_widechar_property() : TwstPasTreeContainer;virtual;abstract;
+    function load_class_currency_property() : TwstPasTreeContainer;virtual;abstract;
   published
     procedure EmptySchema();
 
@@ -96,6 +97,7 @@ type
     procedure class_widestring_property();
     procedure class_ansichar_property();
     procedure class_widechar_property();
+    procedure class_currency_property();
   end;
 
   { TTest_XsdParser }
@@ -136,6 +138,7 @@ type
     function load_class_widestring_property() : TwstPasTreeContainer;override;
     function load_class_ansichar_property() : TwstPasTreeContainer;override;
     function load_class_widechar_property() : TwstPasTreeContainer;override;
+    function load_class_currency_property() : TwstPasTreeContainer;override;
   end;
 
   { TTest_WsdlParser }
@@ -176,6 +179,7 @@ type
     function load_class_widestring_property() : TwstPasTreeContainer;override;
     function load_class_ansichar_property() : TwstPasTreeContainer;override;
     function load_class_widechar_property() : TwstPasTreeContainer;override;
+    function load_class_currency_property() : TwstPasTreeContainer;override; 
   published
     procedure no_binding_style();
     procedure signature_last();
@@ -1859,6 +1863,47 @@ begin
   end;
 end;
 
+procedure TTest_CustomXsdParser.class_currency_property(); 
+const s_class_name = 'TSampleClass';
+var
+  clsType : TPasClassType;
+  tr : TwstPasTreeContainer;
+
+  procedure CheckProperty(const AName,ATypeName,ADeclaredTypeName : string; const AFieldType : TPropertyType);
+  var
+    prp : TPasProperty;
+  begin
+    prp := FindMember(clsType,AName) as TPasProperty;
+      CheckNotNull(prp);
+      CheckEquals(AName,prp.Name);
+      CheckEquals(AName,tr.GetExternalName(prp));
+      CheckNotNull(prp.VarType);
+      CheckEquals(ATypeName,prp.VarType.Name,'TypeName');
+      CheckEquals(ADeclaredTypeName,tr.GetExternalName(prp.VarType),'DeclaredTypeName');
+      CheckEquals(PropertyType_Att[AFieldType],tr.IsAttributeProperty(prp));
+  end;
+
+var
+  mdl : TPasModule;
+  elt : TPasElement;
+begin
+  tr := load_class_currency_property();
+  try
+    mdl := tr.FindModule('class_currency_property');
+    CheckNotNull(mdl,'class_currency_property');
+    elt := tr.FindElement(s_class_name);
+      CheckNotNull(elt,s_class_name);
+      CheckEquals(s_class_name,elt.Name);
+      CheckEquals(s_class_name,tr.GetExternalName(elt));
+      CheckIs(elt,TPasClassType);
+      clsType := elt as TPasClassType;
+      CheckProperty('elementProp','Currency','decimal',ptField);
+      CheckProperty('elementAtt','Currency','decimal',ptAttribute);
+  finally
+    tr.Free();
+  end;
+end;
+
 { TTest_XsdParser }
 
 function TTest_XsdParser.ParseDoc(const ADoc: string): TwstPasTreeContainer;
@@ -1989,7 +2034,12 @@ begin
   Result := ParseDoc('class_ansichar_property');
 end;
 
-function TTest_XsdParser.load_class_widechar_property: TwstPasTreeContainer;
+function TTest_XsdParser.load_class_currency_property() : TwstPasTreeContainer;  
+begin
+  Result := ParseDoc('class_currency_property');    
+end;
+
+function TTest_XsdParser.load_class_widechar_property() : TwstPasTreeContainer;
 begin
   Result := ParseDoc('class_widechar_property');
 end;
@@ -2578,6 +2628,11 @@ begin
   Result := ParseDoc('class_widechar_property');
 end;
 
+function TTest_WsdlParser.load_class_currency_property() : TwstPasTreeContainer;  
+begin
+  Result := ParseDoc('class_currency_property');
+end;
+
 initialization
   RegisterTest('XSD parser',TTest_XsdParser.Suite);
   RegisterTest('WSDL parser',TTest_WsdlParser.Suite);

wst/trunk/ws_helper/pascal_parser_intf.pas

@@ -235,8 +235,9 @@ const
         ('TBase64StringRemotable', 'TBase64StringExtRemotable', 'base64Binary'),
         ('TBase16StringRemotable', 'TBase16StringExtRemotable', 'hexBinary')
      );
-   SPECIAL_SIMPLE_TYPES_COUNT = 4 {$IFDEF WST_UNICODESTRING} + 1 {$ENDIF WST_UNICODESTRING};
+   SPECIAL_SIMPLE_TYPES_COUNT = 5 {$IFDEF WST_UNICODESTRING} + 1 {$ENDIF WST_UNICODESTRING};
      SPECIAL_SIMPLE_TYPES : Array[0..Pred(SPECIAL_SIMPLE_TYPES_COUNT)] Of array[0..2] of string = (
+          ('Currency', 'TComplexCurrencyContentRemotable', 'decimal'),
           ('string', 'TComplexStringContentRemotable', 'string'),
           ('WideString', 'TComplexWideStringContentRemotable', 'string'),
           ('AnsiChar', 'TComplexAnsiCharContentRemotable', 'string'),

wst/trunk/ws_helper/xsd_generator.pas

@@ -201,6 +201,14 @@ type
       ASchemaNode  : TDOMElement
     );override;
   end;
+  
+  TCurrencyHelper = class(TAbstractSpecialTypeHelper,IXsdSpecialTypeHelper)
+  protected
+    procedure HandleTypeUsage(
+      ATargetNode,
+      ASchemaNode  : TDOMElement
+    );override;
+  end;   
 
 {$IFDEF WST_UNICODESTRING}
   { TUnicodeStringHelper }
@@ -439,6 +447,17 @@ begin
   ATargetNode.SetAttribute(Format('%s:%s',[s_WST,s_WST_typeHint]),'WideChar');
 end;
 
+{ TCurrencyHelper }
+
+procedure TCurrencyHelper.HandleTypeUsage(ATargetNode, ASchemaNode: TDOMElement);
+var
+  strBuffer : string;
+begin
+  if not FindAttributeByValueInNode(s_WST_base_namespace,ASchemaNode,strBuffer) then
+    ASchemaNode.SetAttribute(Format('%s:%s',[s_xmlns,s_WST]),s_WST_base_namespace);
+  ATargetNode.SetAttribute(Format('%s:%s',[s_WST,s_WST_typeHint]),'Currency');
+end;  
+
 {$IFDEF WST_UNICODESTRING}
 { TUnicodeStringHelper }
 
@@ -519,9 +538,10 @@ function TXsdTypeHandlerRegistry.FindHelper(
   out AHelper: IXsdSpecialTypeHelper
 ) : Boolean;
 const
-   HELPER_COUNT = 3 {$IFDEF WST_UNICODESTRING} + 1 {$ENDIF WST_UNICODESTRING};
+   HELPER_COUNT = 4 {$IFDEF WST_UNICODESTRING} + 1 {$ENDIF WST_UNICODESTRING};
    HELPER_MAP : array[0..Pred(HELPER_COUNT)] of TSpecialTypeHelperRecord = (
-     ( Name : 'widestring'; HelperClass : TWideStringHelper;),
+     ( Name : 'currency'; HelperClass : TCurrencyHelper;),
+     ( Name : 'widestring'; HelperClass : TWideStringHelper;),    
      ( Name : 'ansichar'; HelperClass : TAnsiCharHelper;),
      ( Name : 'widechar'; HelperClass : TWideCharHelper;)
 {$IFDEF WST_UNICODESTRING}