pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
85e796e96251a64420d31915a82a59d71af727dc
lazarus-ccr/wst/trunk/ws_helper/parserutils.pas
inoussa 85e796e962 ws_helper code generation option -gEP : enum type''s items are prefixed with the enum name 
Add more Object Pascal keywords to the parser

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1020 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2009-11-26 10:39:50 +00:00

520 lines
15 KiB
ObjectPascal
Raw Blame History

{
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.
}
{$INCLUDE wst_global.inc}
unit parserutils;
interface
uses
SysUtils, Classes
{$IFNDEF FPC}, xmldom, wst_delphi_xml{$ELSE},DOM{$ENDIF}
, cursor_intf, dom_cursors, xsd_consts
;
type
TNotFoundAction = ( nfaNone, nfaRaiseException );
const
sNEW_LINE = sLineBreak;
type
{ TQualifiedNameObjectFilter }
TQualifiedNameObjectFilter = class(TInterfacedObject,IObjectFilter)
private
FNameSpace : string;
FName : string;
protected
function Evaluate(const AObject : TObject) : Boolean;
public
constructor Create(const AName,ANameSpace : string);
end;
function IsStrEmpty(Const AStr : String):Boolean;
function ExtractIdentifier(const AValue : string) : string ;
function GetToken(var ABuffer : string; const ADelimiter : string) : string;
{$IFDEF WST_HANDLE_DOC}
function EncodeLineBreak(const AInStr : string) : string;
function DecodeLineBreak(const AInStr : string) : string;
{$ENDIF}
function IsReservedKeyWord(const AValue : string):Boolean ;
procedure ExtractNameSpaceShortNamesNested(
ANode : TDOMNode;
AResList : TStrings;
const ANameSpace : WideString
);
function CreateQualifiedNameFilterStr(
const AName : WideString;
APrefixList : TStrings
) : string;
function ExtractNameFromQName(const AQName : string):string ;
procedure ExtractNameSpaceShortNames(
AAttribCursor : IObjectCursor;
AResList : TStrings;
const ANameSpace : WideString;
const ANotFoundAction : TNotFoundAction;
const AClearBefore : Boolean;
const AExceptionClass : ExceptClass
);
function AddNameSpace(const AValue: string; ANameSpaceList : TStrings): TStrings;
procedure BuildNameSpaceList(AAttCursor : IObjectCursor; ANameSpaceList : TStrings);
procedure ExplodeQName(const AQName : string; out ALocalName, ANameSpace : string) ;
function wst_findCustomAttribute(
AWsdlShortNames : TStrings;
ANode : TDOMNode;
const AAttribute : string;
out AValue : string
) : Boolean;
function wst_findCustomAttributeXsd(
AXsdShortNames : TStrings;
ANode : TDOMNode;
const AAttribute : string;
out AValue : string
) : Boolean;
implementation
uses StrUtils, rtti_filters;
const LANGAGE_TOKEN : array[0..127] of string = (
'ABSOLUTE', 'ABSTRACT', 'AND', 'ARRAY', 'AS', 'ASM',
'BEGIN', 'BOOLEAN', 'BYTE',
'CASE', 'CDECL', 'CHAR', 'CLASS', 'COMP', 'CONST', 'CONSTRUCTOR', 'CONTAINS',
'CURRENCY', 'DEFAULT', 'DEPRECATED', 'DESTRUCTOR', 'DISPINTERFACE', 'DISPOSE', 'DIV', 'DO',
'DOUBLE', 'DOWNTO', 'DYNAMIC', 'END', 'EXCEPT', 'EXIT', 'EXPORT', 'EXPORTS',
'EXTERNAL', 'FALSE', 'FAR', 'FILE', 'FINALIZATION', 'FINALLY', 'FOR',
'FORWARD', 'FUNCTION', 'GOTO', 'ELSE', 'EXCEPT', 'EXTENDED',
'IF', 'IMPLEMENTATION', 'IMPLEMENTS', 'IN', 'INHERITED', 'INLINE', 'INT64',
'INITIALIZATION', 'INTEGER', 'INTERFACE', 'IS',
'LABEL', 'LIBRARY', 'LOCAL', 'LONGINT', 'LONGWORD',
'MOD', 'NEAR', 'NEW', 'NIL', 'NODEFAULT', 'NOT',
'OBJECT', 'OF', 'OLEVARIANT', 'ON', 'OPERATOR', 'OR', 'OUT', 'OVERLOAD',
'OVERRIDE','PACKAGE', 'PACKED', 'PASCAL', 'PCHAR', 'PRIVATE', 'PROCEDURE',
'PROGRAM', 'PROPERTY', 'PROTECTED', 'PUBLIC', 'PUBLISHED',
'RAISE', 'READ', 'REAL', 'RECORD', 'REGISTER', 'REINTRODUCE', 'REPEAT',
'REQUIRES', 'RESOURCESTRING', 'RESULT', 'SAFECALL', 'SELF', 'SET', 'SHL',
'SHORTINT', 'SHR', 'SINGLE', 'SMALLINT', 'STDCALL', 'STORED', 'STRING',
'THEN', 'THREADVAR', 'TO', 'TRUE', '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;
function IsStrEmpty(Const AStr : String):Boolean;
begin
Result := ( Length(Trim(AStr)) = 0 );
end;
function ExtractIdentifier(const AValue : string) : string ;
var
i, c : Integer;
s : string;
begin
Result := '';
s := Trim(AValue);
c := Length(s);
if ( c > 0 ) then begin
if not ( s[1] in ['A'..'Z', 'a'..'z', '_'] ) then begin
Result := '_';
end;
for i := 1 to c do begin
if ( s[i] in ['A'..'Z', 'a'..'z', '0'..'9', '_'] ) then begin
Result := Result + s[i];
end else begin
if ( Length(Result) > 0 ) and ( Result[Length(Result)] <> '_' ) then begin
Result := Result + '_';
end;
end;
end;
end;
end;
function GetToken(
var ABuffer : string;
const ADelimiter : string
) : string;
var
locDelPos, locDelLength : Integer;
begin
Result := '';
if IsStrEmpty(ABuffer) then begin
ABuffer := '';
end else begin
locDelPos := Pos(ADelimiter,ABuffer);
if ( locDelPos < 1 ) then begin
Result := ABuffer;
ABuffer := '';
end else begin
locDelLength := Length(ADelimiter);
if ( locDelPos = 1 ) then begin
ABuffer := Copy(ABuffer,(locDelLength + 1),(Length(ABuffer) - locDelLength));
end else begin
Result := Copy(ABuffer,1,(locDelPos - 1));
ABuffer := Copy(ABuffer,(locDelPos + locDelLength),(Length(ABuffer) - locDelLength));
end;
end;
end;
end;
{$IFDEF WST_HANDLE_DOC}
const
REPLACE_CHAR_A = '#'; TARGET_SEQUENCE_A = sLineBreak;
REPLACE_CHAR_B = '|'; TARGET_SEQUENCE_B = #10;
function EncodeLineBreak(const AInStr : string) : string;
begin
Result :=
StringReplace(
StringReplace(AInStr,REPLACE_CHAR_A,(REPLACE_CHAR_A + REPLACE_CHAR_A),[rfReplaceAll]),
TARGET_SEQUENCE_A,REPLACE_CHAR_A,[rfIgnoreCase,rfReplaceAll]
);
Result :=
StringReplace(
StringReplace(Result,REPLACE_CHAR_B,(REPLACE_CHAR_B + REPLACE_CHAR_B),[rfReplaceAll]),
TARGET_SEQUENCE_B,REPLACE_CHAR_B,[rfIgnoreCase,rfReplaceAll]
);
end;
function DecodeLineBreak(const AInStr : string) : string;
var
i, c : PtrInt;
pc : PChar;
tmp, res : string;
begin
res := '';
pc := PChar(AInStr);
i := 1;
c := Length(AInStr);
while ( i <= c ) do begin
if ( pc^ = REPLACE_CHAR_B ) then begin
if ( i < c ) then begin
Inc(pc); Inc(i);
if ( pc^ = REPLACE_CHAR_B ) then
res := res + REPLACE_CHAR_B
else
res := res + TARGET_SEQUENCE_B + pc^;
end else begin
res := res + TARGET_SEQUENCE_B;
end;
end else begin
res := res + pc^;
end;
Inc(pc); Inc(i);
end;
tmp := res;
res := '';
pc := PChar(tmp);
i := 1;
c := Length(tmp);
while ( i <= c ) do begin
if ( pc^ = REPLACE_CHAR_A ) then begin
if ( i < c ) then begin
Inc(pc); Inc(i);
if ( pc^ = REPLACE_CHAR_A ) then
res := res + REPLACE_CHAR_A
else
res := res + TARGET_SEQUENCE_A + pc^;
end else begin
res := res + TARGET_SEQUENCE_A;
end;
end else begin
res := res + pc^;
end;
Inc(pc); Inc(i);
end;
Result := res;
end;
{$ENDIF WST_HANDLE_DOC}
function ExtractNameFromQName(const AQName : string):string ;
var
i : Integer;
begin
Result := Trim(AQName);
i := Pos(':',Result);
if ( i > 0 ) then
Result := Copy(Result,( i + 1 ), MaxInt);
end;
function CreateQualifiedNameFilterStr(
const AName : WideString;
APrefixList : TStrings
) : string;
var
k : Integer;
locStr : string;
locWStr : WideString;
begin
Result := '';
if ( APrefixList.Count > 0 ) then begin
for k := 0 to Pred(APrefixList.Count) do begin
if IsStrEmpty(APrefixList[k]) then begin
locWStr := ''
end else begin
locWStr := APrefixList[k] + ':';
end;
locWStr := locWStr + AName;
locStr := s_NODE_NAME;
Result := Result + ' or ' + locStr + ' = ' + QuotedStr(locWStr);
end;
if ( Length(Result) > 0 ) then begin
Delete(Result,1,Length(' or'));
end;
end else begin
Result := Format('%s = %s',[s_NODE_NAME,QuotedStr(AName)]);
end;
end;
procedure ExtractNameSpaceShortNamesNested(
ANode : TDOMNode;
AResList : TStrings;
const ANameSpace : WideString
);
var
nd : TDOMNode;
begin
AResList.Clear();
nd := ANode;
while Assigned(nd) do begin
if Assigned(nd.Attributes) and ( nd.Attributes.Length > 0 ) then begin
ExtractNameSpaceShortNames(CreateAttributesCursor(nd,cetRttiNode),AResList,ANameSpace,nfaNone,False,nil);
end;
nd := nd.ParentNode;
end;
end;
procedure ExtractNameSpaceShortNames(
AAttribCursor : IObjectCursor;
AResList : TStrings;
const ANameSpace : WideString;
const ANotFoundAction : TNotFoundAction;
const AClearBefore : Boolean;
const AExceptionClass : ExceptClass
);
var
crs : IObjectCursor;
locObj : TDOMNodeRttiExposer;
wStr : WideString;
i : Integer;
ec : ExceptClass;
begin
if AClearBefore then begin
AResList.Clear();
end;
AAttribCursor.Reset();
crs := CreateCursorOn(AAttribCursor,ParseFilter(Format('%s=%s',[s_NODE_VALUE,QuotedStr(ANameSpace)]),TDOMNodeRttiExposer));
crs.Reset();
if crs.MoveNext() then begin
repeat
locObj := crs.GetCurrent() as TDOMNodeRttiExposer;
wStr := Trim(locObj.NodeName);
i := AnsiPos(s_xmlns + ':',wStr);
if ( i > 0 ) then begin
i := AnsiPos(':',wStr);
AResList.Add(Copy(wStr,( i + 1 ), MaxInt));
end else begin
if ( AResList.IndexOf('') = -1 ) then
AResList.Add('');
end;
until not crs.MoveNext();
end else begin
if ( ANotFoundAction = nfaRaiseException ) then begin
if Assigned(AExceptionClass) then
ec := AExceptionClass
else
ec := Exception;
raise ec.CreateFmt('Namespace not found : "%s"',[ANameSpace]);
end;
end;
end;
function wst_findCustomAttribute(
AWsdlShortNames : TStrings;
ANode : TDOMNode;
const AAttribute : string;
out AValue : string
) : Boolean;
var
nd : TDOMNode;
tmpCrs : IObjectCursor;
begin
Result := False;
tmpCrs := CreateCursorOn(
CreateChildrenCursor(ANode,cetRttiNode),
ParseFilter(CreateQualifiedNameFilterStr(s_document,AWsdlShortNames),TDOMNodeRttiExposer)
);
tmpCrs.Reset();
if tmpCrs.MoveNext() then begin
nd := (tmpCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject;
if nd.HasChildNodes() then begin
tmpCrs := CreateCursorOn(
CreateChildrenCursor(nd,cetRttiNode),
ParseFilter(Format('%s=%s',[s_NODE_NAME,QuotedStr(s_customAttributes)]),TDOMNodeRttiExposer)
);
tmpCrs.Reset();
if tmpCrs.MoveNext() then begin
nd := (tmpCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject;
if ( nd.Attributes <> nil ) then begin
nd := nd.Attributes.GetNamedItem(AAttribute);
if Assigned(nd) then begin
Result := True;
AValue := nd.NodeValue;
end;
end;
end;
end;
end;
end;
function wst_findCustomAttributeXsd(
AXsdShortNames : TStrings;
ANode : TDOMNode;
const AAttribute : string;
out AValue : string
) : Boolean;
var
nd : TDOMNode;
begin
Result := False;
if Assigned(ANode) and ( ANode.Attributes <> nil ) then begin
nd := ANode.Attributes.GetNamedItem(Format('%s:%s',[s_WST,AAttribute]));
if Assigned(nd) then begin
Result := True;
AValue := nd.NodeValue;
end;
end;
end;
procedure ExplodeQName(const AQName : string; out ALocalName, ANameSpace : string) ;
var
i : PtrInt;
begin
i := Pos(':',AQName);
if ( i > 0 ) then begin
ANameSpace := Copy(AQName,1,Pred(i));
ALocalName := Copy(AQName,Succ(i),Length(AQName));
end else begin
ANameSpace := '';
ALocalName := AQName;
end;
end;
function AddNameSpace(const AValue: string; ANameSpaceList : TStrings): TStrings;
var
i : PtrInt;
s : string;
ls : TStringList;
begin
s := Trim(AValue);
i := ANameSpaceList.IndexOf(s);
if ( i < 0 ) then begin
i := ANameSpaceList.Add(s);
ls := TStringList.Create();
ANameSpaceList.Objects[i] := ls;
ls.Duplicates := dupIgnore;
ls.Sorted := True;
Result := ls;
end else begin
Result := ANameSpaceList.Objects[i] as TStrings;
end;
end;
procedure BuildNameSpaceList(AAttCursor : IObjectCursor; ANameSpaceList : TStrings);
var
locObj : TDOMNodeRttiExposer;
locNameSpace, locNameSpaceShort : string;
tmpXmlNs : string;
found : Boolean;
begin
if Assigned(AAttCursor) then begin
tmpXmlNs := s_xmlns + ':';
AAttCursor.Reset();
while AAttCursor.MoveNext() do begin
found := False;
locObj := AAttCursor.GetCurrent() as TDOMNodeRttiExposer;
if AnsiSameText(s_xmlns,locObj.NodeName) then begin
found := True;
locNameSpace := locObj.NodeValue;
locNameSpaceShort := '';
end else if AnsiStartsText(tmpXmlNs,locObj.NodeName) then begin
found := True;
locNameSpace := locObj.NodeValue;
locNameSpaceShort := locObj.NodeName;
locNameSpaceShort := Copy(locNameSpaceShort,Pos(':',locNameSpaceShort) + 1, Length(locNameSpaceShort));
end;
if found then
AddNameSpace(locNameSpace,ANameSpaceList).Add(locNameSpaceShort);
end;
end;
end;
{ TQualifiedNameObjectFilter }
function TQualifiedNameObjectFilter.Evaluate(const AObject: TObject): Boolean;
var
locObj : TDOMNodeRttiExposer;
startPos, i : PtrInt;
shortNameSpace : string;
locContinue : Boolean;
tmpNode : TDOMNode;
begin
Result := False;
if ( AObject <> nil ) then begin
locObj := TDOMNodeRttiExposer(AObject);
i := Length(FName);
startPos := ( Length(locObj.NodeName) - i + 1 );
if ( startPos > 0 ) and ( FName = Copy(locObj.NodeName,startPos,i) ) then begin
if ( startPos = 1 ) then begin
shortNameSpace := 'xmlns';
locContinue := True;
end else begin
locContinue := ( startPos > 2 ) and ( locObj.NodeName[startPos-1] = ':' );
if locContinue then
shortNameSpace := 'xmlns:' + Copy(locObj.NodeName,1,( startPos - 2 ));
end;
if locContinue then begin
if ( locObj.InnerObject.Attributes <> nil ) then begin
tmpNode := locObj.InnerObject.Attributes.GetNamedItem(shortNameSpace);
if ( tmpNode <> nil ) and ( tmpNode.NodeValue = FNameSpace ) then
Result := True;
end;
end;
end;
end;
end;
constructor TQualifiedNameObjectFilter.Create(const AName, ANameSpace: string);
begin
FName := AName;
FNameSpace := ANameSpace;;
end;
end.
Reference in New Issue View Git Blame Copy Permalink