Реализация собственного потока
Автор: Mike Scott
Я хотел бы создать конструктор Load, загружающий список из потока...
Новые потоки в Delphi более разносторонние, чем в BP7. Поскольку вы знаете как пользоваться потоками в BP7, а размер статьи ограничен, то я думаю, что для начала вам необходимо попробовать в действии описанный ниже модуль, инкапсулирующий класс для работы с потоками в стиле BP7. Класс является наследником TComponent, но в нашем случае не было бы никакой разницы, если бы он был наследником TObject. К примеру, вы могли бы адаптировать данный код к своему наследнику TList.
Более важен тот факт, что вы можете использовать поток так, как вам это необходимо, исходя из вашей задачи и специфики. Я сделал работу потока похожую по стилю на BP7, где вначале идет ID класса. В каком-нибудь месте вам необходимо вызвать RegisterType( TYourClass, UniqueIDLikeBP7 ), после чего TYourClass готов к работе с потоками.
Вы наверняка обратили внимание, что я реализовал список зарегистрированных классов (регистратор), где с помощью ID легко можно найти классы, читающие и пишущие в поток в момент вызова конструктора Load соответствующего класса. Код простой и не требующий пояснений. Имейте в виду, что данный код можно использовать для организации передачи данных между существующим файловым потоком BP7 в объекты Delphi - я создал это для осуществления миграции с текущего приложения BP7 в Delphi и осуществления совместимости.
Если вам необходима более подробная информацио о работе потоков в Delphi, обратитесь к соответствующему разделу электронной справки Delphi.
unit CompStrm;
interface
uses Classes;
type
TCompatibleStream = class;
{ TStreamObject }
TStreamObject = class(TComponent)
constructor Load(S: TCompatibleStream); virtual; abstract;
procedure Store(S: TCompatibleStream); virtual; abstract;
function GetObjectType: word; virtual; abstract;
end;
TStreamObjectClass = class of TStreamObject;
{ TCompatibleStream }
TCompatibleStream = class(TFileStream)
function ReadString: string;
procedure WriteString(var S: string);
function StrRead: PChar;
procedure StrWrite(P: PChar);
function Get: TStreamObject; virtual;
procedure Put(AnObject: TStreamObject); virtual;
end;
{ Register Type : используйте это для регистрации ваших объектов для
работы с потоками с тем же ID, который они имели в OWL }
procedure RegisterType(AClass: TStreamObjectClass;
AnID: word);
implementation
uses SysUtils, Controls;
var
Registry: TList; { хранение ID объекта и информации о классе }
{ TClassInfo }
type
TClassInfo = class(TObject)
ClassType: TStreamObjectClass;
ClassID: word;
constructor Create(AClassType: TStreamObjectClass;
AClassID: word); virtual;
end;
constructor TClassInfo.Create(AClassType: TStreamObjectClass;
AClassID: word);
var
AnObject: TStreamObject;
begin
if not Assigned(AClassType) then
raise EInvalidOperation.Create('Класс не инициализирован'
);
if not AClassType.InheritsFrom(TStreamObject) then
raise EInvalidOperation.Create('Класс ' + AClassType.ClassName +
' не является потомком TStreamObject'
);
ClassType := AClassType;
ClassID := AClassID;
end;
{ функции поиска информации о классе }
function FindClassInfo(AClass: TClass): TClassInfo;
var
i: integer;
begin
for i := Registry.Count - 1 downto 0 do
begin
Result := TClassInfo(Registry.Items[i]);
if Result.ClassType = AClass then
exit;
end;
raise EInvalidOperation.Create('Класс ' + AClass.ClassName +
' не зарегистрирован для работы с потоком');
end;
function FindClassInfoByID(AClassID: word): TClassInfo;
var
i: integer;
AName: string[31];
begin
for i := Registry.Count - 1 downto 0 do
begin
Result := TClassInfo(Registry.Items[i]);
AName := TClassInfo(Registry.Items[i]).ClassType.ClassName;
if Result.ClassID = AClassID then
exit;
end;
raise EInvalidOperation.Create('ID класса ' + IntToStr(AClassID) +
' отсутствует в регистраторе
классов' ) ;
end;
procedure RegisterType(AClass: TStreamObjectClass;
AnID: word);
var
i: integer;
begin
{ смотрим, был ли класс уже зарегистрирован }
for i := Registry.Count - 1 downto 0 do
with TClassInfo(Registry[i]) do
if ClassType = AClass then
begin
if ClassID <> AnID then
raise EInvalidOperation.Create('Класс ' + AClass.ClassName +
' уже зарегистрирован с ID ' +
IntToStr(ClassID));
exit;
end;
Registry.Add(TClassInfo.Create(AClass, AnID));
end;
{ TCompatibleStream }
function TCompatibleStream.ReadString: string;
begin
ReadBuffer(Result[0], 1);
if byte(Result[0]) > 0 then
ReadBuffer(Result[1], byte(Result[0
]));
end;
procedure TCompatibleStream.WriteString(var S: string);
begin
WriteBuffer(S[0], 1);
if Length(S) > 0 then
WriteBuffer(S[1], Length(S));
end;
function TCompatibleStream.StrRead: PChar;
var
L: Word;
P: PChar;
begin
ReadBuffer(L, SizeOf(Word));
if L = 0 then
StrRead := nil
else
begin
P := StrAlloc(L + 1);
ReadBuffer(P[0], L);
P[L] := #0;
StrRead := P;
end;
end;
procedure TCompatibleStream.StrWrite(P: PChar);
var
L: Word;
begin
if P = nil then
L := 0
else
L := StrLen(P);
WriteBuffer(L, SizeOf(Word));
if L > 0 then
WriteBuffer(P[0], L);
end;
function TCompatibleStream.Get: TStreamObject;
var
AClassID: word;
begin
{ читаем ID объекта, находим это в регистраторе и загружаем объект }
ReadBuffer(AClassID, sizeof(AClassID));
Result := FindClassInfoByID(AClassID).ClassType.Load(Self);
end;
procedure TCompatibleStream.Put(AnObject: TStreamObject);
var
AClassInfo: TClassInfo;
ANotedPosition: longint;
DoTruncate: boolean;
begin
{ получает объект из регистратора }
AClassInfo := FindClassInfo(AnObject.ClassType);
{ запоминаем позицию в случае проблемы }
ANotedPosition := Position;
try
{ пишем id класса и вызываем метод store }
WriteBuffer(AClassInfo.ClassID, sizeof(AClassInfo.ClassID));
AnObject.Store(Self);
except
{ откатываемся в предыдущую позицию и, если EOF, тогда truncate }
DoTruncate := Position = Size;
Position := ANotedPosition;
if DoTruncate then
Write(ANotedPosition, 0);
raise;
end;
end;
{ выход из обработки, очистка регистратора }
procedure DoneCompStrm; far;
var
i: integer;
begin
{ освобождаем регистратор }
for i := Registry.Count - 1 downto 0 do
TObject(Registry.Items[i]
).Free;
Registry.Free;
end;
begin
Registry := TList.Create;
AddExitProc(DoneCompStrm);
end.
|
|
