XPTestedUnitParser.pas
上传用户:yjb1804
上传日期:2021-01-30
资源大小:3105k
文件大小:13k
源码类别:

Email服务器

开发平台:

Delphi

  1. unit XPTestedUnitParser;
  2. {
  3.  $Source: /cvsroot/dunit/dunit/Contrib/DUnitWizard/Source/DelphiExperts/DUnitProject/XPTestedUnitParser.pas,v $
  4.  $Revision: 1.3 $
  5.  $Date: 2004/08/22 14:25:40 $
  6.  Last amended by $Author: pvspain $
  7.  $State: Exp $
  8.  XPTestedUnitParser:
  9.  Copyright (c) 2002 by The Excellent Programming Company Pty Ltd
  10.  (Australia) (ABN 27 005 394 918). All rights reserved.
  11.  Contact Paul Spain via email: paul@xpro.com.au
  12.  This unit is free software; you can redistribute it and/or
  13.  modify it under the terms of the GNU Lesser General Public
  14.  License as published by the Free Software Foundation; either
  15.  version 2.1 of the License, or (at your option) any later version.
  16.  This unit is distributed in the hope that it will be useful,
  17.  but WITHOUT ANY WARRANTY; without even the implied warranty of
  18.  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19.  Lesser General Public License for more details.
  20.  You should have received a copy of the GNU Lesser General Public
  21.  License along with this unit; if not, the license can be viewed at:
  22.  http://www.gnu.org/copyleft/lesser.html
  23.  or write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  24.  Boston, MA  02111-1307  USA
  25. }
  26. interface
  27. uses
  28.   Classes,                // TStream
  29.   XPTestedUnitUtils,
  30.   ToolsAPI,               // IOTASourceEditor
  31.   XPIterator;             // IXPForwardIterator;
  32. type
  33.   TXPParserError = ( peNone, peNilArgument );
  34. //////////////////////////////////////////////////////////////////////////////
  35. //   IXPTestedUnitParser declaration
  36. //////////////////////////////////////////////////////////////////////////////
  37.   IXPTestedUnitParser = interface
  38.     ['{DD8CBC34-7719-4007-8AFF-287A12D8AF67}']
  39.     function Parse(const AUnit: TStream): boolean; overload;
  40.     // Default argument causes current IDE unit to be parsed
  41.     function Parse(const AnEditor: IOTASourceEditor = nil): boolean; overload;
  42.     procedure GetError(out Description: string; out Code: TXPParserError);
  43.     function ParseTree: IXPParserTree;
  44.   end;
  45. //////////////////////////////////////////////////////////////////////////////
  46. //   Unit entry point
  47. //////////////////////////////////////////////////////////////////////////////
  48. function CreateXPTestedUnitParser: IXPTestedUnitParser;
  49. implementation
  50. uses
  51.   XPPascalScanner,
  52.   XPToken,
  53.   XPKeyWords,
  54.   XP_OTAUtils,
  55.   XP_OTAEditorUtils;
  56. const CVSID: string = '$Header: /cvsroot/dunit/dunit/Contrib/DUnitWizard/Source/DelphiExperts/DUnitProject/XPTestedUnitParser.pas,v 1.3 2004/08/22 14:25:40 pvspain Exp $';
  57. type
  58.   TToken = record
  59.     Name: string;
  60.     Position: longint;
  61.   end;
  62.   TParserState = (
  63.     psClassDeclaration,
  64.     psClassHeritage
  65.   );
  66.   TParserStates = set of TParserState;
  67.   TParser = class(TInterfacedObject, IXPTestedUnitParser)
  68.   private
  69.     FErrorDescription: string;
  70.     FErrorCode: TXPParserError;
  71.     FScanner: TXPPascalScanner;
  72.     FVisibility: TXPClassVisibility;
  73.     FStatus: TParserStates;
  74.     FParserTree: IXPParserTree;
  75.     FCurrentSection: IXPSectionNode;
  76.     FCurrentClass: IXPClassNode;
  77.     FTokens: array[0..2] of TToken;
  78.     procedure SectionMonitor(const Token: TXPToken);
  79.     procedure VisibilityMonitor(const Token: TXPToken);
  80.     procedure MethodMonitor(const Token: TXPToken);
  81.     procedure PropertyMonitor(const Token: TXPToken);
  82.     procedure ClassTypeMonitor(const Token: TXPToken);
  83.     procedure ClassEndMonitor(const Token: TXPToken);
  84.     procedure FunctionMonitor(const Token: TXPToken);
  85.     function KeyWordIsResWord(const KeywordToken: TXPToken;
  86.       ReservedWords: TXPResWords): boolean;
  87.     function LookAheadIsResWord(const Token: TXPToken;
  88.       ReservedWords: TXPResWords): boolean;
  89.     procedure History(const Token: TXPToken);
  90.   protected
  91.     //
  92.     // IXPTestedUnitParser implementation
  93.     //
  94.     function Parse(const AUnit: TStream): boolean; overload;
  95.     function Parse(const AnEditor: IOTASourceEditor = nil): boolean; overload;
  96.     procedure GetError(out Description: string; out Code: TXPParserError);
  97.     function ParseTree: IXPParserTree;
  98.   public
  99.     constructor Create;
  100.     destructor Destroy; override;
  101.   end;
  102. //////////////////////////////////////////////////////////////////////////////
  103. //   Unit entry point
  104. //////////////////////////////////////////////////////////////////////////////
  105. function CreateXPTestedUnitParser: IXPTestedUnitParser;
  106. begin
  107.   Result := TParser.Create;
  108. end;
  109. //////////////////////////////////////////////////////////////////////////////
  110. //   IXPTestedUnitParser implementation
  111. //////////////////////////////////////////////////////////////////////////////
  112. constructor TParser.Create;
  113. begin
  114.   inherited Create;
  115.   FParserTree := XPTestedUnitUtils.CreateXPParserTree;
  116.   FScanner := TXPPascalScanner.Create;
  117.   FScanner.OnToken.Add(History);
  118.   FScanner.OnToken.Add(ClassTypeMonitor);
  119.   // Order of addition reresents order of firing and is significant here.
  120.   // Each observer sets up state used by the subsequent observer(s).
  121.   FScanner.OnKeyWordToken.Add(SectionMonitor);
  122.   FScanner.OnKeyWordToken.Add(ClassEndMonitor);
  123.   FScanner.OnKeyWordToken.Add(FunctionMonitor);
  124.   FScanner.OnKeyWordToken.Add(VisibilityMonitor);
  125.   FScanner.OnKeyWordToken.Add(MethodMonitor);
  126.   FScanner.OnKeyWordToken.Add(PropertyMonitor);
  127. end;
  128. destructor TParser.Destroy;
  129. begin
  130.   FScanner.Free;
  131.   inherited;
  132. end;
  133. procedure TParser.GetError(out Description: string;
  134.   out Code: TXPParserError);
  135. begin
  136.   Description := '';
  137.   Code := peNone;
  138. end;
  139. function TParser.Parse(const AUnit: TStream): boolean;
  140. begin
  141.   if System.Assigned(AUnit) then
  142.   begin
  143.     FErrorDescription := 'No error';
  144.     FErrorCode := peNone;
  145.     FVisibility := cvNone;
  146.     FStatus := [];
  147.     FCurrentSection := nil;
  148.     FCurrentClass := nil;
  149.     FParserTree.Clear;
  150.     FScanner.Scan(AUnit);
  151.     Result := true;
  152.     FillChar(FTokens, Sizeof(TToken) * 3, 0);
  153.   end
  154.   else
  155.   begin
  156.     FErrorDescription := 'IXPTestedUnitParser.Parse(): Nil argument passed';
  157.     FErrorCode := peNilArgument;
  158.     Result := false;
  159.   end;
  160. end;
  161. function TParser.Parse(const AnEditor: IOTASourceEditor): boolean;
  162. var
  163.   Stream: TStream;
  164.   Editor: IOTASourceEditor;
  165. begin
  166.   Editor := AnEditor;
  167.   if (Editor = nil) and not XP_OTAUtils.GetCurrentSourceEditor(Editor) then
  168.       XP_OTAUtils.MessageViewAdd('[DUnitWizard]: Error: TParser.Parse():'
  169.       + 'Unable to get IOTASourceEditor for current unit');
  170.   if Editor <> nil then
  171.   begin
  172.     Stream := TXPEditReaderStream.Create(Editor);
  173.     try
  174.       Result := Parse(Stream);
  175.     finally
  176.       Stream.Free;
  177.     end;
  178.   end
  179.   else
  180.     Result := false;
  181. end;
  182. function TParser.KeyWordIsResWord(const KeywordToken: TXPToken;
  183.   ReservedWords: TXPResWords): boolean;
  184. begin
  185.   Result := (KeywordToken.KeyWord.Kind = kwResWord)
  186.     and (KeywordToken.KeyWord.ResWord in ReservedWords);
  187. end;
  188. function TParser.LookAheadIsResWord(const Token: TXPToken;
  189.   ReservedWords: TXPResWords): boolean;
  190. begin
  191.   Result := (Token.LookAhead <> nil) and (Token.LookAhead^.Kind = tkKeyWord)
  192.     and KeyWordIsResWord(Token.LookAhead^, ReservedWords);
  193. end;
  194. procedure TParser.SectionMonitor(const Token: TXPToken);
  195. begin
  196.   if (Token.KeyWord.Kind = kwResWord) then
  197.     case Token.KeyWord.ResWord of
  198.     rwInterface:
  199.       // Check for possible legal tokens following INTERFACE section
  200.       // keyword
  201.       if LookAheadIsResWord(Token, [rwConst, rwFunction, rwImplementation,
  202.         rwProcedure, rwType, rwUses, rwVar]) then
  203.         begin
  204.           FCurrentSection := CreateXPSectionNode(FParserTree, usInterface);
  205.           FCurrentClass := nil;
  206.         end;
  207.     rwImplementation:
  208.       begin
  209.         FCurrentSection := CreateXPSectionNode(FParserTree, usImplementation);
  210.         FCurrentClass := nil;
  211.       end;
  212.     rwInitialization:
  213.       begin
  214.         FCurrentSection := CreateXPSectionNode(FParserTree, usInitialization);
  215.         FCurrentClass := nil;
  216.       end;
  217.     rwFinalization:
  218.       begin
  219.         FCurrentSection := CreateXPSectionNode(FParserTree, usFinalization);
  220.         FCurrentClass := nil;
  221.       end;
  222.     rwUnit:
  223.         if Assigned(Token.LookAhead) then
  224.           FParserTree.SetName(Token.LookAhead^.Lexeme);
  225.     end;
  226. end;
  227. // TODO: Object Pascal grammar states that CLASS declarations must
  228. //  end  with END
  229. // but...
  230. //   TMyClass = class(TAnotherClass);
  231. // compiles. Is this a Delphi bug or just silently resolved in Delphi? This
  232. // case is handled by ClassTypeMonitor().
  233. procedure TParser.ClassEndMonitor(const Token: TXPToken);
  234. begin
  235.   // Check for class termination with END keyword
  236.   if (psClassDeclaration in FStatus) and KeyWordIsResWord(Token, [rwEnd]) then
  237.   begin
  238.     Assert(FCurrentClass <> nil,
  239.       'TParser.ClassEndMonitor(): FCurrentClass unassigned');
  240.     // Class end pos = token pos + length(token)
  241.     FCurrentClass.ClassEnd := Token.Position + Length(Token.Lexeme);
  242.     Exclude(FStatus, psClassDeclaration);
  243.     FVisibility := cvNone;
  244.   end;
  245. end;
  246. procedure TParser.VisibilityMonitor(const Token: TXPToken);
  247. begin
  248.   if (psClassDeclaration in FStatus) and (Token.KeyWord.Kind = kwDirective) then
  249.     case Token.KeyWord.Directive of
  250.     dPrivate:
  251.       FVisibility := cvPrivate;
  252.     dProtected:
  253.       FVisibility := cvProtected;
  254.     dPublic:
  255.       FVisibility := cvPublic;
  256.     dPublished:
  257.       FVisibility := cvPublished;
  258.     end;
  259. end;
  260. procedure TParser.MethodMonitor(const Token: TXPToken);
  261. const
  262.   IsEnabled = true;
  263. begin
  264.   if (psClassDeclaration in FStatus) and KeyWordIsResWord(Token,
  265.     [rwConstructor, rwDestructor, rwFunction, rwProcedure])
  266.     and (Token.LookAhead <> nil) then
  267.   begin
  268.     Assert(FCurrentClass <> nil,
  269.       'TParser.MethodMonitor(): FCurrentClass unassigned');
  270.     CreateXPMethodNode(FCurrentClass.Visibilities[FVisibility],
  271.       Token.LookAhead^.Lexeme, IsEnabled);
  272.   end;
  273. end;
  274. procedure TParser.PropertyMonitor(const Token: TXPToken);
  275. const
  276.   IsEnabled = true;
  277. begin
  278.   if (psClassDeclaration in FStatus) and KeyWordIsResWord(Token, [rwProperty])
  279.     and (Token.LookAhead <> nil) then
  280.   begin
  281.     Assert(FCurrentClass <> nil,
  282.       'TParser.PropertyMonitor(): FCurrentClass unassigned');
  283.     CreateXPPropertyNode(FCurrentClass.Visibilities[FVisibility],
  284.       Token.LookAhead^.Lexeme, IsEnabled);
  285.   end;
  286. end;
  287. procedure TParser.FunctionMonitor(const Token: TXPToken);
  288. const
  289.   IsEnabled = true;
  290. begin
  291.   if Assigned(FCurrentSection) and (FCurrentSection.GetSection = usInterface)
  292.     // exclude methods
  293.     and not (psClassDeclaration in FStatus)
  294.     and KeyWordIsResWord(Token, [rwFunction, rwProcedure])
  295.     // exclude procedural type declarations
  296.     and (FTokens[1].Name <> '=') and Assigned(Token.LookAhead) then
  297.     CreateXPFunctionNode(FCurrentSection, Token.LookAhead^.Lexeme, IsEnabled);
  298.     
  299. end;
  300. procedure TParser.History(const Token: TXPToken);
  301. begin
  302.   // Push new token lexeme onto end of buffer
  303.   FTokens[0] := FTokens[1];
  304.   FTokens[1] := FTokens[2];
  305.   FTokens[2].Name := Token.Lexeme;
  306.   FTokens[2].Position := Token.Position;
  307. end;
  308. procedure TParser.ClassTypeMonitor(const Token: TXPToken);
  309. const
  310.   IsEnabled = true;
  311. begin
  312.   // Check for class declaration
  313.   // tokens: 0:<name>  1:'=' 2:'class' 3: not in [';', 'of']
  314.   if not (psClassDeclaration in FStatus) and (FCurrentSection <> nil)
  315.     and (FCurrentSection.GetSection in [usInterface, usImplementation])
  316.     // Token = 'class' keyword
  317.     and KeyWordIsResWord(Token, [rwClass])
  318.     and (FTokens[1].Name = '=') and (Token.LookAhead <> nil)
  319.     // class forward declaration: next token is ';'
  320.     and (Token.LookAhead^.Lexeme[1] <> ';')
  321.     // class reference declaration: next token is 'of'
  322.     and not LookAheadIsResWord(Token, [rwOf]) then
  323.   begin
  324.     // New class - name in FTokenLexemes[0]
  325.     FCurrentClass := CreateXPClassNode(FCurrentSection, FTokens[0].Name,
  326.       IsEnabled);
  327.     FCurrentClass.ClassBegin := FTokens[0].Position;
  328.     Include(FStatus, psClassDeclaration);
  329.     FVisibility := cvPublished;
  330.     if (Token.LookAhead <> nil)
  331.       and (Token.LookAhead^.Lexeme[1] = '(') then
  332.       Include(FStatus, psClassHeritage);
  333.   end
  334.   // Check for empty subclass declaration - no END keyword
  335.   else if (psClassHeritage in FStatus) and (Token.Lexeme[1] = ')') then
  336.   begin
  337.     // Finished parsing ClassHeritage
  338.     Exclude(FStatus, psClassHeritage);
  339.     // Look ahead for class termination following ClassHeritage
  340.     if (Token.LookAhead <> nil) and (Token.LookAhead^.Lexeme[1] = ';') then
  341.     begin
  342.       Assert(FCurrentClass <> nil,
  343.         'TParser.ClassTypeMonitor(): FCurrentClass unassigned');
  344.       // Class end pos = look ahead pos + length(look ahead token)
  345.       FCurrentClass.ClassEnd := Token.LookAhead^.Position + 1;
  346.       Exclude(FStatus, psClassDeclaration);
  347.       FVisibility := cvNone;
  348.     end;
  349.   end;
  350. end;
  351. function TParser.ParseTree: IXPParserTree;
  352. begin
  353.   Result := FParserTree;
  354. end;
  355. end.