Simtel MSDOS - Coast to Coast/simteldosarchivecoasttocoast.iso/pcmag/vol9n21.zip/DGDATE.PAS

Pascal/Delphi Source File | 1990-09-25 | 16KB | 484 lines

{
 ▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄
 █                                                                         █
 █        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.

{ ========================================================================= }
{ ========================================================================= }