Storing information about projects has far-reaching goals: analysis of source code and architecture with recommendations for their optimization.
And let’s start with a simple task: extracting information about the contents of the module, in particular – finding and displaying procedures and functions.
Scripts
I took the algorithm used in the CodeHL.pas syntax highlighting module as the basis of the analyzer, which suggests the need to create a universal procedure for parsing. But for now, to my chagrin, I resorted to copy-paste to get the working code for the UpdateProjectList_UpdateUnitProcList () procedure.
procedure UpdateProjectList_UpdateUnitProcList(AIDUnit: integer; AShowProgress: boolean);
// updating information on procedures modules
// AIDUnit - module ID
// AShowProgress - progress display flag
// the settings of the CodeHL module are used in the work
var
tmpFileName:string;
tmpStrings: TStringList;
i: integer;
j: integer
tmpWord:string;
tmpchar:string;
s1, s2: string;
tmpIndex: integer;
tmpText:string;
tmpBeginCount: integer;
tmpProcDetected: boolean;
tmpProcCount: integer;
tmpDataSet: TDataSet;
begin
if AShowProgress then
Progress(0, 0, R('UAPP_MODULE_DATA_UPDATE',UAPP_MODULE_DATA_UPDATE) );
try
tmpFileName := Trim( SQLExecute('SELECT project.path || "\script\" || unit.path FROM unit LEFT JOIN project ON project.id = unit.id_project WHERE unit.id=' + IntToStr(AIDUnit)) ) ;
// the file may not exist, this is not quite normal, but it is not processed here
if not FileExists(tmpFileName) then
exit;
tmpStrings := TStringList.Create;
// feature of MVDB - the main file must be encoded in UTF-8, and all others must be in ANSI
if UpperCase( ExtractFileName(tmpFileName) ) = 'SCRIPT.PAS' then
tmpStrings.LoadFromFile(tmpFileName)
else
tmpStrings.LoadFromFileANSI(tmpFileName);
//
tmpText := tmpStrings.Text;
tmpStrings.Clear;
// create a list of procedures and functions
tmpBeginCount := 0;
tmpProcCount := 0;
tmpProcDetected := False;
tmpIndex := -1;
tmpWord := '';
for i := 1 to Length(tmpText) do
begin
tmpChar := tmpText[i];
if Ord(tmpChar) = 0 then // line terminator may appear at the end of the line.
break;
// linear mode - this disables character-by-character analysis until a trigger sequence is detected
if tmpIndex <> -1 then
begin
s1 := CHL_LM_End[tmpIndex];
// terminating sequence found?
if copy(tmpText, i, Length(s1)) = s1 then
begin
// if the terminating sequence is more than one character, then we make an adjustment
if Length(s1) > 1 then
delete(tmpText, i + 1, Length(s1) - 1);
//
tmpIndex := -1;
tmpWord := '';
end
else
tmpWord := tmpWord + tmpChar;
continue;
end;
// end of word
if tmpText[i] in [' ', '{', '}', '/', '\', ')', '(', ';', ':', '"', '''' , '.', ',', chr(13)] then
begin
// check for start of linear mode
for j := 0 to Length(CHL_LM_Begin) - 1 do
begin
if copy(tmpText, i, Length(CHL_LM_Begin[j])) = CHL_LM_Begin[j] then
begin
tmpIndex := j;
continue;
end;
end;
// check for words
tmpWord := Trim(tmpWord);
if tmpWord <> '' then
begin
if tmpProcDetected then
begin
tmpStrings.Add(tmpWord);
tmpProcDetected := False;
end
else
if (UpperCase(tmpWord) = 'BEGIN') or (UpperCase(tmpWord) = 'CASE') or (UpperCase(tmpWord) = 'TRY') then
inc(tmpBeginCount)
else
if UpperCase(tmpWord) = 'END' then
begin
dec(tmpBeginCount);
if tmpBeginCount = 0 then
dec(tmpProcCount);
end
else
if ( UpperCase(tmpWord) = 'PROCEDURE' ) or ( UpperCase(tmpWord) = 'FUNCTION' ) then
begin
if tmpProcCount = 0 then
tmpProcDetected := True;
inc(tmpProcCount);
end;
//
tmpWord := '';
end;
end
else
tmpWord := tmpWord + tmpChar;
end;
// see if anything has been deleted...
Application.ProcessMessages;
SQLQuery('SELECT id, name FROM unitProc WHERE id_unit = '+IntToStr(AIDUnit),tmpDataSet);
while not tmpDataSet.EOF do
begin
if tmpStrings.IndexOf( tmpDataSet.FieldByName('name').asString ) < 0 then
begin
SQLExecute('UPDATE unitProc SET status = "Not found" WHERE id = '+tmpDataSet.FieldByName('id').asString );
Application.ProcessMessages;
end;
tmpDataSet.Next;
end;
// see if we need to add...
for i:=0 to tmpStrings.Count - 1 do
begin
if AShowProgress then
Progress(i, tmpStrings.Count - 1, 'Adding procedures' )
else
Application.ProcessMessages;
tmpDataSet.First;
tmpProcDetected := False;
while not tmpDataSet.EOF do
begin
if tmpStrings.strings(i) = tmpDataSet.FieldByName('name').asString then
begin
tmpProcDetected := True;
break;
end;
tmpDataSet.Next;
end;
if not tmpProcDetected then
begin // add...
SQLExecute('INSERT INTO unitProc (id_unit,name,status) VALUES ('+IntToStr(AIDUnit)+','+StrToSQL( tmpStrings.strings(i) )+','+StrToSQL('New ')+')' );
Application.ProcessMessages;
end;
end;
tmpDataSet.Free;
tmpStrings.Free;
finally
if AShowProgress then
progress();
end;
end;Code language: Delphi (delphi)Unlike other filling and checking procedures, only one query to the database is used to retrieve data, and checks are carried out using the TDataSet and TStringList components, in which information about existing records and information about the procedures and functions of the module are loaded.
Another feature of My Visual Database is that the encoding of the main script.pas module must be UTF-8, and the encodings of other modules must be ANSY, and this must be taken into account when parsing module files.
To get the procedure text by name, the UserApp_GetProcBody() function is used, which is based on the same parser as in the UpdateProjectList_UpdateUnitProcList() and CodeHL_TextToHTML() procedures. (I undertake to figure out how to get rid of copy-paste in these three procedures for the next version).
function UserApp_GetProcBody( AText:string; AProcName:string ):string;
var
i: integer;
j: integer;
tmpWord: string;
tmpChar: string;
s1, s2: string;
tmpIndex: integer;
tmpBeginCount: integer;
tmpProcDetected: boolean;
tmpProcCount: integer;
tmpProcStartPos: integer;
tmpProcEndPos: integer;
tmpStartPos: integer;
tmpBody: boolean;
tmpText:string;
s: string;
begin
tmpText := AText;
tmpBeginCount := 0;
tmpProcCount := 0;
tmpProcDetected := False;
tmpIndex := -1;
tmpWord := '';
tmpBody := False;
for i := 1 to Length(tmpText) do
begin
tmpChar := tmpText[i];
if Ord(tmpChar) = 0 then // line terminator may appear at the end of the line.
break;
if tmpBody then
Result := Result + tmpChar;
// linear mode - this disables character-by-character analysis until a trigger sequence is detected
if tmpIndex <> -1 then
begin
s1 := CHL_LM_End[tmpIndex];
// terminating sequence found?
if copy(tmpText, i, Length(s1)) = s1 then
begin
// if the terminating sequence is more than one character, then we make an adjustment
if Length(s1) > 1 then
delete(tmpText, i + 1, Length(s1) - 1);
//
tmpIndex := -1;
tmpWord := '';
end
else
tmpWord := tmpWord + tmpChar;
continue;
end;
// end of word
if tmpText[i] in [' ', '{', '}', '/', '\', ')', '(', ';', ':', '"', '''' , '.', ',', chr(13)] then
begin
// check for start of linear mode
for j := 0 to Length(CHL_LM_Begin) - 1 do
begin
if copy(tmpText, i, Length(CHL_LM_Begin[j])) = CHL_LM_Begin[j] then
begin
tmpIndex := j;
continue;
end;
end;
// check for words
tmpWord := Trim(tmpWord);
if tmpWord <> '' then
begin
if tmpProcDetected then
begin
if UpperCase(tmpWord) = UpperCase(AProcName) then
begin
for j := i-Length(tmpWord)-9 downto 0 do
begin
s := copy(tmpText,j,i-j+1);
if ( UpperCase(copy(s,1,9)) = 'PROCEDURE') or ( UpperCase(copy(s,1,8 )) = 'FUNCTION') then
begin
Result := s;
break;
end;
end;
tmpBody := True;
end;
tmpProcDetected := False;
end
else
if (UpperCase(tmpWord) = 'BEGIN') or (UpperCase(tmpWord) = 'CASE') or (UpperCase(tmpWord) = 'TRY') then
inc(tmpBeginCount)
else
if UpperCase(tmpWord) = 'END' then
begin
dec(tmpBeginCount);
if tmpBeginCount = 0 then
begin
dec(tmpProcCount);
if (tmpProcCount = 0) and tmpBody then
tmpBody := False;
end;
end
else
if ( UpperCase(tmpWord) = 'PROCEDURE' ) or ( UpperCase(tmpWord) = 'FUNCTION' ) then
begin
if tmpProcCount = 0 then
tmpProcDetected := True;
inc( tmpProcCount );
end;
//
tmpWord := '';
end;
end
else
tmpWord := tmpWord + tmpChar;
end;
end;Code language: Delphi (delphi)Other improvements
- UserApp_LoadExample() – добавлена обработка случая, когда источником примера является таблица отображения процедур модуля: для извлечения текста вызывается UserApp_GetProcBody().
- Splash_Create() – добавлена строка для отображения статуса инициализации приложения.
- Splash_ShowProgress() – добавлена процедура отображения статуса инициализации приложения. Актуально для приложений с большим временем запуска.
- UserApp_InitForm() – добавлены вызовы Splash_ShowProgress() для пояснения этапов инициализации
- UserApp_UpdateDD() – добавлена обработка для формы dtfUnit_Tree, у которой теперь есть дочерняя форма dtfUnitProc
- frmMain_btnProc_Update_OnClick() – добавлена процедура обработки нажатия кнопки, по которой производится анализ выбранного модуля.
- english.txt, русский.txt – в файлы локализации ресурсов добавлены новые данные
Result
I changed the picture on the splash screen to make the inscriptions more readable.
Added a PageControl to display procedures and functions (in the future I plan to collect information about constants and global variables).
When you select a procedure, you can view its code.
Descriptions for procedures built into My Visual Database have been added to the database.
Plans
- Display information about application static forms (forms created in the My Visual Database form editor).
- Display information about the structure of the database
- Show dependencies between modules and forms
- Extract descriptive data from sources to create automatic project documentation.
- Add to the search engine search for projects, modules and module procedures
- Synchronization of module versions.
- Creation of reference modules (repository of modules).