TTimer

[max_rip]

Есть ли что-то подобное для FPC, если нет то как можно реализовать что-то подобное, но необходимо чтоб это работало и на Unix и на Windows платформе.
Вот посидел покумекал чо то набросал через потоки

Код: Выделить всё

unit Timers;

interface

uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes,SysUtils;

Type
   Tmy_timer = class(TThread)
   private
     Interval:integer;
     my_Execute:Pointer;
   protected
     procedure Execute; override;
   public
     Constructor Create(const Interval_millsecond: Integer; const Execute_procedure: Pointer;CreateSuspended : boolean);
   end;

implementation


constructor Tmy_timer.Create(const Interval_millsecond: Integer; const Execute_procedure: Pointer;CreateSuspended : boolean);
begin
   FreeOnTerminate := True;
   Interval:=Interval_millsecond;
   my_Execute:=Execute_procedure;
   inherited Create(CreateSuspended);
end;



procedure Tmy_timer.Execute;
var
   newStatus : string;
begin
   while (not Terminated) do
     begin
          sleep(Interval);
              try
               Synchronize(my_Execute);
              finally
              end;
     end;
end;


end.


Теперь стоит в том как вызвать передаваему в парамтерах процедуру.
Synchronize(my_Execute); выдает разнообразые ошибки.
сам метод Execute потока еще не дописан, временно поставлено sleep(Interval); Дальнейшая реализация планируется через GetTickCount

[max_rip]

Так нашел первую ошибку
в объвление скорее всего надо использывать
my_Execute: procedure of object;
вместо my_Execute:Pointer;
теперь остается найти как их привести между собой.

[Sergei I. Gorelkin]

Вроде бы Synchronize вызывается вот так (не относящееся к делу пропущено):

Код: Выделить всё

type
  // нужно объявлять отдельным типом, иначе геморрой при присваивании обеспечен...
  TEvent=procedure of object;

  Tmy_timer=class(TThread)
  private
    FEvent: TEvent;
    procedure DoEvent;
  public
    constructor Create(... ; AEvent: TEvent);
    property Event: TEvent read FEvent write FEvent;
  end;

constructor Tmy_timer.Create(... ; AEvent: TEvent);
begin
   ...
  FEvent := AEvent;
end;

procedure Tmy_timer.DoEvent;
begin
  if Assigned(FEvent) then FEvent;
end;

procedure Tmy_timer.Execute;
begin
  ...
  // '@' нужно в режиме {$mode objfpc} и не нужно в режиме {$mode delphi}
  Synchronize(@DoEvent);
  ...
end;


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

[max_rip]

Огромное спасибо, если получится более или меннее рабочий таймер выложу сюда

[max_rip]

Вот сам модуль.

Код: Выделить всё

unit Timers;
{$mode objfpc}
interface

uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes,SysUtils;


Type
TEvent=procedure of object;
   Tmy_timer = class(TThread)
   private
    FEvent: TEvent;
    procedure DoEvent;
    FInterval:integer;
   public
     property Event: TEvent read FEvent write FEvent;
     property Interval: integer read FInterval write FInterval;
     constructor Create(AEvent : TEvent;AInterval:integer;CreateSuspended : boolean);//(CreateSuspended : boolean);
     procedure Execute;
   end;

implementation

constructor Tmy_timer.Create(AEvent : TEvent;AInterval:integer;CreateSuspended : boolean);
begin
FEvent:=AEvent;
FInterval:=AInterval;
   FreeOnTerminate := True;
   inherited Create(CreateSuspended);
end;

procedure Tmy_timer.DoEvent;

begin
   if Assigned(FEvent) then FEvent;
end;

procedure Tmy_timer.Execute;
begin
   while (not Terminated) do
     begin
          Synchronize(@DoEvent);
          sleep(interval);
     end;
end;


end.


Вот код программы

Код: Выделить всё

program Project1;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes,SysUtils,timers
  { add your units here };
 

procedure pprint1;
begin
writeln('potok1');
end;
procedure pprint2;
begin
writeln('potok2');
end;
procedure pprint3;
begin
writeln('potok3');
end;

type
  TExecute_procedure = class
  private
  public
    class procedure Timer1;
    class procedure Timer2;
    class procedure Timer3;
  end;
procedure TExecute_procedure.Timer1;
begin
pprint1;
end;
procedure TExecute_procedure.Timer2;
begin
pprint2;
end;
procedure TExecute_procedure.Timer3;
begin
pprint3;
end;

var
    zz,yy,xx : Tmy_timer;
    aa: TExecute_procedure;
    ss: string;
begin

zz:=Tmy_timer.create(@aa.Timer1,500,false);
writeln( GetLastOSError);
yy:=Tmy_timer.create(@aa.Timer2,500,false);
writeln( GetLastOSError);
xx:=Tmy_timer.create(@aa.Timer3,500,false);
writeln( GetLastOSError);
repeat
      writeln ('Enter exit fo close program');
      readln(ss)
until ss='exit';
end.


При запуске из лазариуса вылетает ошибка RunError(211), при запуске в FPC все ок. Но в результате запуска потоки так и не стартуют, при использование Tmy_timer.create(@aa.Timer3,500,true); c execute получаем поток но монопольный который работает сам и программа дальше не выполняется.
Даже если убрать все эти указатели на другие процедуры, ничего не меняется.

PS. Если чуть модифицировать последний цикл

Код: Выделить всё

begin
      readln(ss);
      if ss = 'aa' then begin writeln(zz.Suspended);writeln(yy.Suspended);writeln(xx.Suspended); end;
end   

в ответ получим три FALSE.
Насколько я понимаю это означает что цикл в работе.

[max_rip]

В общем списался с Sergei I. Gorelkin в аськи, он вязл код из предыдущего поста, и у него все прекрасно работает, правдо у него версия 2,1,1 и 2,0,3. Ну слил я SVN что у них там было собрал с 3 попытки. Запускаю fp, открываю и компилю файл - тишина в ответ.
Люди попробуйте у себя, может я какие-то опции не указываю.
Только уберите в реализации потока Synchronize(@DoEvent); оставьте просто вызов DoEvent. (По совету Sergei I. Gorelkin бех синхронизации у него заработало.)
У меня ВинХП 2 СП, + кое какие обновления.
в линухе собирал на 2,0,4 тоже самое.