За 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)

Ссылки

Добавить комментарий

Ваш адрес email не будет опубликован. Обязательные поля помечены *