Ваши проекты

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

Ссылки

Проект с исходными кодами

Ваши проекты

Обновление списка проектов

Запуск приложения

Открытие проекта

Открытие папки

Удаление папки проекта

Эпилог

Ссылки

➥

LAST BETA

Светлое фильтрованное

Имиджевая революция

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

Подпишитесь, чтобы получать уведомления о новых публикациях.

Архивы

➥

LAST BETA

Про странство

Светлое фильтрованное

Имиджевая революция