From 7ff8d383ef2d67942d8771d5fe78ef094de0a107 Mon Sep 17 00:00:00 2001 From: inoussa Date: Mon, 23 Nov 2009 17:55:10 +0000 Subject: [PATCH] schema sparser => External type definitions referenced by statement in XSD files or WSDL schema section are now handle. Note that the external files must reside in the same folder as the main schema being parsed. The external files are parsed and used in the main file. git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1015 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../test_suite/files/import_base_library.wsdl | 23 + .../test_suite/files/import_base_library.xsd | 11 + .../files/import_second_library.wsdl | 27 + .../files/import_second_library.xsd | 16 + wst/trunk/tests/test_suite/test_parsers.pas | 73 +- .../tests/test_suite/wst_test_suite_gui.lpi | 1 - wst/trunk/ws_helper/delphi/ws_helper.dpr | 3 +- wst/trunk/ws_helper/locators.pas | 70 + wst/trunk/ws_helper/parserdefs.pas | 1337 ----------------- wst/trunk/ws_helper/ws_helper.lpi | 66 +- wst/trunk/ws_helper/ws_helper.pas | 3 +- wst/trunk/ws_helper/ws_helper_prog.inc | 7 +- wst/trunk/ws_helper/wsdl_parser.pas | 20 + wst/trunk/ws_helper/xsd_consts.pas | 2 + wst/trunk/ws_helper/xsd_parser.pas | 89 +- 15 files changed, 369 insertions(+), 1379 deletions(-) create mode 100644 wst/trunk/tests/test_suite/files/import_base_library.wsdl create mode 100644 wst/trunk/tests/test_suite/files/import_base_library.xsd create mode 100644 wst/trunk/tests/test_suite/files/import_second_library.wsdl create mode 100644 wst/trunk/tests/test_suite/files/import_second_library.xsd create mode 100644 wst/trunk/ws_helper/locators.pas delete mode 100644 wst/trunk/ws_helper/parserdefs.pas 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