[DungeonLords]

Сообщение от DJ PhoeniX

2. выделенная строчка (ИМХО) должна иметь следующий вид:

Код:

if not ExtractFileExt(FileName)='.pas' then exit;

ИМХО, разве это не одно и тоже? Символ "*" значит "любое".

Кстати, как проверить, существует ли папка по пути C:\Papka?

[PhoeniX]

А разве Delphi поддерживает звёздочки в сравнениях??? О_о
Никогда о таком не слышал. Проверь, у тебя хоть 1 файл не отсекается?

[Rokuell]

Сообщение от DungeonLords

ИМХО, разве это не одно и тоже? Символ "*" значит "любое".

Не впутывай свои представления в программирование. Лучше будет, если напишешь

Код:

if not LowerCase(ExtractFileExt(FileName))='.pas' then exit;

Хотя я всё равно не понимаю, зачем эту строку тебе пришлось вставлять в процедуру SaveAsTree , ведь FileName должен содержать полный путь к файлу, куда надо сохранить дерево, т.е например: C:\PAPKA\tree.txt , при этом папка C:\PAPKA\ должна существовать, иначе возникнет ошибка.

Сообщение от DungeonLords

Кстати, как проверить, существует ли папка по пути C:\Papka?

Используй функцию DirectoryExists

[DungeonLords]

Спасибо всем огромное за помощь. Но вот ерунда, програма почему-то вместе с настоящими классами прожёвывает и строки такого вида "//THeightData". Как с этим бороться?

[DungeonLords]

Сообщение от DungeonLords

Спасибо всем огромное за помощь. Но вот ерунда, програма почему-то вместе с настоящими классами прожёвывает и строки такого вида "//THeightData". Как с этим бороться?

Помогите пожалуйста.

[Rokuell]

Сообщение от DungeonLords

Спасибо всем огромное за помощь. Но вот ерунда, програма почему-то вместе с настоящими классами прожёвывает и строки такого вида "//THeightData". Как с этим бороться?

Не слишком понял - лучше выложи сюда файл для анализа и укажи номер строки, из-за которой программа работает некорректно. Буду тогда исправлять.

[DungeonLords]

Сообщение от Rokuell

Не слишком понял - лучше выложи сюда файл для анализа и укажи номер строки, из-за которой программа работает некорректно. Буду тогда исправлять.

Если честно, я почти не понимаю код! Вот взять это: recadd - что это такое?

Ну и вообще, ИМХО, в начале никак не предполагал, что будет столько классов.

Из-за этих причин мне не удалось вставить код, отслеживающий в каком файле сейчас происходит чтение и на какой строке.

Скриншот: http://s48.radikal.ru/i122/0909/2f/343061ef3cae.jpg

[Rokuell]

Дело в том, что окончательная отладка производилась на стандартных классах Delphi ( я сканировал C:\Program Files\Borland\Delphi7\Source\ включая подпапки ) и при этом глюков или постороннего хлама не было.
Поэтому дальнейшая отладка возможна только на конкретном примере.

Из-за этих причин мне не удалось вставить код, отслеживающий в каком файле сейчас происходит чтение и на какой строке.

У меня предусмотрен режим отладки:
Для примера кода:
http://www.delphisources.ru/forum/sh...2&postcount=11
достаточно поставить

Код:

CT.IncludeDebugInfo := true;

тогда при сохранении в файл будут включены не только названия классов, но и имя файла и номер строки, откуда это имя взято ( сорри, что не обратил ваше внимание на эту опцию ранее ).

[Rokuell]

Если честно, я почти не понимаю код! Вот взять это: recadd - что это такое?

Могу объяснить:
recadd - это рекурсивная функция принадлежащая методу TClassesTree.MakeTree

Код:

procedure TClassesTree.MakeTree(tree: TTreeView);
var i:integer;
 function recadd(id:integer; itemto:TTreeNode):integer;
 var i:integer;
 begin
  i := FNodes[id].fchildid;
  while (i<>-1) do i := recadd(i,tree.Items.AddChild(itemto,FNodes[i].name));
  Result := FNodes[id].nextid;
 end;
begin
 if not IsLinked then MakeLinks;
 i := FNodes[0].fchildid;
 while (i<>-1) do i := recadd(i,tree.Items.Add(nil,FNodes[i].name));
end;

Рассмотрим работу этого метода подробнее:
1. if not IsLinked then MakeLinks; - проверка, установлены ли в дереве связи между узлами.
IsLinked становиться равной false при добавлении нового узла (т.е. класса ).

2. i := FNodes[0].fchildid; - построение дерева (т.е. добавление узлов в tree: TTreeView) начинается с первого потомка корня.
Само добавление происходит при вызове tree.Items.Add(nil,FNodes[i].name)

3. while (i<>-1) do i := recadd(i,tree.Items.Add(nil,FNodes[i].name));
Для всех потомков корня вызывается функция recadd которая возвращает следующий узел в списке потомков.

4. в самой же функции происходит добавление в дерево всех потомков к.л. узла.

Может не слишком ясно объясняю, но рекурсию вообще-то лучше рассматривать на примере.

[DungeonLords]

Теперь яснее.

Я восхищён вашей продуманностью! Надо же, режим отладки .

Ну благодаря ему выискалось что происходит. Значит есть некий .pas файл. В нём записано:
...
TTileManagementFlag =(tmClearUsedFlags,tmMarkUsedTiles,tmReleaseUnused Tiles,tmAllocateNewTiles,tmWaitForPreparing);
TTileManagementFlags = set of TTileManagementFlag;

// TGLTerrainRenderer
//
{: Basic terrain renderer.<p>
This renderer uses no sophisticated meshing, it just builds and maintains
a set of terrain tiles, performs basic visibility culling and renders its
stuff. You can use it has a base class/sample for more specialized
terrain renderers.<p>
The Terrain heightdata is retrieved directly from a THeightDataSource, and
expressed as z=f(x, y) data. }
//TGLTerrainRenderer = class (TGLSceneObject)
TGLTerrainRenderer = class (TGLSceneObject)
private
{ Private Declarations }
FHeightDataSource : THeightDataSource;
...

В вашей программе встречается и "TGLTerrainRenderer" и "//TGLTerrainRenderer", разумеется второй это не класс, а комментарий.

Если уж так надо, высылаю файл GLTerrainRenderer.pas: http://slil.ru/28008070

[Rokuell]

Исправил. Теперь модуль также корректно обрабатывает строки и комментарии.
т.е. ситуации вида:

Код:

// type TNewClass = class
{
type TNewClass = class
}
(*
type TNewClass = class
*)
var s:string = 'type TNewClass = class';

Модуль ClassesTree часть 1:

Код:

unit ClassesTree;

interface

uses SysUtils,StrUtils,ComCtrls,Classes;

type

 TClassNode =  record
  parentid:integer;
  previd:integer;
  nextid:integer;
  fchildid:integer;
  lchildid:integer;
  name:string;
  parent:string;
  // debug info
  fullpath:string;
  line:integer;
 end;

 TAnalysisState = (sNorm,sStr,sSLfirst,sSLcom,sFB,sCBfirst,sCBcom,sCBend);

 TClassesTree = class
 private
  FTF:Text;
  FNodes: array of TClassNode;
  FCount: integer;
  FTabChar:string;
  FIncludeClassLinks:boolean;
  FIncludeDebugInfo:boolean;
  IsLinked:boolean;
  function GetClass(Id:Integer): TClassNode;
  procedure SetClass(Id:integer; Value: TClassNode);
  procedure DeleteLinks;
  procedure SkanDir(Dir:string);
  procedure SkanDirExt(Dir:string);
  procedure SkanFile(FileName:string);
  function ExcludeStringsAndComments(vs:string; var st:TAnalysisState):string;
 public
  // include constructions:   TClass2 = class of TClass1;
  property IncludeClassLinks:boolean read FIncludeClassLinks write FIncludeClassLinks;
  // if true - at use methods SaveAsTree and SaveAsSortList will add debug info ( TClassNode.fullpath and TClassNode.line )
  property IncludeDebugInfo:boolean read FIncludeDebugInfo write FIncludeDebugInfo;
  // TabChar using in method SaveAsTree
  property TabChar:string read FTabChar write FTabChar;
  property Count:integer read FCount;
  property Classes[Id:Integer]:TClassNode read GetClass write SetClass; default;
  function AddClass(AName, AParent: string):integer; overload;
  function AddClass(AName, AParent, AFullPath: string; ALine:integer):integer; overload;
  function IndexOf(AName:string):integer;
  procedure MakeLinks;
  procedure MakeTree(tree:TTreeView);
  // at use method SaveAsTree, the results file may be load into TTreeView using method LoadFromFile
  // ( only if TabChar = #9 )
  procedure SaveAsTree(FileName:string);
  procedure SaveAsSortList(FileName:string);
  // if flag IncludeSubFolders is true , we also find *.pas files in subfolders
  procedure GetClassesFromDir(Dir:string; IncludeSubFolders:boolean=false);
  procedure Clear;
  constructor Create; overload;
  destructor Destroy; override;
 end;

implementation

{ TClassesTree }

constructor TClassesTree.Create;
begin
 IsLinked := false;
 FTabChar := #9;
 FCount := 0;
 FIncludeClassLinks := true;
 FIncludeDebugInfo := false;
 SetLength(FNodes,1);
 FNodes[0].name := '';
 FNodes[0].parent := '';
end;

destructor TClassesTree.Destroy;
begin
 SetLength(FNodes,0);
 FNodes := nil;
 inherited;
end;

procedure TClassesTree.Clear;
begin
 IsLinked := false;
 FCount := 0;
 SetLength(FNodes,1);
 FNodes[0].name := '';
 FNodes[0].parent := '';
end;

function TClassesTree.GetClass(Id: Integer): TClassNode;
begin
 if Id in [1..FCount] then Result := FNodes[Id]
 else Result := FNodes[0];
end;

procedure TClassesTree.SetClass(Id: integer; Value: TClassNode);
begin
 if Id in [1..FCount] then FNodes[Id] := Value;
end;

function TClassesTree.AddClass(AName, AParent: string): integer;
begin
 IsLinked := false;
 Inc(FCount);
 SetLength(FNodes,FCount+1);
 FNodes[FCount].name := AName;
 FNodes[FCount].parent := AParent;
 Result := FCount;
end;

function TClassesTree.AddClass(AName, AParent, AFullPath: string; ALine:integer):integer;
begin
 IsLinked := false;
 Inc(FCount);
 SetLength(FNodes,FCount+1);
 FNodes[FCount].name := AName;
 FNodes[FCount].parent := AParent;
 FNodes[FCount].fullpath := AFullPath;
 FNodes[FCount].line := ALine;
 Result := FCount;
end;

function TClassesTree.IndexOf(AName: string): integer;
var i:integer;
begin
 Result := 0;
 AName := LowerCase(AName);
 for i:=1 to FCount do
 if AName = LowerCase(FNodes[i].name) then
  begin
   Result := i;
   Break;
  end;
end;

procedure TClassesTree.DeleteLinks;
var i:integer;
begin
 for i:=0 to FCount do
 with FNodes[i] do
  begin
   parentid := -1;
   previd := -1;
   nextid := -1;
   fchildid := -1;
   lchildid := -1;
  end;
 IsLinked := false;
end;

procedure TClassesTree.MakeLinks;
var i,pid:integer;
begin
 DeleteLinks;
 for i:=1 to FCount do
  begin
   pid := Self.IndexOf(FNodes[i].parent);
   FNodes[i].parentid := pid;
   if FNodes[pid].fchildid = -1 then
    begin
     FNodes[pid].fchildid := i;
     FNodes[pid].lchildid := i;
    end
   else
    begin
     FNodes[i].previd := FNodes[pid].lchildid;
     FNodes[FNodes[pid].lchildid].nextid := i;
     FNodes[pid].lchildid := i;
    end;
  end;
end;

procedure TClassesTree.MakeTree(tree: TTreeView);
var i:integer;
 function recadd(id:integer; itemto:TTreeNode):integer;
 var i:integer;
 begin
  i := FNodes[id].fchildid;
  while (i<>-1) do i := recadd(i,tree.Items.AddChild(itemto,FNodes[i].name));
  Result := FNodes[id].nextid;
 end;
begin
 if not IsLinked then MakeLinks;
 i := FNodes[0].fchildid;
 while (i<>-1) do i := recadd(i,tree.Items.Add(nil,FNodes[i].name));
end;

procedure TClassesTree.SaveAsTree(FileName: string);
var i:integer;
 function recsave(id:integer; pref:string):integer;
 var i:integer;
 begin
  if FIncludeDebugInfo then Writeln(FTF,pref+FNodes[id].name+'  ',FNodes[id].line,'  ',FNodes[id].fullpath)
  else Writeln(FTF,pref+FNodes[id].name);
  i := FNodes[id].fchildid;
  while (i<>-1) do i:=recsave(i,pref+FTabChar);
  Result := FNodes[id].nextid;
 end;
begin
 if not IsLinked then MakeLinks;
 Assign(FTF,FileName);
 Rewrite(FTF);
 i := FNodes[0].fchildid;
 while (i<>-1) do i:=recsave(i,'');
 Close(FTF);
end;

procedure TClassesTree.SaveAsSortList(FileName: string);
var sl:TStringList;
    i:integer;
begin
 sl := TStringList.Create;
 try
  if FIncludeDebugInfo then
   for i:=1 to FCount do sl.Add(FNodes[i].name+'  '+IntToStr(FNodes[i].line)+'  '+FNodes[i].fullpath)
  else
   for i:=1 to FCount do sl.Add(FNodes[i].name);
  sl.Sort;
  sl.SaveToFile(FileName);
 finally
  sl.Free;
 end;
end;

procedure TClassesTree.SkanDir(Dir:string);
var F:TSearchRec;
begin
 if Dir[Length(Dir)] <> '\' then Dir:=Dir+'\';
 if FindFirst(Dir+'*.*',faAnyFile,F) = 0 then
  repeat
   if ((F.Attr and faDirectory) = 0) and ( LowerCase(ExtractFileExt(F.Name)) = '.pas' ) then
    begin
     SkanFile(Dir+F.Name);
    end;
  until FindNext(F) <> 0;
 FindClose(F);
end;

[Rokuell]

Модуль ClassesTree часть 2:

Код:

procedure TClassesTree.SkanDirExt(Dir:string);
var F:TSearchRec;
    dirlist,filelist:TStringList;
    i:integer;
begin
 if Dir[Length(Dir)] <> '\' then Dir:=Dir+'\';
 dirlist := TStringList.Create;
 filelist := TStringList.Create;
 dirlist.Add(Dir);
 try
  repeat
   Dir := dirlist.Strings[0];
   dirlist.Delete(0);
   if FindFirst(Dir+'*.*',faAnyFile,F) = 0 then
    repeat
     if ((F.Attr and faDirectory) = faDirectory) and (F.Name <> '.') and (F.Name <> '..') then
      dirlist.Add(Dir+F.Name+'\')
     else
     if ((F.Attr and faDirectory) = 0) and ( LowerCase(ExtractFileExt(F.Name)) = '.pas' ) then
      filelist.Add(Dir+F.Name);
    until FindNext(F) <> 0;
   FindClose(F);
  until dirlist.Count = 0;
  for i:=0 to filelist.Count-1 do SkanFile(filelist[i]);
 finally
  dirlist.Free;
  filelist.Free;
 end;
end;

function TClassesTree.ExcludeStringsAndComments(vs:string; var st:TAnalysisState):string;
var i:integer;
    rl:integer;

// Комментарии:
//  //.....  - type 1  or type Slash              ( SL )
//  {.....}  - type 2  or type Figure Brackets    ( FB )
//  (*...*)  - type 3  or type Compound Brackets  ( CB )
// sNorm     - обычный код
// sStr      - строка
// sSLfirst  - встретился первый символ slash / , ждём второй /
// sSLcom    - встретили второй символ slash / , идет комментарий типа 1
// sFB       - встретили символ Figure Brackets { , идёт комментарий типа 2
// sCBfirst  - встретился первый символ ( , ждём *
// sCBcom    - встретился символ * , идёт комментарий типа 3
// sCBend    - встретился символ * , ждём )

begin
 SetLength(Result,Length(vs));
 rl := 0;
 for i:=1 to Length(vs) do
  begin
    Case st of
     sNorm    : begin
                 Case vs[i] of
                  '''': st:=sStr;
                  '/': st:=sSLfirst;
                  '{': st:=sFB;
                  '(': st:=sCBfirst;
                  else begin
                        Inc(rl); Result[rl]:=vs[i];
                       end;
                 End;
                end;
     sStr     : begin
                 if vs[i]='''' then st:=sNorm;
                 Continue;
                end;
     sSLfirst : begin
                 if vs[i]='/' then begin st:=sSLcom; Break; end
                 else
                  begin
                   Inc(rl); Result[rl]:='/';
                   Case vs[i] of
                    '''': st:=sStr;
                    '{': st:=sFB;
                    '(': st:=sCBfirst;
                    else begin
                          st:=sNorm;
                          Inc(rl); Result[rl]:=vs[i];
                         end;
                   End;
                  end;
                end;
     //sSLcom   : ;
     sFB      : begin
                 if vs[i]='}' then st:=sNorm;
                 Continue;
                end;
     sCBfirst : begin
                 if vs[i]='*' then begin st:=sCbcom; Continue; end
                 else
                  begin
                   Inc(rl); Result[rl]:='(';
                   Case vs[i] of
                    '''': st:=sStr;
                    '/': st:=sSLfirst;
                    '{': st:=sFB;
                    '(': st:=sCBfirst;
                    else begin
                          st:=sNorm;
                          Inc(rl); Result[rl]:=vs[i];
                         end;
                   End;
                  end;
                end;
     sCBcom   : begin
                 if vs[i]='*' then st:=sCBend;
                 Continue;
                end;
     sCBend   : begin
                 if vs[i]=')' then st:=sNorm
                 else if vs[i]<>'*' then st:=sCBcom;
                 Continue;
                end;
    End;
  end;

 Case st of
  sSLfirst: begin Inc(rl); Result[rl]:='/'; st:=sNorm; end;
  sCBfirst: begin Inc(rl); Result[rl]:='('; st:=sNorm; end;
  sCBend: begin st:=sCBCom; end;
  sSLcom: begin st:=sNorm; end;
 End;

 SetLength(Result,rl);
end;

procedure TClassesTree.SkanFile(FileName:string);
const _sf01 = '= class of';
      _sf02 = '=class of';
      _sf1 = '= class';
      _sf2 = '=class';
var s:string;
    ln,p:integer;
    state:TAnalysisState;

 function GetCname:string;
 var p1,p2:integer;
 begin
  p2 := p-1;
  while (s[p2]=' ') do Dec(p2);
  p1 := p2;
  if p1 <> 1 then
   begin
    while (s[p1]<>' ') and (p1>1) do Dec(p1);
    Result := Copy(s,p1+1,p2-p1);
   end
  else Result := s[p1];
 end;

 function GetCparent:string;
 var p1,p2,p3:integer;
 begin
  p1 := PosEx('(',s,p);
  if p1 > 0 then
   begin
    p2 := PosEx(')',s,p1);
    p3 := PosEx(',',s,p1);
    // note: may be construction: TInterfacedPersistent = class(TPersistent, IInterface)
    // and if pos(',') < pos(')')
    // we take only name of class ( in this case: TPersistent )
    if (p3 > 0) and (p3 < p2) then
     Result := StringReplace(Copy(s,p1+1,p3-p1-1),#32,'',[rfReplaceAll])
    else Result := StringReplace(Copy(s,p1+1,p2-p1-1),#32,'',[rfReplaceAll]);
   end
  else Result := '';
 end;

 function GetCLparent(sflen:integer):string;
 var p1,p2:integer;
 begin
  p1 := p + sflen + 1;
  if p1 > Length(s) then
   begin
    Result := '';
    Exit;
   end;
  p2 := PosEx(';',s,p1);
  if p2 > 0 then
   begin
    Result := StringReplace(Copy(s,p1,p2-p1),#32,'',[rfReplaceAll]);
   end
  else Result := '';
 end;

 function IsCorrect(sflen:integer):integer;
 var p1:integer;
 begin
  if p-1>0 then
   begin
    if s[p-1] = ':' then Result := 0
    else
     begin
      p1 := p + sflen;
      if p1 > Length(s) then Result := p
      else
       begin
        if (s[p1] <> ' ') and (s[p1] <> '(') then Result := 0
        else Result := p;
       end;
     end;
   end
  else Result := 0;
 end;

begin
 Assign(FTF,FileName);
 Reset(FTF);
 ln := 0;
 state := sNorm;
 while not EOF(FTF) do
  begin
   Readln(FTF,s);
   Inc(ln);
   s := StringReplace(s,#9,#32,[rfReplaceAll]);
   s := StringReplace(s,#32#32,#32,[rfReplaceAll]);
   s := ExcludeStringsAndComments(s,state);
   if s = '' then Continue;
   // find
   p := Pos(_sf01,LowerCase(s));
   if p = 0 then
    begin
     p := Pos(_sf02,LowerCase(s));
     if p > 0 then
      begin
       if FIncludeClassLinks then Self.AddClass(GetCname,GetCLparent(Length(_sf02)),FileName,ln);
       Continue;
      end;
    end
   else
    begin
     if FIncludeClassLinks then Self.AddClass(GetCname,GetCLparent(Length(_sf01)),FileName,ln);
     Continue;
    end;
   //
   p := Pos(_sf1,LowerCase(s));
   if p = 0 then
    begin
     p := Pos(_sf2,LowerCase(s));
     if p > 0 then p := IsCorrect(Length(_sf2));
    end
   else p := IsCorrect(Length(_sf1));
   // add
   if p > 0 then Self.AddClass(GetCname,GetCparent,FileName,ln)
  end;
 Close(FTF);
end;

procedure TClassesTree.GetClassesFromDir(Dir:string; IncludeSubFolders:boolean=false);
begin
 if DirectoryExists(Dir) then
  begin
   if IncludeSubFolders then SkanDirExt(Dir)
   else SkanDir(Dir);
   MakeLinks;
  end;
end;

end.

[DungeonLords]

Rokuell,
великолепно! Всё работает! Спасибо вам миллион раз.