Как подавить создание компонента

← →
Другой Дмитрий (2005-05-13 09:18) [0]

Мой компонент должен быть в приложении один.
При его создании в конструкторе проверяю глобальную переменную.
Если она nil, то присваиваю ей self. А вот если она не nil? А вот если она не nil, то компонент не должен создаваться вообще.
Как это можно реализовать?

← →
Style © (2005-05-13 10:43) [1]

поищи информацию о синглетонах..
нада копать в сторону классового метода
class function NewInstance: TObject; override;

TdmSingleton = class(TdmRoot) private { Private declarations } public class function NewInstance: TObject; override; procedure FreeInstance; override; constructor Create(AOwner: TComponent); override; { Public declarations } end; implementation uses CommonConst; {$R *.dfm} { TdmSingleton } constructor TdmSingleton.Create(AOwner: TComponent); begin inherited; RegisterClass( TPersistentClass(ClassType) ); end; procedure TdmSingleton.FreeInstance; begin if(GetClass(ClassName) = nil) then begin Inherited FreeInstance; end; end; class function TdmSingleton.NewInstance: TObject; begin if(GetClass(ClassName) = nil) then begin Result := Inherited NewInstance; end else raise Exception.Create(Format(ESingletonClass, [ClassName])); end;

← →
Priest (2005-05-13 11:19) [2]

А кусок кода
procedure TdmSingleton.FreeInstance;
begin
if(GetClass(ClassName) = nil) then
begin
Inherited FreeInstance;
end;
end;

Нужен чтобы нельзя его выло удалить?

← →
Style © (2005-05-13 11:24) [3]

>>Нужен чтобы нельзя его выло удалить?

Полагается что он не создан и удалять нечего..

← →
Igorek © (2005-05-13 11:38) [4]

Другой Дмитрий (13.05.05 9:18)
Создаешь/удаляешь в секциях инициализации/финализации. В палитру не публикуешь. Будет твой модуль где-то в uses - создастся, иначе нет.

← →
Priest (2005-05-13 11:48) [5]

Что-то у меня в момент запуска выдаёт исключение в строке
RegisterClass( TPersistentClass(ClassType) );

Вот я сделал пример, правда не смог запустить
var
S1,S2:TdmSingleton;
begin
S1:=TdmSingleton.Create;
S2:=TdmSingleton.Create;
S1.Free;
end.

Когда вызывается S1:=TdmSingleton.Create; то всё успешно срабатывает. Когда вызываю S2:=TdmSingleton.Create; то в методе
TdmSingleton.NewInstance создаётся исключение и вызывается деструктор с последующим FreeInstance. Так как экземпляра нет, то и удалять не чего :)). А вот когда сработает строка S1.Free; Вызовится FreeInstance и экземпляр не удалится???

← →
Другой Дмитрий (2005-05-13 11:55) [6]

Создаешь/удаляешь в секциях инициализации/финализации. В палитру не публикуешь. Будет твой модуль где-то в uses - создастся, иначе нет.

Должен быть в палитре. У него куча свойств с редакторами для настройки приложения.

← →
Igorek © (2005-05-13 12:15) [7]

Другой Дмитрий (13.05.05 11:55) [6]
См. "Прерывание создания компонента" на http://delphiworld.narod.ru/

← →
Юрий Зотов © (2005-05-13 12:29) [8]

Вообще говоря, если NewInstance при попытке повторного создания все равно возбуждает Exception, то все эти навороты ни к чему. Достаточно сделать так, как изначально и делал автор (через глобальную переменную), а при при попытке повторного создания просто возбудить Exception в конструкторе. При этом только что созданный второй экземпляр будет удален автоматически.

Другое дело, когда надо обойтись без Exception - тогда да, тогда нужна связка NewInstance/FreeInstance. Но и здесь вместо регистрации класа можно просто использовать глобальную переменную.
implementation var Singleton: TSingleton; procedure TSingleton.FreeInstance; begin Singleton := nil; Inherited end; class function TSingleton.NewInstance: TObject; begin if Singleton = nil then begin Result := Inherited NewInstance; Singleton := TSingleton(Result) end else Result := Singleton end;

← →
Igorek © (2005-05-13 12:56) [9]

Юрий Зотов © (13.05.05 12:29) [8]
Другое дело, когда надо обойтись без Exception
Трудно представить, когда такое надо - слишком неочевидное поведение IDE (без сообщения в данном случае).
Кроме того при Вашем варианте возникнут проблемы с дублированием имени компонента.

← →
Style © (2005-05-13 14:03) [10]

Сорри, немного поторопился не все проверил...
А с помощью RegisterClass хотел наоборот обойти ииспользование глобальной переменной, ну ни люблю я их 8).. а не получилось...

← →
Другой Дмитрий (2005-05-13 14:07) [11]

Пока остановился на коде конструктора
if MyGlobalComp<>nil then raise Exception.Create("Уже есть"); inherited Create(Aowner);

Только не пойму, почему вылетает вместо "Уже есть" - "AV in rtl60.bpl"?

← →
Style © (2005-05-13 14:14) [12]

У меня без AV работает

interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, DataRoot; type TdmSingleton = class(TdmRoot) private { Private declarations } public class function NewInstance: TObject; override; constructor Create(AOwner: TComponent); override; { Public declarations } end; var P: pointer; implementation uses CommonConst; {$R *.dfm} { TdmSingleton } constructor TdmSingleton.Create(AOwner: TComponent); begin if p = nil then begin inherited; p := self; end else raise Exception.Create("Уже есть"); end; class function TdmSingleton.NewInstance: TObject; begin if(not Assigned(p)) then begin Result := Inherited NewInstance; end else result := p; end; initialization p := nil;

← →
Юрий Зотов © (2005-05-13 14:25) [13]

> Igorek © (13.05.05 12:56) [9]

> Трудно представить, когда такое надо - слишком неочевидное
> поведение IDE (без сообщения в данном случае).

Мне тоже. Но всяко бывает, может, когда-то это и надо.

> возникнут проблемы с дублированием имени компонента.

Действительно, возникают. Я использовал этот механизм для некомпонентских классов - там, сами понимате, никаких проблем нет. С компонентом они возникают - но элементарно устраняются перекрытием SetName.

Интересно, однако, и то, что вариант [1] для компонента из палитры не работает совсем. Вероятно, дело в том, что RegisterComponents сама вызывает RegisterClass(es) - после чего, конечно, все проверки GetClass на nil, конечно, становятся в design-time бессмысленными. Проверьте сами [1] и вот это:
type TMyComp = class(TComponent) public constructor Create(AOwner: TComponent); override; end; constructor TMyComp.Create(AOwner: TComponent); begin inherited; if GetClass(ClassName) <> nil then ShowMessage("Registered") end;

> Другой Дмитрий (13.05.05 09:18)

Вывод из всей этой дискусии - делайте так, как и делали, без лишних заморочек - а чтобы подавить создание второго экземпляра просто возбуждайте Exception в конструкторе, вот и все.

← →
Юрий Зотов © (2005-05-13 14:33) [14]

> Style © (13.05.05 14:03) [10]

> с помощью RegisterClass хотел наоборот обойти ииспользование
> глобальной переменной, ну ни люблю я их

1. Если унести глобальную переменную в секцию implementation, то она становится безопасной. Это вполне нормальное решение.

2. В данном случае глобальная переменная занимает 4 байта. Код вызова RegisterClass, нескольких вызовов GetClass и проверок на nil наверняка займет гораздо больше, да и работать будет медленнее - поэтому никаких преимуществ это решение не дает. А раз так, то и нет смысла усложнять код.

← →
Другой Дмитрий (2005-05-13 14:42) [15]

Style © (13.05.05 14:14) [12]

У меня без AV работает

Создал новые run-time и design-time пакеты.
Внес туда предложенный код, исправил только TdmRoot на TComponent. Зарегистрировал.
Помещаю компонент на форму, запускаю. Все о"к.
Помещаю второй компонент - вылетает "Уже есть". После нажатия на ОК - первый компонент исчезает. При попытке добавить новый - Ошибка "Privileged instruction" а иногда AV.
Мож у меня чего с самой Delphi не так?

← →
Style © (2005-05-13 14:46) [16]

>>2. В данном случае глобальная переменная занимает 4 байта. >>Код вызова RegisterClass, нескольких вызовов GetClass и >>проверок на nil наверняка займет гораздо больше, да и >>работать будет медленнее - поэтому никаких преимуществ это >>решение не дает. А раз так, то и нет смысла усложнять код.

Вспомнил, вообще я пытался сделать следующее. Хотелось бы что бы наследники TdmSingleton не падали в Exception. т.е. класс - является синглетоном по своему имени... А наследник TdmApplication = class(TdmSingleton) - имеет другое имя. Поэтому один экземпляр создать можно.
Наверное надо будет лучше создать Глобальный TStringList. И написать свои методы AddClassObject, GetClassObject...

← →
Style © (2005-05-13 14:51) [17]

Я так понимаю в DesignTime не желательно делать raise...
попробуй следующее...

constructor TdmSingleton.Create(AOwner: TComponent);
begin
if p = nil then
begin
inherited;
p := self;
end
else
if not (csDesigning in ComponentState) then
raise Exception.Create("Уже есть")
else
MessageBox(0, pchar("Уже есть"), "Ошибка", 0);
end;

← →
Юрий Зотов © (2005-05-13 15:00) [18]

Вот нормалньно работающее решение:
type TMyComp = class(TComponent) public constructor Create(AOwner: TComponent); override; destructor Destroy; override; end; implementation var Comp: TMyComp; { TMyComp } constructor TMyComp.Create(AOwner: TComponent); begin inherited; if Comp = nil then Comp := Self else raise Exception.Create("Already exists") end; destructor TMyComp.Destroy; begin if Comp = Self then Comp := nil; inherited end;

← →
Юрий Зотов © (2005-05-13 15:02) [19]

> Style © (13.05.05 14:51) [17]

> Я так понимаю в DesignTime не желательно делать raise...

Без проблем. В VCL такого полно.

← →
Другой Дмитрий (2005-05-13 15:07) [20]

Style © (13.05.05 14:51) [17]

Я так понимаю в DesignTime не желательно делать raise...
попробуй следующее...

Так лучше. Теперь осталась одна проблема:
при повторном помещении компонента на форму dmSingleton1 переименовывается в dmSingleton2, если еще раз положить то dmSingleton2 переименовывается в dmSingleton1 и т.д.

Юрий Зотов © (13.05.05 15:00) [18]

Вот нормалньно работающее решение:

Так попробовал работает без замечаний!

← →
Другой Дмитрий (2005-05-13 15:15) [21]

Кстати у меня AV было потому что в деструкторе не присваивал MyGlobalComp:=nil. Всем спасибо. Завожу новую тему.

2 Другой Дмитрий [21]
О, точно молодец...

2 ЮЗ

>>В VCL такого полно
Я просто предположил... Действительно перед каждым raise ComponentState не проверят.

>> constructor TMyComp.Create(AOwner: TComponent); >> begin >> inherited; >> if Comp = nil then >> Comp := Self >> else >> raise Exception.Create("Already exists") >> end; >>

Юрий, а так NewInstance будет все равно выполнен, и затем выполнится FreeInstance потому что был вызван Exception в конструкторе...

> Style © (13.05.05 15:47) [22]

> NewInstance будет все равно выполнен, и затем выполнится
> FreeInstance потому что был вызван Exception в конструкторе.

Именно так. Что и требовалось.

>>Именно так. Что и требовалось.

class function TdmSingleton.NewInstance: TObject;
begin
if(not Assigned(p)) then
begin
Result := Inherited NewInstance;
end
else
result := p;
end;

Просто мне кажеться что лучше проверить на nil чем
выделять и освобождать память.

>>Уже обсуждалось (см. [8], [9] и [13]). Придется перекрывать еще и SetName.

А, ну понял, Извеняюсь... Я просто в RunTime пытаюсь этот класс использовать и особой разницы не вижу...

> Style © (13.05.05 16:13) [26]

> и особой разницы не вижу...

В run-time нет автоматической регистрации класса и назначения Name.

> В run-time нет автоматической регистрации класса и назначения
> Name.

Вот потому и про Name не я задумывался...

Юрий Зотов © (13.05.05 14:25) [13]
С компонентом они возникают - но элементарно устраняются перекрытием SetName.
Мне не удалось решить это перекрытием SetName.

Style © (13.05.05 14:03) [10]
А с помощью RegisterClass хотел наоборот обойти ииспользование глобальной переменной, ну ни люблю я их 8).. а не получилось...
type TMyComp = class(TComponent) class function NewInstance: TObject; override; procedure FreeInstance; override; end; implementation type // ["{70904F4E-3682-460B-9C1B-C02DC85620E9}"] - генерим гуид (Ctrl+Shift+G) :))) T70904F4E3682460B9C1BC02DC85620E9 //убираем минусы и добавляем T = class(TPersistent)end; TDummy = T70904F4E3682460B9C1BC02DC85620E9; class function TMyComp.NewInstance: TObject; begin if (GetClass(TDummy.ClassName) = nil) then begin RegisterClass(TPersistentClass(TDummy)); Result := inherited NewInstance; end else raise Exception.Create(Format("Уже есть %s", [ClassName])); end; procedure TMyComp.FreeInstance; begin UnRegisterClass(TPersistentClass(TDummy)); inherited; end; procedure Register; begin RegisterComponents("!test", [TMyComp]); end;

Как подавить создание компонента Найти похожие ветки