dedepfiles.pas

dede 的源代码 3.10b

unit DeDePFiles;
//////////////////////////
// Last Change: 02.II.2001
//////////////////////////

interface

uses classes, DeDeConstants;

//Type TPredicate = (pNone, pType, pProp, pMeth, pVar, pConst, pProc, pFunc);

Type TParsedFile = Class (TFileStream)
       Procedure AddDeclaration(sVal : String; iType : Integer);
       Function GetNextDeclaration (Var sVal : String; var iType : Integer) : Boolean;
     End;


Type TClassPredicate = (prNone, prFunc, prProc, prField);

Type TClassParser = Object
       private
         FiCharCount, Delta : Integer;
         fbReadInherits, fbReadIt : Boolean;
         fsInherits : String;
       protected
         FsLowerString, FsString : String;
         FsClassName, sDeclarationType : String;
         GlobChar : Char;
         GlobPos : Integer;
         GlobWord, LastWord : String;
         bStringMode, bProperty, bIndexMode : Boolean;
         iLevel : Integer;
         IdentList, NameList,DefList : TStringList;
         BegPos : Integer;
         Predicate : TClassPredicate;
         Procedure InitParse(s : String; aIdentList, aNameList, aDefList : TStringList);
         Procedure GetNextChar;
         Procedure ReadWord;
         Procedure ParseWord;
       public
         // 0 indent
         // 1 name
         // 2 def
         Function ParseClass(var sClassString : String; Var DefsArray : Array of TStringList; var sClassName : String) : boolean;
     End;


Type TOnNewProcEvent = Procedure (sProcDecl : String; buffer : TSymBuffer; size : Integer; Progress : Byte; bAdd : Boolean) of Object;

Type TImplementationParser = Object
       private
         FiCharCount, Delta : Integer;
         fbReadInherits, fbReadIt : Boolean;
         fsInherits : String;
       protected
         FsLowerString, FsString : String;
         FsClassName, sDeclarationType : String;
         GlobChar : Char;
         GlobPos, GlobSize : Integer;
         GlobWord, LastWord : String;
         bProperty: Boolean;
         iLevel : Integer;
         BegPos : Integer;
         FbFound, FbInProc, FbDontIncreaseParens, FbType : Boolean;
         FOnNewProcedure : TOnNewProcEvent;
         POS0, POS1,POS2,POS3 : Integer;
         Procedure GetNextChar;
         Procedure ReadWord;
         Procedure ParseWord;
       public
         procedure InitParse(sClassString : String; OnNewProcedure : TOnNewProcEvent);
         procedure ParseIt;
     End;

Type TNewDCU2DSFParser = Object
       protected
         List : TStringList;
         FOnNewProcedure : TOnNewProcEvent;
       public
         procedure InitParse(aList : TStringList; OnNewProcedure : TOnNewProcEvent);
         procedure ParseIt;
     End;

var TmpStr, ErrList : TStringList;

implementation

uses SysUtils, Dialogs, Windows;


procedure TruncAll(Var s : String);
begin
  While (Copy(s,1,1)= #32) or (Copy(s,1,1)= #13) or (Copy(s,1,1)= #10) Do s:=Copy(s,2,Length(s)-1);
  While (Copy(s,Length(s),1) = #32) or (Copy(s,Length(s),1) = #13) or (Copy(s,Length(s),1) = #10) Do s:=Copy(s,1,Length(s)-1);
end;

Function MakeBack(s:String) : String;
var  i : Integer;
begin
  Result:='';
  For i:=Length(s) downto 1 do Result:=Result+s[i];
end;

function EncodeString ( const S : string) : string;
var
  I : Integer;
const
  ParsSpecChars : set of char = [#13,#10,'@','#','/','''','"','&'];
begin
  I := 1;
  Result := '';
  while I <= Length(S) do begin
    if s[i] in ParsSpecChars then Result := Result + '/'+IntToStr(Ord(S[i]))
    else Result := Result + s[i];
    Inc(I);
  end;
end;

function DecodeString ( const S : string) : string;
var
  I : Integer;
  tmp : String;
begin
  I := 1;
  Result := '';
  while I <= Length(S) do begin
    if s[i]='/' then  begin
      tmp := '0';
      Inc(I);
      while (I <= Length(S)) and (s[i] in ['0'..'9']) do begin
        tmp := tmp+s[i];
        Inc(I);
      end;
      if tmp<>'0' then Result := Result+Char(StrToInt(tmp))
    end else Result := Result + s[i];
    Inc(I);
  end;
end;

function RemoveComments(s: string): string;
var s2: string;
begin
  while (Pos('(*',s) > 0) and (Pos('*)',s) > Pos('(*',s)) do
    Delete(s,Pos('(*',s),Pos('*)',s)-Pos('(*',s)+2);
  while Pos('//',s) > 0 do begin
    s2 := Copy(s,Pos('//',s),Length(s));
    if Pos(#13+#10,s2) > 0 then
      Delete(s,Pos('//',s),Pos(#13+#10,s2)-1)
    else
      Delete(s,Pos('//',s),Length(s));
  end;
  while (Pos('{',s) > 0) and (Pos('}',s) > Pos('{',s)) do
    Delete(s,Pos('{',s),Pos('}',s)-Pos('{',s)+1);
  Result := s;
end;

function RemoveIntervals(s : String) : String;
var i : Integer;
begin
  Result:='';
  For i:=1 To Length(s)-1 do
      if (s[i] in [' ']) and (s[i+1] in [' '])
          then
          else Result:=Result+s[i];

  s:=Result;
  Result:='';
  i:=0;
  While i<Length(s)-1 do
    begin
      Inc(i);
      Result:=Result+s[i];
      if (s[i] in [',']) and (s[i+1] in [' '])
          then Inc(i);
    end;

end;

procedure TParsedFile.AddDeclaration(sVal: String; iType: Integer);
var w : Word;
begin
  //sVal:=EncodeString(sVal);
  w:=Length(sVal);
  WriteBuffer(w,2);
  WriteBuffer(iType,4);
  Writebuffer(sVal[1],w);
end;

function TParsedFile.GetNextDeclaration(Var sVal : String; var iType : Integer) : Boolean;
var w : Word;
begin
  ReadBuffer(w,2);
  ReadBuffer(iType,4);
  SetLength(sVal,w);
  Readbuffer(sVal[1],w);
 // sVal:=DecodeString(sVal);
  Result:= not (position=size);
end;


{ TClassParser }

procedure TClassParser.GetNextChar;
begin
  Inc(GlobPos);
  If GlobPos>FiCharCount
     Then GlobChar:=#0
     Else GlobChar:=FsLowerString[GlobPos];
end;

procedure TClassParser.InitParse(s : String; aIdentList, aNameList,aDefList : TStringList);
begin
  IdentList:=aIdentList;
  NameList:=aNameList;
  DefList:=aDefList;


  FsString:=RemoveComments(s);
  FsString:=RemoveIntervals(FsString);

  FsLowerString:=AnsiLowerCase(FsString);
  FiCharCount:=Length(s);
  GlobPos:=0;
  BegPos:=0;
  GlobChar:=#0;
  GlobWord:='';
  LastWord:='';
  sDeclarationType:='public';
  bStringMode:=False;
  bIndexMode:=False;
  iLevel:=0;
  Predicate:=prNone;
  bProperty:=False;
  fbReadInherits:=false;
  fbReadIt:=false;
  fsInherits:='';
end;

function TClassParser.ParseClass(var sClassString: String;
  var DefsArray: array of TStringList; var sClassName: String): boolean;
var i,iPos,iPos2 : Integer;
    sLowerString : String;
    sWord : String;
begin
  InitParse(sClassString, DefsArray[0], DefsArray[1], DefsArray[2]);

  FsClassName:='<class parse failed>';
  Repeat
    ReadWord;
    ParseWord;
  Until GlobChar=#0;

  sClassName:=FsClassName;
  fsInherits:=trim(fsInherits);
  if fsInherits='' then fsInherits:='TObject';
  sClassString:=fsInherits;
end;

procedure TClassParser.ParseWord;
var sIdent, sName, sDef  : String;
    iPos : Integer;
begin
  If fsClassName='<class parse failed>' then
    if (GlobWord='object') or (GlobWord='class') or (GlobWord='interface')
       then begin
          iPos:=Pos(LastWord, FsLowerString);
          fsClassName:=Copy(FsString,iPos,Length(LastWord));
          fbReadInherits:=True;
       end;

  if GlobChar='(' then
     begin
      Inc(iLevel);
      if fbReadInherits then fbReadIt:=True;
     end;
  if (iLevel>0) and (GlobChar=')') then begin Dec(iLevel); fbReadInherits:=false; end;

  if (GlobChar='[') and (Predicate=prNone) then
    begin
      Predicate:=prField;
      BegPos:=GlobPos-Length(GlobWord)-1;
      Inc(iLevel);
    end;

  if GlobWord='procedure' then
     begin
       Predicate:=prProc;
       BegPos:=GlobPos;
       fbReadInherits:=false;
     end;

  if GlobWord='function' then
     begin
       Predicate:=prFunc;
       BegPos:=GlobPos;
       fbReadInherits:=false;
     end;

  if GlobWord='property' then bProperty:=True;

  if (GlobChar=':') and (Predicate=prNone) and (iLevel=0)  then
     if (GlobWord<>'private') and (GlobWord<>'public') and (GlobWord<>'published') and (GlobWord<>'protected') then
       begin
         Predicate:=prField;
         If Length(GlobWord)=0 Then GlobWord:=LastWord;
         BegPos:=GlobPos-Length(GlobWord)-1
       end;

  if (GlobWord='private') or (GlobWord='public') or (GlobWord='published') or (GlobWord='protected')
     then sDeclarationType:=GlobWord;

  if (iLevel>0) and (GlobChar=']') then Dec(iLevel);

  if (iLevel=0) and (fbReadIt) then
    begin
      fsInherits:=Copy(FsString,GlobPos-Length(GlobWord),Length(GlobWord));
      fbReadIt:=false;
    end;

  If (iLevel=0) and (GlobChar=';') and (Predicate<>prNone) Then
    Begin
      Case Predicate Of
        prProc : sIdent:='procedure';
        prFunc : sIdent:='function';
        prField: If bProperty Then sIdent:='property'
                              Else sIdent:='';
      End;
      If GlobWord='' Then GlobWord:=LastWord;
      IdentList.Add(sDeclarationType+' '+sIdent);
      sDef:=Copy(FsString,BegPos,GlobPos{-Delta}-BegPos+1);
      TruncAll(sDef);
      iPos:=0;

      If Predicate = prField Then
        begin
         iPos:=Pos(':',MakeBack(sDef));
         iPos:=Length(sDef)-iPos+1;
        end;

      if iPos=0 then iPos:=Pos('(',sDef);
      if iPos=0 Then iPos:=Pos(#32,sDef);
      if (not (Predicate = prField)) and (iPos=0) then iPos:=Length(sDef);
      sName:=Copy(sDef,1,iPos-1);
      sDef:=Copy(sDef,iPos,Length(sDef)-iPos+1);
      TruncAll(sName);
      TruncAll(sDef);
      NameList.Add(sName);
      DefList.Add(sDef);

      Predicate:=prNone;
      bProperty:=False;
    End;


end;

procedure TClassParser.ReadWord;
begin
   If GlobWord<>''
      Then begin
             LastWord:=GlobWord;
             Delta:=0;
           end ;