paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-10 05:28:44 +02:00
Code Issues Packages Projects Releases Wiki Activity
227cd9354c
fpc/fvision/time.pas
Tomas Hajny 227cd9354c * FPC/2 support
2002-10-12 19:39:00 +00:00

478 lines
23 KiB
ObjectPascal
Raw Blame History

{ $Id$ }
{*********************[ TIME UNIT ]************************}
{ }
{ System independent TIME unit }
{ }
{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer }
{ ldeboer@attglobal.net - primary e-mail address }
{ ldeboer@starwon.com.au - backup e-mail address }
{ }
{****************[ THIS CODE IS FREEWARE ]*****************}
{ }
{ This sourcecode is released for the purpose to }
{ promote the pascal language on all platforms. You may }
{ redistribute it and/or modify with the following }
{ DISCLAIMER. }
{ }
{ This SOURCE CODE is distributed "AS IS" WITHOUT }
{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR }
{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. }
{ }
{*****************[ SUPPORTED PLATFORMS ]******************}
{ 16 and 32 Bit compilers }
{ DOS - Turbo Pascal 7.0 + (16 Bit) }
{ DPMI - Turbo Pascal 7.0 + (16 Bit) }
{ - FPC 0.9912+ (GO32V2) (32 Bit) }
{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) }
{ - Delphi 1.0+ (16 Bit) }
{ WIN95/NT - Delphi 2.0+ (32 Bit) }
{ - Virtual Pascal 2.0+ (32 Bit) }
{ - Speedsoft Sybil 2.0+ (32 Bit) }
{ - FPC 0.9912+ (32 Bit) }
{ OS2 - Virtual Pascal 1.0+ (32 Bit) }
{ - Speed Pascal 1.0+ (32 Bit) }
{ - C'T patch to BP (16 Bit) }
{ }
{******************[ REVISION HISTORY ]********************}
{ Version Date Fix }
{ ------- --------- --------------------------------- }
{ 1.00 06 Dec 96 First multi platform release. }
{ 1.10 06 Jul 97 New functiions added. }
{ 1.20 22 Jul 97 FPC pascal compiler added. }
{ 1.30 29 Aug 97 Platform.inc sort added. }
{ 1.40 13 Oct 97 Delphi 2/3 32 bit code added. }
{ 1.50 06 Nov 97 Speed pascal code added. }
{ 1.60 05 May 98 Virtual pascal 2.0 compiler added. }
{ 1.61 07 Jul 99 Speedsoft SYBIL 2.0 code added. }
{**********************************************************}
UNIT Time;
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
INTERFACE
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{====Include file to sort compiler platform out =====================}
{$I Platform.inc}
{====================================================================}
{==== Compiler directives ===========================================}
{$IFNDEF PPC_FPC} { FPC doesn't support these switches }
{$F-} { Short calls are okay }
{$A+} { Word Align Data }
{$B-} { Allow short circuit boolean evaluations }
{$O+} { This unit may be overlaid }
{$G+} { 286 Code optimization - if you're on an 8088 get a real computer }
{$E+} { Emulation is on }
{$N-} { No 80x87 code generation }
{$ENDIF}
{$X+} { Extended syntax is ok }
{$R-} { Disable range checking }
{$S-} { Disable Stack Checking }
{$I-} { Disable IO Checking }
{$Q-} { Disable Overflow Checking }
{$V-} { Turn off strict VAR strings }
{====================================================================}
{***************************************************************************}
{ INTERFACE ROUTINES }
{***************************************************************************}
{-CurrentMinuteOfDay-------------------------------------------------
Returns the number of minutes since midnight of a current system time.
19Jun97 LdB (Range: 0 - 1439)
---------------------------------------------------------------------}
FUNCTION CurrentMinuteOfDay: Word;
{-CurrentSecondOfDay-------------------------------------------------
Returns the number of seconds since midnight of current system time.
24Jun97 LdB (Range: 0 - 86399)
---------------------------------------------------------------------}
FUNCTION CurrentSecondOfDay: LongInt;
{-CurrentSec100OfDay-------------------------------------------------
Returns the 1/100ths of a second since midnight of current system time.
24Jun97 LdB (Range: 0 - 8639999)
---------------------------------------------------------------------}
FUNCTION CurrentSec100OfDay: LongInt;
{-MinuteOfDay--------------------------------------------------------
Returns the number of minutes since midnight of a valid given time.
19Jun97 LdB (Range: 0 - 1439)
---------------------------------------------------------------------}
FUNCTION MinuteOfDay (Hour24, Minute: Word): Word;
{-SecondOfDay--------------------------------------------------------
Returns the number of seconds since midnight of a valid given time.
19Jun97 LdB (Range: 0 - 86399)
---------------------------------------------------------------------}
FUNCTION SecondOfDay (Hour24, Minute, Second: Word): LongInt;
{-SetTime------------------------------------------------------------
Set the operating systems time clock to the given values. If values
are invalid this function will fail without notification.
06Nov97 LdB
---------------------------------------------------------------------}
PROCEDURE SetTime (Hour, Minute, Second, Sec100: Word);
{-GetTime------------------------------------------------------------
Returns the current time settings of the operating system.
06Nov97 LdB
---------------------------------------------------------------------}
PROCEDURE GetTime (Var Hour, Minute, Second, Sec100: Word);
{-MinutesToTime------------------------------------------------------
Returns the time in hours and minutes of a given number of minutes.
19Jun97 LdB
---------------------------------------------------------------------}
PROCEDURE MinutesToTime (Md: LongInt; Var Hour24, Minute: Word);
{-SecondsToTime------------------------------------------------------
Returns the time in hours, mins and secs of a given number of seconds.
19Jun97 LdB
---------------------------------------------------------------------}
PROCEDURE SecondsToTime (Sd: LongInt; Var Hour24, Minute, Second: Word);
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
IMPLEMENTATION
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
{$IFNDEF PPC_SPEED} { NON SPEED COMPILER }
{$IFDEF PPC_FPC} { FPC WINDOWS COMPILER }
USEs Windows; { Standard unit }
{$ELSE} { OTHER COMPILERS }
USES WinTypes, WinProcs; { Standard units }
{$ENDIF}
{$ELSE} { SPEEDSOFT COMPILER }
USES WinBase; { Standard unit }
TYPE TSystemTime = SystemTime; { Type fix up }
{$ENDIF}
{$ENDIF}
{$IFDEF OS_OS2} { OS2 COMPILERS }
{$IFDEF PPC_VIRTUAL} { VIRTUAL PASCAL }
USES OS2Base; { Standard unit }
{$ENDIF}
{$IFDEF PPC_SPEED} { SPEED PASCAL }
USES BseDos, Os2Def; { Standard unit }
{$ENDIF}
{$IFDEF PPC_FPC} { FPC }
USES Dos, DosCalls; { Standard unit }
TYPE DateTime = TDateTime; { Type correction }
{$ENDIF}
{$IFDEF PPC_BPOS2} { C'T PATCH TO BP CODE }
USES DosTypes, DosProcs; { Standard unit }
TYPE DateTime = TDateTime; { Type correction }
{$ENDIF}
{$ENDIF}
{$ifdef OS_UNIX}
USES Dos;
{$endif OS_UNIX}
{$ifdef OS_GO32}
USES Dos;
{$endif OS_GO32}
{***************************************************************************}
{ INTERFACE ROUTINES }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ CurrentMinuteOfDay -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Jun97 LdB}
{---------------------------------------------------------------------------}
FUNCTION CurrentMinuteOfDay: Word;
VAR Hour, Minute, Second, Sec100: Word;
BEGIN
GetTime(Hour, Minute, Second, Sec100); { Get current time }
CurrentMinuteOfDay := (Hour * 60) + Minute; { Minute from midnight }
END;
{---------------------------------------------------------------------------}
{ CurrentSecondOfDay -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Jun97 LdB}
{---------------------------------------------------------------------------}
FUNCTION CurrentSecondOfDay: LongInt;
VAR Hour, Minute, Second, Sec100: Word;
BEGIN
GetTime(Hour, Minute, Second, Sec100); { Get current time }
CurrentSecondOfDay := (LongInt(Hour) * 3600) +
(Minute * 60) + Second; { Second from midnight }
END;
{---------------------------------------------------------------------------}
{ CurrentSec100OfDay -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Jun97 LdB}
{---------------------------------------------------------------------------}
FUNCTION CurrentSec100OfDay: LongInt;
VAR Hour, Minute, Second, Sec100: Word;
BEGIN
GetTime(Hour, Minute, Second, Sec100); { Get current time }
CurrentSec100OfDay := (LongInt(Hour) * 360000) +
(LongInt(Minute) * 6000) + (Second*100)+ Sec100; { Sec100 from midnight }
END;
{---------------------------------------------------------------------------}
{ MinuteOfDay -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Jun97 LdB }
{---------------------------------------------------------------------------}
FUNCTION MinuteOfDay (Hour24, Minute: Word): Word;
BEGIN
MinuteOfDay := (Hour24 * 60) + Minute; { Minute from midnight }
END;
{---------------------------------------------------------------------------}
{ SecondOfDay -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Jun97 LdB }
{---------------------------------------------------------------------------}
FUNCTION SecondOfDay (Hour24, Minute, Second: Word): LongInt;
BEGIN
SecondOfDay := (LongInt(Hour24) * 3600) +
(Minute * 60) + Second; { Second from midnight }
END;
{---------------------------------------------------------------------------}
{ SetTime -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Nov97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE SetTime (Hour, Minute, Second, Sec100: Word);
{$IFDEF OS_DOS} { DOS/DPMI CODE }
{$IFDEF ASM_BP} { BP COMPATABLE ASM }
ASSEMBLER;
ASM
MOV CH, BYTE PTR Hour; { Fetch hour }
MOV CL, BYTE PTR Minute; { Fetch minute }
MOV DH, BYTE PTR Second; { Fetch second }
MOV DL, BYTE PTR Sec100; { Fetch hundredths }
MOV AX, $2D00; { Set function id }
PUSH BP; { Safety save register }
INT $21; { Set the time }
POP BP; { Restore register }
END;
{$ENDIF}
{$IFDEF ASM_FPC} { FPC COMPATABLE ASM }
BEGIN
ASM
MOVB Hour, %CH; { Fetch hour }
MOVB Minute, %CL; { Fetch minute }
MOVB Second, %DH; { Fetch second }
MOVB Sec100, %DL; { Fetch hundredths }
MOVW $0x2D00, %AX; { Set function id }
PUSHL %EBP; { Save register }
INT $0x21; { BIOS set time }
POPL %EBP; { Restore register }
END;
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
{$IFDEF BIT_16} { 16 BIT WINDOWS CODE }
ASSEMBLER;
ASM
MOV CH, BYTE PTR Hour; { Fetch hour }
MOV CL, BYTE PTR Minute; { Fetch minute }
MOV DH, BYTE PTR Second; { Fetch second }
MOV DL, BYTE PTR Sec100; { Fetch hundredths }
MOV AX, $2D00; { Set function id }
PUSH BP; { Safety save register }
INT $21; { Set the time }
POP BP; { Restore register }
END;
{$ENDIF}
{$IFDEF BIT_32} { 32 BIT WINDOWS CODE }
VAR DT: TSystemTime;
BEGIN
{$IFDEF PPC_FPC} { FPC WINDOWS COMPILER }
GetLocalTime(@DT); { Get the date/time }
{$ELSE} { OTHER COMPILERS }
GetLocalTime(DT); { Get the date/time }
{$ENDIF}
DT.wHour := Hour; { Transfer hour }
DT.wMinute := Minute; { Transfer minute }
DT.wSecond := Second; { Transfer seconds }
DT.wMilliseconds := Sec100 * 10; { Transfer millisecs }
SetLocalTime(DT); { Set the date/time }
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_OS2} { OS2 CODE }
VAR DT: DateTime;
BEGIN
DosGetDateTime(DT); { Get the date/time }
DT.Hours := Hour; { Transfer hour }
DT.Minutes := Minute; { Transfer minute }
DT.Seconds := Second; { Transfer seconds }
DT.Hundredths := Sec100; { Transfer hundredths }
DosSetDateTime(DT); { Set the time }
END;
{$ENDIF}
{$ifdef OS_UNIX}
BEGIN
{settime is dummy in Linux}
END;
{$endif OS_UNIX}
{---------------------------------------------------------------------------}
{ GetTime -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Nov97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE GetTime (Var Hour, Minute, Second, Sec100: Word);
{$IFDEF OS_DOS} { DOS/DPMI CODE }
{$IFDEF ASM_BP} { BP COMPATABLE ASM }
ASSEMBLER;
ASM
MOV AX, $2C00; { Set function id }
PUSH BP; { Safety save register }
INT $21; { System get time }
POP BP; { Restore register }
XOR AH, AH; { Clear register }
CLD; { Strings go forward }
MOV AL, DL; { Transfer register }
LES DI, Sec100; { ES:DI -> hundredths }
STOSW; { Return hundredths }
MOV AL, DH; { Transfer register }
LES DI, Second; { ES:DI -> seconds }
STOSW; { Return seconds }
MOV AL, CL; { Transfer register }
LES DI, Minute; { ES:DI -> minutes }
STOSW; { Return minutes }
MOV AL, CH; { Transfer register }
LES DI, Hour; { ES:DI -> hours }
STOSW; { Return hours }
END;
{$ENDIF}
{$IFDEF OS_GO32} { FPC COMPATABLE ASM }
BEGIN
(* ASM
MOVW $0x2C00, %AX; { Set function id }
PUSHL %EBP; { Save register }
INT $0x21; { System get time }
POPL %EBP; { Restore register }
XORB %AH, %AH; { Clear register }
MOVB %DL, %AL; { Transfer register }
MOVL Sec100, %EDI; { EDI -> Sec100 }
MOVW %AX, (%EDI); { Return Sec100 }
MOVB %DH, %AL; { Transfer register }
MOVL Second, %EDI; { EDI -> Second }
MOVW %AX, (%EDI); { Return Second }
MOVB %CL, %AL; { Transfer register }
MOVL Minute, %EDI; { EDI -> Minute }
MOVW %AX, (%EDI); { Return minute }
MOVB %CH, %AL; { Transfer register }
MOVL Hour, %EDI; { EDI -> Hour }
MOVW %AX, (%EDI); { Return hour }
END; *)
{ direct call of real interrupt seems to render the system
unstable on Win2000 because some registers are not properly
restored if a mouse interrupt is generated while the Dos
interrupt is called... PM }
Dos.GetTime(Hour,Minute,Second,Sec100);
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
{$IFDEF BIT_16} { 16 BIT WINDOWS CODE }
ASSEMBLER;
ASM
MOV AX, $2C00; { Set function id }
PUSH BP; { Safety save register }
INT $21; { System get time }
POP BP; { Restore register }
XOR AH, AH; { Clear register }
CLD; { Strings go forward }
MOV AL, DL; { Transfer register }
LES DI, Sec100; { ES:DI -> hundredths }
STOSW; { Return hundredths }
MOV AL, DH; { Transfer register }
LES DI, Second; { ES:DI -> seconds }
STOSW; { Return seconds }
MOV AL, CL; { Transfer register }
LES DI, Minute; { ES:DI -> minutes }
STOSW; { Return minutes }
MOV AL, CH; { Transfer register }
LES DI, Hour; { ES:DI -> hours }
STOSW; { Return hours }
END;
{$ENDIF}
{$IFDEF BIT_32} { 32 BIT WINDOWS CODE }
VAR DT: TSystemTime;
BEGIN
{$IFDEF PPC_FPC} { FPC WINDOWS COMPILER }
GetLocalTime(@DT); { Get the date/time }
{$ELSE} { OTHER COMPILERS }
GetLocalTime(DT); { Get the date/time }
{$ENDIF}
Hour := DT.wHour; { Transfer hour }
Minute := DT.wMinute; { Transfer minute }
Second := DT.wSecond; { Transfer seconds }
Sec100 := DT.wMilliseconds DIV 10; { Transfer hundredths }
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_OS2} { OS2 CODE }
VAR DT: DateTime;
BEGIN
DosGetDateTime(DT); { Get the date/time }
Hour := DT.Hours; { Transfer hour }
Minute := DT.Minutes; { Transfer minute }
Second := DT.Seconds; { Transfer seconds }
Sec100 := DT.Hundredths; { Transfer hundredths }
END;
{$ENDIF}
{$ifdef OS_UNIX}
BEGIN
Dos.GetTime(Hour,Minute,Second,Sec100);
END;
{$endif OS_UNIX}
{---------------------------------------------------------------------------}
{ MinutesToTime -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Jun97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE MinutesToTime (Md: LongInt; Var Hour24, Minute: Word);
BEGIN
Hour24 := Md DIV 60; { Hours of time }
Minute := Md MOD 60; { Minutes of time }
END;
{---------------------------------------------------------------------------}
{ SecondsToTime -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Jun97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE SecondsToTime (Sd: LongInt; Var Hour24, Minute, Second: Word);
BEGIN
Hour24 := Sd DIV 3600; { Hours of time }
Minute := Sd MOD 3600 DIV 60; { Minutes of time }
Second := Sd MOD 60; { Seconds of time }
END;
END.
{
$Log$
Revision 1.11 2002-10-12 19:39:00 hajny
* FPC/2 support
Revision 1.10 2002/09/24 16:48:24 hajny
* fix for TDateTime clash
Revision 1.9 2002/09/22 19:42:22 hajny
+ FPC/2 support added
Revision 1.8 2002/09/09 08:02:49 pierre
* avoid instabilities on win2000
Revision 1.7 2002/09/07 15:06:38 peter
* old logs removed and tabs fixed
Revision 1.6 2002/06/04 11:12:41 marco
* Renamefest
Revision 1.5 2002/06/03 20:26:16 pierre
* use local time for windows
}
Reference in New Issue View Git Blame Copy Permalink