diff --git a/wst/trunk/tests/test_suite/files/import_base_library.wsdl b/wst/trunk/tests/test_suite/files/import_base_library.wsdl new file mode 100644 index 000000000..8b98c0e4e --- /dev/null +++ b/wst/trunk/tests/test_suite/files/import_base_library.wsdl @@ -0,0 +1,23 @@ + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/tests/test_suite/files/import_base_library.xsd b/wst/trunk/tests/test_suite/files/import_base_library.xsd new file mode 100644 index 000000000..ba8bb8e7e --- /dev/null +++ b/wst/trunk/tests/test_suite/files/import_base_library.xsd @@ -0,0 +1,11 @@ + + + + + + + + + diff --git a/wst/trunk/tests/test_suite/files/import_second_library.wsdl b/wst/trunk/tests/test_suite/files/import_second_library.wsdl new file mode 100644 index 000000000..352938f5e --- /dev/null +++ b/wst/trunk/tests/test_suite/files/import_second_library.wsdl @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/tests/test_suite/files/import_second_library.xsd b/wst/trunk/tests/test_suite/files/import_second_library.xsd new file mode 100644 index 000000000..590307d18 --- /dev/null +++ b/wst/trunk/tests/test_suite/files/import_second_library.xsd @@ -0,0 +1,16 @@ + + + + + + + + + + diff --git a/wst/trunk/tests/test_suite/test_parsers.pas b/wst/trunk/tests/test_suite/test_parsers.pas index 9fee5cc38..8d2eb92a5 100644 --- a/wst/trunk/tests/test_suite/test_parsers.pas +++ b/wst/trunk/tests/test_suite/test_parsers.pas @@ -21,7 +21,7 @@ uses {$ELSE} TestFrameWork, xmldom, wst_delphi_xml, {$ENDIF} - pastree, pascal_parser_intf, xsd_parser, wsdl_parser, test_suite_utils; + pastree, pascal_parser_intf, xsd_parser, wsdl_parser, test_suite_utils, wst_types; type @@ -61,6 +61,8 @@ type function load_class_ansichar_property() : TwstPasTreeContainer;virtual;abstract; function load_class_widechar_property() : TwstPasTreeContainer;virtual;abstract; function load_class_currency_property() : TwstPasTreeContainer;virtual;abstract; + + function load_schema_import() : TwstPasTreeContainer;virtual;abstract; published procedure EmptySchema(); @@ -98,6 +100,8 @@ type procedure class_ansichar_property(); procedure class_widechar_property(); procedure class_currency_property(); + + procedure schema_import(); end; { TTest_XsdParser } @@ -139,6 +143,8 @@ type function load_class_ansichar_property() : TwstPasTreeContainer;override; function load_class_widechar_property() : TwstPasTreeContainer;override; function load_class_currency_property() : TwstPasTreeContainer;override; + + function load_schema_import() : TwstPasTreeContainer;override; end; { TTest_WsdlParser } @@ -179,7 +185,9 @@ 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; + function load_class_currency_property() : TwstPasTreeContainer;override; + + function load_schema_import() : TwstPasTreeContainer;override; published procedure no_binding_style(); procedure signature_last(); @@ -193,7 +201,7 @@ type end; implementation -uses parserutils, xsd_consts, typinfo; +uses parserutils, xsd_consts, typinfo, locators; const x_complexType_SampleArrayIntFieldType = 'TArrayIntFieldType'; @@ -1904,12 +1912,56 @@ begin end; end; +procedure TTest_CustomXsdParser.schema_import(); +const + s_base_namespace = 'urn:base-library'; + s_base_type = 'SampleBase_Type'; + s_second_namespace = 'urn:second-library'; + s_second_type = 'Second_Type'; +var + tr : TwstPasTreeContainer; + mdl : TPasModule; + ls : TList; + elt, prpElt : TPasElement; + prp : TPasProperty; + baseType, scdClass : TPasClassType; +begin + tr := load_schema_import(); + + mdl := tr.FindModule(s_base_namespace); + CheckNotNull(mdl,s_base_namespace); + ls := mdl.InterfaceSection.Declarations; + CheckEquals(1,ls.Count); + elt := tr.FindElement(s_base_type); + CheckNotNull(elt,s_base_type); + CheckIs(elt,TPasClassType); + baseType := TPasClassType(elt); + + mdl := tr.FindModule(s_second_namespace); + CheckNotNull(mdl,s_second_namespace); + ls := mdl.InterfaceSection.Declarations; + CheckEquals(1,ls.Count); + elt := tr.FindElement(s_second_type); + CheckNotNull(elt,s_second_type); + CheckIs(elt,TPasClassType); + scdClass := TPasClassType(elt); + prpElt := FindMember(scdClass,'SampleProperty'); + CheckNotNull(prpElt); + CheckIs(prpElt,TPasProperty); + prp := TPasProperty(prpElt); + CheckNotNull(prp.VarType); + CheckEquals(PtrUInt(prp.VarType),PtrUInt(prp.VarType)); + + FreeAndNil(tr); +end; + { TTest_XsdParser } function TTest_XsdParser.ParseDoc(const ADoc: string): TwstPasTreeContainer; var locDoc : TXMLDocument; prs : IXsdPaser; + prsCtx : IParserContext; fileName : string; begin fileName := wstExpandLocalFileName(TestFilesPath + ADoc + '.xsd'); @@ -1918,6 +1970,8 @@ begin Result := TwstPasTreeContainer.Create(); CreateWstInterfaceSymbolTable(Result); prs := TXsdParser.Create(locDoc,Result,ADoc); + prsCtx := prs as IParserContext; + prsCtx.SetDocumentLocator(TFileDocumentLocator.Create(ExtractFilePath(fileName))); prs.ParseTypes(); finally ReleaseDomNode(locDoc); @@ -2039,6 +2093,11 @@ begin Result := ParseDoc('class_currency_property'); end; +function TTest_XsdParser.load_schema_import(): TwstPasTreeContainer; +begin + Result := ParseDoc('import_second_library'); +end; + function TTest_XsdParser.load_class_widechar_property() : TwstPasTreeContainer; begin Result := ParseDoc('class_widechar_property'); @@ -2060,6 +2119,7 @@ function TTest_WsdlParser.ParseDoc(const ADoc: string): TwstPasTreeContainer; var locDoc : TXMLDocument; prs : IParser; + prsCtx : IParserContext; fileName : string; begin fileName := wstExpandLocalFileName(TestFilesPath + ADoc + '.wsdl'); @@ -2068,6 +2128,8 @@ begin Result := TwstPasTreeContainer.Create(); CreateWstInterfaceSymbolTable(Result); prs := TWsdlParser.Create(locDoc,Result); + prsCtx := prs as IParserContext; + prsCtx.SetDocumentLocator(TFileDocumentLocator.Create(ExtractFilePath(fileName))); prs.Execute(pmAllTypes,ADoc); finally ReleaseDomNode(locDoc); @@ -2633,6 +2695,11 @@ begin Result := ParseDoc('class_currency_property'); end; +function TTest_WsdlParser.load_schema_import(): TwstPasTreeContainer; +begin + Result := ParseDoc('import_second_library'); +end; + initialization RegisterTest('XSD parser',TTest_XsdParser.Suite); RegisterTest('WSDL parser',TTest_WsdlParser.Suite); diff --git a/wst/trunk/tests/test_suite/wst_test_suite_gui.lpi b/wst/trunk/tests/test_suite/wst_test_suite_gui.lpi index 604f3024e..7161ae11f 100644 --- a/wst/trunk/tests/test_suite/wst_test_suite_gui.lpi +++ b/wst/trunk/tests/test_suite/wst_test_suite_gui.lpi @@ -172,7 +172,6 @@ - diff --git a/wst/trunk/ws_helper/delphi/ws_helper.dpr b/wst/trunk/ws_helper/delphi/ws_helper.dpr index 1f4bdbfe5..62b9c329e 100644 --- a/wst/trunk/ws_helper/delphi/ws_helper.dpr +++ b/wst/trunk/ws_helper/delphi/ws_helper.dpr @@ -42,7 +42,8 @@ uses xsd_parser, ws_parser_imp, wsdl_parser, - xsd_generator; + xsd_generator, + locators; {$INCLUDE ws_helper_prog.inc} diff --git a/wst/trunk/ws_helper/locators.pas b/wst/trunk/ws_helper/locators.pas new file mode 100644 index 000000000..7671fa0b8 --- /dev/null +++ b/wst/trunk/ws_helper/locators.pas @@ -0,0 +1,70 @@ +{ + This file is part of the Web Service Toolkit + Copyright (c) 2009 by Inoussa OUEDRAOGO + + This file is provide under modified LGPL licence + ( the files COPYING.modifiedLGPL and COPYING.LGPL). + + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +} +{$INCLUDE wst_global.inc} +unit locators; + +interface + +uses + Classes, SysUtils +{$IFDEF WST_DELPHI} + , xmldom, wst_delphi_xml +{$ENDIF WST_DELPHI} +{$IFDEF FPC} + , DOM, XMLRead +{$ENDIF FPC} + , xsd_parser; + +type + + { TFileDocumentLocator } + + TFileDocumentLocator = class(TInterfacedObject,IDocumentLocator) + private + FBasePath : string; + protected + property BasePath : string read FBasePath; + protected + function Find( + const ADocLocation : string; + out ADoc : TXMLDocument + ) : Boolean; + public + constructor Create(const ABasePath : string); + end; + +implementation + +{ TFileDocumentLocator } + +function TFileDocumentLocator.Find( + const ADocLocation: string; + out ADoc: TXMLDocument +) : Boolean; +var + locFileName : string; +begin + locFileName := BasePath + ExtractFileName(ADocLocation); + locFileName := ExpandFileName(locFileName); + Result := FileExists(locFileName); + if Result then + ReadXMLFile(ADoc,locFileName); +end; + +constructor TFileDocumentLocator.Create(const ABasePath: string); +begin + FBasePath := IncludeTrailingPathDelimiter(ABasePath); +end; + +end. + diff --git a/wst/trunk/ws_helper/parserdefs.pas b/wst/trunk/ws_helper/parserdefs.pas deleted file mode 100644 index 0f9e18af1..000000000 --- a/wst/trunk/ws_helper/parserdefs.pas +++ /dev/null @@ -1,1337 +0,0 @@ -{ - This unit is part of the Web Service Toolkit - Copyright (c) 2006 by Inoussa OUEDRAOGO - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -} - - -unit parserdefs; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, Contnrs; - -Type - - ESymbolException = class(Exception) - End; - - TSymbolTable = class; - TTypeDefinition = class; - TForwardTypeDefinition = class; - - { TAbstractSymbolDefinition } - - TAbstractSymbolDefinition = class - private - FName: String; - FExternalAlias : string; - protected - procedure SetName(const AName : string);virtual; - procedure FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition - );virtual; - Public - constructor Create(Const AName : String); - procedure RegisterExternalAlias(const AExternalName : String); - function SameName(const AName : string) : Boolean;virtual; - Property Name : String Read FName; - Property ExternalName : String Read FExternalAlias; - End; - - TAbstractSymbolDefinitionClass = class of TAbstractSymbolDefinition; - - TPascalTokenDefinition = class(TAbstractSymbolDefinition) - end; - - TSymbolTableChange = ( stcAdding, stcDeleting ); - ISymbolTableChangeListner = interface - ['{0147E0EE-FF1A-4CFA-BD71-3F8E90494EC9}'] - procedure NotifyChange( - ASender : TSymbolTable; - AItem : TAbstractSymbolDefinition; - const AEvent : TSymbolTableChange - ); - end; - - { TAbstractConstantDefinition } - - TAbstractConstantDefinition = class(TAbstractSymbolDefinition) end; - - TSimpleConstantType = ( sctString, sctInteger ); - TSimpleConstantBuffer = record - case DataType : TSimpleConstantType of - sctInteger : ( IntValue : Integer; ); - sctString : ( StrValue : string[255]; ); - end; - - { TSimpleConstantDefinition } - - TSimpleConstantDefinition = class(TAbstractConstantDefinition) - private - FValue: TSimpleConstantBuffer; - public - constructor Create(const AName : string; const AValue : string);overload; - constructor Create(const AName : string; const AValue : Integer);overload; - property Value : TSimpleConstantBuffer read FValue; - end; - - { TTypeDefinition } - - TTypeDefinition = class(TAbstractSymbolDefinition) - public - function NeedFinalization():Boolean;virtual; - end; - - TAnyTypeDefinition = class(TTypeDefinition) - end; - - { TTypeAliasDefinition } - - TTypeAliasDefinition = class(TTypeDefinition) - private - FBaseType: TTypeDefinition; - protected - procedure FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition - );override; - public - constructor Create(const AName : string; ABaseType : TTypeDefinition); - property BaseType : TTypeDefinition read FBaseType; - end; - - { TSimpleTypeDefinition } - - TSimpleTypeDefinition = class(TTypeDefinition) - public - function NeedFinalization():Boolean;override; - end; - - { TForwardTypeDefinition } - - TForwardTypeDefinition = class(TTypeDefinition) - end; - - TArrayStyle = ( asScoped, asEmbeded ); - - { TArrayDefinition } - - TArrayDefinition = class(TTypeDefinition) - private - FItemExternalName: string; - FItemName: string; - FItemType: TTypeDefinition; - FStyle: TArrayStyle; - protected - procedure FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition - );override; - public - constructor Create( - const AName : string; - AItemType : TTypeDefinition; - const AItemName, - AItemExternalName : string; - const AStyle : TArrayStyle - ); - function NeedFinalization():Boolean;override; - property ItemName : string read FItemName; - property ItemType : TTypeDefinition read FItemType; - property ItemExternalName : string read FItemExternalName; - property Style : TArrayStyle read FStyle; - end; - - TEnumTypeDefinition = class; - - { TEnumItemDefinition } - - TEnumItemDefinition = class(TAbstractSymbolDefinition) - private - FEnumType: TEnumTypeDefinition; - FOrder: Integer; - protected - procedure FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition - );override; - Public - constructor Create( - Const AName : String; - AEnumType : TEnumTypeDefinition; - Const AOrder : Integer - ); - Property Order : Integer Read FOrder; - property EnumType : TEnumTypeDefinition read FEnumType; - End; - - { TEnumTypeDefinition } - - TEnumTypeDefinition = class(TTypeDefinition) - Private - FItemList : TObjectList; - private - function GetItem(Index: Integer): TEnumItemDefinition; - function GetItemCount: Integer; - Public - constructor Create(Const AName : String); - destructor Destroy();override; - function NeedFinalization():Boolean;override; - Procedure AddItem(AItem:TEnumItemDefinition); - function FindItem(Const AName:String):TEnumItemDefinition; - Property ItemCount : Integer Read GetItemCount; - Property Item[Index:Integer]:TEnumItemDefinition Read GetItem; - End; - - TStorageOption = ( soAlways, soOptional, soNever ); - - { TPropertyDefinition } - - TPropertyDefinition = class(TAbstractSymbolDefinition) - private - FDataType: TTypeDefinition; - FIsAttribute: Boolean; - FStorageOption: TStorageOption; - protected - procedure FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition - );override; - public - constructor Create( - Const AName : String; - ADataType : TTypeDefinition - ); - property DataType : TTypeDefinition Read FDataType; - property IsAttribute : Boolean read FIsAttribute write FIsAttribute; - property StorageOption : TStorageOption read FStorageOption write FStorageOption; - End; - - { TClassTypeDefinition } - - TClassTypeDefinition = class(TTypeDefinition) - private - FParent: TTypeDefinition; - FPropertyList : TObjectList; - private - function GetProperty(const Index : Integer): TPropertyDefinition; - function GetPropertyCount: Integer; - protected - procedure FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition - );override; - public - constructor Create(Const AName : String); - destructor Destroy();override; - function NeedFinalization():Boolean;override; - function IsDescendantOf(ABaseType : TTypeDefinition) : Boolean; - procedure SetParent(const AValue: TTypeDefinition); - function AddProperty( - Const AName : String; - ADataType : TTypeDefinition - ) : TPropertyDefinition; - function IndexOfProperty(const AName : string):Integer; - property Parent : TTypeDefinition read FParent; - property PropertyCount : Integer read GetPropertyCount; - property Properties[const Index : Integer] : TPropertyDefinition read GetProperty; - end; - - TClassTypeDefinitionClass = class of TClassTypeDefinition; - - TNativeClassTypeDefinition = class(TClassTypeDefinition) - end; - - { TNativeSimpleTypeDefinition } - - TNativeSimpleTypeDefinition = class(TSimpleTypeDefinition) - private - FBoxedType: TNativeClassTypeDefinition; - public - procedure SetBoxedType(ABoxedType : TNativeClassTypeDefinition); - property BoxedType : TNativeClassTypeDefinition read FBoxedType; - end; - - TParameterModifier = ( pmNone, pmConst, pmVar, pmOut ); - - { TParameterDefinition } - - TParameterDefinition = class(TAbstractSymbolDefinition) - private - FDataType: TTypeDefinition; - FModifier: TParameterModifier; - protected - procedure SetModifier(const AModifier : TParameterModifier); - procedure FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition - );override; - Public - constructor Create( - Const AName : String; - Const AModifier : TParameterModifier; - ADataType : TTypeDefinition - ); - property Modifier : TParameterModifier Read FModifier; - property DataType : TTypeDefinition Read FDataType; - End; - - TMethodType = ( mtProcedure, mtFunction ); -Const - ParameterModifierMAP : Array[TParameterModifier] Of String = - ( '', 'Const', 'Var', 'Out' ); -Type - - { TMethodDefinition } - - TMethodDefinition = class(TAbstractSymbolDefinition) - private - FMethodType: TMethodType; - FParameterList : TObjectList; - FProperties: TStrings; - private - function GetParameter(Index: Integer): TParameterDefinition; - function GetParameterCount: Integer; - protected - procedure SetMethodType( AMethodType : TMethodType ); - procedure FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition - );override; - Public - constructor Create(Const AName : String; Const AMethodType : TMethodType); - destructor Destroy();override; - function AddParameter( - Const AName : String; - Const AModifier : TParameterModifier; - ADataType : TTypeDefinition - ):TParameterDefinition; - function GetParameterIndex(Const AName : String):Integer; - function FindParameter(Const AName : String):TParameterDefinition; - property MethodType : TMethodType Read FMethodType; - property ParameterCount : Integer Read GetParameterCount; - property Parameter[Index:Integer] : TParameterDefinition Read GetParameter; - property Properties : TStrings read FProperties; - End; - - TBindingStyle = ( bsDocument, bsRPC, bsUnknown ); - - { TInterfaceDefinition } - - TInterfaceDefinition = class(TAbstractSymbolDefinition) - Private - FInterfaceGUID: string; - FMethodList : TObjectList; - private - FAddress: string; - FBindingStyle: TBindingStyle; - function GetMethod(Index: Integer): TMethodDefinition; - function GetMethodCount: Integer; - protected - procedure FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition - );override; - Public - constructor Create(Const AName : String); - destructor Destroy();override; - function GetMethodIndex(Const AName : String):Integer; - function FindMethod(Const AName : String):TMethodDefinition; - function AddMethod( - Const AName : String; - Const AMethodType : TMethodType - ):TMethodDefinition; - function AddMethod(AMthd : TMethodDefinition):TMethodDefinition; - Property MethodCount : Integer Read GetMethodCount; - Property Method[Index:Integer] : TMethodDefinition Read GetMethod; - property InterfaceGUID : string read FInterfaceGUID write FInterfaceGUID; - property Address : string read FAddress write FAddress; - property BindingStyle : TBindingStyle read FBindingStyle write FBindingStyle; - End; - - { TSymbolTable } - - TSymbolTable = class(TAbstractSymbolDefinition) - Private - FList : TObjectList; - FLinkedTables : TObjectList; - FListners : IInterfaceList; - private - procedure CheckIndex(Const AIndex : Integer); - function GetCount: Integer; - function GetItem(Index: Integer): TAbstractSymbolDefinition; - function GetLinkedTableCount: Integer; - function GetLinkedTables(Index : Integer): TSymbolTable; - procedure SetName(const AValue: String); - procedure ReorderClass(ASym : TClassTypeDefinition); - protected - procedure NotifyChange( - ASender : TSymbolTable; - AItem : TAbstractSymbolDefinition; - const AEvent : TSymbolTableChange - ); - procedure FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition - );override; - Public - constructor Create(Const AName : String); - destructor Destroy();override; - procedure Clear(); - function Add(ASym : TAbstractSymbolDefinition):Integer; - procedure Delete(ASym : TAbstractSymbolDefinition); - function IndexOf(Const AName : String):Integer;overload; - function IndexOf( - const AName : string; - const AMinClass : TAbstractSymbolDefinitionClass - ):Integer;overload; - function IndexOf(ASym : TAbstractSymbolDefinition):Integer;overload; - function Find(Const AName : String):TAbstractSymbolDefinition;overload; - function Find( - const AName : string; - const AMinClass : TAbstractSymbolDefinitionClass - ):TAbstractSymbolDefinition;overload; - function ByName(Const AName : String):TAbstractSymbolDefinition; - procedure RegisterListner(AListner : ISymbolTableChangeListner); - procedure UnregisterListner(AListner : ISymbolTableChangeListner); - Property Name : String Read FName Write SetName; - Property Count : Integer Read GetCount; - Property Item[Index:Integer] : TAbstractSymbolDefinition Read GetItem;default; - property LinkedTables[Index : Integer] : TSymbolTable read GetLinkedTables; - property LinkedTableCount : Integer read GetLinkedTableCount; - End; - - - //function CreateSystemSymbolTable() : TSymbolTable; - procedure AddSystemSymbol(ADest : TSymbolTable); - procedure AddSoapencSymbol(ADest : TSymbolTable); - function CreateWstInterfaceSymbolTable() : TSymbolTable; - function IsReservedKeyWord(const AValue : string):Boolean ; - -implementation -uses StrUtils, parserutils; - -const LANGAGE_TOKEN : array[0..107] of string = ( - 'ABSTRACT', 'AND', 'ARRAY', 'AS', 'ASM', - 'BEGIN', 'BOOLEAN', 'BYTE', - 'CASE', 'CDECL', 'CHAR', 'CLASS', 'COMP', 'CONST', 'CONSTRUCTOR', 'CONTAINS', 'CURRENCY', - 'DEFAULT', 'DESTRUCTOR', 'DIV', 'DO', 'DOUBLE', 'DOWNTO', 'DYNAMIC', - 'END', 'EXPORT', 'EXPORTS', 'EXTERNAL', - 'FAR', 'FILE', 'FINALLY', 'FOR', 'FORWARD', 'FUNCTION', 'GOTO', - 'ELSE', 'EXCEPT', 'EXTENDED', - 'IF', 'IMPLEMENTATION', 'IMPLEMENTS', 'IN', 'INHERITED', 'INT64', 'INITIALIZATION', - 'INTEGER', 'INTERFACE', 'IS', - 'LABEL', 'LIBRARY', 'LOCAL', 'LONGINT', 'LONGWORD', - 'MOD', 'NEAR', 'NIL', 'NODEFAULT', 'NOT', - 'OBJECT', 'OF', 'OLEVARIANT', 'OR', 'OUT', 'OVERLOAD', 'OVERRIDE', - 'PACKAGE', 'PACKED', 'PASCAL', 'PCHAR', 'PRIVATE', 'PROCEDURE', 'PROGRAM', 'PUBLISHED', - 'RAISE', 'READ', 'REAL', 'RECORD', 'REGISTER', 'REINTRODUCE', 'REPEAT', 'REQUIRES', 'RESULT', - 'SAFECALL', 'SET', 'SHL', 'SHORTINT', 'SHR', 'SINGLE', 'SMALLINT', 'STDCALL', 'STORED', - 'THEN', 'TO', 'TRY', 'TYPE', 'UNIT', 'UNTIL', 'USES', - 'VAR', 'VARARGS', 'VARIANT', 'VIRTUAL', 'WHILE', 'WIDECHAR', 'WITH', 'WORD', 'WRITE', 'XOR' -); -const WST_RESERVED_TOKEN : array[0..1] of string = ( 'Item', 'Item' ); -function IsReservedKeyWord(const AValue : string):Boolean ; -begin - Result := AnsiMatchText(AValue,LANGAGE_TOKEN) or - AnsiMatchText(AValue,WST_RESERVED_TOKEN); -end; - -{ TAbstractSymbolDefinition } - -constructor TAbstractSymbolDefinition.Create(const AName: String); -begin - Assert(Not IsStrEmpty(AName)); - FName := AName; - FExternalAlias := FName; -end; - -procedure TAbstractSymbolDefinition.RegisterExternalAlias(const AExternalName : String); -begin - FExternalAlias := AExternalName; -end; - -function TAbstractSymbolDefinition.SameName(const AName: string): Boolean; -begin - Result := AnsiSameText(AName,Self.Name) or AnsiSameText(AName,Self.ExternalName); -end; - -procedure TAbstractSymbolDefinition.SetName(const AName: string); -begin - FName := AName; -end; - -procedure TAbstractSymbolDefinition.FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition -); -begin - -end; - -{ TParameterDefinition } - -procedure TParameterDefinition.SetModifier(const AModifier: TParameterModifier); -begin - FModifier := AModifier; -end; - -procedure TParameterDefinition.FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition -); -begin - if ( FDataType = AFrw ) then - FDataType := Atype; -end; - -constructor TParameterDefinition.Create( - const AName: String; - const AModifier: TParameterModifier; - ADataType: TTypeDefinition -); -begin - Inherited Create(AName); - Assert(Assigned(ADataType)); - FModifier := AModifier; - FDataType := ADataType; -end; - -{ TMethodDefinition } - -function TMethodDefinition.GetParameter(Index: Integer): TParameterDefinition; -begin - Result := FParameterList[Index] As TParameterDefinition; -end; - -function TMethodDefinition.GetParameterCount: Integer; -begin - Result := FParameterList.Count; -end; - -procedure TMethodDefinition.SetMethodType(AMethodType: TMethodType); -begin - FMethodType := AMethodType; -end; - -procedure TMethodDefinition.FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition -); -var - i : Integer; -begin - for i := 0 to Pred(ParameterCount) do - Parameter[i].FixForwardTypeDefinitions(AFrw, Atype); -end; - -constructor TMethodDefinition.Create( - const AName: String; - const AMethodType: TMethodType -); -begin - Inherited Create(AName); - FMethodType := AMethodType; - FParameterList := TObjectList.create(True); - FProperties := TStringList.Create(); -end; - -destructor TMethodDefinition.Destroy(); -begin - FreeAndNil(FProperties); - FreeAndNil(FParameterList); - inherited Destroy(); -end; - -function TMethodDefinition.AddParameter( - Const AName : String; - Const AModifier : TParameterModifier; - ADataType : TTypeDefinition -): TParameterDefinition; -begin - If ( GetParameterIndex(AName) = -1 ) Then Begin - Result := TParameterDefinition.Create(AName,AModifier,ADataType); - FParameterList.Add(Result); - End Else Begin - Raise ESymbolException.CreateFmt('Duplicated parameter : %s.%s',[Name,AName]); - End; -end; - -function TMethodDefinition.GetParameterIndex(const AName: String): Integer; -begin - For Result := 0 To Pred(ParameterCount) Do - If AnsiSameText(AName,Parameter[Result].Name) Then - Exit; - Result := -1; -end; - -function TMethodDefinition.FindParameter( - const AName: String -): TParameterDefinition; -Var - i : Integer; -begin - i := GetParameterIndex(AName); - If ( i > -1 ) Then - Result := Parameter[i] - Else - Result := Nil; -end; - -{ TInterfaceDefinition } - -function TInterfaceDefinition.GetMethod(Index: Integer): TMethodDefinition; -begin - Result := FMethodList[Index] As TMethodDefinition; -end; - -function TInterfaceDefinition.GetMethodCount: Integer; -begin - Result := FMethodList.Count; -end; - -procedure TInterfaceDefinition.FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition -); -var - i : Integer; -begin - for i := 0 to Pred(MethodCount) do - Method[i].FixForwardTypeDefinitions(AFrw, Atype); -end; - -constructor TInterfaceDefinition.Create(const AName: String); -begin - Inherited Create(AName); - FMethodList := TObjectList.create(True); -end; - -destructor TInterfaceDefinition.Destroy(); -begin - FreeAndNil(FMethodList); - inherited Destroy(); -end; - -function TInterfaceDefinition.GetMethodIndex(const AName: String): Integer; -begin - For Result := 0 To Pred(MethodCount) Do - If AnsiSameText(AName,Method[Result].Name) Then - Exit; - Result := -1; -end; - -function TInterfaceDefinition.FindMethod(const AName: String): TMethodDefinition; -Var - i : Integer; -begin - i := GetMethodIndex(AName); - If ( i > -1 ) Then - Result := Method[i] - Else - Result := Nil; -end; - -function TInterfaceDefinition.AddMethod( - Const AName : String; - Const AMethodType : TMethodType -):TMethodDefinition; -begin - if ( GetMethodIndex(Name) = -1 ) then begin - Result := AddMethod(TMethodDefinition.Create(AName,AMethodType)); - end else begin - raise ESymbolException.CreateFmt('Duplicated methode : %s.%s',[Name,AName]); - end; -end; - -function TInterfaceDefinition.AddMethod(AMthd: TMethodDefinition): TMethodDefinition; -begin - if ( GetMethodIndex(AMthd.Name) = -1 ) then begin - Result := AMthd; - FMethodList.Add(Result); - end else begin - raise ESymbolException.CreateFmt('Duplicated methode : %s.%s',[Name,AMthd.Name]); - end; -end; - -{ TSymbolTable } - -procedure TSymbolTable.CheckIndex(const AIndex: Integer); -begin - If ( AIndex < 0 ) Or ( AIndex >= Count ) Then - Raise ESymbolException.CreateFmt('Invalid Table Index : %d',[AIndex]); -end; - -function TSymbolTable.GetCount: Integer; -begin - Result := FList.Count; -end; - -function TSymbolTable.GetItem(Index: Integer): TAbstractSymbolDefinition; -begin - CheckIndex(Index); - Result := FList[Index] As TAbstractSymbolDefinition; -end; - -function TSymbolTable.GetLinkedTableCount: Integer; -begin - Result := FLinkedTables.Count; -end; - -function TSymbolTable.GetLinkedTables(Index : Integer): TSymbolTable; -begin - Result := FLinkedTables[Index] as TSymbolTable; -end; - -procedure TSymbolTable.SetName(const AValue: String); -begin - if ( FName = AValue ) then - Exit; - FName := AValue; -end; - -procedure TSymbolTable.ReorderClass(ASym: TClassTypeDefinition); -var - i ,j : Integer; - locSymb : TClassTypeDefinition; -begin - locSymb := ASym; - while True do begin - if not Assigned(locSymb.Parent) then - Exit; - i := FList.IndexOf(locSymb); - if ( i < 0 ) then - Exit; - j := FList.IndexOf(locSymb.Parent); - if ( j < 0 ) then - Exit; - //if ( i > j ) then - //Exit; - if ( i < j ) then - FList.Exchange(i,j); - if not locSymb.Parent.InheritsFrom(TClassTypeDefinition) then - Exit; - locSymb := locSymb.Parent as TClassTypeDefinition; - end; -end; - -procedure TSymbolTable.NotifyChange( - ASender : TSymbolTable; - AItem : TAbstractSymbolDefinition; - const AEvent : TSymbolTableChange -); -var - i : Integer; -begin - for i := 0 to Pred(FListners.Count) do - (FListners[i] as ISymbolTableChangeListner).NotifyChange(ASender,AItem,AEvent); -end; - -procedure TSymbolTable.FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition -); -var - i : Integer; -begin - for i := 0 to Pred(Count) do - Item[i].FixForwardTypeDefinitions(AFrw, Atype); -end; - -constructor TSymbolTable.Create(Const AName : String); -begin - Inherited Create(AName); - FList := TObjectList.Create(True); - FLinkedTables := TObjectList.Create(False); - FListners := TInterfaceList.Create(); -end; - -destructor TSymbolTable.Destroy(); -begin - if Assigned(FList) then - Clear(); - FreeAndNil(FList); - FreeAndNil(FLinkedTables); - FListners := nil; - inherited Destroy(); -end; - -procedure TSymbolTable.Clear(); -var - i : Integer; -begin - FLinkedTables.Clear(); - for i := 0 to Pred(FList.Count) do - Delete(FList[0] as TAbstractSymbolDefinition); -end; - -function TSymbolTable.Add(ASym: TAbstractSymbolDefinition): Integer; -var - i : Integer; - locNeedFix : Boolean; - frwdTyp : TForwardTypeDefinition; -begin - Result := IndexOf(ASym); - If ( Result = -1 ) Then Begin - locNeedFix := False; - i := IndexOf(ASym.Name); - if ( i <> -1 ) then begin - if Item[i].InheritsFrom(TForwardTypeDefinition) and - ( not ASym.InheritsFrom(TForwardTypeDefinition) ) - then - locNeedFix := True - else - raise ESymbolException.CreateFmt('Duplicated symbol name %s : ( %s/%s ), ( %s/%s )',[ASym.Name,Item[i].ClassName,Item[i].ExternalName,ASym.ClassName,ASym.ExternalName]); - end; - NotifyChange(Self,ASym,stcAdding); - Result := FList.Add(ASym); - if ASym.InheritsFrom(TSymbolTable) then - FLinkedTables.Add(ASym); - if locNeedFix then begin - frwdTyp := Item[i] as TForwardTypeDefinition; - FixForwardTypeDefinitions( frwdTyp, (ASym as TTypeDefinition ) ); - FList.Exchange(i,Result); - Delete(frwdTyp); - end; - Result := IndexOf(ASym); - End; -end; - -procedure TSymbolTable.Delete(ASym: TAbstractSymbolDefinition); -var - i : Integer; -begin - if Assigned(ASym) then begin - i := FList.IndexOf(ASym); - if ( i >= 0 ) then begin - NotifyChange(Self,ASym,stcDeleting); - FList.Delete(i); - end; - end; -end; - -function TSymbolTable.IndexOf(const AName: String): Integer; -begin - for Result := 0 to Pred(Count) do - if Item[Result].SameName(AName) then - Exit; - Result := -1; -end; - -function TSymbolTable.IndexOf( - const AName : string; - const AMinClass : TAbstractSymbolDefinitionClass -): Integer; -var - syb : TAbstractSymbolDefinition; -begin - for Result := 0 to Pred(Count) do begin - syb := Item[Result]; - if syb.SameName(AName) and syb.InheritsFrom(AMinClass) then - Exit; - end; - Result := -1; -end; - -function TSymbolTable.IndexOf(ASym: TAbstractSymbolDefinition): Integer; -begin - Result := FList.IndexOf(ASym); -end; - -function TSymbolTable.Find(const AName: String): TAbstractSymbolDefinition; -Var - i : Integer; -begin - i := IndexOf(AName); - if ( i > -1 ) then begin - Result := Item[i] - end else begin - for i := 0 to Pred(LinkedTableCount) do begin - Result := LinkedTables[i].Find(AName); - if Assigned(Result) then - Exit; - end; - Result := Nil; - end; -end; - -function TSymbolTable.Find( - const AName : string; - const AMinClass : TAbstractSymbolDefinitionClass -): TAbstractSymbolDefinition; -var - i : Integer; -begin - i := IndexOf(AName,AMinClass); - if ( i > -1 ) then begin - Result := Item[i] - end else begin - for i := 0 to Pred(LinkedTableCount) do begin - Result := LinkedTables[i].Find(AName,AMinClass); - if Assigned(Result) then - Exit; - end; - Result := Nil; - end; -end; - -function TSymbolTable.ByName(const AName: String): TAbstractSymbolDefinition; -begin - Result := Find(AName); - If Not Assigned(Result) Then - Raise ESymbolException.CreateFmt('No such Symbol : %s',[AName]); -end; - -procedure TSymbolTable.RegisterListner(AListner: ISymbolTableChangeListner); -begin - if Assigned(AListner) and ( FListners.IndexOf(AListner) < 0 ) then - FListners.Add(AListner); -end; - -procedure TSymbolTable.UnregisterListner(AListner: ISymbolTableChangeListner); -begin - if Assigned(AListner) and ( FListners.IndexOf(AListner) >= 0 ) then - FListners.Remove(AListner); -end; - -{ TEnumItemDefinition } - -procedure TEnumItemDefinition.FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition -); -begin - if ( TObject(AFrw) = TObject(FEnumType) ) then - FEnumType := Atype as TEnumTypeDefinition; -end; - -constructor TEnumItemDefinition.Create( - const AName : string; - AEnumType : TEnumTypeDefinition; - const AOrder : Integer -); -begin - Assert(Assigned(AEnumType)); - inherited Create(AName); - FOrder := AOrder; - FEnumType := AEnumType; -end; - -{ TEnumTypeDefinition } - -function TEnumTypeDefinition.GetItem(Index: Integer): TEnumItemDefinition; -begin - Result := FItemList[Index] As TEnumItemDefinition; -end; - -function TEnumTypeDefinition.GetItemCount: Integer; -begin - Result := FItemList.Count; -end; - -constructor TEnumTypeDefinition.Create(const AName: String); -begin - Inherited Create(AName); - FItemList := TObjectList.Create(False); -end; - -destructor TEnumTypeDefinition.Destroy(); -begin - FItemList.Free(); - inherited Destroy(); -end; - -function TEnumTypeDefinition.NeedFinalization(): Boolean; -begin - Result := False; -end; - -procedure TEnumTypeDefinition.AddItem(AItem:TEnumItemDefinition); -Begin - If ( FItemList.IndexOf(AItem) = -1 ) Then - FItemList.Add(AItem); -end; - -function TEnumTypeDefinition.FindItem(const AName: String): TEnumItemDefinition; -Var - i,c : Integer; -begin - c := Pred(ItemCount); - For i := 0 To c Do Begin - If AnsiSameText(AName,Item[i].Name) Then Begin - Result := Item[i]; - Exit; - End; - End; - Result := Nil; -end; - -{ TTypeDefinition } -const SIMPLE_TYPES : Array[0..14] Of array[0..2] of string = ( - ('string', 'TComplexStringContentRemotable', 'string'), - ('integer', 'TComplexInt32SContentRemotable', 'int'), - ('LongWord', 'TComplexInt32UContentRemotable', 'unsignedInt' ), - ('SmallInt', 'TComplexInt16SContentRemotable', 'short'), - ('ShortInt', 'TComplexInt8SContentRemotable', 'byte'), - ('char', '', ''), - ('boolean', 'TComplexBooleanContentRemotable', 'boolean'), - ('Byte', 'TComplexInt8UContentRemotable', 'unsignedByte'), - ('Word', 'TComplexInt16UContentRemotable', 'unsignedShort'), - ('Longint', 'TComplexInt32SContentRemotable', 'int'), - ('Int64', 'TComplexInt64SContentRemotable', 'long'), - ('Qword', 'TComplexInt64UContentRemotable', 'unsignedLong'), - ('Single', 'TComplexFloatSingleContentRemotable', 'single'), - ('Double', 'TComplexFloatDoubleContentRemotable', 'double'), - ('Extended', 'TComplexFloatExtendedContentRemotable', 'decimal') - ); - -function TTypeDefinition.NeedFinalization(): Boolean; -var - i : Integer; -begin - for i := Low(SIMPLE_TYPES) to High(SIMPLE_TYPES) do begin - if AnsiSameText(SIMPLE_TYPES[i][0],Name) then begin - Result := True; - Exit; - end; - end; - Result := False; -end; - -{ TClassTypeDefinition } - -procedure TClassTypeDefinition.SetParent(const AValue: TTypeDefinition); -begin - if ( AValue = Self ) then begin - raise ESymbolException.Create('A class can not be its parent.'); - end; - if ( FParent = AValue ) then begin - Exit; - end; - FParent := AValue; -end; - -function TClassTypeDefinition.AddProperty( - const AName : String; - ADataType : TTypeDefinition -): TPropertyDefinition; -var - i : Integer; -begin - if not Assigned(ADataType) then - raise ESymbolException.CreateFmt('Property data type not provided : "%s".',[AName]); - i := IndexOfProperty(AName); - if ( i = -1 ) then - i := FPropertyList.Add(TPropertyDefinition.Create(AName,ADataType)); - Result := FPropertyList[i] as TPropertyDefinition; -end; - -function TClassTypeDefinition.IndexOfProperty(const AName: string): Integer; -begin - for Result := 0 to Pred(PropertyCount) do begin - if AnsiSameText(AName,Properties[Result].Name) then - Exit; - end; - Result := -1; -end; - -function TClassTypeDefinition.GetProperty(const Index : Integer): TPropertyDefinition; -begin - Result := FPropertyList[Index] as TPropertyDefinition; -end; - -function TClassTypeDefinition.GetPropertyCount: Integer; -begin - Result := FPropertyList.Count; -end; - -procedure TClassTypeDefinition.FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition -); -var - i : Integer; -begin - if ( FParent = AFrw ) then - FParent := Atype; - for i := 0 to Pred(PropertyCount) do begin - Properties[i].FixForwardTypeDefinitions(AFrw,Atype); - end; -end; - -constructor TClassTypeDefinition.Create(const AName: String); -begin - inherited Create(AName); - FPropertyList := TObjectList.Create(True); -end; - -destructor TClassTypeDefinition.Destroy(); -begin - FreeAndNil(FPropertyList); - inherited Destroy(); -end; - -function TClassTypeDefinition.NeedFinalization(): Boolean; -begin - Result := True; -end; - -function TClassTypeDefinition.IsDescendantOf(ABaseType: TTypeDefinition): Boolean; -var - tmpDef : TTypeDefinition; -begin - tmpDef := Self; - while Assigned(tmpDef) do begin - if ( tmpDef = ABaseType ) then begin - Result := True; - Exit; - end; - if tmpDef is TClassTypeDefinition then begin - tmpDef := (tmpDef as TClassTypeDefinition).Parent; - end else begin - tmpDef := nil; - end; - end; - Result := False; -end; - - -{ TPropertyDefinition } - -procedure TPropertyDefinition.FixForwardTypeDefinitions( - AFrw : TForwardTypeDefinition; - Atype : TTypeDefinition -); -begin - if ( FDataType = AFrw ) then - FDataType := Atype; -end; - -constructor TPropertyDefinition.Create( - const AName : String; - ADataType : TTypeDefinition -); -begin - inherited Create(AName); - FDataType := ADataType; -end; - -{ TSimpleTypeDefinition } - -function TSimpleTypeDefinition.NeedFinalization(): Boolean; -begin - Result := False; -end; - -procedure AddSystemSymbol(ADest: TSymbolTable); -var - i : Integer; - splTyp : TNativeSimpleTypeDefinition; - syb : TNativeClassTypeDefinition; - s : string; -begin - for i := Low(SIMPLE_TYPES) to High(SIMPLE_TYPES) do begin - splTyp := TNativeSimpleTypeDefinition.Create(SIMPLE_TYPES[i][0]); - ADest.Add(splTyp); - s := SIMPLE_TYPES[i][1]; - if not IsStrEmpty(s) then begin - syb := ADest.Find(SIMPLE_TYPES[i][1]) as TNativeClassTypeDefinition; - if not Assigned(syb) then begin - syb := TNativeClassTypeDefinition.Create(SIMPLE_TYPES[i][1]); - end; - ADest.Add(syb); - //syb.RegisterExternalAlias(SIMPLE_TYPES[i][2]); - splTyp.SetBoxedType(syb); - end; - end; - for i := Low(SIMPLE_TYPES) to High(SIMPLE_TYPES) do begin - splTyp := ADest.ByName(SIMPLE_TYPES[i][0]) as TNativeSimpleTypeDefinition; - if not IsStrEmpty(SIMPLE_TYPES[i][2]) then begin - splTyp.RegisterExternalAlias(SIMPLE_TYPES[i][2]); - end; - end; -end; - -procedure AddSoapencSymbol(ADest: TSymbolTable); -var - locSymTable : TSymbolTable; -begin - locSymTable := TSymbolTable.Create('soapenc'); - ADest.Add(locSymTable); - locSymTable.RegisterExternalAlias('http://schemas.xmlsoap.org/soap/encoding/'); - locSymTable.Add(TAnyTypeDefinition.Create('any')); -end; - -function CreateWstInterfaceSymbolTable() : TSymbolTable; - function AddClassDef( - ATable : TSymbolTable; - const AClassName, - AParentName : string; - const AClassType : TClassTypeDefinition = nil - ):TClassTypeDefinition; - begin - if Assigned(AClassType) then begin - Result := AClassType.Create(AClassName); - end else begin - Result := TClassTypeDefinition.Create(AClassName); - end; - if not IsStrEmpty(AParentName) then - Result.SetParent(ATable.ByName(AParentName) as TClassTypeDefinition); - ATable.Add(Result); - end; - -var - loc_TBaseComplexSimpleContentRemotable : TClassTypeDefinition; - locTyp : TTypeDefinition; -begin - Result := TSymbolTable.Create('base_service_intf'); - try - AddSystemSymbol(Result); - AddClassDef(Result,'TBaseRemotable',''); - AddClassDef(Result,'TAbstractSimpleRemotable','TBaseRemotable'); - AddClassDef(Result,'TDateRemotable','TAbstractSimpleRemotable').RegisterExternalAlias('dateTime'); - AddClassDef(Result,'TDurationRemotable','TAbstractSimpleRemotable').RegisterExternalAlias('duration'); - AddClassDef(Result,'TTimeRemotable','TAbstractSimpleRemotable').RegisterExternalAlias('time'); - - AddClassDef(Result,'TAbstractComplexRemotable','TBaseRemotable'); - loc_TBaseComplexSimpleContentRemotable := AddClassDef(Result,'TBaseComplexSimpleContentRemotable','TAbstractComplexRemotable'); - (Result.ByName('TComplexInt16SContentRemotable') as TClassTypeDefinition).SetParent(loc_TBaseComplexSimpleContentRemotable); - (Result.ByName('TComplexFloatDoubleContentRemotable') as TClassTypeDefinition).SetParent(loc_TBaseComplexSimpleContentRemotable); - - AddClassDef(Result,'TBaseComplexRemotable','TAbstractComplexRemotable'); - AddClassDef(Result,'THeaderBlock','TBaseComplexRemotable'); - AddClassDef(Result,'TBaseArrayRemotable','TAbstractComplexRemotable'); - AddClassDef(Result,'TBaseObjectArrayRemotable','TBaseArrayRemotable'); - AddClassDef(Result,'TBaseSimpleTypeArrayRemotable','TBaseArrayRemotable'); - AddClassDef(Result,'TArrayOfStringRemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfBooleanRemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfInt8URemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfInt8SRemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfInt16SRemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfInt16URemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfInt32URemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfInt32SRemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfInt64SRemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfInt64URemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfFloatSingleRemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfFloatDoubleRemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfFloatExtendedRemotable','TBaseSimpleTypeArrayRemotable'); - AddClassDef(Result,'TArrayOfFloatCurrencyRemotable','TBaseSimpleTypeArrayRemotable'); - - locTyp := TTypeAliasDefinition.Create('token',Result.ByName('string') as TTypeDefinition); - Result.Add(locTyp); - locTyp := TTypeAliasDefinition.Create('anyURI',Result.ByName('string') as TTypeDefinition); - Result.Add(locTyp); - locTyp := TTypeAliasDefinition.Create('float',Result.ByName('Single') as TTypeDefinition); - Result.Add(locTyp); - locTyp := TTypeAliasDefinition.Create('nonNegativeInteger',Result.ByName('LongWord') as TTypeDefinition); - Result.Add(locTyp); - locTyp := TTypeAliasDefinition.Create('positiveInteger',Result.ByName('nonNegativeInteger') as TTypeDefinition); - Result.Add(locTyp); - - locTyp := TTypeAliasDefinition.Create('base64Binary',Result.ByName('string') as TTypeDefinition); - Result.Add(locTyp); - - except //base64Binary - FreeAndNil(Result); - raise; - end; -end; - -{ TTypeAliasDefinition } - -procedure TTypeAliasDefinition.FixForwardTypeDefinitions( - AFrw: TForwardTypeDefinition; - Atype: TTypeDefinition -); -begin - if ( FBaseType = AFrw ) then - FBaseType := Atype; -end; - -constructor TTypeAliasDefinition.Create( - const AName : string; - ABaseType : TTypeDefinition -); -begin - Assert(Assigned(ABaseType)); - inherited Create(AName); - FBaseType := ABaseType; -end; - -{ TSimpleConstantDefinition } - -constructor TSimpleConstantDefinition.Create(const AName: string;const AValue: string); -begin - inherited Create(AName); - FValue.DataType := sctString; - FValue.StrValue := AValue; -end; - -constructor TSimpleConstantDefinition.Create(const AName: string;const AValue: Integer); -begin - inherited Create(AName); - FValue.DataType := sctInteger; - FValue.IntValue := AValue; -end; - -{ TArrayDefinition } - -procedure TArrayDefinition.FixForwardTypeDefinitions( - AFrw: TForwardTypeDefinition; - Atype: TTypeDefinition -); -begin - if ( FItemType = AFrw ) then - FItemType := Atype; -end; - -constructor TArrayDefinition.Create( - const AName : string; - AItemType : TTypeDefinition; - const AItemName, - AItemExternalName : string; - const AStyle : TArrayStyle -); -begin - Assert(Assigned(AItemType)); - inherited Create(AName); - FStyle := AStyle; - FItemType := AItemType; - FItemName := AItemName; - FItemExternalName := AItemExternalName; - if IsStrEmpty(FItemExternalName) then - FItemExternalName := FItemName; -end; - -function TArrayDefinition.NeedFinalization(): Boolean; -begin - Result := True; -end; - -{ TNativeSimpleTypeDefinition } - -procedure TNativeSimpleTypeDefinition.SetBoxedType(ABoxedType: TNativeClassTypeDefinition); -begin - FBoxedType := ABoxedType; -end; - -end. diff --git a/wst/trunk/ws_helper/ws_helper.lpi b/wst/trunk/ws_helper/ws_helper.lpi index 81136105b..66253e74e 100644 --- a/wst/trunk/ws_helper/ws_helper.lpi +++ b/wst/trunk/ws_helper/ws_helper.lpi @@ -43,83 +43,83 @@ - - - - - - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + + + + + + diff --git a/wst/trunk/ws_helper/ws_helper.pas b/wst/trunk/ws_helper/ws_helper.pas index 2ac741dd6..ced384025 100644 --- a/wst/trunk/ws_helper/ws_helper.pas +++ b/wst/trunk/ws_helper/ws_helper.pas @@ -43,7 +43,8 @@ uses xsd_parser, ws_parser_imp, wsdl_parser, - xsd_generator, wsdl_generator; + xsd_generator, wsdl_generator, + locators; {$INCLUDE ws_helper_prog.inc} diff --git a/wst/trunk/ws_helper/ws_helper_prog.inc b/wst/trunk/ws_helper/ws_helper_prog.inc index a997a8b1f..f59e14623 100644 --- a/wst/trunk/ws_helper/ws_helper_prog.inc +++ b/wst/trunk/ws_helper/ws_helper_prog.inc @@ -106,14 +106,17 @@ var var locDoc : TXMLDocument; prsr : IXsdPaser; + prsrCtx : IParserContext; begin prsr := nil; ReadXMLFile(locDoc,inFileName); {$IFNDEF WST_INTF_DOM} try {$ENDIF} - prsr := TXsdParser.Create(locDoc,symtable,ChangeFileExt(ExtractFileName(inFileName),'')) as IXsdPaser; - prsr.ParseTypes(); + prsr := TXsdParser.Create(locDoc,symtable,ChangeFileExt(ExtractFileName(inFileName),'')) as IXsdPaser; + prsrCtx := prsr as IParserContext; + prsrCtx.SetDocumentLocator(TFileDocumentLocator.Create(ExtractFilePath(ExpandFileName(inFileName)))); + prsr.ParseTypes(); {$IFNDEF WST_INTF_DOM} finally ReleaseDomNode(locDoc); diff --git a/wst/trunk/ws_helper/wsdl_parser.pas b/wst/trunk/ws_helper/wsdl_parser.pas index 6432f9557..7acb118b6 100644 --- a/wst/trunk/ws_helper/wsdl_parser.pas +++ b/wst/trunk/ws_helper/wsdl_parser.pas @@ -36,11 +36,14 @@ type procedure Execute(const AMode : TParserMode; const AModuleName : string); end; + { TWsdlParser } + TWsdlParser = class(TInterfacedObject, IInterface, IParserContext, IParser) private FDoc : TXMLDocument; FSymbols : TwstPasTreeContainer; FModule : TPasModule; + FDocumentLocator : IDocumentLocator; private FTargetNameSpace : string; FNameSpaceList : TStringList; @@ -88,6 +91,8 @@ type function FindShortNamesForNameSpace(const ANameSpace : string) : TStrings; function GetTargetNameSpace() : string; function GetTargetModule() : TPasModule; + function GetDocumentLocator() : IDocumentLocator; + procedure SetDocumentLocator(const ALocator : IDocumentLocator); public constructor Create( ADoc : TXMLDocument; @@ -284,6 +289,16 @@ begin Result := FModule; end; +function TWsdlParser.GetDocumentLocator(): IDocumentLocator; +begin + Result := FDocumentLocator; +end; + +procedure TWsdlParser.SetDocumentLocator(const ALocator: IDocumentLocator); +begin + FDocumentLocator := ALocator; +end; + function TWsdlParser.GetTargetNameSpace() : string; begin Result := FTargetNameSpace; @@ -1248,14 +1263,19 @@ procedure TWsdlParser.Prepare(const AModuleName: string); var locDomObj : TDOMNode; locPrs : IXsdPaser; + locPrsCtx : IParserContext; ns : string; + locDocLocator : IDocumentLocator; begin if Assigned(FSchemaCursor) then begin + locDocLocator := GetDocumentLocator(); FSchemaCursor.Reset(); while FSchemaCursor.MoveNext() do begin locDomObj := (FSchemaCursor.GetCurrent() as TDOMNodeRttiExposer).InnerObject; locPrs := TWsdlSchemaParser.Create(FDoc,locDomObj,FSymbols,Self); locPrs.SetNotifier(FOnMessage); + locPrsCtx := locPrs as IParserContext; + locPrsCtx.SetDocumentLocator(locDocLocator); ns := (locPrs as IParserContext).GetTargetNameSpace(); FXsdParsers.AddObject(ns,TIntfObjectRef.Create(locPrs)); end; diff --git a/wst/trunk/ws_helper/xsd_consts.pas b/wst/trunk/ws_helper/xsd_consts.pas index 1832d2578..738572316 100644 --- a/wst/trunk/ws_helper/xsd_consts.pas +++ b/wst/trunk/ws_helper/xsd_consts.pas @@ -46,6 +46,7 @@ const s_enumeration : WideString = 'enumeration'; s_extension : WideString = 'extension'; s_guid : WideString = 'GUID'; + s_import = 'import'; s_input : WideString = 'input'; s_item : WideString = 'item'; s_literal = 'literal'; @@ -71,6 +72,7 @@ const //s_return : WideString = 'return'; s_rpc = 'rpc'; s_schema : WideString = 'schema'; + s_schemaLocation = 'schemaLocation'; s_xs : WideString = 'http://www.w3.org/2001/XMLSchema'; s_xs_short = 'xsd'; s_sequence : WideString = 'sequence'; diff --git a/wst/trunk/ws_helper/xsd_parser.pas b/wst/trunk/ws_helper/xsd_parser.pas index aa24d9349..cc6903332 100644 --- a/wst/trunk/ws_helper/xsd_parser.pas +++ b/wst/trunk/ws_helper/xsd_parser.pas @@ -42,6 +42,13 @@ type TOnParserMessage = procedure (const AMsgType : TMessageType; const AMsg : string) of object; + IDocumentLocator = interface + ['{F063700B-C0ED-4C54-9A54-C97030E80BD4}'] + function Find( + const ADocLocation : string; + out ADoc : TXMLDocument + ) : Boolean; + end; IParserContext = interface ['{F400BA9E-41AC-456C-ABF9-CEAA75313685}'] @@ -51,6 +58,8 @@ type function FindShortNamesForNameSpace(const ANameSpace : string) : TStrings; function GetTargetNameSpace() : string; function GetTargetModule() : TPasModule; + function GetDocumentLocator() : IDocumentLocator; + procedure SetDocumentLocator(const ALocator : IDocumentLocator); end; IXsdPaser = interface @@ -83,6 +92,8 @@ type FXSShortNames : TStrings; FChildCursor : IObjectCursor; FOnMessage: TOnParserMessage; + FDocumentLocator : IDocumentLocator; + FImportParsed : Boolean; private procedure DoOnMessage(const AMsgType : TMessageType; const AMsg : string); private @@ -96,18 +107,22 @@ type function FindNameSpace(const AShortName : string; out AResult : string) : Boolean; function FindShortNamesForNameSpaceLocal(const ANameSpace : string) : TStrings; function FindShortNamesForNameSpace(const ANameSpace : string) : TStrings; + function GetDocumentLocator() : IDocumentLocator; + procedure SetDocumentLocator(const ALocator : IDocumentLocator); + procedure SetNotifier(ANotifier : TOnParserMessage); function InternalParseType( const AName : string; const ATypeNode : TDOMNode ) : TPasType; + procedure ParseImportDocuments(); virtual; public constructor Create( ADoc : TXMLDocument; ASchemaNode : TDOMNode; ASymbols : TwstPasTreeContainer; AParentContext : IParserContext - ); + ); virtual; destructor Destroy();override; function ParseType( const AName, @@ -127,6 +142,7 @@ type property Module : TPasModule read FModule; property OnMessage : TOnParserMessage read FOnMessage write FOnMessage; end; + TCustomXsdSchemaParserClass = class of TCustomXsdSchemaParser; TXsdParser = class(TCustomXsdSchemaParser) public @@ -145,6 +161,14 @@ uses ws_parser_imp, dom_cursors, parserutils, xsd_consts {$ENDIF} ; +function NodeValue(const ANode : TDOMNode) : DOMString;{$IFDEF USE_INLINE}inline;{$ENDIF} +begin + if ( ANode = nil ) then + Result := '' + else + Result := ANode.NodeValue; +end; + { TCustomXsdSchemaParser } constructor TCustomXsdSchemaParser.Create( @@ -206,6 +230,57 @@ begin Result := SymbolTable.FindElement(AName); end; +procedure TCustomXsdSchemaParser.ParseImportDocuments(); +var + crsSchemaChild, typTmpCrs : IObjectCursor; + strFilter, locFileName, locNameSpace : string; + importNode : TDOMElement; + importDoc : TXMLDocument; + locParser : IXsdPaser; + locOldCurrentModule : TPasModule; + locContinue : Boolean; +begin + if FImportParsed then + Exit; + if ( FDocumentLocator = nil ) then + Exit; + + FImportParsed := True; + if Assigned(FChildCursor) then begin + locOldCurrentModule := SymbolTable.CurrentModule; + try + crsSchemaChild := FChildCursor.Clone() as IObjectCursor; + strFilter := CreateQualifiedNameFilterStr(s_import,FXSShortNames); + crsSchemaChild := CreateCursorOn(crsSchemaChild,ParseFilter(strFilter,TDOMNodeRttiExposer)); + crsSchemaChild.Reset(); + while crsSchemaChild.MoveNext() do begin + importNode := (crsSchemaChild.GetCurrent() as TDOMNodeRttiExposer).InnerObject as TDOMElement; + if ( importNode.Attributes <> nil ) and ( importNode.Attributes.Length > 0 ) then begin + locFileName := NodeValue(importNode.Attributes.GetNamedItem(s_schemaLocation)); + if ( not IsStrEmpty(locFileName) ) and + FDocumentLocator.Find(locFileName,importDoc) + then begin + locNameSpace := NodeValue(importNode.Attributes.GetNamedItem(s_namespace)); + locContinue := IsStrEmpty(locNameSpace) or ( SymbolTable.FindModule(locNameSpace) = nil ); + if locContinue then begin + locParser := TCustomXsdSchemaParserClass(Self.ClassType).Create( + importDoc, + importDoc.DocumentElement, + SymbolTable, + Self as IParserContext + ); + locParser.SetNotifier(FOnMessage); + locParser.ParseTypes(); + end; + end; + end; + end; + finally + SymbolTable.SetCurrentModule(locOldCurrentModule); + end; + end; +end; + function TCustomXsdSchemaParser.FindNamedNode( AList : IObjectCursor; const AName : WideString; @@ -278,6 +353,16 @@ begin end; end; +function TCustomXsdSchemaParser.GetDocumentLocator(): IDocumentLocator; +begin + Result := FDocumentLocator; +end; + +procedure TCustomXsdSchemaParser.SetDocumentLocator(const ALocator: IDocumentLocator); +begin + FDocumentLocator := ALocator; +end; + procedure TCustomXsdSchemaParser.SetNotifier(ANotifier: TOnParserMessage); begin FOnMessage := ANotifier; @@ -476,6 +561,8 @@ var typeModule : TPasModule; locTypeNodeFound : Boolean; begin + if not FImportParsed then + ParseImportDocuments(); sct := nil; DoOnMessage(mtInfo, Format('Parsing "%s" ...',[AName])); try