За 5 лет использования My Visual Database в качестве инструмента разработки у меня накопилось около 500(!) различных проектов, созданных в этой уникальной среде разработки. Среди них как коммерческие программы, так и примеры решения отдельных технических задач, которые были размещены на форуме разработчиков. Поэтому я решил добавить в “Справочник разработчика” возможность учета и анализа контента проектов.

На главном окне добавлена вкладка “Проекты”, на которой в иерархическом виде отображается список проектов с указанием названия, места расположения файлов, статуса и описания. Так как кроме стандартных операций редактирования для работы с этим списком понадобятся дополнительные функции, то для их вызова я добавил панель с кнопками в нижней части вкладки. Обычно я стараюсь располагать все кнопки на одной панели вверху, но в данном случае такое решение вполне оправдано, так как разделяет общие функции от частных и при переключении основных вкладок не меняет внешний вид основной панели инструментов.
Для хранения новых данных было добавлено четыре таблицы:

- project – проекты
- unit – модули проектов
- unitProc – процедуры в модулях проектов
- unitProcParam – параметры процедур
На данном этапе задействована только таблица project, но в скором будущем я планирую использовать и остальные таблицы для анализа архитектуры проекта и автоматизации учета версий модулей для повторного их использования в различных проектах.
К сожалению, особенность архитектуры самого MVDB не позволяет подключать к проекту модули, находящиеся снаружи папки со скриптами, поэтому у разных проектов могут быть одинаковые копии одних и тех же модулей, что затрудняет их сопровождение (устранение ошибок и развитие).
Также в каждой папке с проектом находится исполняемый файл, размер которого на текущий момент составляет около 19 МБ. Для 500 проектов, большая часть которых служит для иллюстраций приёмов работы, расход дисковой памяти для хранения одинаковых копий составляет более 9 ГБ, поэтому я добавил возможность зачистки проектов от исполняемых файлов, а при необходимости – быстрого создания его в нужной папке.
Обновление списка проектов

Если проектов много, то вносить их вручную долго. Поэтому я добавил специальную процедуру, которая не только добавляет в базу новые проекты, но и следит, не исчезли ли старые, а также при необходимости удаляет исполняемые файлы.
procedure frmUpdateProjectList_btnUpdate_OnClick (Sender: TObject; var Cancel: boolean);
// обновить список проектов
var
tmpFileList: string;
tmpFiles: array of string;
i: integer;
tmpSQL: string;
tmpDataSet:TDataSet;
tmpCount: integer;
tmpMaxCount: integer;
tmpPath: string;
tmpName: string;
tmpIDParent: string;
tmpFileName: string;
function FindParent:string;
// поиск родительской папки по максимальному совпадению путей
begin
tmpSQL := 'SELECT id FROM ( SELECT id, length( path ) FROM project WHERE (isGroup = 1) and (path = substr('+StrToSQL(tmpPath)+',1,length(path) ) ) ORDER BY 2 DESC LIMIT 1 )';
Result := SQLExecute(tmpSQL);
if Result = '' then
Result := 'NULL';
end;
begin
if DirectoryExists(frmUpdateProjectList.edtPath.Text) then
begin
Progress(0,0,'Обновление списка проектов');
tmpSQL := 'SELECT count(*) FROM project';
tmpMaxCount := SQLExecute(tmpSQL);
tmpCount := 0;
try
// проверка имеющихся записей
tmpSQL := 'SELECT * FROM project';
SQLQuery(tmpSQL,tmpDataSet);
try
while not tmpDataSet.EOF do
begin
Progress(tmpCount,tmpMaxCount,'Проверка папок');
if not DirectoryExists( tmpDataSet.FieldByName('path').asString ) then
begin
tmpSQL := 'UPDATE project SET status = "Путь не найден" WHERE id = '+tmpDataSet.FieldByName('id').asString;
SQLExecute(tmpSQL);
end;
tmpDataSet.Next;
inc(tmpCount);
end;
finally
tmpDataSet.Free;
end;
Progress(0,0,'Поиск новых проектов');
ProjectRootDir := frmUpdateProjectList.edtPath.Text;
RemoveExe := frmUpdateProjectList.chbRemoveExe.Checked;
UserApp_WriteParams;
// процесс обработки
tmpFileList := Trim(GetFilesList(ProjectRootDir,'*.vdb'));
tmpFiles := SplitString(tmpFileList,chr(10));
tmpMaxCount := Length(tmpFiles);
for i:=0 to Length(tmpFiles)-1 do
begin
Progress(i,tmpMaxCount,'Поиск новых проектов');
tmpPath := ExtractFileDir( tmpFiles[i] );
tmpSQL := 'SELECT count(*) FROM project WHERE path = '+StrToSQL(tmpPath);
if SQLExecute(tmpSQL) = 0 then // проект не найден
begin
tmpName := Trim( ExtractFileName(tmpFiles[i]) );
delete(tmpName,Length(tmpName)-3,4);
tmpIDParent := FindParent;
tmpSQL := 'INSERT INTO project (name,path,parentID,isGroup,status) VALUES ('+StrToSQL(tmpName)+','+StrToSQL(tmpPath)+','+tmpIDParent+',0,"Новый проект")';
SQLExecute(tmpSQL);
end;
end;
// удаление exe
if RemoveExe then
begin
tmpSQL := 'SELECT count(*) FROM project';
tmpMaxCount := SQLExecute(tmpSQL);
tmpSQL := 'SELECT * FROM project';
SQLQuery(tmpSQL,tmpDataSet);
try
while not tmpDataSet.EOF do
begin
Progress(tmpCount,tmpMaxCount,'Удаление исполняемых файлов');
//
tmpFileName := tmpDataSet.FieldByName('path').asString + '\'+ tmpDataSet.FieldByName('name').asString + '.exe';
if FileExists(tmpFileName) then
DeleteFile(tmpFileName);
//
tmpDataSet.Next;
inc(tmpCount);
end;
finally
tmpDataSet.Free;
end;
end;
finally
Progress();
end;
Form_UpdateData( GetFormByName( 'dtfProject_Tree' ) );
end
else
begin
ShowHint(frmUpdateProjectList.edtPath,'Папка не найдена');
Cancel := True;
end;
end;
Code language: Delphi (delphi)
Из особенностей данной процедуры стоит отметить функцию FindParent, которая анализирует путь размещения проекта и находит подходящего родителя в дереве проектов. При отладке данной функции был обнаружен интересный эффект в поведении дерева, а именно:
Если значение поля ParentID = -1, то скорость загрузки дерева снижается до неприлично низкого уровня.
Запуск приложения
Для запуска проекта нужен исполняемый файл, но хранить его в каждом проекте смысла нет. Поэтому его можно получить копированием файла builder.dll из папки, в которой установлен My Visual Database.
procedure frmMain_btnStart_OnClick (Sender: TObject; var Cancel: boolean);
// запуск на выполнение
var
tmpGrid: TdbStringGridEx;
tmpID: integer;
tmpSQL: string;
tmpFile: string;
tmpDir: string;
begin
tmpGrid := DTF_GetGrid('dtfProject_Tree');
tmpID := tmpGrid.dbItemID;
if tmpID = -1 then
ShowHint(tmpGrid,'Выберите проект')
else
begin
tmpSQL := 'SELECT path || "\" || name || ".exe" FROM project WHERE id = '+IntToStr(tmpID);
tmpFile := SQLExecute(tmpSQL);
if not FileExists(tmpFile) then // если исполняемый файл не найден, попробуем его создать
begin
// проверим, существует ли папка проекта
tmpSQL := 'SELECT path FROM project WHERE id = '+IntToStr(tmpID);
tmpDir := SQLExecute(tmpSQL);
if not DirectoryExists(tmpDir) then
begin
tmpSQL := 'UPDATE project SET status = "Путь не найден" WHERE id = '+IntToStr(tmpID);
SQLExecute(tmpSQL);
ShowMessage('Папка не найдена: '+tmpDir);
end
else
begin
// для этого скопируем файл build.dll и переименуем его!
if not FileExists( BuilderDLL ) then
ShowMessage('Не найден файл '+BuilderDLL) // TODO: добавить форму настройки данного параметра
else
begin
CopyFile(BuilderDLL,tmpFile);
end;
end;
end;
OpenFile(tmpFile);
end;
end;
Code language: Delphi (delphi)
Для хранения пути к файлу builder.dll используется переменная и параметры:
var
BuilderDLL: string; // путь, где располагается плеер проекта
procedure UserApp_ReadParams;
// чтение параметров
begin
ProjectRootDir := IniFile_Read('PARAMS','ProjectRootDir','c:\');
RemoveExe := IniFile_Read_Bool('PARAMS','RemoveExe',False);
BuilderDLL := IniFile_Read('PARAMS','BuilderDLL','c:\Program Files (x86)\My Visual Database\builder.dll');
end;
Code language: Delphi (delphi)
Открытие проекта
Это самое простое действие, которое реализовано следующим образом:
procedure frmMain_btnOpenProject_OnClick (Sender: TObject; var Cancel: boolean);
// открыть проект в редакторе MVDN
var
tmpGrid: TdbStringGridEx;
tmpID: integer;
tmpSQL: string;
tmpFile: string;
begin
tmpGrid := DTF_GetGrid('dtfProject_Tree');
tmpID := tmpGrid.dbItemID;
if tmpID = -1 then
ShowHint(tmpGrid,'Выберите проект')
else
begin
tmpSQL := 'SELECT path || "\" || name || ".vdb" FROM project WHERE id = '+IntToStr(tmpID);
tmpFile := SQLExecute(tmpSQL);
if FileExists(tmpFile) then
OpenFile(tmpFile)
else
begin
tmpSQL := 'UPDATE project SET status = "Проект не найден" WHERE id = '+IntToStr(tmpID);
SQLExecute(tmpSQL);
ShowMessage('Проект не найден: '+tmpFile);
end;
end;
end;
Code language: Delphi (delphi)
Открытие папки
Эта операция сходна с открытием проекта
procedure frmMain_btnFolder_OnClick (Sender: TObject; var Cancel: boolean);
// открыть папку проекта
var
tmpGrid: TdbStringGridEx;
tmpID: integer;
tmpSQL: string;
tmpFile: string;
begin
tmpGrid := DTF_GetGrid('dtfProject_Tree');
tmpID := tmpGrid.dbItemID;
if tmpID = -1 then
ShowHint(tmpGrid,'Выберите проект')
else
begin
tmpSQL := 'SELECT path FROM project WHERE id = '+IntToStr(tmpID);
tmpFile := SQLExecute(tmpSQL);
if DirectoryExists(tmpFile) then
OpenFile(tmpFile)
else
begin
tmpSQL := 'UPDATE project SET status = "Путь не найден" WHERE id = '+IntToStr(tmpID);
SQLExecute(tmpSQL);
ShowMessage('Папка не найдена: '+tmpFile);
end;
end;
end;
Code language: Delphi (delphi)
Удаление папки проекта
А вот для реализации этой функции пришлось создать альтернативную функцию удаления папки, так как стандартная RemoveDir(), которая досталась от Delphi со времен DOS, удаляет только пустые папки. А вот RemoveDirEx() способна удалить папку вместе со всем её содержимым.
function RemoveDirEx(ADir: string):boolean;
// удаление каталога с предварительной очисткой от файлов и вложенных каталогов
var
i: integer;
tmpList: TStringList;
tmpDir: string;
begin
Result := False;
// убрать слеш в конце
if copy(ADir, Length(ADir), 1) = '\' then
delete(ADir, Length(ADir), 1);
if DirectoryExists(ADir) then
begin
tmpList := TStringList.Create;
try
// удаляем файлы
tmpList.Text := GetFilesList(ADir);
for i := 0 to tmpList.Count - 1 do
DeleteFile( tmpList.Strings[i]);
tmpList.Sorted := True;
tmpList.Text := GetDirectories(ADir);
// удаляем папки
for i := tmpList.Count - 1 downto 0 do
RemoveDir( tmpList.strings(i) );
finally
tmpList.Free;
end;
Result := RemoveDir( ADir );
end;
end;
procedure frmMain_btnDelete_Dir_OnClick (Sender: TObject; var Cancel: boolean);
// удаление проекта с диска и из базы
var
tmpGrid: TdbStringGridEx;
tmpID: integer;
tmpSQL: string;
tmpDir: string;
begin
tmpGrid := DTF_GetGrid('dtfProject_Tree');
tmpID := tmpGrid.dbItemID;
if tmpID = -1 then
ShowHint(tmpGrid,'Выберите проект')
else
begin
if MessageBox( 'Удалить проект и все его файлы?', 'Удаление проекта', MB_YESNO + MB_ICONWARNING ) = mrYes then
begin
tmpSQL := 'SELECT path FROM project WHERE id = '+IntToStr(tmpID);
tmpDir := SQLExecute(tmpSQL);
if not RemoveDirEx(tmpDir) then
ShowMessage('Не удалось удалить папку '+tmpDir)
else
begin
tmpSQL := 'DELETE FROM project WHERE id = '+IntToStr(tmpID);
tmpDir := SQLExecute(tmpSQL);
tmpGrid.dbUpdate;
end;
end;
end;
end;
Code language: Delphi (delphi)
Эпилог
В процессе отладки программы выяснилось, что в процедуре удаления записи содержится ошибка: при удалении узла дерева не удаляются дочерние элементы, в следствии чего теряются записи и происходит торможение при отображении дерева.
Признаком того, что таблица имеет древовидные данные, является наличие поля ParentID. Это условность, которая принята в данном приложении (да и во многих примерах среды разработки). Поэтому неплохо бы узнать, есть ли такое поле в таблице. Для этого добавляем функцию DB_FieldExists(). Однако при её реализации выяснилось, что запрос с использованием встроенной функции pragma_table_info() не работает в MVDB, хотя прекрасно выполняется в SQLiteStudio. Поэтому пришлось добавить кода больше, чем я планировал:
function DB_FieldExists( ATableName: string; AFieldName:string ):boolean;
// проверяет существование таблицы
var
tmpDataSet:TDataSet;
begin
case dbType of
DBT_UNKNOW: RaiseException('DB_TableExists - не поддерживается для типа базы DBT_UNKNOW');
DBT_SQLITE: begin
// Result := SQLExecute('SELECT COUNT(*) AS CNTREC FROM ( pragma_table_info('+ATableName+') WHERE name="'+AFieldName+'" )' ) = 1; // SQLite - не работает в MVDB, но работает в SQLiteStudio
Result := False;
SQLQuery('PRAGMA table_info('+ATableName+') ',tmpDataSet);
while not tmpDataSet.EOF do
begin
if UpperCase( tmpDataSet.FieldByName('name').asString ) = UpperCase( AFieldName ) then
begin
Result := True;
break;
end;
tmpDataSet.Next;
end;
tmpDataSet.Free;
end;
DBT_MYSQL: RaiseException('DB_TableExists - не поддерживается для типа базы DBT_MYSQL');
end;
end;
Code language: Delphi (delphi)
Процедуру удаления узла дерева DB_DeleteTree() я создал по принципу стека FIFO, так как рекурсия в MVDB не всегда работает так, как ожидается. При каждом удалении записи в стек записываются ID дочерних записей. Затея удалять записи несколькими запросами без создания транзакции не очень правильная, надо подумать, как обезопасить данные на случай аварийного завершения процесса.
procedure DB_DeleteTree( ATableName: string; AParentID: string );
var
tmpSQL: string;
tmpIDList: TStringList;
tmpID: string;
tmpIDs: array of string;
i: integer;
begin
tmpIDList := TStringList.Create;
try
tmpIDList.Add(AParentID);
repeat
tmpID := tmpIDList.Strings[0];
SQLExecute('DELETE from '+ATableName+' WHERE id = '+tmpID );
tmpIDList.Delete(0);
tmpSQL := 'SELECT GROUP_CONCAT(id) FROM '+ATableName+' WHERE ParentID = '+tmpID;
tmpIDs := SplitString( SQLExecute(tmpSQL),',' );
for i:=0 to length(tmpIDs) - 1 do
begin
if tmpIDs[i] <> '' then
tmpIDList.Add(tmpIDs[i]);
end;
until tmpIDList.Count = 0;
finally
tmpIDList.Free;
end;
end;
Code language: Delphi (delphi)
Теперь процедура удаления выглядит так:
procedure frmMain_btnDelete_OnClick (Sender: TObject; var Cancel: boolean);
// удаление
var
tmpID: string;
tmpTableName: string;
begin
if frmMain.pgcMain.ActivePage = frmMain.tshExample then
begin
if IDExample <> -1 then
if MessageBox( 'Удалить пример?', 'Удаление', MB_YESNO + MB_ICONWARNING ) = mrYes then
begin
SQLExecute('delete from example where id = '+IntToStr(IDExample) );
UpdateDatabase('example');
end;
end
else
if (frmMain.pgcMain.ActivePage = frmMain.tshNavigation) and (ActiveGrid<>nil) then
begin
tmpID := IntToStr(ActiveGrid.dbItemID);
tmpTableName := Grid_GetTableName(ActiveGrid);
if tmpID = '-1' then
ShowHint(ActiveGrid,'Выберите запись')
else
if MessageBox( 'Удалить запись?', 'Удаление', MB_YESNO + MB_ICONWARNING ) = mrYes then
begin
if DB_FieldExists( tmpTableName, 'parentID') then // если таблица с деревом
DB_DeleteTree(tmpTableName,tmpID) // удаляем ветку
else // иначе - удаляем запись
SQLExecute('delete from '+tmpTableName+' where id = '+tmpID );
UpdateDatabase(tmpTableName);
end;
end;
end;
Code language: Delphi (delphi)