2007-09-16 00:31:45 +00:00
{
This file is part of the Web Service Toolkit
Copyright ( c) 2 0 0 7 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 xsd_generator;
interface
uses
Classes, SysUtils, TypInfo,
{$IFNDEF FPC} xmldom, wst_delphi_xml{$ELSE} DOM, wst_fpc_xml{$ENDIF} ,
pastree, pascal_parser_intf;
type
2008-06-06 14:59:24 +00:00
TGeneratorOption = ( xgoIgnorembeddedArray ) ;
TGeneratorOptions = set of TGeneratorOption;
2007-09-16 00:31:45 +00:00
EXsdGeneratorException = class( Exception) end ;
TBaseTypeHandler = class ;
TBaseTypeHandlerClass = class of TBaseTypeHandler;
IGenerator = interface
[ '{F69523B3-A6FF-4BFB-9ACB-D4B9F32DBCA9}' ]
procedure Execute(
ASymTable : TwstPasTreeContainer;
AModuleName : string
) ;
end ;
IXsdGenerator = interface( IGenerator)
[ '{FBFF92BC-B72B-4B85-8D16-379F9E548DDB}' ]
function GetSchemaNode( ADocument : TDOMDocument) : TDOMNode;
2008-06-06 14:59:24 +00:00
procedure SetPreferedShortNames( const ALongName, AShortName : string ) ;
function GetPreferedShortNames( ) : TStrings;
2007-09-16 00:31:45 +00:00
end ;
IXsdTypeHandler = interface
[ '{541EA377-4F70-49B1-AFB4-FC62B24F567B}' ]
procedure Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ;
function GetOwner( ) : IXsdGenerator;
end ;
2008-09-17 01:45:04 +00:00
IXsdSpecialTypeHelper = interface
[ '{1F4115E8-2B82-4E63-844B-36EB5911172F}' ]
procedure HandleTypeUsage(
ATargetNode,
ASchemaNode : TDOMElement
) ;
end ;
2007-09-16 00:31:45 +00:00
IXsdTypeHandlerRegistry = interface
[ '{C5666646-3426-4696-93EE-AFA8EE7CAE53}' ]
function Find(
ASymbol : TPasElement;
Aowner : IGenerator;
out AHandler : IXsdTypeHandler
) : Boolean ;
2008-09-17 01:45:04 +00:00
function FindHelper(
ASymbol : TPasElement;
out AHelper : IXsdSpecialTypeHelper
) : Boolean ;
2007-09-16 00:31:45 +00:00
procedure Register( AFactory : TBaseTypeHandlerClass) ;
end ;
{ TCustomXsdGenerator }
TCustomXsdGenerator = class(
TInterfacedObject,
IInterface,
IGenerator,
IXsdGenerator
)
private
FDocument : TDOMDocument;
2008-06-06 14:59:24 +00:00
FOptions: TGeneratorOptions;
FShortNames : TStrings;
2007-09-16 00:31:45 +00:00
protected
function GetSchemaNode( ADocument : TDOMDocument) : TDOMNode; virtual ; abstract ;
2008-06-06 14:59:24 +00:00
procedure SetPreferedShortNames( const ALongName, AShortName : string ) ;
function GetPreferedShortNames( ) : TStrings;
2007-09-16 00:31:45 +00:00
procedure Execute(
ASymTable : TwstPasTreeContainer;
AModuleName : string
) ;
procedure Prepare(
ASymTable : TwstPasTreeContainer;
AModule : TPasModule
) ; virtual ;
property Document : TDOMDocument read FDocument;
2008-06-06 14:59:24 +00:00
property Options : TGeneratorOptions read FOptions;
2007-09-16 00:31:45 +00:00
public
2008-06-06 14:59:24 +00:00
constructor Create( const ADocument : TDOMDocument) ; overload ;
constructor Create(
const ADocument : TDOMDocument;
const AOptions : TGeneratorOptions
) ; overload ;
destructor Destroy( ) ; override ;
2007-09-16 00:31:45 +00:00
end ;
{ TXsdGenerator }
TXsdGenerator = class( TCustomXsdGenerator)
private
FSchemaNode : TDOMElement;
protected
function GetSchemaNode( ADocument : TDOMDocument) : TDOMNode; override ;
procedure Prepare( ASymTable : TwstPasTreeContainer; AModule : TPasModule) ; override ;
end ;
{ TBaseTypeHandler }
TBaseTypeHandler = class( TInterfacedObject, IXsdTypeHandler)
private
FOwner : Pointer ;
2008-09-17 01:45:04 +00:00
FRegistry : IXsdTypeHandlerRegistry;
2007-09-16 00:31:45 +00:00
protected
procedure Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ; virtual ; abstract ;
function GetOwner( ) : IXsdGenerator;
class function CanHandle( ASymbol : TObject) : Boolean ; virtual ; abstract ;
2012-10-22 13:31:03 +00:00
function GetSchemaNode( ADocument : TDOMDocument) : TDOMElement;
2008-08-01 21:38:55 +00:00
procedure DeclareNameSpaceOf_WST( ADocument : TDOMDocument) ;
procedure DeclareAttributeOf_WST( AElement : TDOMElement; const AAttName, AAttValue : DOMString) ;
2008-09-17 01:45:04 +00:00
function GetRegistry( ) : IXsdTypeHandlerRegistry; {$IFDEF USE_INLINE} inline ; {$ENDIF}
2007-09-16 00:31:45 +00:00
public
2008-09-17 01:45:04 +00:00
constructor Create(
AOwner : IGenerator;
ARegistry : IXsdTypeHandlerRegistry
) ; virtual ;
2007-09-16 00:31:45 +00:00
end ;
function GetNameSpaceShortName(
const ANameSpace : string ;
2008-06-06 14:59:24 +00:00
ADocument : TDOMDocument;
const APreferedList : TStrings
2013-08-27 16:39:08 +00:00
) : string ; overload ;
2007-09-16 00:31:45 +00:00
2009-03-13 17:10:21 +00:00
function GetXsdTypeHandlerRegistry( ) : IXsdTypeHandlerRegistry;
2007-09-16 00:31:45 +00:00
function CreateElement( const ANodeName : DOMString; AParent : TDOMNode; ADoc : TDOMDocument) : TDOMElement; {$IFDEF USE_INLINE} inline ; {$ENDIF}
implementation
2008-06-06 14:59:24 +00:00
uses
2008-08-18 18:19:00 +00:00
xsd_consts, Contnrs, StrUtils, wst_types, parserutils;
2007-09-16 00:31:45 +00:00
type
2008-09-17 01:45:04 +00:00
{ TAbstractSpecialTypeHelper }
TAbstractSpecialTypeHelper = class( TInterfacedObject, IXsdSpecialTypeHelper)
protected
procedure HandleTypeUsage(
ATargetNode,
ASchemaNode : TDOMElement
) ; virtual ; abstract ;
public
constructor Create( ) ; virtual ;
end ;
TAbstractSpecialTypeHelperClass = class of TAbstractSpecialTypeHelper;
{ TWideStringHelper }
TWideStringHelper = class( TAbstractSpecialTypeHelper, IXsdSpecialTypeHelper)
protected
procedure HandleTypeUsage(
ATargetNode,
ASchemaNode : TDOMElement
2008-11-19 10:38:29 +00:00
) ; override ;
2008-09-17 01:45:04 +00:00
end ;
2009-01-19 17:46:33 +00:00
TAnsiCharHelper = class( TAbstractSpecialTypeHelper, IXsdSpecialTypeHelper)
protected
procedure HandleTypeUsage(
ATargetNode,
ASchemaNode : TDOMElement
) ; override ;
end ;
TWideCharHelper = class( TAbstractSpecialTypeHelper, IXsdSpecialTypeHelper)
protected
procedure HandleTypeUsage(
ATargetNode,
ASchemaNode : TDOMElement
) ; override ;
end ;
2009-10-07 17:41:09 +00:00
TCurrencyHelper = class( TAbstractSpecialTypeHelper, IXsdSpecialTypeHelper)
protected
procedure HandleTypeUsage(
ATargetNode,
ASchemaNode : TDOMElement
) ; override ;
end ;
2009-01-19 17:46:33 +00:00
2008-09-17 01:45:04 +00:00
{$IFDEF WST_UNICODESTRING}
{ TUnicodeStringHelper }
TUnicodeStringHelper = class( TAbstractSpecialTypeHelper, IXsdSpecialTypeHelper)
protected
procedure HandleTypeUsage(
ATargetNode,
ASchemaNode : TDOMElement
2008-12-17 21:29:09 +00:00
) ; override ;
2008-09-17 01:45:04 +00:00
end ;
{$ENDIF WST_UNICODESTRING}
2007-09-16 00:31:45 +00:00
{ TXsdTypeHandlerRegistry }
TXsdTypeHandlerRegistry = class( TInterfacedObject, IInterface, IXsdTypeHandlerRegistry)
private
FList : TClassList;
private
function FindIndexOfHandler( ASymbol : TPasElement) : Integer ;
protected
function Find(
ASymbol : TPasElement;
Aowner : IGenerator;
out AHandler : IXsdTypeHandler
) : Boolean ;
2008-09-17 01:45:04 +00:00
function FindHelper(
ASymbol : TPasElement;
out AHelper : IXsdSpecialTypeHelper
) : Boolean ;
2007-09-16 00:31:45 +00:00
procedure Register( AFactory : TBaseTypeHandlerClass) ;
public
constructor Create( ) ;
destructor Destroy( ) ; override ;
end ;
{ TTypeDefinition_TypeHandler }
TTypeDefinition_TypeHandler = class( TBaseTypeHandler)
protected
procedure Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ; override ;
class function CanHandle( ASymbol : TObject) : Boolean ; override ;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
procedure GenerateDocumentation(
AContainerNode : TDOMElement;
const ADocString : string ;
ADocument : TDOMDocument
) ;
{$ENDIF WST_HANDLE_DOC}
2007-09-16 00:31:45 +00:00
end ;
{ TTypeAliasDefinition_TypeHandler }
TTypeAliasDefinition_TypeHandler = class( TTypeDefinition_TypeHandler)
protected
procedure Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ; override ;
class function CanHandle( ASymbol : TObject) : Boolean ; override ;
end ;
{ TEnumTypeHandler }
TEnumTypeHandler = class( TTypeDefinition_TypeHandler)
protected
procedure Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ; override ;
class function CanHandle( ASymbol : TObject) : Boolean ; override ;
end ;
{ TClassTypeDefinition_TypeHandler }
TClassTypeDefinition_TypeHandler = class( TTypeDefinition_TypeHandler)
protected
procedure Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ; override ;
class function CanHandle( ASymbol : TObject) : Boolean ; override ;
end ;
{ TPasRecordType_TypeHandler }
TPasRecordType_TypeHandler = class( TTypeDefinition_TypeHandler)
protected
procedure Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ; override ;
class function CanHandle( ASymbol : TObject) : Boolean ; override ;
end ;
{ TBaseArrayRemotable_TypeHandler }
TBaseArrayRemotable_TypeHandler = class( TTypeDefinition_TypeHandler)
protected
procedure Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ; override ;
class function CanHandle( ASymbol : TObject) : Boolean ; override ;
end ;
2008-09-17 01:45:04 +00:00
{ TAbstractSpecialTypeHelper }
2007-09-16 00:31:45 +00:00
2008-09-17 01:45:04 +00:00
constructor TAbstractSpecialTypeHelper. Create( ) ;
2007-09-16 00:31:45 +00:00
begin
2008-09-17 01:45:04 +00:00
inherited Create( ) ;
2007-09-16 00:31:45 +00:00
end ;
2008-09-17 01:45:04 +00:00
2007-09-16 00:31:45 +00:00
function GetTypeNameSpace(
AContainer : TwstPasTreeContainer;
AType : TPasElement
) : string ;
var
locElt : TPasElement;
begin
Result : = '' ;
locElt : = AType;
if ( locElt < > nil ) then begin
if locElt. InheritsFrom( TPasUnresolvedTypeRef) then
locElt : = AContainer. FindElement( AContainer. GetExternalName( locElt) ) ;
if ( locElt < > nil ) and
( not locElt. InheritsFrom( TPasUnresolvedTypeRef) ) and
//locElt.InheritsFrom(TPasType) and
( locElt. Parent < > nil ) and
( locElt. Parent. Parent < > nil )
then begin
Result : = AContainer. GetExternalName( locElt. Parent. Parent) ;
end ;
end ;
Result : = Trim( Result ) ;
if ( Length( Result ) = 0 ) then
Result : = AContainer. GetExternalName( AContainer. CurrentModule) ;
end ;
function FindAttributeByValueInNode(
const AAttValue : string ;
const ANode : TDOMNode;
out AResAtt : string ;
2012-10-22 13:31:03 +00:00
const AStartIndex : Integer ;
const AStartingWith : string ;
var AFoundPosition : Integer
2013-08-27 16:39:08 +00:00
) : boolean ; overload ;
2007-09-16 00:31:45 +00:00
var
i, c : Integer ;
b : Boolean ;
begin
AResAtt : = '' ;
if Assigned( ANode) and Assigned( ANode. Attributes) then begin
b : = ( Length( AStartingWith) = 0 ) ;
c : = Pred( ANode. Attributes. Length ) ;
2008-06-06 14:59:24 +00:00
// if ( AStartIndex >= 0 ) then
// i := AStartIndex;
2007-10-19 15:30:20 +00:00
for i : = AStartIndex to c do begin
2007-09-16 00:31:45 +00:00
if AnsiSameText( AAttValue, ANode. Attributes. Item[ i] . NodeValue) and
( b or ( Pos( AStartingWith, ANode. Attributes. Item[ i] . NodeName) = 1 ) )
then begin
AResAtt : = ANode. Attributes. Item[ i] . NodeName;
2012-10-22 13:31:03 +00:00
AFoundPosition : = i;
2007-09-16 00:31:45 +00:00
Result : = True ;
Exit;
end ;
end ;
end ;
Result : = False ;
end ;
2012-10-22 13:31:03 +00:00
function FindAttributeByValueInNode(
const AAttValue : string ;
const ANode : TDOMNode;
out AResAtt : string ;
const AStartIndex : Integer = 0 ;
const AStartingWith : string = ''
2013-08-27 16:39:08 +00:00
) : boolean ; overload ;
2012-10-22 13:31:03 +00:00
var
i, c : Integer ;
b : Boolean ;
k : Integer ;
begin
Result : = FindAttributeByValueInNode(
AAttValue, ANode, AResAtt, AStartIndex, AStartingWith, k
) ;
end ;
2007-09-16 00:31:45 +00:00
function GetNameSpaceShortName(
const ANameSpace : string ;
2008-06-06 14:59:24 +00:00
ADocument : TDOMDocument;
const APreferedList : TStrings
2013-08-27 16:39:08 +00:00
) : string ; overload ;
2012-10-22 13:31:03 +00:00
var
k : Integer ;
begin
k : = - 1 ;
while FindAttributeByValueInNode( ANameSpace, ADocument. DocumentElement, Result , ( k+ 1 ) , s_xmlns, k) do begin
Result : = Copy( Result , Length( s_xmlns+ ':' ) + 1 , MaxInt) ;
if ( Result = '' ) then begin
k : = k + 1 ;
Continue;
end ;
exit;
end ;
if ( APreferedList < > nil ) then
Result : = Trim( APreferedList. Values[ ANameSpace] ) ;
if ( Result = '' ) then
Result : = Format( 'ns%d' , [ GetNodeListCount( ADocument. DocumentElement. Attributes) ] ) ;
ADocument. DocumentElement. SetAttribute( Format( '%s:%s' , [ s_xmlns, Result ] ) , ANameSpace) ;
end ;
function GetNameSpaceShortName(
const ANameSpace : string ;
ADocument : TDOMElement;
const APreferedList : TStrings
2013-08-27 16:39:08 +00:00
) : string ; overload ;
2012-10-22 13:31:03 +00:00
var
k : Integer ;
2007-09-16 00:31:45 +00:00
begin
2012-10-22 13:31:03 +00:00
k : = - 1 ;
while FindAttributeByValueInNode( ANameSpace, ADocument, Result , ( k+ 1 ) , s_xmlns, k) do begin
2007-09-16 00:31:45 +00:00
Result : = Copy( Result , Length( s_xmlns+ ':' ) + 1 , MaxInt) ;
2012-10-22 13:31:03 +00:00
if ( Result = '' ) then begin
k : = k + 1 ;
Continue;
end ;
exit;
2007-09-16 00:31:45 +00:00
end ;
2012-10-22 13:31:03 +00:00
if ( APreferedList < > nil ) then
Result : = Trim( APreferedList. Values[ ANameSpace] ) ;
if ( Result = '' ) then
Result : = Format( 'ns%d' , [ GetNodeListCount( ADocument. Attributes) ] ) ;
ADocument. SetAttribute( Format( '%s:%s' , [ s_xmlns, Result ] ) , ANameSpace) ;
2007-09-16 00:31:45 +00:00
end ;
function CreateElement( const ANodeName : DOMString; AParent : TDOMNode; ADoc : TDOMDocument) : TDOMElement; //inline;
begin
Result : = ADoc. CreateElement( ANodeName) ;
AParent. AppendChild( Result ) ;
end ;
2008-09-17 01:45:04 +00:00
{ TWideStringHelper }
procedure TWideStringHelper. HandleTypeUsage(
ATargetNode,
ASchemaNode : TDOMElement
) ;
var
strBuffer : string ;
begin
if not FindAttributeByValueInNode( s_WST_base_namespace, ASchemaNode, strBuffer) then
ASchemaNode. SetAttribute( Format( '%s:%s' , [ s_xmlns, s_WST] ) , s_WST_base_namespace) ;
ATargetNode. SetAttribute( Format( '%s:%s' , [ s_WST, s_WST_typeHint] ) , 'WideString' ) ;
end ;
2009-01-19 17:46:33 +00:00
{ TAnsiCharHelper }
procedure TAnsiCharHelper. HandleTypeUsage( ATargetNode, ASchemaNode: TDOMElement) ;
var
strBuffer : string ;
begin
if not FindAttributeByValueInNode( s_WST_base_namespace, ASchemaNode, strBuffer) then
ASchemaNode. SetAttribute( Format( '%s:%s' , [ s_xmlns, s_WST] ) , s_WST_base_namespace) ;
ATargetNode. SetAttribute( Format( '%s:%s' , [ s_WST, s_WST_typeHint] ) , 'AnsiChar' ) ;
end ;
{ TWideCharHelper }
procedure TWideCharHelper. HandleTypeUsage( ATargetNode, ASchemaNode: TDOMElement) ;
var
strBuffer : string ;
begin
if not FindAttributeByValueInNode( s_WST_base_namespace, ASchemaNode, strBuffer) then
ASchemaNode. SetAttribute( Format( '%s:%s' , [ s_xmlns, s_WST] ) , s_WST_base_namespace) ;
ATargetNode. SetAttribute( Format( '%s:%s' , [ s_WST, s_WST_typeHint] ) , 'WideChar' ) ;
end ;
2009-10-07 17:41:09 +00:00
{ TCurrencyHelper }
procedure TCurrencyHelper. HandleTypeUsage( ATargetNode, ASchemaNode: TDOMElement) ;
var
strBuffer : string ;
begin
if not FindAttributeByValueInNode( s_WST_base_namespace, ASchemaNode, strBuffer) then
ASchemaNode. SetAttribute( Format( '%s:%s' , [ s_xmlns, s_WST] ) , s_WST_base_namespace) ;
ATargetNode. SetAttribute( Format( '%s:%s' , [ s_WST, s_WST_typeHint] ) , 'Currency' ) ;
end ;
2008-09-17 01:45:04 +00:00
{$IFDEF WST_UNICODESTRING}
{ TUnicodeStringHelper }
procedure TUnicodeStringHelper. HandleTypeUsage(
ATargetNode,
ASchemaNode : TDOMElement
) ;
var
strBuffer : string ;
begin
if not FindAttributeByValueInNode( s_WST_base_namespace, ASchemaNode, strBuffer) then
ASchemaNode. SetAttribute( Format( '%s:%s' , [ s_xmlns, s_WST] ) , s_WST_base_namespace) ;
ATargetNode. SetAttribute( Format( '%s:%s' , [ s_WST, s_WST_typeHint] ) , 'UnicodeString' ) ;
end ;
{$ENDIF WST_UNICODESTRING}
var
XsdTypeHandlerRegistryInst : IXsdTypeHandlerRegistry = nil ;
function GetXsdTypeHandlerRegistry( ) : IXsdTypeHandlerRegistry;
begin
Result : = XsdTypeHandlerRegistryInst;
end ;
procedure RegisterFondamentalTypes( ) ;
var
r : IXsdTypeHandlerRegistry;
begin
r : = GetXsdTypeHandlerRegistry( ) ;
r. Register( TEnumTypeHandler) ;
r. Register( TClassTypeDefinition_TypeHandler) ;
r. Register( TPasRecordType_TypeHandler) ;
r. Register( TBaseArrayRemotable_TypeHandler) ;
r. Register( TTypeAliasDefinition_TypeHandler) ;
end ;
2007-09-16 00:31:45 +00:00
{ TWsdlTypeHandlerRegistry }
function TXsdTypeHandlerRegistry. FindIndexOfHandler( ASymbol: TPasElement) : Integer ;
Var
i, c : Integer ;
begin
Result : = - 1 ;
c : = FList. Count;
for i : = 0 to Pred( c) do begin
if TBaseTypeHandlerClass( FList[ i] ) . CanHandle( ASymbol) then begin
Result : = i;
Break;
end ;
end ;
end ;
function TXsdTypeHandlerRegistry. Find(
ASymbol : TPasElement;
Aowner : IGenerator;
out AHandler : IXsdTypeHandler
) : Boolean ;
var
fct : TBaseTypeHandlerClass;
i : Integer ;
begin
i : = FindIndexOfHandler( ASymbol) ;
Result : = ( i > = 0 ) ;
if Result then begin
fct : = TBaseTypeHandlerClass( FList[ i] ) ;
2008-09-17 01:45:04 +00:00
AHandler : = fct. Create( Aowner, Self) as IXsdTypeHandler;
2007-09-16 00:31:45 +00:00
end ;
end ;
2008-09-17 01:45:04 +00:00
type
TSpecialTypeHelperRecord = record
Name : string ;
HelperClass : TAbstractSpecialTypeHelperClass;
end ;
function TXsdTypeHandlerRegistry. FindHelper(
ASymbol : TPasElement;
out AHelper: IXsdSpecialTypeHelper
) : Boolean ;
const
2009-10-07 17:41:09 +00:00
HELPER_COUNT = 4 {$IFDEF WST_UNICODESTRING} + 1 {$ENDIF WST_UNICODESTRING} ;
2008-09-17 01:45:04 +00:00
HELPER_MAP : array [ 0 .. Pred( HELPER_COUNT) ] of TSpecialTypeHelperRecord = (
2009-10-07 17:41:09 +00:00
( Name : 'currency' ; HelperClass : TCurrencyHelper; ) ,
( Name : 'widestring' ; HelperClass : TWideStringHelper; ) ,
2009-01-19 17:46:33 +00:00
( Name : 'ansichar' ; HelperClass : TAnsiCharHelper; ) ,
( Name : 'widechar' ; HelperClass : TWideCharHelper; )
2008-09-17 01:45:04 +00:00
{$IFDEF WST_UNICODESTRING}
, ( Name : 'unicodestring' ; HelperClass : TUnicodeStringHelper; )
{$ENDIF WST_UNICODESTRING}
) ;
var
i : PtrInt;
locName : string ;
begin
AHelper : = nil ;
if ( ASymbol < > nil ) and ASymbol. InheritsFrom( TPasNativeSpecialSimpleType) then begin
locName : = LowerCase( ASymbol. Name ) ;
for i : = Low( HELPER_MAP) to High( HELPER_MAP) do begin
if ( locName = HELPER_MAP[ i] . Name ) then begin
AHelper : = HELPER_MAP[ i] . HelperClass. Create( ) as IXsdSpecialTypeHelper;
Break;
end ;
end ;
end ;
Result : = ( AHelper < > nil ) ;
end ;
2007-09-16 00:31:45 +00:00
procedure TXsdTypeHandlerRegistry. Register( AFactory: TBaseTypeHandlerClass) ;
begin
if ( FList. IndexOf( AFactory) = - 1 ) then begin
FList. Add( AFactory) ;
end ;
end ;
constructor TXsdTypeHandlerRegistry. Create( ) ;
begin
FList : = TClassList. Create( ) ;
end ;
destructor TXsdTypeHandlerRegistry. Destroy( ) ;
begin
FreeAndNil( FList) ;
inherited Destroy( ) ;
end ;
{ TBaseTypeHandler }
function TBaseTypeHandler. GetOwner( ) : IXsdGenerator;
begin
Result : = IXsdGenerator( FOwner) ;
end ;
2012-10-22 13:31:03 +00:00
function TBaseTypeHandler. GetSchemaNode( ADocument : TDOMDocument) : TDOMElement;
2008-08-01 21:38:55 +00:00
begin
2012-10-22 13:31:03 +00:00
Result : = GetOwner( ) . GetSchemaNode( ADocument) as TDOMElement;
2008-08-01 21:38:55 +00:00
end ;
procedure TBaseTypeHandler. DeclareNameSpaceOf_WST( ADocument : TDOMDocument) ;
var
defSchemaNode : TDOMElement;
strBuffer : string ;
begin
defSchemaNode : = GetSchemaNode( ADocument) as TDOMElement;
if not FindAttributeByValueInNode( s_WST_base_namespace, defSchemaNode, strBuffer) then
defSchemaNode. SetAttribute( Format( '%s:%s' , [ s_xmlns, s_WST] ) , s_WST_base_namespace) ;
end ;
procedure TBaseTypeHandler. DeclareAttributeOf_WST(
AElement : TDOMElement;
const AAttName, AAttValue : DOMString
) ;
begin
AElement. SetAttribute( Format( '%s:%s' , [ s_WST, AAttName] ) , AAttvalue) ;
end ;
2008-09-17 01:45:04 +00:00
function TBaseTypeHandler. GetRegistry( ) : IXsdTypeHandlerRegistry;
begin
Result : = FRegistry;
end ;
constructor TBaseTypeHandler. Create(
AOwner: IGenerator;
ARegistry : IXsdTypeHandlerRegistry
) ;
2007-09-16 00:31:45 +00:00
begin
Assert( Assigned( AOwner) ) ;
FOwner : = Pointer( AOwner) ;
2008-09-17 01:45:04 +00:00
FRegistry : = ARegistry;
2007-09-16 00:31:45 +00:00
end ;
{ TTypeDefinition_TypeHandler }
procedure TTypeDefinition_TypeHandler. Generate(
AContainer : TwstPasTreeContainer;
const ASymbol: TPasElement;
ADocument: TDOMDocument
) ;
begin
Assert( ASymbol. InheritsFrom( TPasType) ) ;
end ;
class function TTypeDefinition_TypeHandler. CanHandle( ASymbol: TObject) : Boolean ;
begin
Result : = Assigned( ASymbol) and ASymbol. InheritsFrom( TPasType) ;
end ;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
procedure TTypeDefinition_TypeHandler. GenerateDocumentation(
AContainerNode : TDOMElement;
const ADocString : string ;
ADocument : TDOMDocument
) ;
var
tmpNode : TDOMElement;
begin
if ( Length( Trim( ADocString) ) > 0 ) then begin
tmpNode : = CreateElement( Format( '%s:%s' , [ s_xs_short, s_annotation] ) , AContainerNode, ADocument) ;
tmpNode : = CreateElement( Format( '%s:%s' , [ s_xs_short, s_documentation] ) , tmpNode, ADocument) ;
tmpNode. AppendChild( ADocument. CreateTextNode( ADocString) ) ;
end ;
end ;
{$ENDIF WST_HANDLE_DOC}
2007-09-16 00:31:45 +00:00
{ TTypeAliasDefinition_TypeHandler }
procedure TTypeAliasDefinition_TypeHandler. Generate(
AContainer : TwstPasTreeContainer;
const ASymbol: TPasElement;
ADocument: TDOMDocument
) ;
var
typItm : TPasAliasType;
2009-06-27 22:39:02 +00:00
s : string ;
2007-09-16 00:31:45 +00:00
defSchemaNode, resNode : TDOMElement;
unitExternalName, baseUnitExternalName : string ;
2008-09-15 02:34:09 +00:00
trueDestType : TPasType;
2009-04-07 16:28:22 +00:00
typeHelper : IXsdSpecialTypeHelper;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
i : PtrInt;
ls : TStrings;
{$ENDIF WST_HANDLE_DOC}
2007-09-16 00:31:45 +00:00
begin
inherited ;
typItm : = ASymbol as TPasAliasType;
if Assigned( typItm) then begin
unitExternalName : = GetTypeNameSpace( AContainer, ASymbol) ;
defSchemaNode : = GetSchemaNode( ADocument) as TDOMElement;
2012-10-22 13:31:03 +00:00
GetNameSpaceShortName( unitExternalName, defSchemaNode, GetOwner( ) . GetPreferedShortNames( ) ) ;
2007-09-16 00:31:45 +00:00
s : = Format( '%s:%s' , [ s_xs_short, s_element] ) ;
resNode : = CreateElement( s, defSchemaNode, ADocument) ;
resNode. SetAttribute( s_name, AContainer. GetExternalName( typItm) ) ;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
ls : = AContainer. Properties. FindList( typItm) ;
if ( ls < > nil ) then begin
i : = ls. IndexOfName( s_documentation) ;
if ( i > = 0 ) then
GenerateDocumentation( resNode, DecodeLineBreak( ls. ValueFromIndex[ i] ) , ADocument) ;
end ;
{$ENDIF WST_HANDLE_DOC}
2008-09-15 02:34:09 +00:00
trueDestType : = typItm. DestType;
if trueDestType. InheritsFrom( TPasUnresolvedTypeRef) then
trueDestType : = AContainer. FindElement( AContainer. GetExternalName( typItm. DestType) ) as TPasType;
baseUnitExternalName : = GetTypeNameSpace( AContainer, trueDestType) ;
2012-10-22 13:31:03 +00:00
s : = GetNameSpaceShortName( baseUnitExternalName, defSchemaNode, GetOwner( ) . GetPreferedShortNames( ) ) ;
2008-09-15 02:34:09 +00:00
s : = Format( '%s:%s' , [ s, AContainer. GetExternalName( trueDestType) ] ) ;
2007-09-16 00:31:45 +00:00
resNode. SetAttribute( s_type, s) ;
2009-04-07 16:28:22 +00:00
if trueDestType. InheritsFrom( TPasNativeSpecialSimpleType) then begin
if GetRegistry( ) . FindHelper( trueDestType, typeHelper) then
typeHelper. HandleTypeUsage( resNode, defSchemaNode) ;
end ;
2007-09-16 00:31:45 +00:00
end ;
end ;
class function TTypeAliasDefinition_TypeHandler. CanHandle( ASymbol: TObject) : Boolean ;
begin
Result : = Assigned( ASymbol) and ASymbol. InheritsFrom( TPasAliasType) ;
end ;
{ TEnumTypeHandler }
procedure TEnumTypeHandler. Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ;
var
typItm : TPasEnumType;
ns_shortName, s : string ;
defSchemaNode, resNode, restrictNode : TDOMElement;
i, c : Integer ;
unitExternalName : string ;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
ls : TStrings;
{$ENDIF WST_HANDLE_DOC}
2007-09-16 00:31:45 +00:00
begin
typItm : = ASymbol as TPasEnumType;
if Assigned( typItm) then begin
unitExternalName : = GetTypeNameSpace( AContainer, ASymbol) ;
if FindAttributeByValueInNode( unitExternalName, ADocument. DocumentElement, ns_shortName) then begin
ns_shortName : = Copy( ns_shortName, Length( s_xmlns+ ':' ) + 1 , MaxInt) ;
end else begin
ns_shortName : = Format( 'ns%d' , [ GetNodeListCount( ADocument. DocumentElement. Attributes) ] ) ;
ADocument. DocumentElement. SetAttribute( Format( '%s:%s' , [ s_xmlns, ns_shortName] ) , unitExternalName) ;
end ;
defSchemaNode : = GetSchemaNode( ADocument) as TDOMElement;
s : = Format( '%s:%s' , [ s_xs_short, s_simpleType] ) ;
resNode : = CreateElement( s, defSchemaNode, ADocument) ;
resNode. SetAttribute( s_name, AContainer. GetExternalName( typItm) ) ;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
ls : = AContainer. Properties. FindList( typItm) ;
if ( ls < > nil ) then begin
i : = ls. IndexOfName( s_documentation) ;
if ( i > = 0 ) then
GenerateDocumentation( resNode, DecodeLineBreak( ls. ValueFromIndex[ i] ) , ADocument) ;
end ;
{$ENDIF WST_HANDLE_DOC}
2007-09-16 00:31:45 +00:00
s : = Format( '%s:%s' , [ s_xs_short, s_restriction] ) ;
restrictNode : = CreateElement( s, resNode, ADocument) ;
restrictNode. SetAttribute( s_base, Format( '%s:%s' , [ s_xs_short, 'string' ] ) ) ;
c : = typItm. Values. Count;
for i : = 0 to pred( c) do begin
s : = Format( '%s:%s' , [ s_xs_short, s_enumeration] ) ;
CreateElement( s, restrictNode, ADocument) . SetAttribute(
s_value,
AContainer. GetExternalName( TPasEnumValue( typItm. Values[ i] ) )
) ;
end ;
end ;
end ;
class function TEnumTypeHandler. CanHandle( ASymbol: TObject) : Boolean ;
begin
Result : = inherited CanHandle( ASymbol) and ASymbol. InheritsFrom( TPasEnumType) ;
end ;
{ TClassTypeDefinition_TypeHandler }
type TTypeCategory = ( tcComplexContent, tcSimpleContent ) ;
procedure TClassTypeDefinition_TypeHandler. Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ;
2008-06-06 14:59:24 +00:00
function TypeHasSequence( const AClassType : TPasClassType; const ACategory : TTypeCategory) : Boolean ;
var
k : PtrInt;
p : TPasProperty;
begin
Result : = False ;
if ( AClassType. Members. Count > 0 ) then begin
for k : = 0 to Pred( AClassType. Members. Count) do begin
if TPasElement( AClassType. Members[ k] ) . InheritsFrom( TPasProperty) then begin
p : = TPasProperty( AClassType. Members[ k] ) ;
if not AContainer. IsAttributeProperty( p) then begin
if ( ACategory = tcSimpleContent ) then begin
raise EXsdGeneratorException. CreateFmt( 'Invalid type definition, a simple type cannot have "not attribute" properties : "%s"' , [ AContainer. GetExternalName( AClassType) ] ) ;
end ;
Result : = True ;
end ;
end ;
end ;
end ;
end ;
procedure ProcessPropertyExtendedMetadata( const AProp : TPasProperty; const APropNode : TDOMElement) ;
var
ls : TStrings;
line, ns, ns_short, localName, attName, attValue : string ;
k, q : PtrInt;
begin
ls : = AContainer. Properties. GetList( AProp) ;
if ( ls < > nil ) and ( ls. Count > 0 ) then begin
for k : = 0 to Pred( ls. Count) do begin
line : = ls. Names[ k] ;
q : = Pos( '#' , line) ;
if ( q > 0 ) then begin
ns : = Copy( line, 1 , Pred( q) ) ;
localName : = Copy( line, Succ( q) , MaxInt) ;
2012-10-22 13:31:03 +00:00
ns_short : = GetNameSpaceShortName( ns, GetSchemaNode( ADocument) , GetOwner( ) . GetPreferedShortNames( ) ) ;
2008-06-06 14:59:24 +00:00
attName : = Format( '%s:%s' , [ ns_short, localName] ) ;
line : = ls. Values[ line] ;
q : = Pos( '#' , line) ;
if ( q > 0 ) then begin
ns : = Copy( line, 1 , Pred( q) ) ;
localName : = Copy( line, Succ( q) , MaxInt) ;
2012-10-22 13:31:03 +00:00
ns_short : = GetNameSpaceShortName( ns, GetSchemaNode( ADocument) , GetOwner( ) . GetPreferedShortNames( ) ) ;
2008-06-06 14:59:24 +00:00
attValue : = Format( '%s:%s' , [ ns_short, localName] ) ;
end else begin
attValue : = line;
end ;
APropNode. SetAttribute( attName, attValue) ;
end ;
end ;
end ;
end ;
2008-10-23 19:21:59 +00:00
procedure ProcessXsdAny( const AContentNode : TDOMElement; const AXsdInfo : string ) ;
var
xsdAnyNode : TDOMElement;
ss : string ;
locLS : TStringList;
begin
xsdAnyNode : = CreateElement( Format( '%s:%s' , [ s_xs_short, s_any] ) , AContentNode, ADocument) ;
locLS : = TStringList. Create( ) ;
try
locLS. Delimiter : = ';' ;
locLS. DelimitedText : = AXsdInfo;
ss : = locLS. Values[ s_processContents] ;
if not IsStrEmpty( ss) then
xsdAnyNode. SetAttribute( s_processContents, ss) ;
ss : = locLS. Values[ s_minOccurs] ;
if not IsStrEmpty( ss) then
xsdAnyNode. SetAttribute( s_minOccurs, ss) ;
ss : = locLS. Values[ s_maxOccurs] ;
if not IsStrEmpty( ss) then
xsdAnyNode. SetAttribute( s_maxOccurs, ss) ;
finally
locLS. Free( ) ;
end ;
end ;
procedure ProcessXsdAnyAttribute( const AContentNode : TDOMElement; const AXsdInfo : string ) ;
var
xsdAnyNode : TDOMElement;
ss : string ;
locLS : TStringList;
begin
xsdAnyNode : = CreateElement( Format( '%s:%s' , [ s_xs_short, s_anyAttribute] ) , AContentNode, ADocument) ;
locLS : = TStringList. Create( ) ;
try
locLS. Delimiter : = ';' ;
locLS. DelimitedText : = AXsdInfo;
ss : = locLS. Values[ s_processContents] ;
if not IsStrEmpty( ss) then
xsdAnyNode. SetAttribute( s_processContents, ss) ;
finally
locLS. Free( ) ;
end ;
end ;
2008-06-06 14:59:24 +00:00
var
2008-09-17 01:45:04 +00:00
cplxNode, sqcNode, derivationNode, defSchemaNode : TDOMElement;
2008-06-06 14:59:24 +00:00
procedure ProcessProperty( const AProp : TPasProperty) ;
var
p : TPasProperty;
s : string ;
propNode : TDOMElement;
2009-11-09 09:48:35 +00:00
propTypItm, propItmUltimeType, arrayItemType : TPasType;
2008-06-06 14:59:24 +00:00
prop_ns_shortName : string ;
isEmbeddedArray : Boolean ;
2008-09-17 01:45:04 +00:00
typeHelper : IXsdSpecialTypeHelper;
2008-06-06 14:59:24 +00:00
begin
p : = AProp;
2010-10-15 13:43:44 +00:00
if AnsiSameText( sWST_PROP_STORE_PREFIX, Copy( p. StoredAccessorName, 1 , Length( sWST_PROP_STORE_PREFIX) ) ) or
AnsiSameText( 'True' , p. StoredAccessorName)
then begin
2008-06-06 14:59:24 +00:00
if AContainer. IsAttributeProperty( p) then begin
s : = Format( '%s:%s' , [ s_xs_short, s_attribute] ) ;
if Assigned( derivationNode) then
propNode : = CreateElement( s, derivationNode, ADocument)
else
propNode : = CreateElement( s, cplxNode, ADocument) ;
end else begin
s : = Format( '%s:%s' , [ s_xs_short, s_element] ) ;
propNode : = CreateElement( s, sqcNode, ADocument) ;
end ;
propNode. SetAttribute( s_name, AContainer. GetExternalName( p) ) ;
propTypItm : = p. VarType;
if Assigned( propTypItm) then begin
2008-09-15 02:34:09 +00:00
if propTypItm. InheritsFrom( TPasUnresolvedTypeRef) then
propTypItm : = AContainer. FindElement( AContainer. GetExternalName( propTypItm) ) as TPasType;
2009-01-19 17:46:33 +00:00
//prop_ns_shortName := GetNameSpaceShortName(GetTypeNameSpace(AContainer,propTypItm),ADocument,GetOwner().GetPreferedShortNames());
2008-06-06 14:59:24 +00:00
propItmUltimeType : = GetUltimeType( propTypItm) ;
isEmbeddedArray : = propItmUltimeType. InheritsFrom( TPasArrayType) and
( AContainer. GetArrayStyle( TPasArrayType( propItmUltimeType) ) = asEmbeded ) ;
2009-01-19 17:46:33 +00:00
if isEmbeddedArray then begin
s : = AContainer. GetExternalName( TPasArrayType( propItmUltimeType) . ElType) ;
2009-11-09 09:48:35 +00:00
arrayItemType : = TPasArrayType( propItmUltimeType) . ElType;
2012-10-22 13:31:03 +00:00
prop_ns_shortName : = GetNameSpaceShortName( GetTypeNameSpace( AContainer, arrayItemType) , GetSchemaNode( ADocument) , GetOwner( ) . GetPreferedShortNames( ) ) ;
2009-11-09 09:48:35 +00:00
propNode. SetAttribute( s_type, Format( '%s:%s' , [ prop_ns_shortName, s] ) ) ;
if arrayItemType. InheritsFrom( TPasNativeSpecialSimpleType) then begin
if GetRegistry( ) . FindHelper( arrayItemType, typeHelper) then
typeHelper. HandleTypeUsage( propNode, defSchemaNode) ;
end ;
2009-01-19 17:46:33 +00:00
end else begin
2008-06-06 14:59:24 +00:00
s : = AContainer. GetExternalName( propTypItm) ;
2012-10-22 13:31:03 +00:00
prop_ns_shortName : = GetNameSpaceShortName( GetTypeNameSpace( AContainer, propTypItm) , GetSchemaNode( ADocument) , GetOwner( ) . GetPreferedShortNames( ) ) ;
2009-11-09 09:48:35 +00:00
propNode. SetAttribute( s_type, Format( '%s:%s' , [ prop_ns_shortName, s] ) ) ;
if propTypItm. InheritsFrom( TPasNativeSpecialSimpleType) then begin
if GetRegistry( ) . FindHelper( propTypItm, typeHelper) then
typeHelper. HandleTypeUsage( propNode, defSchemaNode) ;
end ;
2009-01-19 17:46:33 +00:00
end ;
2009-11-09 09:48:35 +00:00
{ propNode. SetAttribute( s_type, Format( '%s:%s' , [ prop_ns_shortName, s] ) ) ;
2008-09-17 01:45:04 +00:00
if propTypItm. InheritsFrom( TPasNativeSpecialSimpleType) then begin
if GetRegistry( ) . FindHelper( propTypItm, typeHelper) then
typeHelper. HandleTypeUsage( propNode, defSchemaNode) ;
2009-11-09 09:48:35 +00:00
end ; }
2008-06-06 14:59:24 +00:00
if ( Length( p. DefaultValue) > 0 ) then
propNode. SetAttribute( s_default, p. DefaultValue) ;
if AContainer. IsAttributeProperty( p) then begin
2010-10-15 13:43:44 +00:00
if AnsiSameText( sWST_PROP_STORE_PREFIX, Copy( p. StoredAccessorName, 1 , Length( sWST_PROP_STORE_PREFIX) ) ) then begin
2008-09-11 00:42:54 +00:00
{propNode.SetAttribute(s_use,'optional')}
end else begin
2008-06-06 14:59:24 +00:00
propNode. SetAttribute( s_use, 'required' ) ;
2008-09-11 00:42:54 +00:00
end ;
2008-06-06 14:59:24 +00:00
end else begin
2010-10-15 13:43:44 +00:00
if AnsiSameText( sWST_PROP_STORE_PREFIX, Copy( p. StoredAccessorName, 1 , Length( sWST_PROP_STORE_PREFIX) ) ) then
2008-06-06 14:59:24 +00:00
propNode. SetAttribute( s_minOccurs, '0' ) ;
2008-08-01 21:38:55 +00:00
if isEmbeddedArray then begin
propNode. SetAttribute( s_maxOccurs, s_unbounded) ;
if AContainer. IsCollection( TPasArrayType( propItmUltimeType) ) then begin
DeclareNameSpaceOf_WST( ADocument) ;
DeclareAttributeOf_WST( propNode, s_WST_collection, 'true' ) ;
end ;
end ;
2008-06-06 14:59:24 +00:00
end ;
end ;
ProcessPropertyExtendedMetadata( p, propNode) ;
end ;
end ;
2007-09-16 00:31:45 +00:00
var
typItm : TPasClassType;
2008-06-06 14:59:24 +00:00
s : string ;
2007-09-16 00:31:45 +00:00
i : Integer ;
typeCategory : TTypeCategory;
hasSequence : Boolean ;
trueParent : TPasType;
2008-10-23 19:21:59 +00:00
hasXsdAny, hasXsdAnyAtt : Boolean ;
xsdAnyString, xsdAnyAttString : string ;
2008-08-18 18:19:00 +00:00
ls : TStrings;
2007-09-16 00:31:45 +00:00
begin
inherited ;
typItm : = ASymbol as TPasClassType;
if Assigned( typItm) then begin
2012-10-22 13:31:03 +00:00
GetNameSpaceShortName( AContainer. GetExternalName( AContainer. CurrentModule) , GetSchemaNode( ADocument) , GetOwner( ) . GetPreferedShortNames( ) ) ;
2007-09-16 00:31:45 +00:00
defSchemaNode : = GetSchemaNode( ADocument) as TDOMElement;
s : = Format( '%s:%s' , [ s_xs_short, s_complexType] ) ;
cplxNode : = CreateElement( s, defSchemaNode, ADocument) ;
cplxNode. SetAttribute( s_name, AContainer. GetExternalName( typItm) ) ;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
ls : = AContainer. Properties. FindList( typItm) ;
if ( ls < > nil ) then begin
i : = ls. IndexOfName( s_documentation) ;
if ( i > = 0 ) then
GenerateDocumentation( cplxNode, DecodeLineBreak( ls. ValueFromIndex[ i] ) , ADocument) ;
end ;
{$ENDIF WST_HANDLE_DOC}
2007-09-16 00:31:45 +00:00
typeCategory : = tcComplexContent;
derivationNode : = nil ;
hasSequence : = True ;
if Assigned( typItm. AncestorType) then begin
trueParent : = typItm. AncestorType;
2008-08-18 18:19:00 +00:00
if trueParent. InheritsFrom( TPasUnresolvedTypeRef) then
trueParent : = AContainer. FindElement( AContainer. GetExternalName( trueParent) ) as TPasType;
2010-11-01 12:08:12 +00:00
if ( trueParent < > nil ) then begin
if trueParent. InheritsFrom( TPasNativeClassType) and AnsiSameText( 'THeaderBlock' , trueParent. Name ) then begin
DeclareNameSpaceOf_WST( ADocument) ;
DeclareAttributeOf_WST( cplxNode, s_WST_headerBlock, 'true' ) ;
end else if trueParent. InheritsFrom( TPasNativeClassType) and AnsiSameText( 'TSimpleContentHeaderBlock' , trueParent. Name ) then begin
DeclareNameSpaceOf_WST( ADocument) ;
DeclareAttributeOf_WST( cplxNode, s_WST_headerBlockSimpleContent, 'true' ) ;
end ;
if trueParent. InheritsFrom( TPasAliasType) then
trueParent : = GetUltimeType( trueParent) ;
if trueParent. InheritsFrom( TPasNativeSimpleContentClassType) or
trueParent. InheritsFrom( TPasNativeSimpleType)
then begin
typeCategory : = tcSimpleContent;
end ;
if trueParent. InheritsFrom( TPasNativeSimpleContentClassType) or
( not trueParent. InheritsFrom( TPasNativeClassType) )
then begin
if ( typeCategory = tcSimpleContent ) then begin
derivationNode : = CreateElement( Format( '%s:%s' , [ s_xs_short, s_simpleContent] ) , cplxNode, ADocument) ;
derivationNode : = CreateElement( Format( '%s:%s' , [ s_xs_short, s_extension] ) , derivationNode, ADocument) ;
end else begin
derivationNode : = CreateElement( Format( '%s:%s' , [ s_xs_short, s_extension] ) , cplxNode, ADocument) ;
end ;
2012-10-22 13:31:03 +00:00
s : = Trim( GetNameSpaceShortName( GetTypeNameSpace( AContainer, trueParent) , GetSchemaNode( ADocument) , GetOwner( ) . GetPreferedShortNames( ) ) ) ;
2010-11-01 12:08:12 +00:00
if ( Length( s) > 0 ) then
s : = s + ':' ;
s : = s + AContainer. GetExternalName( trueParent) ;
derivationNode. SetAttribute( s_base, s) ;
2008-08-01 21:38:55 +00:00
end ;
2010-11-01 12:08:12 +00:00
hasSequence : = False ;
2008-08-01 21:38:55 +00:00
end ;
2007-09-16 00:31:45 +00:00
end ;
2008-06-06 14:59:24 +00:00
if ( typItm. Members. Count > 0 ) then
hasSequence : = TypeHasSequence( typItm, typeCategory) ;
2008-10-23 19:21:59 +00:00
hasXsdAny : = False ;
hasXsdAnyAtt : = False ;
if ( typeCategory = tcComplexContent ) then begin
ls : = AContainer. Properties. FindList( typItm) ;
i : = ls. IndexOfName( Format( '%s#%s' , [ s_xs, s_any] ) ) ;
hasXsdAny : = ( i > 0 ) ;
if hasXsdAny then begin
xsdAnyString : = ls. ValueFromIndex[ i] ;
if not hasSequence then
hasSequence : = True ;
end ;
i : = ls. IndexOfName( Format( '%s#%s' , [ s_xs, s_anyAttribute] ) ) ;
hasXsdAnyAtt : = ( i > 0 ) ;
if hasXsdAnyAtt then
xsdAnyAttString : = ls. ValueFromIndex[ i] ;
end ;
2007-09-16 00:31:45 +00:00
if hasSequence then begin
s : = Format( '%s:%s' , [ s_xs_short, s_sequence] ) ;
2008-06-06 14:59:24 +00:00
if Assigned( derivationNode) then
sqcNode : = CreateElement( s, derivationNode, ADocument)
else
2007-09-16 00:31:45 +00:00
sqcNode : = CreateElement( s, cplxNode, ADocument) ;
end else begin
sqcNode : = nil ;
end ;
2008-06-06 14:59:24 +00:00
for i : = 0 to Pred( typItm. Members. Count) do begin
if TPasElement( typItm. Members[ i] ) . InheritsFrom( TPasProperty) then
ProcessProperty( TPasProperty( typItm. Members[ i] ) ) ;
end ;
2008-10-23 19:21:59 +00:00
if hasXsdAny then
ProcessXsdAny( sqcNode, xsdAnyString) ;
if hasXsdAnyAtt then
ProcessXsdAnyAttribute( cplxNode, xsdAnyAttString) ;
2007-09-16 00:31:45 +00:00
end ;
end ;
class function TClassTypeDefinition_TypeHandler. CanHandle( ASymbol: TObject) : Boolean ;
begin
Result : = inherited CanHandle( ASymbol) and
( ASymbol. InheritsFrom( TPasClassType) and ( TPasClassType( ASymbol) . ObjKind = okClass ) ) ;
end ;
{ TPasRecordType_TypeHandler }
procedure TPasRecordType_TypeHandler. Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ;
var
cplxNode : TDOMElement;
typItm : TPasRecordType;
propTypItm : TPasType;
s, prop_ns_shortName : string ;
defSchemaNode, sqcNode, propNode : TDOMElement;
i : Integer ;
p : TPasVariable;
hasSequence : Boolean ;
storeOption : string ;
2009-04-07 16:28:22 +00:00
typeHelper : IXsdSpecialTypeHelper;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
ls : TStrings;
{$ENDIF WST_HANDLE_DOC}
2007-09-16 00:31:45 +00:00
begin
inherited ;
typItm : = ASymbol as TPasRecordType;
if Assigned( typItm) then begin
2012-10-22 13:31:03 +00:00
GetNameSpaceShortName( AContainer. GetExternalName( AContainer. CurrentModule) , GetSchemaNode( ADocument) , GetOwner( ) . GetPreferedShortNames( ) ) ;
2007-09-16 00:31:45 +00:00
defSchemaNode : = GetSchemaNode( ADocument) as TDOMElement;
s : = Format( '%s:%s' , [ s_xs_short, s_complexType] ) ;
cplxNode : = CreateElement( s, defSchemaNode, ADocument) ;
cplxNode. SetAttribute( s_name, AContainer. GetExternalName( typItm) ) ;
2008-08-01 21:38:55 +00:00
DeclareNameSpaceOf_WST( ADocument) ;
DeclareAttributeOf_WST( cplxNode, s_WST_record, 'true' ) ;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
ls : = AContainer. Properties. FindList( typItm) ;
if ( ls < > nil ) then begin
i : = ls. IndexOfName( s_documentation) ;
if ( i > = 0 ) then
GenerateDocumentation( cplxNode, DecodeLineBreak( ls. ValueFromIndex[ i] ) , ADocument) ;
end ;
{$ENDIF WST_HANDLE_DOC}
2007-09-16 00:31:45 +00:00
hasSequence : = False ;
for i : = 0 to Pred( typItm. Members. Count) do begin
if TPasElement( typItm. Members[ i] ) . InheritsFrom( TPasVariable) then begin
p : = TPasVariable( typItm. Members[ i] ) ;
if not AContainer. IsAttributeProperty( p) then begin
hasSequence : = True ;
Break;
end ;
end ;
end ;
if hasSequence then begin
s : = Format( '%s:%s' , [ s_xs_short, s_sequence] ) ;
sqcNode : = CreateElement( s, cplxNode, ADocument) ;
end else begin
sqcNode : = nil ;
end ;
2008-09-15 02:34:09 +00:00
for i : = 0 to Pred( typItm. Members. Count) do begin
if TPasElement( typItm. Members[ i] ) . InheritsFrom( TPasVariable) then begin
p : = TPasVariable( typItm. Members[ i] ) ;
if AContainer. IsAttributeProperty( p) then begin
s : = Format( '%s:%s' , [ s_xs_short, s_attribute] ) ;
propNode : = CreateElement( s, cplxNode, ADocument) ;
end else begin
s : = Format( '%s:%s' , [ s_xs_short, s_element] ) ;
propNode : = CreateElement( s, sqcNode, ADocument) ;
end ;
propNode. SetAttribute( s_name, AContainer. GetExternalName( p) ) ;
propTypItm : = p. VarType;
if Assigned( propTypItm) then begin
if propTypItm. InheritsFrom( TPasUnresolvedTypeRef) then
propTypItm : = AContainer. FindElement( AContainer. GetExternalName( propTypItm) ) as TPasType;
2012-10-22 13:31:03 +00:00
prop_ns_shortName : = GetNameSpaceShortName( GetTypeNameSpace( AContainer, propTypItm) , GetSchemaNode( ADocument) , GetOwner( ) . GetPreferedShortNames( ) ) ;
2008-09-15 02:34:09 +00:00
propNode. SetAttribute( s_type, Format( '%s:%s' , [ prop_ns_shortName, AContainer. GetExternalName( propTypItm) ] ) ) ;
2009-04-07 16:28:22 +00:00
if propTypItm. InheritsFrom( TPasNativeSpecialSimpleType) then begin
if GetRegistry( ) . FindHelper( propTypItm, typeHelper) then
typeHelper. HandleTypeUsage( propNode, defSchemaNode) ;
end ;
2008-09-15 02:34:09 +00:00
storeOption : = Trim( AContainer. Properties. GetValue( p, s_WST_storeType) ) ;
2007-09-16 00:31:45 +00:00
if AContainer. IsAttributeProperty( p) then begin
2008-09-15 02:34:09 +00:00
if ( Length( storeOption) > 0 ) then begin
2007-09-16 00:31:45 +00:00
case AnsiIndexText( storeOption, [ s_required, s_optional, s_prohibited] ) of
2008-09-15 02:34:09 +00:00
0 : propNode. SetAttribute( s_use, storeOption) ;
1 : ;
2 : propNode. SetAttribute( s_use, storeOption) ;
else
raise EXsdGeneratorException. CreateFmt( 'Invalid attribute "%s" value : "%s".' , [ s_use, storeOption] ) ;
2007-09-16 00:31:45 +00:00
end ;
end ;
2008-09-15 02:34:09 +00:00
end else begin
case AnsiIndexText( storeOption, [ s_required, s_optional, s_prohibited] ) of
0 : ; //propNode.SetAttribute(s_minOccurs,'1');
1 : propNode. SetAttribute( s_minOccurs, '0' ) ;
end ;
//propNode.SetAttribute(s_maxOccurs,'1');
2007-09-16 00:31:45 +00:00
end ;
end ;
end ;
2008-09-15 02:34:09 +00:00
end ;
2007-09-16 00:31:45 +00:00
end ;
end ;
class function TPasRecordType_TypeHandler. CanHandle( ASymbol : TObject) : Boolean ;
begin
Result : = inherited CanHandle( ASymbol) and ASymbol. InheritsFrom( TPasRecordType) ;
end ;
{ TBaseArrayRemotable_TypeHandler }
procedure TBaseArrayRemotable_TypeHandler. Generate(
AContainer : TwstPasTreeContainer;
const ASymbol : TPasElement;
ADocument : TDOMDocument
) ;
2012-10-22 13:31:03 +00:00
function GetNameSpaceShortName( const ANameSpace : string ) : string ; overload ;
2007-09-16 00:31:45 +00:00
begin
2012-10-22 13:31:03 +00:00
Result : = GetNameSpaceShortName( ANameSpace, GetSchemaNode( ADocument) , GetOwner( ) . GetPreferedShortNames( ) ) ;
2007-09-16 00:31:45 +00:00
end ;
var
typItm : TPasArrayType;
propTypItm : TPasType;
s, prop_ns_shortName : string ;
defSchemaNode, cplxNode, sqcNode, propNode : TDOMElement;
unitExternalName : string ;
2009-04-07 16:28:22 +00:00
typeHelper : IXsdSpecialTypeHelper;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
i : PtrInt;
ls : TStrings;
{$ENDIF WST_HANDLE_DOC}
2007-09-16 00:31:45 +00:00
begin
inherited ;
typItm : = ASymbol as TPasArrayType;
if not Assigned( typItm) then
Exit;
if Assigned( typItm) then begin
unitExternalName : = GetTypeNameSpace( AContainer, typItm) ;
GetNameSpaceShortName( unitExternalName) ;
defSchemaNode : = GetSchemaNode( ADocument) as TDOMElement;
s : = Format( '%s:%s' , [ s_xs_short, s_complexType] ) ;
cplxNode : = CreateElement( s, defSchemaNode, ADocument) ;
cplxNode. SetAttribute( s_name, AContainer. GetExternalName( typItm) ) ;
2008-08-18 18:19:00 +00:00
{$IFDEF WST_HANDLE_DOC}
ls : = AContainer. Properties. FindList( typItm) ;
if ( ls < > nil ) then begin
i : = ls. IndexOfName( s_documentation) ;
if ( i > = 0 ) then
GenerateDocumentation( cplxNode, DecodeLineBreak( ls. ValueFromIndex[ i] ) , ADocument) ;
end ;
{$ENDIF WST_HANDLE_DOC}
2007-09-16 00:31:45 +00:00
s : = Format( '%s:%s' , [ s_xs_short, s_sequence] ) ;
sqcNode : = CreateElement( s, cplxNode, ADocument) ;
propTypItm : = typItm. ElType;
s : = Format( '%s:%s' , [ s_xs_short, s_element] ) ;
propNode : = CreateElement( s, sqcNode, ADocument) ;
propNode. SetAttribute( s_name, s_item) ;
2008-08-01 21:38:55 +00:00
if AContainer. IsCollection( typItm) then begin
DeclareNameSpaceOf_WST( ADocument) ;
DeclareAttributeOf_WST( propNode, s_WST_collection, 'true' ) ;
end ;
2007-09-16 00:31:45 +00:00
if Assigned( propTypItm) then begin
prop_ns_shortName : = GetNameSpaceShortName( GetTypeNameSpace( AContainer, propTypItm) ) ; // AContainer.GetExternalName(propTypItm.Parent.Parent));
propNode. SetAttribute( s_type, Format( '%s:%s' , [ prop_ns_shortName, AContainer. GetExternalName( propTypItm) ] ) ) ;
2009-04-07 16:28:22 +00:00
if propTypItm. InheritsFrom( TPasNativeSpecialSimpleType) then begin
if GetRegistry( ) . FindHelper( propTypItm, typeHelper) then
typeHelper. HandleTypeUsage( propNode, defSchemaNode) ;
end ;
2007-09-16 00:31:45 +00:00
propNode. SetAttribute( s_minOccurs, '0' ) ;
propNode. SetAttribute( s_maxOccurs, s_unbounded) ;
end ;
end ;
end ;
class function TBaseArrayRemotable_TypeHandler. CanHandle( ASymbol: TObject) : Boolean ;
begin
Result : = inherited CanHandle( ASymbol) and ASymbol. InheritsFrom( TPasArrayType) ;
end ;
{ TCustomXsdGenerator }
procedure TCustomXsdGenerator. Execute(
ASymTable : TwstPasTreeContainer;
AModuleName : string
) ;
var
j, k : Integer ;
tri : TPasElement;
g : IXsdTypeHandler;
gr : IXsdTypeHandlerRegistry;
2011-11-26 17:54:55 +00:00
typeList : TList2;
2007-09-16 00:31:45 +00:00
mdl : TPasModule;
begin
if ( ASymTable = nil ) then
raise EXsdGeneratorException. Create( 'Invalid symbol table.' ) ;
mdl : = ASymTable. FindModule( AModuleName) ;
if ( mdl = nil ) then
raise EXsdGeneratorException. CreateFmt( 'Unable to find module : "%s".' , [ AModuleName] ) ;
Prepare( ASymTable, mdl) ;
gr : = GetXsdTypeHandlerRegistry( ) ;
typeList : = mdl. InterfaceSection. Declarations;
k : = typeList. Count;
2008-06-06 14:59:24 +00:00
if ( xgoIgnorembeddedArray in Options ) then begin
for j : = 0 to Pred( k) do begin
tri : = TPasElement( typeList[ j] ) ;
if tri. InheritsFrom( TPasType) and
( not tri. InheritsFrom( TPasNativeClassType) ) and
( not tri. InheritsFrom( TPasNativeSimpleType) ) and
( ( not tri. InheritsFrom( TPasArrayType) ) or
( ASymTable. GetArrayStyle( TPasArrayType( tri) ) < > asEmbeded )
)
then begin
if gr. Find( tri, Self, g) then
g. Generate( ASymTable, tri, Self. Document) ;
end ;
end ;
end else begin
for j : = 0 to Pred( k) do begin
tri : = TPasElement( typeList[ j] ) ;
if tri. InheritsFrom( TPasType) and
( not tri. InheritsFrom( TPasNativeClassType) ) and
( not tri. InheritsFrom( TPasNativeSimpleType) )
then begin
if gr. Find( tri, Self, g) then
g. Generate( ASymTable, tri, Self. Document) ;
end ;
2007-09-16 00:31:45 +00:00
end ;
end ;
end ;
procedure TCustomXsdGenerator. Prepare( ASymTable : TwstPasTreeContainer; AModule : TPasModule) ;
begin
end ;
2008-06-06 14:59:24 +00:00
constructor TCustomXsdGenerator. Create( const ADocument : TDOMDocument) ;
begin
Create( ADocument, [ ] ) ;
end ;
constructor TCustomXsdGenerator. Create(
const ADocument: TDOMDocument;
const AOptions: TGeneratorOptions
) ;
var
sl : TStringList;
2007-09-16 00:31:45 +00:00
begin
if ( ADocument = nil ) then
raise EXsdGeneratorException. Create( 'Invalid document.' ) ;
FDocument : = ADocument;
2008-06-06 14:59:24 +00:00
FOptions : = AOptions;
FShortNames : = TStringList. Create( ) ;
sl : = TStringList( FShortNames) ;
//sl.Sorted := True;
sl. Duplicates : = dupIgnore;
2012-10-22 13:31:03 +00:00
SetPreferedShortNames( s_soap, s_soap_short_name) ;
SetPreferedShortNames( s_xs, s_xs_short) ;
SetPreferedShortNames( s_WST_base_namespace, s_WST) ;
SetPreferedShortNames( s_wsdl, 'wsdl' ) ;
2008-06-06 14:59:24 +00:00
end ;
procedure TCustomXsdGenerator. SetPreferedShortNames( const ALongName, AShortName: string ) ;
begin
FShortNames. Values[ ALongName] : = AShortName;
end ;
function TCustomXsdGenerator. GetPreferedShortNames( ) : TStrings;
begin
Result : = FShortNames;
end ;
destructor TCustomXsdGenerator. Destroy( ) ;
begin
FreeAndNil( FShortNames) ;
inherited ;
2007-09-16 00:31:45 +00:00
end ;
{ TXsdGenerator }
function TXsdGenerator. GetSchemaNode( ADocument : TDOMDocument) : TDOMNode;
begin
Result : = FSchemaNode;
end ;
procedure TXsdGenerator. Prepare( ASymTable : TwstPasTreeContainer; AModule : TPasModule) ;
var
unitExternalName : string ;
begin
inherited Prepare( ASymTable, AModule) ;
unitExternalName : = ASymTable. GetExternalName( AModule) ;
FSchemaNode : = CreateElement( s_schema, Document, Document) ;
FSchemaNode. SetAttribute( s_targetNamespace, unitExternalName) ;
FSchemaNode. SetAttribute( Format( '%s:%s' , [ s_xmlns, s_xs_short] ) , s_xs) ;
FSchemaNode. SetAttribute( Format( '%s:%s' , [ s_xmlns, s_tns] ) , unitExternalName) ;
end ;
2009-01-19 17:46:33 +00:00
2007-09-16 00:31:45 +00:00
initialization
XsdTypeHandlerRegistryInst : = TXsdTypeHandlerRegistry. Create( ) as IXsdTypeHandlerRegistry;
RegisterFondamentalTypes( ) ;
finalization
XsdTypeHandlerRegistryInst : = nil ;
end .