|
|
Регистрация | << Правила форума >> | FAQ | Пользователи | Календарь | Поиск | Сообщения за сегодня | Все разделы прочитаны |
|
Опции темы | Поиск в этой теме | Опции просмотра |
#16
|
|||
|
|||
Цитата:
Кстати, как проверить, существует ли папка по пути C:\Papka? Делаем'c разные игры. Искать на glscene.ru |
#17
|
||||
|
||||
А разве Delphi поддерживает звёздочки в сравнениях??? О_о
Никогда о таком не слышал. Проверь, у тебя хоть 1 файл не отсекается? Оставайтесь хорошими людьми... VK id2634397, ds [at] phoenix [dot] dj |
#18
|
||||
|
||||
Цитата:
Не впутывай свои представления в программирование. Лучше будет, если напишешь Код:
if not LowerCase(ExtractFileExt(FileName))='.pas' then exit; Цитата:
Велик и могуч наш Object Pascal ! ICQ: 357-591-887 |
#19
|
|||
|
|||
Спасибо всем огромное за помощь. Но вот ерунда, програма почему-то вместе с настоящими классами прожёвывает и строки такого вида "//THeightData". Как с этим бороться?
Делаем'c разные игры. Искать на glscene.ru |
#20
|
|||
|
|||
Цитата:
Делаем'c разные игры. Искать на glscene.ru |
#21
|
||||
|
||||
Цитата:
Велик и могуч наш Object Pascal ! ICQ: 357-591-887 |
#22
|
|||
|
|||
Цитата:
Ну и вообще, ИМХО, в начале никак не предполагал, что будет столько классов. Из-за этих причин мне не удалось вставить код, отслеживающий в каком файле сейчас происходит чтение и на какой строке. Скриншот: http://s48.radikal.ru/i122/0909/2f/343061ef3cae.jpg Делаем'c разные игры. Искать на glscene.ru |
#23
|
||||
|
||||
Дело в том, что окончательная отладка производилась на стандартных классах Delphi ( я сканировал C:\Program Files\Borland\Delphi7\Source\ включая подпапки ) и при этом глюков или постороннего хлама не было.
Поэтому дальнейшая отладка возможна только на конкретном примере. Цитата:
У меня предусмотрен режим отладки: Для примера кода: http://www.delphisources.ru/forum/sh...2&postcount=11 достаточно поставить Код:
CT.IncludeDebugInfo := true; Велик и могуч наш Object Pascal ! ICQ: 357-591-887 Последний раз редактировалось Rokuell, 26.09.2009 в 19:54. |
#24
|
||||
|
||||
Цитата:
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. в самой же функции происходит добавление в дерево всех потомков к.л. узла. Может не слишком ясно объясняю, но рекурсию вообще-то лучше рассматривать на примере. Велик и могуч наш Object Pascal ! ICQ: 357-591-887 |
#25
|
|||
|
|||
Теперь яснее.
Я восхищён вашей продуманностью! Надо же, режим отладки . Ну благодаря ему выискалось что происходит. Значит есть некий .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 Делаем'c разные игры. Искать на glscene.ru Последний раз редактировалось DungeonLords, 23.09.2009 в 10:50. |
#26
|
||||
|
||||
Исправил. Теперь модуль также корректно обрабатывает строки и комментарии.
т.е. ситуации вида: Код:
// type TNewClass = class { type TNewClass = class } (* type TNewClass = class *) var s:string = 'type TNewClass = class'; Код:
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; Велик и могуч наш Object Pascal ! ICQ: 357-591-887 |
#27
|
||||
|
||||
Модуль 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. Велик и могуч наш Object Pascal ! ICQ: 357-591-887 |
#28
|
|||
|
|||
Rokuell,
великолепно! Всё работает! Спасибо вам миллион раз. Делаем'c разные игры. Искать на glscene.ru |