Разные вопросы

Вызов процедуры, имя которой содержится в переменной

2013-08-19T19:04:34+07:00

Как я могу вызвать процедуру, чье имя хранится в таблице, списке, и т.п.? Другими словами, я хочу сохранить имя процедуры в переменной и для ее вызова обращаться к значению этой переменной. Какие предложения?

Code:

unit ProcDict;

interface

type MyProc = procedure(s: string);

procedure RegisterProc(procName: string; proc: MyProc);

procedure ExecuteProc(procName: string; arg: string);

implementation

uses Classes;

var ProcDict: TStringList;

procedure RegisterProc(procName: string; proc: MyProc);

begin

ProcDict.AddObject(procName, TObject(@proc));

end;

procedure ExecuteProc(procName: string; arg: string);

var

index: Integer;

begin

index := ProcDict.IndexOf(ProcName);

ifindex >= 0then

MyProc(ProcDict.objects[index])(arg);

// Можно вставить обработку исключительной ситуации - сообщение об ошибке

end;

initialization

ProcDict := TStringList.Create;

ProcDict.Sorted := true;

finalization

ProcDict.Free;

end.

вы могли бы создать StringList как показано ниже:

Code:

StringList.Create; StringList.AddObject('Proc1',@Proc1);

StringList.AddObject('Proc2',@Proc2);

и затем реализовать это в вашей программе:

Code:

var

myFunc: procedure;

begin

if Stringlist.indexof(S) = -1then

MessageDlg('Не понял процедуру ' + S, mtError, [mbOk], 0)

else

begin

@myFunc := Stringlist.Objects[Stringlist.indexof(S)];

myFunc;

end;

RAM

Взято из Советов по Delphi от Валентина Озерова

Сборник Kuliba

Выполнение процедуры по адресу

2013-08-19T19:05:36+07:00

Code:

var F: procedure(x, y: double);

@F := GetProcAddress(hDLL, 'SOMEPROC');

F(3, 4);

Ключом здесь является использование оператора @, располагаемого с левой части процедурной переменной. Он говорит компилятору: "Не волнуйтесь здесь о совместимости типов, просто присвойте полученный в правой части выражения адрес переменной в левой части выражения (и процедурные переменные являются переменными-указателями).

- Peter Below

Взято из Советов по Delphi от Валентина Озерова

Сборник Kuliba

Информация о TClass

2013-08-19T19:06:38+07:00

TObject - "корневой" объект.

TClass определен как Class of TObject. Переменная Class НЕ является указателем на экземпляр объекта. Это указатель на *ТИП* объекта Class.

Code:

var

Obj1: TWinControl;

Class1: classof TWinControl;

Class1 := TWinControl - правильное присваивание. Мы не распределяем память, у нас нет экземпляра TWinControl, мы не можем вызвать Class1.OnClick.

Class1 - это *тип* TWinControl с тем же контекстом использования, что и "TWinControl".

Поскольку мы можем использовать TWinControl.Create, то также мы можем использовать и Class1.Create, при этом создавая новый экземпляр TWinControl.

С тех пор как TEdit - наследник TWinControl, Class1 := TEdit правильное присваивание и Class1.Create создает экземпляр TEdit.

Если у меня имеется переменная Obj2: TWinControl, и даже если я присвоил экземпляр TListbox Obj2, я не могу ссылаться на Obj2.Items, поскольку Obj2 определен как TWinControl, а TWinControl не имеет свойства Items.

Те же характеристики верны и для Class1. Class1 определен как Class of TWinControl, поэтому они имеют общий конструктор, определенный в классе TWinControl.

Это не пугает меня при создании дополнительных типов:

Code:

TMyObj1 = class(TEdit)

constructor CreateMagic; virtual;

end;

TMyObj2 = class(TMyObj1)

constructor CreateMagic; override;

end;

TMyClass = classof TMyObj;

var

MyObj1: TMyObj1;

MyObj2: TMyObj2;

function MakeAnother(AClass: TMyClass): TMyObj1;

begin

Result := AClass.CreateMagic;

end;

begin

MyObj2 := TMyObj2.CreateMagic;

MyObj1 := MakeAnother(MyObj2.ClassType);

end.

Взято из Советов по Delphi от Валентина Озерова

Сборник Kuliba

Как внести изменения в код VCL?

2013-08-19T17:09:01+07:00

Примечание: внесение изменений в VCL не поддерживается Borland или Borland Developer Support.

-Но если Вы решили сделать это...

Изменения в код VCL никогда не должны вносится в секцию "interface" модуля - только в секцию "implimentation". Наиболее безопасный способ внести изменения в VCL - создать новый каталог названный "исправленный VCL". Скопируйте файл VCL который Вы хотите изменить в этот каталог. Внесите изменения (лучше прокомментировать их) в этот файл. Затем добавьте путь к Вашему каталогу "исправленный VCL" в самое начало "library path". Перезапустите Delphi/C++ Builder и перекомпилируйте Ваш проект. "library path" можно изменить в меню:

Delphi 1 : Options | Environment | Library

Delphi 2 : Tools | Options | Library

Delphi 3 : Tools | Environment Options | Library

Delphi 4 : Tools | Environment Options | Library

C++ Builder : Options | Environment | Library

Как забыть о необходимости разрушать объекты?

2013-08-19T19:08:27+07:00

Code:

type

ISelfDestroy = interface;

//forget about GUID, if you are not using COM

TSelfDestroy = class(TInterfacedObject, ISelfDestroy)

private

FObject: TObject;

public

constructor Create(AObject: TObject);

destructor Destroy; override;

end;

implementation

constructor TSelfDestroy.Create(AObject: TObject);

begin

FObject := AObject;

end;

destructor TSelfDestroy.Destroy;

begin

FreeAndNil(FObject);

inherited;

end;

// So when you use, just do like this...

procedure TForm1.Button1Click(Sender: TObject);

var

MyObject: TMyObject;

SelfDestroy: TSelfDestroy;

begin

MyObject := TMyObject.Create;

SelfDestroy := TSelfDestroy.Create(MyObject);

// The MyObject will free automatically as soon as TSelfDestroy

// goes out of scope.

// Carry on your code here...

end;

Взято с сайтаhttps://www.swissdelphicenter.ch/en/tipsindex

Как можно работать с объектами не заботясь об их разрушении?

2013-08-19T17:01:39+07:00

Вначале сделаем интерфейс для нашего объекта:

Code:

type

IAutoClean = interface

['{61D9CBA6-B1CE-4297-9319-66CC86CE6922}']

end;

TAutoClean = class(TInterfacedObject, IAutoClean)

private

FObj: TObject;

public

constructor Create(AObj: TObject);

destructor Destroy; override;

end;

implementation

constructor TAutoClean.Create(AObj: TObject);

begin

FObj := AObj;

end;

destructor TAutoClean.Destroy;

begin

FreeAndNil(FObj);

inherited;

end;

А теперь будем использовать его вместо объекта:

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

a: IAutoClean;

//must declare as local variable, so when this procedure finished, it's out of scope

o: TOpenDialog; //any component

begin

o := TOpenDialog.Create(self);

a := TAutoClean.Create(o);

if o.Execute then

ShowMessage(o.FileName);

end;

Взято с Delphi Knowledge Base: https://www.baltsoft

Как создать компонент во время выполнения приложения?

2013-08-19T17:06:34+07:00

При создании визуальных контролов в runtime, важным моментом является назначение родительских свойств и использование метода SetBounds, чтобы этот контрол стал видимы.

Code:

type

TForm1 = class(TForm)

protected

MyLabel: TLabel;

procedure LabelClick(Sender: TObject);

procedure CreateControl;

end;

procedure TForm1.LabelClick(Sender: TObject);

begin

(Sender asLabel).Caption := ...

end;

procedure TForm1.CreateControl;

var

ALeft, ATop, AWidth, AHeight: Integer;

begin

ALeft := 10;

ATop := 10;

AWidth := 50;

AHeight := 13;

MyLabel := TLabel.Create(Self);

MyLabel.Parent := Self;

MyLabel.Name:='LabelName';

MyLabel.SetBounds(ALeft, ATop, AWidth, AHeight);

MyLabel.OnClick := LabelClick;

end;

Взято из https://forum.sources

Как создать копию произвольного компонента?

2013-08-19T17:09:40+07:00

Code:

{

Здесь пpоцедypа CreateClone, котоpая кpеатит компонентy ОЧЕHЬ ПОХОЖУЮ на

входнyю. С такими же значениями свойств. Пpисваивается все, кpоме методов.

}

function CreateClone(Src: TComponent): TComponent;

var

F: TStream;

begin

F := nil;

try

F := TMemoryStream.Create;

F.WriteComponent(Src);

RegisterClass(TComponentClass(Src.ClassType));

F.Position := 0;

Result := F.ReadComponent(nil);

finally

F.Free;

end;

Клонирование объектов

2013-08-19T19:11:28+07:00

Создатькопиюобъектав Delphi оченьпросто. Конвертируемобъектвтекст, азатем - обратно. Приэтомбудутпродублированывсесвойства, кромессылокнаобработчикисобытий. Дляпреобразованиякомпонентавфайлиобратнонампонадобятсяфункциипотоков WriteComponent(TComponent) и ReadComponent(TComponent). Приэтомвпотокзаписываетсядвоичныйресурс. Последнийспомощьюфункции ObjectBinaryToText можнопреобразоватьвтекст.
Создадимнаихосновефункциипреобразования:

Code:

function ComponentToString(Component: TComponent): string;

var

ms: TMemoryStream;

ss: TStringStream;

begin

ss := TStringStream.Create(' ');

ms := TMemoryStream.Create;

try

ms.WriteComponent(Component);

ms.position := 0;

ObjectBinaryToText(ms, ss);

ss.position := 0;

Result := ss.DataString;

finally

ms.Free;

ss.free;

end;

procedure StringToComponent(Component: TComponent; Value: string);

var

StrStream:TStringStream;

ms: TMemoryStream;

begin

StrStream := TStringStream.Create(Value);

try

ms := TMemoryStream.Create;

try

ObjectTextToBinary(StrStream, ms);

ms.position := 0;

ms.ReadComponent(Component);

finally

ms.Free;

end;

finally

StrStream.Free;

end;

Спомощьюпарыэтихфункциймыможемпреобразоватьлюбойкомпонентвтекст, азатемпроинициализироватьдругойкомпоненттогожеклассаэтимиданными.
Нижеприведенресурсформысоднойкнопкойитекстобработчиканажатиянаэтукнопку.

Code:

object Form1: TForm1

Left = 262

Top = 129

Width = 525

Height = 153

Caption = 'Form1'

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

Scaled = False

PixelsPerInch = 96

TextHeight = 13

object Button1: TButton

Left = 16

Top = 32

Width = 57

Height = 49

Caption = 'Caption'

TabOrder = 0

OnClick = Button1Click

end

procedure TForm1.Button1Click(Sender: TObject);

var

Button: TButton;

OldName: string;

begin

Button := TButton.Create(self);

//...сохраняем имя компонента

OldName := (Sender as TButton).Name;

//...стираем имя компонента, чтобы избежать конфликта имен.

//...После этого Button1 станет = nil.

(Sender as TButton).Name := '';

//...преобразуем в текст и обратно

StringToComponent( Button, ComponentToString(Sender as TButton) );

//...дадим компоненту уникальное(?) имя

Button.Name := 'Button' + IntToStr(random(1000));

//...вернем исходному компоненту имя.

//...После этого Button1 станет снова указывать на объект.

(Sender as TButton).Name := OldName;

//...размещаем новую кнопку справа от исходной

Button.parent := self;

Button1.Tag := Button1.Tag + 1;

Button.Left := Button.Left + Button.Width * Button1.Tag + 1;

end;

Приведенныйметоднедублируетуказателинаобработчикисобытий. Однако, еслитакимобразомдублироватьформы, товседочерниекомпонентыивсеобработчикисохранятся.

составлениестатьи: АндрейЧудин, ЦПРТДБиблио-Глобус

Взято из https://delphi.chertenok

Работа метода Assign

2013-08-19T19:07:31+07:00

В общем случае, утверждение "Destination := Source" не идентично утверждению "Destination.Assign(Source)".

Утверждение "Destination := Source" принуждает Destination ссылаться на тот же объект, что и Source, а "Destination.Assign(Source)" копирует содержание объектных ссылок Source в объектные ссылки Destination.

Если Destination является свойством некоторого объекта (тем не менее, и свойство не является ссылкой на другой объект, как, например, свойство формы ActiveControl, или свойство DataSource элементов управления для работы с базами данных), тогда утверждение "Destination := Source" идентично утверждению "Destination.Assign(Source)". Это объясняет, почему LB.Items := MemStr работает, когда MemStr := LB.Items нет.

Взято из Советов по Delphi от Валентина Озерова

Сборник Kuliba

Сгруппировать свойства наподобие Font

2013-08-19T19:10:14+07:00

...чтобы сгруппировать свойства наподобие Font, вам необходимо создать наследника (подкласс) TPersistent. Например:

Code:

TBoolList = class(TPersistent)

private

FValue1: Boolean;

FValue2: Boolean

published

property Value1: Boolean read FValue1 write FValue1;

property Value2: Boolean read FValue2 write FValue2;

end;

Затем, в вашем новом компоненте, для этого подкласса необходимо создать ivar. Чтобы все работало правильно, вам необходимо перекрыть конструктор.

Code:

TMyPanel = class(TCustomPanel)

private

FBoolList: TBoolList;

public

constructor Create( AOwner: TComponent ); override;

published

property BoolList: TBoolList read FBoolList write FBoolLisr;

end;

Затем добавьте следующий код в ваш конструктор:

Code:

constructor TMyPanel.Create( AOwner: TComponent );

begin

inherited Create( AOwner );

FBoolList := TBoolList.Create;

end;

Взято с https://delphiworld.narod

Сохранение и загрузка данных в объекты на примере коллекций.

2013-08-19T19:12:45+07:00

ЕсливВашейпрограммеиспользуютсяклассыдляописанияобъектовнекоторойпредметнойобласти, тоданные, ихинициализирующие, можнохранитьивбазеданных. Номожновыбратьгораздоболеепродуктивныйподход, которыйдоступенв Delphi/C++ Builder. Средаразработки Delphi/C++ Builder хранитресурсывсехформвдвоичныхилитекстовыхфайлахиэтавозможностьдоступнаидляразрабатываемыхсеепомощьюпрограмм. Вданномслучае, дляоценкиудобствтакогоподходалучшевсегорассмотретьконкретныйпример.

Необходимореализоватьхранениеинформациионекоейслужберассылкииееподписчиках. Будемхранитьданныеопочтовомсервереисписокподписчиков. Каждаязаписьоподписчикехранитеголичныеданныеиадрес, атакжесписоктем(иликаталогов), накоторыеонподписан. КакбольшиепоклонникиГрадиБуча (Grady Booch), атакжебудучизаинтересованывудобнойорганизациикода, мыорганизуеминформациюоподписчикахввидеобъектов. В Delphi дляданнойзадачиидеальноподходиткласс TCollection, реализующийвсюнеобходимуюфункциональностьдляработысоспискамитипизированныхобъектов. Дляэтогомынаследуемсяот TCollection, называяновыйкласс TMailList - списокрассылки, атакжесоздаемнаследникаот TCollectionItem - TMailClient - адресатрассылки. Последнийбудетсодержатьвсенеобходимыеданныеоподписчике, атакжереализовыватьнеобходимыефункциидляработысним.

Самуколлекциюсподписчикаминамнужнобудетпоместитьвнекийбазовыйкласс, которыймыибудемсохранятьизагружать. Нарольтаковогоподходиткласс TMailer - почтовыйклиент.
Начнемс TMailClient.

Code:

type

TMailClient = class(TCollectionItem)

private

FName: string;

FAddress: string;

FEnabled: boolean;

FFolders: TStringList;

public

Files: TStringList; // список файлов к рассылке. заполняется в run-time. Сохранению не подлежит

constructor Create(Collection: TCollection); override;

destructor Destroy; override;

procedure PickFiles;

published

propertyName: stringread FName write FName; // имя адресата

property Address: stringread FAddress write FAddress; // почтовый адрес

property Enabled: boolean read FEnabled write FEnabled default true;

property Folders: TStringList read FFolders write FFolders; // список папок (тем) подписки

end;

Класссодержитсведенияоимениклиента, егоадресе, егостатусе(Enabled), атакжесписоккаталогов, накоторыеонподписан. Процедура PickFiles составляетсписокфайловкотправкеисохраняетеговсвойстве Files
Класс TMailList, хранящийобъектыкласса TMailClient, приведенниже.

Code:

TMailList = class(TCollection)

public

function GetMailClient(Index: Integer): TMailClient;

procedure SetMailClient(Index: Integer; Value: TMailClient);

public

function Add: TMailClient;

property Items[Index: Integer]: TMailClient read GetMailClient write SetMailClient; default;

end;

Теперьпоместимкласс TMailList вкласс TMailer. Внегоможнобудетпотомвключитьданныеопараметрахдоступакпочтовомусерверудляотправкипочты. Онмогбыиотправлятьпочту, новданномпримереэтонеиспользовано, дабынеперегружатькод.

Тоестьвнашемпримереонвыполняеттолькорольносителяданныхоподписчикахиихподписке. Класс TComponent, откоторогооннаследуетсяможносохранитьвфайл, втовремякак TCollection самостоятельнонесохранится. Толькоеслионаагрегированав TComponent. Именноэтоунасиреализовано.

Code:

TMailer = class(TComponent)

private

FMailList: TMailList;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

property MailList: TMailList read FMailList write FMailList; // коллекция - список рассылки.

// здесь можно поместить, к примеру, данные о соединении с почтовым сервером

end;

Повторюсь. Вданномслучаемынаследуемсяоткласса TComponent, длятого, чтобыбылавозможностизаписиданныхобъектавфайл. Свойство MailList содержитужеобъекткласса TMailList.
Реализациявсехприведенныхклассовприведенаниже.

Code:

constructor TMailClient.Create(Collection: TCollection);

begin

inherited;

Folders := TStringList.Create;

Files := TStringList.Create;

FEnabled := true;

end;

destructor TMailClient.Destroy;

begin

Folders.Free;

Files.Free;

inherited;

end;

// здесь во всех каталогах Folders ищем файлы для рассылки и помещаем их в Files.

procedure TMailClient.PickFiles;

var i: integer;

begin

for i:=0to Folders.Count-1do CreateFileList(Files, Folders[i]);

end;

// Стандартный код при наследовании от класса коллекции: переопределяем тип

function TMailList.GetMailClient(Index: Integer): TMailClient;

begin

Result := TMailClient(inherited Items[Index]);

end;

// Стандартный код при наследовании от класса коллекции

procedure TMailList.SetMailClient(Index: Integer; Value: TMailClient);

begin

Items[Index].Assign(Value);

end;

// Стандартный код при наследовании от класса коллекции: переопределяем тип

function TMailList.Add: TMailClient;

begin

Result := TMailClient(inherited Add);

end;

// создаем коллекцию адресатов рассылки TMailList

constructor TMailer.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

MailList := TMailList.Create(TMailClient);

end;

destructor TMailer.Destroy;

begin

MailList.Free;

inherited;

end;

//---------------------

Функция CreateFileList создаетпокаким-либоправиламсписокфайловнаосновепереданногоейспискакаталогов, обходяихрекурсивно. Кпримеру, онаможетбытьреализованатак.

Code:

procedure CreateFileList(sl: TStringList; const FilePath: string);

var

sr: TSearchRec;

procedure ProcessFile;

begin

if (sr.Name = '.')or(sr.Name = '..') then exit;

if sr.Attr <> faDirectory then

sl.Add(FilePath + '\' + sr.Name);

if sr.Attr = faDirectory then

begin

CreateFileList(sl, FilePath + '\' + sr.Name);

end;

begin

ifnot DirectoryExists(FilePath) then exit;

if FindFirst(FilePath + '\' + '*.*', faAnyFile , sr) = 0then ProcessFile;

while FindNext(sr) = 0do ProcessFile;

FindClose(sr);

end;

Витогемырасполагаемклассом TMailer, содержащимвсюнеобходимуюнаминформацию. Теперьперейдемксозданиюобъекта, ихсохранениюизагрузке.

Code:

var

Mailer: TMailer; // это наш объект для хранения данных о почтовой рассылки

// Процедура загрузки данных в объект. Может быть процедурой OnCreate() главной формы.

procedure TfMain.FormCreate(Sender: TObject);

var

sDataFile, sTmp: string;

i, j: integer;

begin

Mailer := TMailer.Create(self);

// будем считать, что данные были сохранены в файл users.dat в каталоге программы

sDataFile := ExtractFilePath(ParamStr(0)) + 'users.dat';

//...загрузка данных из файла

if FileExists(sDataFile) then

LoadComponentFromTextFile(Mailer, sDataFile);

{ здесь данные из файла загружены }

//...перебор подписчиков

for i:=0to Mailer.MailList.Count-1do

begin

sTmp := Mailer.MailList[i].Name; //...обращение к имени

sTmp := Mailer.MailList[i].Address; //...обращение к адресу

//... sTmp - фиктивная переменная. Поменяйте ее на свои.

Mailer.MailList[i].PickFiles; //... поиск файлов для отправки очередному подписчику.

//...перебор найденных файлов к отправке

for j:=0to Mailer.MailList[i].Files.Count-1do

begin

sTmp := Mailer.MailList[i].Files[j];

end;

Послезагрузкиданныхмыможемработатьсданнымивнашейколлекцииподписчиков. Добавлятьиудалятьих ( Mailer.MailList.Add; Mailer.MailList.Delete(Index); ). Призавершенииработыпрограммынеобходимосохранитьуженовыеданныевтотжефайл.

Code:

// Процедура сохранения данных из объекта в файл. Может быть процедурой OnDestroy() главной формы.

procedure TfMain.OnDestroy;

begin

//...сохранение данных в файл users.dat

SaveComponentToTextFile(Mailer, ExtractFilePath(ParamStr(0)) + 'users.dat');

end;

ХранениеданныхвфайлепозволяетоказатьсяотиспользованияБД, еслиобъемданныхнеслишкомвеликинетнеобходимостивсовместномдоступекданным.
Самоеглавное - мыорганизуемвседанныеввиденабораудобныхдляработыклассовинетратимвремянаихсохранениеиинициализациюизБД.
Приведенныйпримерлишьиллюстрируетэтотподход. Дляегореализациимогутподойтии 2 таблицывБД. Однакоприведенныйподходудобенприусловии, чтоданныеимеютсложнуюиерархию. Кпримеру, вложенныеколлекцииразныхтиповгораздосложнееразложитьвбазеданных, дляихизвлеченияпотребуется SQL. Решайтесами, судяпосвоейконкретнойзадаче.

Далееприведенкодфункцийдлясохранения/чтениякомпонента.

Code:

//...процедура загружает(инициализирует) компонент из текстового файла с ресурсом

procedure LoadComponentFromTextFile(Component: TComponent; const FileName: string);

var

ms: TMemoryStream;

fs: TFileStream;

begin

fs := TFileStream.Create(FileName, fmOpenRead);

ms := TMemoryStream.Create;

try

ObjectTextToBinary(fs, ms);

ms.position := 0;

ms.ReadComponent(Component);

finally

ms.Free;

fs.free;

end;

//...процедура сохраняет компонент в текстовый файл

procedure SaveComponentToTextFile(Component: TComponent; const FileName: string);

var

ms: TMemoryStream;

fs: TFileStream;

begin

fs := TFileStream.Create(FileName, fmCreate or fmOpenWrite);

ms := TMemoryStream.Create;

try

ms.WriteComponent(Component);

ms.position := 0;

ObjectBinaryToText(ms, fs);

finally

ms.Free;

fs.free;

end;

составлениестатьи: АндрейЧудин, ЦПРТДБиблио-Глобус.

Взято из https://delphi.chertenok

Список handle всех окон моего приложения

2013-08-19T19:09:20+07:00

Code:

function EnumProc(wnd: HWND; var count: DWORD): Bool; stdcall;

begin

Inc(count);

result := True;

EnumChildWindows(wnd, @EnumProc, integer(@count));

end;

procedure TForm1.Button1Click(Sender: TObject);

var

count: DWORD;

begin

count := 0;

EnumThreadWindows(GetCurrentThreadID, @EnumProc, Integer(@count));

Caption := Format('%d window handles in use', [count]);

end;

Взято с сайтаhttps://www.swissdelphicenter.ch/en/tipsindex

Шаблоны в Object Pascal

2013-08-19T17:08:00+07:00

Шаблоны в Object Pascal

( перевод одноименной статьи с сайта community.borland.com )

Наверное каждый Delphi программист хоть раз общался с программистом C++ и объяснял насколько

Delphi мощнее и удобнее. Но в некоторый момент, программист C++ заявляет примерно следующее

"OK, но Delphi использует Pascal, а значит не поддерживает множественное наследование и шаблоны,

поэтому он не так хорош как C++."

Насчет множественного наследования можно легко заявить, что Delphi имеет интерфейсы, которые

прекрасно справляются со своей задачей, но вот насчет шаблонов Вам придётся согласится, так как

Object Pascal не поддерживает их.

Давайте посмотрим на эту проблему по-внимательней

Шаблоны позволяют делать универсальные контейнеры такие как списки, стеки, очереди, и т.д.

Если Вы хотите осуществить что-то подобное в Delphi, то у Вас есть два пути:

Использовать контейнер TList, который содержит указатели. В этом случае Вам придётся всё

время делать явное приведение типов.

Сделать подкласс контейнера TCollection или TObjectList, и убрать все методы, зависящие от типов

каждый раз, когда Вы захотите использовать новый тип данных.

Третий вариант, это сделать модуль с универсальным классом контейнера, и каждый раз, когда нужно

использовать новый тип данных, нам прийдётся в редакторе искать и вносить исправления. Было бы

здорово, если всю эту работу за Вас делал компилятор.... вот этим мы сейчас и займёмся!

Например, возьмём классы TCollection и TCollectionItem. Когда Вы объявляете нового потомка TCollectionItem

, то так же Вы наследуете новый класс от TOwnedCollection и переопределяете большинство методов, чтобы

их можно было вызывать с новыми типами.

Давайте посмотрим, как создать универсальную коллекцию шаблонов класса:

Шаг 1: Создайте новый текстовый файл (не юнитовский) с именем TemplateCollectionInterface.pas:

Code:

_COLLECTION_ = class (TOwnedCollection)

protected

function GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;

procedure SetItem (const aIndex : Integer;

const aValue : _COLLECTION_ITEM_);

public

constructor Create (const aOwner : TComponent);

function Add : _COLLECTION_ITEM_;

function FindItemID (const aID : Integer) : _COLLECTION_ITEM_;

function Insert (const aIndex : Integer) : _COLLECTION_ITEM_;

property Items [const aIndex : Integer] : _COLLECTION_ITEM_ read GetItem write SetItem;

end;

Обратите внимание, что нет никаких uses или interface clauses, только универсальное объявление

типа, в котором _COLLECTION_ это имя универсальной коллекции класса, а _COLLECTION_ITEM_

это имя методов, содержащихся в нашем шаблоне.

Шаг 2: Создайте второй текстовый файл и сохраните его как TemplateCollectionImplementation.pas:

Code:

constructor _COLLECTION_.Create (const aOwner : TComponent);

begin

inherited Create (aOwner, _COLLECTION_ITEM_);

end;

function _COLLECTION_.Add : _COLLECTION_ITEM_;

begin

Result := _COLLECTION_ITEM_ (inherited Add);

end;

function _COLLECTION_.FindItemID (const aID : Integer) : _COLLECTION_ITEM_;

begin

Result := _COLLECTION_ITEM_ (inherited FindItemID (aID));

end;

function _COLLECTION_.GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;

begin

Result := _COLLECTION_ITEM_ (inherited GetItem (aIndex));

end;

function _COLLECTION_.Insert (const aIndex : Integer) : _COLLECTION_ITEM_;

begin

Result := _COLLECTION_ITEM_ (inherited Insert (aIndex));

end;

procedure _COLLECTION_.SetItem (const aIndex : Integer;

const aValue : _COLLECTION_ITEM_);

begin

inherited SetItem (aIndex, aValue);

end;

Снова нет никаких uses или interface clauses , а только код универсального типа.

Шаг 3: Создайте новый unit-файл с именем MyCollectionUnit.pas:

Code:

unit MyCollectionUnit;

interface

uses Classes;

type TMyCollectionItem = class (TCollectionItem)

private

FMyStringData : String;

FMyIntegerData : Integer;

public

procedure Assign (aSource : TPersistent); override;

published

property MyStringData : Stringread FMyStringData write FMyStringData;

property MyIntegerData : Integer read FMyIntegerData write FMyIntegerData;

end;

// !!! Указываем универсальному классу на реальный тип

_COLLECTION_ITEM_ = TMyCollectionItem;

// !!! директива добавления интерфейса универсального класса

{$INCLUDE TemplateCollectionInterface}

// !!! переименовываем универсальный класс

TMyCollection = _COLLECTION_;

implementation

uses SysUtils;

// !!! препроцессорная директива добавления универсального класса

{$INCLUDE TemplateCollectionImplementation}

procedure TMyCollectionItem.Assign (aSource : TPersistent);

begin

if aSource is TMyCollectionItem then

begin

FMyStringData := TMyCollectionItem(aSource).FMyStringData;

FMyIntegerData := TMyCollectionItem(aSource).FMyIntegerData;

end

elseinherited;

end;

end.

Вот и всё! Теперь компилятор будет делать всю работу за Вас! Если Вы измените интерфейс

универсального класса, то изменения автоматически распространятся на все модули, которые

он использует.

Второй пример

Давайте создадим универсальный класс для динамических массивов.

Шаг 1: Создайте текстовый файл с именем TemplateVectorInterface.pas:

Code:

_VECTOR_INTERFACE_ = nterface

function GetLength : Integer;

procedure SetLength (const aLength : Integer);

function GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;

procedure SetItems (const aIndex : Integer;

const aValue : _VECTOR_DATA_TYPE_);

function GetFirst : _VECTOR_DATA_TYPE_;

procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);

function GetLast : _VECTOR_DATA_TYPE_;

procedure SetLast (const aValue : _VECTOR_DATA_TYPE_);

function High : Integer;

function Low : Integer;

function Clear : _VECTOR_INTERFACE_;

function Extend (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

function Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

property Length : Integer read GetLength write SetLength;

property Items [const aIndex : Integer] : _VECTOR_DATA_TYPE_ read GetItems write SetItems; default;

property First : _VECTOR_DATA_TYPE_ read GetFirst write SetFirst;

property Last : _VECTOR_DATA_TYPE_ read GetLast write SetLast;

end;

_VECTOR_CLASS_ = class (TInterfacedObject, _VECTOR_INTERFACE_)

private

FArray : arrayof _VECTOR_DATA_TYPE_;

protected

function GetLength : Integer;

procedure SetLength (const aLength : Integer);

function GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;

procedure SetItems (const aIndex : Integer;

const aValue : _VECTOR_DATA_TYPE_);

function GetFirst : _VECTOR_DATA_TYPE_;

procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);

function GetLast : _VECTOR_DATA_TYPE_;

procedure SetLast (const aValue : _VECTOR_DATA_TYPE_);

public

function High : Integer;

function Low : Integer;

function Clear : _VECTOR_INTERFACE_;

function Extend (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

function Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

constructor Create (const aLength : Integer);

end;

Шаг 2: Создайте текстовый файл и сохраните его как TemplateVectorImplementation.pas:

Code:

constructor _VECTOR_CLASS_.Create (const aLength : Integer);

begin

inherited Create;

SetLength (aLength);

end;

function _VECTOR_CLASS_.GetLength : Integer;

begin

Result := System.Length (FArray);

end;

procedure _VECTOR_CLASS_.SetLength (const aLength : Integer);

begin

System.SetLength (FArray, aLength);

end;

function _VECTOR_CLASS_.GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;

begin

Result := FArray [aIndex];

end;

procedure _VECTOR_CLASS_.SetItems (const aIndex : Integer;

const aValue : _VECTOR_DATA_TYPE_);

begin

FArray [aIndex] := aValue;

end;

function _VECTOR_CLASS_.High : Integer;

begin

Result := System.High (FArray);

end;

function _VECTOR_CLASS_.Low : Integer;

begin

Result := System.Low (FArray);

end;

function _VECTOR_CLASS_.GetFirst : _VECTOR_DATA_TYPE_;

begin

Result := FArray [System.Low (FArray)];

end;

procedure _VECTOR_CLASS_.SetFirst (const aValue : _VECTOR_DATA_TYPE_);

begin

FArray [System.Low (FArray)] := aValue;

end;

function _VECTOR_CLASS_.GetLast : _VECTOR_DATA_TYPE_;

begin

Result := FArray [System.High (FArray)];

end;

procedure _VECTOR_CLASS_.SetLast (const aValue : _VECTOR_DATA_TYPE_);

begin

FArray [System.High (FArray)] := aValue;

end;

function _VECTOR_CLASS_.Clear : _VECTOR_INTERFACE_;

begin

FArray := Nil;

Result := Self;

end;

function _VECTOR_CLASS_.Extend (const aDelta : Word) : _VECTOR_INTERFACE_;

begin

System.SetLength (FArray, System.Length (FArray) + aDelta);

Result := Self;

end;

function _VECTOR_CLASS_.Contract (const aDelta : Word) : _VECTOR_INTERFACE_;

begin

System.SetLength (FArray, System.Length (FArray) - aDelta);

Result := Self;

end;

Шаг 3: Создайте unit файл с именем FloatVectorUnit.pas:

Code:

unit FloatVectorUnit;

interface

uses Classes; // !!! Модуль "Classes" содержит объявление класса TInterfacedObject

type _VECTOR_DATA_TYPE_ = Double; // !!! тип данных для класса массива Double

{$INCLUDE TemplateVectorInterface}

IFloatVector = _VECTOR_INTERFACE_; // !!! give the interface a meanigful name

TFloatVector = _VECTOR_CLASS_; // !!! give the class a meanigful name

function CreateFloatVector (const aLength : Integer = 0) : IFloatVector; // !!! дополнительная функция

implementation

{$INCLUDE TemplateVectorImplementation}

function CreateFloatVector (const aLength : Integer = 0) : IFloatVector;

begin

Result := TFloatVector.Create (aLength);

end;

end.

Естественно, можно дополнить универсальный класс дополнительными

функциями. Всё зависит от Вашей фантазии!

Использование шаблонов

Вот пример использования нового векторного интерфейса:

Code:

procedure TestFloatVector;

var aFloatVector : IFloatVector;

aIndex : Integer;

begin

aFloatVector := CreateFloatVector;

aFloatVector.Extend.Last := 1;

aFloatVector.Extend.Last := 2;

for aIndex := aFloatVector.Low to aFloatVector.High do

begin

WriteLn (FloatToStr (aFloatVector [aIndex]));

end;

end.

Единственное требование при создании шаблонов таким способом, это то, что

каждый новый тип должен быть объявлен в отдельном модуле, а так же Вы должны

иметь исходники для универсальных классов.

Взято из https://forum.sources