Хранение информации о проектах имеет далеко идущие цели: анализ исходного кода и архитектуры с выдачей рекомендаций по их оптимизации.
А начнем с простой задачи: извлечение информации о содержимом модуля, в частности – поиск и отображение процедур и функций.
Скрипты
За основу анализатора я взял алгоритм, используемый в модуле подсветки синтаксиса CodeHL.pas, что наводит на мысль о необходимости создания универсальной процедуры для парсинга. Но пока, к моему огорчению, я прибегнул к копипасту, чтобы получить рабочий код процедуры UpdateProjectList_UpdateUnitProcList().
procedure UpdateProjectList_UpdateUnitProcList(AIDUnit: integer; AShowProgress: boolean);
// обновление информации по процедурам модулям
// AIDUnit - ID модуля
// AShowProgress - флаг отображения прогресса
// в работе используются настройки модуля CodeHL
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)) );
// файла может не быть, это не совсем нормально, но обрабатывается не здесь
if not FileExists(tmpFileName) then
exit;
tmpStrings := TStringList.Create;
// фишка MVDB - главный файл должен быть в кодировке UTF-8, а все остальные - ANSI
if UpperCase( ExtractFileName(tmpFileName) ) = 'SCRIPT.PAS' then
tmpStrings.LoadFromFile(tmpFileName)
else
tmpStrings.LoadFromFileANSI(tmpFileName);
//
tmpText := tmpStrings.Text;
tmpStrings.Clear;
// создаём список процедур и функций
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 // в конце строки может оказаться символ завершения строки.
break;
// линейный режим - это отключение посимвольного анализа до обнаружения триггерной последовательности
if tmpIndex <> -1 then
begin
s1 := CHL_LM_End[tmpIndex];
// обнаружена завершающая последовательность?
if copy(tmpText, i, Length(s1)) = s1 then
begin
// если завершающая последовательность больше одного символа, то делаем корректировку
if Length(s1) > 1 then
delete(tmpText, i + 1, Length(s1) - 1);
//
tmpIndex := -1;
tmpWord := '';
end
else
tmpWord := tmpWord + tmpChar;
continue;
end;
// конец слова
if tmpText[i] in [' ', '{', '}', '/', '\', ')', '(', ';', ':', '"', '''', '.', ',', chr(13)] then
begin
// проверка начала линейного режима
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;
// проверка слов
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;
// смотрим, не удалили ли чего...
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 = "Не найдена" WHERE id = '+tmpDataSet.FieldByName('id').asString );
Application.ProcessMessages;
end;
tmpDataSet.Next;
end;
// смотрим, не надо ли добавить...
for i:=0 to tmpStrings.Count - 1 do
begin
if AShowProgress then
Progress(i, tmpStrings.Count - 1, 'Добавление процедур' )
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 // добавляем...
SQLExecute('INSERT INTO unitProc (id_unit,name,status) VALUES ('+IntToStr(AIDUnit)+','+StrToSQL( tmpStrings.strings(i) )+','+StrToSQL('Новая ')+')');
Application.ProcessMessages;
end;
end;
tmpDataSet.Free;
tmpStrings.Free;
finally
if AShowProgress then
Progress();
end;
end;
Code language: Delphi (delphi)
В отличии от других процедур заполнения и проверок, для извлечения данных используется только один запрос к базе, а проверки осуществляются с использованием компонентов TDataSet и TStringList, в которых загружаются сведения об имеющихся записях и информация о процедурах и функциях модуля.
Ещё одна особенность My Visual Database состоит в том, что кодировка главного модуля script.pas должна быть UTF-8, а кодировки остальных модулей – ANSY, и это необходимо учитывать при парсинге файлов модулей.
Для получения текста процедуры по имени используется функция UserApp_GetProcBody(), в основе которой лежит тот же парсер, что и в процедурах UpdateProjectList_UpdateUnitProcList() и CodeHL_TextToHTML(). (Обязуюсь к следующей версии придумать, как избавиться от копипаста в этих трёх процедурах).
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 // в конце строки может оказаться символ завершения строки.
break;
if tmpBody then
Result := Result + tmpChar;
// линейный режим - это отключение посимвольного анализа до обнаружения триггерной последовательности
if tmpIndex <> -1 then
begin
s1 := CHL_LM_End[tmpIndex];
// обнаружена завершающая последовательность?
if copy(tmpText, i, Length(s1)) = s1 then
begin
// если завершающая последовательность больше одного символа, то делаем коректировку
if Length(s1) > 1 then
delete(tmpText, i + 1, Length(s1) - 1);
//
tmpIndex := -1;
tmpWord := '';
end
else
tmpWord := tmpWord + tmpChar;
continue;
end;
// конец слова
if tmpText[i] in [' ', '{', '}', '/', '\', ')', '(', ';', ':', '"', '''', '.', ',', chr(13)] then
begin
// проверка начала линейного режима
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;
// проверка слов
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)
Другие доработки
- UserApp_LoadExample() – добавлена обработка случая, когда источником примера является таблица отображения процедур модуля: для извлечения текста вызывается UserApp_GetProcBody().
- Splash_Create() – добавлена строка для отображения статуса инициализации приложения.
- Splash_ShowProgress() – добавлена процедура отображения статуса инициализации приложения. Актуально для приложений с большим временем запуска.
- UserApp_InitForm() – добавлены вызовы Splash_ShowProgress() для пояснения этапов инициализации
- UserApp_UpdateDD() – добавлена обработка для формы dtfUnit_Tree, у которой теперь есть дочерняя форма dtfUnitProc
- frmMain_btnProc_Update_OnClick() – добавлена процедура обработки нажатия кнопки, по которой производится анализ выбранного модуля.
- english.txt, русский.txt – в файлы локализации ресурсов добавлены новые данные
Результат
Заменил картинку на заставке, чтобы надписи были более читабельными.

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

При выборе процедуры можно просмотреть её код.

В базу данных добавлены описания для встроенных в My Visual Database процедур.

Планы
- Отображать информацию о статических формах приложения (формах, созданных в редакторе форм My Visual Database).
- Отображать информацию о структуре базы данных
- Отображать зависимости между модулями и формами
- Извлекать описательные данные из исходников для создания автоматической документации проекта.
- Добавить в поисковую систему поиск по проектам, модулям и процедурам модулей
- Синхронизация версий модулей.
- Создание эталонных модулей (репозиторий модулей).