fpc/packages/amunits/examples/simple_timer.pas

program simpletimer;


uses exec, timer, amigados, amigalib;



{ manifest constants -- 'never will change' }
const
     SECSPERMIN   = (60);
     SECSPERHOUR  = (60*60);
     SECSPERDAY   = (60*60*24);

var
     seconds : longint;
     tr      : ptimerequest;      { IO block for timer commands }
     oldtimeval : ttimeval;   { timevals to store times     }
     mytimeval  : ttimeval;
     currentval : ttimeval;

Function Create_Timer(theUnit : longint) : pTimeRequest;
var
    Error : longint;
    TimerPort : pMsgPort;
    TimeReq : pTimeRequest;
begin
    TimerPort := CreatePort(Nil, 0);
    if TimerPort = Nil then
        Create_Timer := Nil;
    TimeReq := pTimeRequest(CreateExtIO(TimerPort,sizeof(tTimeRequest)));
    if TimeReq = Nil then begin
        DeletePort(TimerPort);
        Create_Timer := Nil;
    end;
    Error := OpenDevice(TIMERNAME, theUnit, pIORequest(TimeReq), 0);
    if Error <> 0 then begin
        DeleteExtIO(pIORequest(TimeReq));
        DeletePort(TimerPort);
        Create_Timer := Nil;
    end;
    TimerBase := pointer(TimeReq^.tr_Node.io_Device);
    Create_Timer := pTimeRequest(TimeReq);
end;

Procedure Delete_Timer(WhichTimer : pTimeRequest);
var
    WhichPort : pMsgPort;
begin

    WhichPort := WhichTimer^.tr_Node.io_Message.mn_ReplyPort;
    if assigned(WhichTimer) then begin
        CloseDevice(pIORequest(WhichTimer));
        DeleteExtIO(pIORequest(WhichTimer));
    end;
    if assigned(WhichPort) then
        DeletePort(WhichPort);
end;

procedure wait_for_timer(tr : ptimerequest; tv : ptimeval);
begin
    tr^.tr_node.io_Command := TR_ADDREQUEST; { add a new timer request }

    { structure assignment }
    tr^.tr_time.tv_secs := tv^.tv_secs;
    tr^.tr_time.tv_micro := tv^.tv_micro;

    { post request to the timer -- will go to sleep till done }
    DoIO(pIORequest(tr));
end;

{ more precise timer than AmigaDOS Delay() }
function time_delay(tv : ptimeval; theunit : longint): longint;
var
    tr : ptimerequest;
begin
    { get a pointer to an initialized timer request block }
    tr := create_timer(theunit);

    { any nonzero return says timedelay routine didn't work. }
    if tr = NIL then time_delay := -1;

    wait_for_timer(tr, tv);

    { deallocate temporary structures }
    delete_timer(tr);
    time_delay := 0;
end;

function set_new_time(secs : longint): longint;
var
    tr : ptimerequest;
begin
    tr := create_timer(UNIT_MICROHZ);

    { non zero return says error }
    if tr = nil then set_new_time := -1;

    tr^.tr_time.tv_secs := secs;
    tr^.tr_time.tv_micro := 0;
    tr^.tr_node.io_Command := TR_SETSYSTIME;
    DoIO(pIORequest(tr));

    delete_timer(tr);
    set_new_time := 0;
end;

function get_sys_time(tv : ptimeval): longint;
var
    tr : ptimerequest;
begin
    tr := create_timer( UNIT_MICROHZ );

    { non zero return says error }
    if tr = nil then get_sys_time := -1;

    tr^.tr_node.io_Command := TR_GETSYSTIME;
    DoIO(pIORequest(tr));

   { structure assignment }
   tv^ := tr^.tr_time;

   delete_timer(tr);
   get_sys_time := 0;
end;




procedure show_time(secs : longint);
var
   days,hrs,mins : longint;
begin
   { Compute days, hours, etc. }
   mins := secs div 60;
   hrs := mins div 60;
   days := hrs div 24;
   secs := secs  mod 60;
   mins := mins mod 60;
   hrs := hrs mod 24;

   { Display the time }
   writeln('*   Hour Minute Second  (Days since Jan.1,1978)');
   writeln('*   ', hrs, ':   ',mins,':   ', secs,'       (  ',days, ' )');
   writeln;
end;


begin
   writeln('Timer test');

   { sleep for two seconds }
   currentval.tv_secs := 2;
   currentval.tv_micro := 0;
   time_delay(@currentval, UNIT_VBLANK);
   writeln('After 2 seconds delay');

   { sleep for four seconds }
   currentval.tv_secs := 4;
   currentval.tv_micro := 0;
   time_delay(@currentval, UNIT_VBLANK);
   writeln('After 4 seconds delay');

   { sleep for 500,000 micro-seconds = 1/2 second }
   currentval.tv_secs := 0;
   currentval.tv_micro := 500000;
   time_delay(@currentval, UNIT_MICROHZ);
   writeln('After 1/2 second delay');

   writeln('DOS Date command shows: ');
   Execute('date', 0, 0);

   { save what system thinks is the time....we'll advance it temporarily }
   get_sys_time(@oldtimeval);
   writeln('Original system time is:');
   show_time(oldtimeval.tv_secs );

   writeln('Setting a new system time');

   seconds := 1000 * SECSPERDAY + oldtimeval.tv_secs;

   set_new_time( seconds );
   { (if user executes the AmigaDOS DATE command now, he will}
   { see that the time has advanced something over 1000 days }

   write('DOS Date command now shows: ');
   Execute('date', 0, 0);

   get_sys_time(@mytimeval);
   writeln('Current system time is:');
   show_time(mytimeval.tv_secs);

   { Added the microseconds part to show that time keeps }
   { increasing even though you ask many times in a row  }

   writeln('Now do three TR_GETSYSTIMEs in a row (notice how the microseconds increase)');
   writeln;
   get_sys_time(@mytimeval);
   writeln('First TR_GETSYSTIME      ',mytimeval.tv_secs,'.', mytimeval.tv_micro);
   get_sys_time(@mytimeval);
   writeln('Second TR_GETSYSTIME     ',mytimeval.tv_secs,'.', mytimeval.tv_micro);
   get_sys_time(@mytimeval);
   writeln('Third TR_GETSYSTIME      ',mytimeval.tv_secs,'.', mytimeval.tv_micro);
   writeln;
   writeln('Resetting to former time');
   set_new_time(oldtimeval.tv_secs);

   get_sys_time(@mytimeval);
   writeln('Current system time is:');
   show_time(mytimeval.tv_secs);

end.