{
▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄
█ █
█ TITLE : DGDATE.TPU █
█ PURPOSE : Date/Time functions. █
█ AUTHOR : David Gerrold, CompuServe ID: 70307,544 █
█ ______________________________________________________________________ █
█ █
█ Written in Turbo Pascal, Version 5.5, █
█ with routines from TurboPower, Object Professional. █
█ █
█ Turbo Pascal is a product of Borland International. █
█ Object Professional is a product of TurboPower Software. █
█ ______________________________________________________________________ █
█ █
█ This is not public domain software. █
█ This software is copyright 1990, by David Gerrold. █
█ Permission is hereby granted for personal use. █
█ █
█ The Brass Cannon Corporation █
█ 9420 Reseda Blvd., #804 █
█ Northridge, CA 91324-2932. █
█ █
▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀
}
{ Compiler Directives ===================================================== }
{$A-} {Switch word alignment off, necessary for cloning}
{$R-} {Range checking off}
{$B-} {Boolean complete evaluation off}
{$S-} {Stack checking off}
{$I-} {I/O checking off}
{$N+,E+} {Simulate numeric coprocessor}
{$M 16384,0,327680} {stack and heap}
{$V-} {Variable range checking off}
{ Name ==================================================================== }
UNIT DgDate;
{
The purpose of DgDate is to provide the most commonly needed date and
time functions.
}
{ Interface =============================================================== }
INTERFACE
USES
{ Object Professional Units }
OpColor,
OpCrt,
OpString,
OpDate,
{ Dg Units }
dgfile, { delete after debugging }
DgWryte,
DgSound,
DgStr;
{ Declarations ============================================================ }
TYPE
TimeString = string [12];
CONST
ClockFlag : boolean = false;
CkColor : byte = LtRedOnBlack; { clock attr color }
CkMono : byte = LtGrayOnBlack; { clock attr mono }
PcTimeStr = 'HH:mm:ss te'; { '10:36:09 pm' }
ClockTimeStr = 'HH:mm te'; { '10:36 pm' }
ShortTimeStr = 'HH:mmt'; { '10:36p' }
MilitaryTimeStr = 'hh:mm'; { '22:36' }
VAR
TimeCheck : Time; { for counting }
TimeStr : TimeString; { clock parameters }
ClockProc : Procedure; { which clock to use }
NoClock : Procedure; { how to turn it off }
LogOnTime : DateTimeRec; { time program began }
{ ========================================================================= }
{ Clock Sounds ============================================================ }
PROCEDURE Chimes;
PROCEDURE TickTock;
{ Time Functions ========================================================== }
PROCEDURE TimeToggle; { flips ClockFlag }
FUNCTION PcTime : TimeString; { '10:36:09 pm' }
FUNCTION ClockTime : TimeString; { '10:36 pm' }
FUNCTION ShortTime : TimeString; { '10:36p' }
FUNCTION MilitaryTime : TimeString; { '22:36' }
{ Date Functions ---------------------------------------------------------- }
FUNCTION DayOfTheWeek (D : Date) : TimeString; { returns 'Sunday' }
FUNCTION DayOfTheWeek3 (D : Date) : TimeString; { returns 'Sun' }
FUNCTION PcDate : TimeString; { '01-Apr-90' }
FUNCTION StarDate : TimeString; { '9004.01' }
FUNCTION LogDate : TimeString; { 'Apr 1, 1990' }
FUNCTION FormalDate : DateString; { 'April 5, 1988' }
FUNCTION FullDate : DateString; { 'Tuesday, March 5, 1988' }
FUNCTION TimeStamp : DateString; { 'Tue, Mar-05-88, 11:01p' }
FUNCTION DateTimeToSortString (D : Date; T : Time) : DateString;
{ Time Display Procedures ------------------------------------------------- }
PROCEDURE ShowClock;
PROCEDURE ShowTimeString (S : DateString);
PROCEDURE ShowTime;
PROCEDURE ShowTimeStamp;
PROCEDURE ShowToday;
{ Parsing functions ------------------------------------------------------- }
FUNCTION ParseDate (S : string) : Date;
{ Parses a date out of a string. }
FUNCTION ParseBirthday (S : string) : Date;
{ Parses a date out of a string. }
{ Implementation ========================================================== }
IMPLEMENTATION
{ ========================================================================= }
{ Declarations ============================================================ }
CONST
ShowTimeLen : byte = 0; { len of ShowTime string }
BeepFlag : boolean = true;
{
The BeepFlag is to insure that the Chimes procedure only beeps once per
hour. Otherwise, the routine might be called several times, resulting
in a one-second burst of sound.
}
{ Chimes ================================================================== }
PROCEDURE Chimes;
BEGIN
if { if }
(CurrentTime mod 3600 = 0) { hour and flag }
and
BeepFlag
then begin { then }
BeepBeep; { make noise }
BeepFlag := false; { turn flag off }
end;
if { if }
CurrentTime mod 3600 <> 0 { not hour }
then
BeepFlag := true; { turn flag on }
END;
{ TickTock ================================================================ }
PROCEDURE TickTock;
PROCEDURE MakeTick;
{ alternates ticking and tocking }
CONST
Tick = 440;
Tock = 880;
TickFreq : word = Tick;
BEGIN
if not Sfx (SfxCues) then exit;
Sound (TickFreq);
Delay (2);
NoSound;
if TickFreq = Tock then
TickFreq := Tick
else
TickFreq := Tock;
END;
BEGIN
if
(CurrentTime < TimeCheck) { or midnight has passed }
then
TimeCheck := CurrentTime; { reset time }
if CurrentTime > TimeCheck then begin { time to ticktock? }
MakeTick;
TimeCheck := CurrentTime;
end;
END;
{ TimeToggle ============================================================== }
PROCEDURE TimeToggle;
BEGIN
ClockFlag := not ClockFlag;
If not ClockFlag then
NoClock;
END;
{ PcTime ================================================================== }
FUNCTION PcTime : TimeString; { '10:36:09 pm' }
BEGIN
PcTime := CurrentTimeString (PcTimeStr);
END;
{ ClockTime =============================================================== }
FUNCTION ClockTime : TimeString; { '10:36 pm' }
BEGIN
ClockTime := CurrentTimeString (ClockTimeStr);
END;
{ ShortTime =============================================================== }
FUNCTION ShortTime : TimeString; { '9:07p' }
BEGIN
ShortTime := CurrentTimeString (ShortTimeStr);
END;
{ MilitaryTime ============================================================ }
FUNCTION MilitaryTime : TimeString; { '21:07' }
BEGIN
MilitaryTime := CurrentTimeString (MilitaryTimeStr);
END;
{ DayOfTheWeek ============================================================ }
FUNCTION DayOfTheWeek (D : Date) : TimeString; { returns 'Tuesday' }
BEGIN
DayOfTheWeek := DayString [DayOfWeek (D)];
END;
{ DayOfTheWeek3 =========================================================== }
FUNCTION DayOfTheWeek3 (D : Date) : TimeString; { returns 'Tue' }
BEGIN
DayOfTheWeek3 := Copy (DayOfTheWeek (D), 1, 3);
END;
{ PcDate ================================================================== }
FUNCTION PcDate : TimeString; { '05-Mar-88' }
BEGIN
PcDate := DateToDateString ('dd-nnn-yy', Today);
END;
{ StarDate ================================================================ }
FUNCTION StarDate : TimeString; { '8803.05' }
BEGIN
StarDate := DateToDateString ('yymm.dd', Today);
END;
{ LogDate ================================================================= }
FUNCTION LogDate : TimeString; { 'Mar 5, 1988' }
BEGIN
LogDate := DateToDateString ('nnn ', Today) +
TrimLead (DateToDateString ('DD, yyyy', Today));
END;
{ FormalDate ============================================================== }
FUNCTION FormalDate : DateString; { 'March 5, 1988' }
BEGIN
FormalDate := TrimTrail (DateToDateString ('nnnnnnnnn', Today)) + ' ' +
TrimLead (DateToDateString ('DD, yyyy', Today));
END;
{ FullDate ================================================================ }
FUNCTION FullDate : DateString; { 'Tuesday, March 5, 1988' }
BEGIN
FullDate := DayOfTheWeek (Today) + ', ' + FormalDate;
END;
{ TimeStamp =============================================================== }
FUNCTION TimeStamp : DateString; { 'Tue, Mar-05-88, 11:01p' }
BEGIN
TimeStamp := DayOfTheWeek3 (Today) + ', ' +
DateToDateString ('nnn-dd-yy, ', Today) +
CurrentTimeString ('hh:mmt');
END;
{ DateTimeToSortString ==================================================== }
FUNCTION DateTimeToSortString (D : Date; T : Time) : DateString;
{ for database programs }
BEGIN
DateTimeToSortString := DateToSortString (D) + TimeToSortString (T);
END;
{ ShowClock =============================================================== }
PROCEDURE ShowClock;
{
Beeps on the hour, if FxBeep byte is set in FxOptions.
Calls procedure stored in ClockProc variable to display time on screen.
User can substitute his own display function by assigning a new
procedure to ClockProc:
ClockProc := MyProcedure;
}
BEGIN
if not ClockFlag then exit; { no clock }
ClockProc; { show time on screen }
Chimes;
END;
{ EraseTimeString ========================================================= }
{$F+} PROCEDURE EraseTimeString; {$F-}
{ erases time or date from screen }
BEGIN
FastFlushAbs (CharStr (' ', ShowTimeLen), 1, ColorMono (CkColor, CkMono));
END;
{ ShowTimeString ========================================================== }
{$F+} PROCEDURE ShowTimeString (S : DateString); {$F-}
{ shows user-formatted time or date }
VAR
Len : byte absolute S;
BEGIN
ShowTimeLen := Len;
FastFlushAbs (S, 1, ColorMono (CkColor, CkMono));
END;
{ ShowTime ================================================================ }
{$F+} PROCEDURE ShowTime; {$F-}
{ shows PcTime on screen }
BEGIN
ShowTimeString (CurrentTimeString (TimeStr));
END;
{ ShowTimeStamp =========================================================== }
{$F+} PROCEDURE ShowTimeStamp; {$F-}
{ Puts time and date in the upper right corner of the screen on 1 line }
BEGIN
ShowTimeString (DayOfTheWeek3 (Today) + ' ' +
DateToDateString ('mm-dd-yy, ', Today) +
CurrentTimeString ('HH:mm:sst'));
END;
{ ShowToday =============================================================== }
{$F+} PROCEDURE ShowToday; {$F-}
{ Puts time and date in the upper right corner of the screen on 2 lines }
BEGIN
FastFlushAbs (LogDate, 1, ColorMono (CkColor, CkMono));
FastFlushAbs (PcTime, 2, ColorMono (CkColor, CkMono));
END;
{ ParseMonth ============================================================== }
FUNCTION ParseMonth (VAR S : DateString) : byte;
{ If S contains month name, returns month number, else returns first number }
VAR
Loop : word;
BEGIN
ParseMonth := 0;
S := StUpCase (S);
Loop := 1;
While { look for month }
(Pos (StUpCase (Copy (MonthString [Loop], 1, 3)), S) = 0)
and
(Loop < 13) { as a string }
do
inc (Loop);
If Loop > 12 then { else }
Loop := ExtractFirstNumber (S); { get month as number }
If Loop < 13 then
ParseMonth := Loop;
END;
{ ParseDate =============================================================== }
FUNCTION ParseDate (S : string) : Date;
{ Parses a date out of a string. }
VAR
M, D, Y : integer;
BEGIN
M := ParseMonth (S); { get month }
D := ExtractFirstNumber (S); { get day }
Y := ExtractFirstNumber (S); { get year }
If ContainsNumber (S) then { if still more numbers }
{ then it's invalid }
ParseDate := BadDate
else
ParseDate := DMYtoDate (D, M, Y);
END;
{ ParseBirthday =========================================================== }
FUNCTION ParseBirthday (S : string) : Date;
{ Parses a date out of a string. }
VAR
D : Date;
BEGIN
D := ParseDate (S); { get date }
If D > Today then
D := IncDateTrunc (D, 0, -100); { check for century }
ParseBirthday := D;
END;
{ ========================================================================= }
{ Initialization ========================================================== }
BEGIN
{
Initialize the ClockProc variable; tell it which clock display procedure
to use. Log what time the program started.
}
TimeStr := PcTimeStr;
ClockProc := ShowTime;
NoClock := EraseTimeString;
TimeCheck := CurrentTime; { initialize variable }
LogOnTime.T := CurrentTime; { what time did we start? }
LogOntime.D := Today; { what day is today? }
END.
{ ========================================================================= }
{ DgDate History ========================================================== }
VERSION HISTORY:
9005.05
Completely restructured for consistency with Object Professional.
9005.06
Added TimeToggle and NoClock procedures.
{ DgTime Needs ============================================================ }
NEED TO ADD:
Can't think of anything ....
{ Bug Reports ============================================================= }
BUGS:
Don't be silly.
{ ========================================================================= }
{ ========================================================================= }
