IMPLEMENTATION MODULE TimeAndDate;
(*
        Title:          Time and Date routines.
        Author:         D.R.Lamkin.
        History:
           03 Jul 84   Initial Version
           10 Aug 84   Type errorcode to mod Errors
           24 Aug 84   X Variants added.
           30 Aug 84   Declare Procedure etc removed.
           30 Aug 84   InstallPANOSHandler added.
           31 Aug 84   Remove references to Strings.
           24 Sep 84   New Error routine
           08 Oct 84   X  procs use SystemSignal
*)


(*
   These routine support two different string formats for the time:
      Textual:   "16 May 84 20:54:19"
      Standard:  "1985-02-17 09:57:15.21"
*)



FROM SYSTEM IMPORT ADR, TKCALL;

FROM TKCalls IMPORT TKword;

FROM Error IMPORT TimeFacilityErrors, ErrorCode, Facility;

FROM Utils IMPORT Capitalize;

FROM String IMPORT CopyCC, CopyLC, LengthC, ExtractCC ;

FROM Handler IMPORT InstallPANOSHandler, SystemSignal;

IMPORT Debug;

TYPE TIME = RECORD
               Year         : CARDINAL;
               Month        : CARDINAL;
               Day          : CARDINAL;
               Hour         : CARDINAL;
               Minute       : CARDINAL;
               Second       : CARDINAL;
               CentiSecond  : CARDINAL
            END;




CONST low=0; high=1;
      secondsperminute = 60;
      minutesperhour = 60;
      tickspersecond = 100;        (* The BBC clock tick *)
      ticksperday = tickspersecond*60*60*24;
      ticks256perday = ticksperday DIV 256;   (* Fortunatly an integer ! *)
      daysPer4Years = 1461;




VAR dmonth: ARRAY [1 .. 12] OF CARDINAL;
    monthstrings: ARRAY [0 .. 12*3] OF CHAR;




(* ========================================================================= *)

PROCEDURE Version( VAR String : ARRAY OF CHAR ) ;
BEGIN
   CopyLC( "TimeAndDate     0.01/16  03 Dec 84 10:29:43" , String ) ;
END Version ;

(* ------------------------------------------------------------------------- *)

PROCEDURE TimeError (code : TimeFacilityErrors) : INTEGER;

BEGIN

RETURN ErrorCode (TimeFacility, ORD (code), "")

END TimeError;




(* ------------------------------------------------------------------------- *)

PROCEDURE Plant2 (VAR v: ARRAY OF CHAR; i: CARDINAL; val: CARDINAL);

VAR f: CARDINAL;

BEGIN

IF val>9 THEN
   f := val DIV 10;
   val := val MOD 10;
ELSE
   f := 0;
END;

v[i] := CHAR(ORD('0') + f);
v[i+1] := CHAR(ORD('0') + val);

END Plant2;




(* ------------------------------------------------------------------------- *)

PROCEDURE Get2 (v: ARRAY OF CHAR; i: CARDINAL; VAR res : CARDINAL)
                                                  : BOOLEAN;

   PROCEDURE IsDigit (c : CHAR) : BOOLEAN;

   BEGIN
   RETURN ("0" <= c) AND (c <= "9")

   END IsDigit;



BEGIN

IF IsDigit (v [i]) AND IsDigit (v [i+1]) THEN
   res := (ORD (v [i]) - ORD ("0")) * 10 + (ORD (v [i+1]) - ORD ("0"));
   RETURN TRUE
ELSE
   RETURN FALSE
END;


END Get2;




(* ------------------------------------------------------------------------- *)

PROCEDURE ValidTimeStamp (ts : TimeStamp) : BOOLEAN;
(* Carry out simple check on the TS, return TRUE if it looks OK *)

VAR time : TIME;

BEGIN

(* We look to see if the year is >= 84 *)

GetTime ( ts, time);

RETURN (time.Year >= 84) AND (time.Year <= 99)

END ValidTimeStamp;




(* ------------------------------------------------------------------------- *)

PROCEDURE ValidTime (tim : TIME) : BOOLEAN;


VAR daysinmonth : CARDINAL;


BEGIN

WITH tim DO

   IF (0 < Month) AND (Month <= 12) THEN
      daysinmonth := dmonth [Month];
      IF ((Year MOD 4) = 0) AND (Month = 2) THEN
         daysinmonth := daysinmonth + 1
      END;
   END;


   RETURN (Year >= 4)                   AND
          (Year <= 99)                  AND
          (0 < Month) AND (Month <= 12) AND
          (Day <= daysinmonth)          AND
          (Hour <24 )                   AND
          (Minute < 60)                 AND
          (Second < 60)                 AND
          (CentiSecond < 100)
END


END ValidTime;



(* ------------------------------------------------------------------------- *)

PROCEDURE ReadBBCTime(VAR t: TimeStamp);


VAR rc: INTEGER;

BEGIN

t.MS := 0;  (* ensure high order bytes are zero *)
rc := TKCALL(TKword, 1, ADR(t));

END ReadBBCTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE SetBBCTime(t: TimeStamp);


VAR rc: INTEGER;

BEGIN

rc := TKCALL(TKword, 2, ADR(t));

END SetBBCTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE GetTime(SYSTime : TimeStamp; VAR tim : TIME);

VAR ticks, daysSince1904, secsToday : CARDINAL;
    yr, mth, dy: CARDINAL;

BEGIN

ticks     := (SYSTime.LS DIV 256) + (SYSTime.MS *65536*256);
secsToday := (((ticks MOD ticks256perday)*256) +
             (SYSTime.LS MOD 256)) DIV tickspersecond;

(* Fill in the easier fields in the time record *)

WITH tim DO
   Hour        := (secsToday DIV secondsperminute) DIV minutesperhour;
   Minute      := (secsToday DIV secondsperminute) MOD minutesperhour;
   Second      := secsToday MOD secondsperminute;
   CentiSecond := ((SYSTime.MS MOD 100) * 96+(SYSTime.LS MOD 100)) MOD 100
                           (* ie (MS*2^32+LS) MOD 100 *)
END;

       (* 1900 was not a leap year, so avoid it *)

IF (ticks DIV ticks256perday) < daysPer4Years THEN
   daysSince1904 := 0
ELSE
   daysSince1904 := (ticks DIV ticks256perday) - daysPer4Years + 1;
END;

dy := daysSince1904+1;  (* from a base of 1 *)

(*  Groups of 4 years - 3 ordinary + 1 leap.*)
yr := 4 + 4 * (daysSince1904 DIV daysPer4Years);
dy := dy MOD daysPer4Years;

(*  Single years. *)
LOOP
   IF (yr MOD 4) = 0 THEN
      IF dy > 366 THEN
         dy := dy - 366
      ELSE
         EXIT
      END
   ELSE
      IF dy > 365 THEN
         dy := dy - 365
      ELSE
         EXIT
      END
   END;
   yr := yr + 1
END;

(*  Months. *)
mth := 1;
LOOP
   IF mth = 2 THEN
      IF (yr MOD 4) = 0 THEN  
                    (* Leap February. *)
         IF dy > 29 THEN
            dy := dy - 29
         ELSE
            EXIT
         END
      ELSE
         IF dy > 28 THEN
            dy := dy - 28
         ELSE
            EXIT
         END
      END
   ELSE
      IF dy > dmonth[mth] THEN
         dy := dy - dmonth[mth]
      ELSE
         EXIT
      END
   END;
   mth := mth + 1
END;

(* Put the calculated fields into the time record *)

WITH tim DO
   Year  := yr;
   Month := mth;
   Day   := dy
END


END GetTime;





(* ------------------------------------------------------------------------- *)

PROCEDURE PutTime (tim : TIME; VAR ts : TimeStamp);

VAR dayssince1904 : CARDINAL;
    dayssince1900 : CARDINAL;
    dayssincelastleap : CARDINAL;
    yearssincelastleap : CARDINAL;
    ticks256 : CARDINAL;
    centisecs : CARDINAL;
    i : CARDINAL;

BEGIN

WITH tim DO

   dayssince1904      := ((Year-4) DIV 4) * daysPer4Years;
   yearssincelastleap := ((Year-4) MOD 4);
   IF yearssincelastleap > 0 THEN
      INC (dayssince1904)
   END;
   dayssince1904 := dayssince1904 + yearssincelastleap * 365;


   (* Now work out the days for current year *)
   FOR i := 1 TO Month-1 DO
      dayssince1904 := dayssince1904 + dmonth[i]
   END;

   IF (yearssincelastleap = 0) AND (Month > 2) THEN
      INC (dayssince1904)
   END;

   dayssince1904 := dayssince1904 + Day - 1;

   dayssince1900 := dayssince1904 + daysPer4Years - 1; (* 1900 not leap *)
   
   centisecs := ((Hour*minutesperhour + Minute)*secondsperminute +
                  Second) * 100 + CentiSecond;
   ticks256  := (dayssince1900 * ticks256perday) + (centisecs DIV 256);

   ts.MS := ticks256 DIV (65536*256);
   ts.LS := ((ticks256 MOD (65536*256)) * 256) + (centisecs MOD 256)

END;


END PutTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE BinaryTime (VAR ts : TimeStamp) : INTEGER;

(*
   Return the binary time in the supplied timestamp record
*)

VAR res : INTEGER;

BEGIN

ReadBBCTime (ts); (* Read the BBC timer *)

IF NOT ValidTimeStamp (ts) THEN
   res := TimeError (TimeNotSet)
ELSE
   res := 0
END;

RETURN res

END BinaryTime;



(* ------------------------------------------------------------------------- *)

PROCEDURE SetBinaryTime (ts : TimeStamp) : INTEGER;

(*
   Set the system time from the timestamp
*)

VAR res : INTEGER;

BEGIN

IF NOT ValidTimeStamp (ts) THEN
   res := TimeError (InvalidBinaryTime)
ELSE
   SetBBCTime (ts);
   res := 0
END;

RETURN res

END SetBinaryTime;



(* ------------------------------------------------------------------------- *)

PROCEDURE BinaryTimeOfStandardTime (VAR ts : TimeStamp;
                                    stime : ARRAY OF CHAR) : INTEGER;

(*
   Convert the given standard time into a timestamp.
*)

VAR tim : TIME;
    century : CARDINAL;

BEGIN

(* First get the time into a time record *)

IF (LengthC (stime) < 22)                OR
   NOT Get2 (stime,  0, century)         OR
   NOT (century = 19)                    OR
   NOT Get2 (stime,  2, tim.Year)        OR
   NOT Get2 (stime,  5, tim.Month)       OR
   NOT Get2 (stime,  8, tim.Day)         OR
   NOT Get2 (stime, 11, tim.Hour)        OR
   NOT Get2 (stime, 14, tim.Minute)      OR
   NOT Get2 (stime, 17, tim.Second)      OR
   NOT Get2 (stime, 20, tim.CentiSecond) OR
   NOT ValidTime (tim) THEN

   RETURN TimeError (BadTimeString)

ELSE

   PutTime (tim, ts);
   RETURN 0

END;
   

END BinaryTimeOfStandardTime;



(* ------------------------------------------------------------------------- *)

PROCEDURE BinaryTimeOfTextualTime (VAR ts : TimeStamp;
                                   ttime : ARRAY OF CHAR) : INTEGER;

(*
   Convert the given textual time into a timestamp.
*)

    PROCEDURE GetMonth(s:ARRAY OF CHAR;i:CARDINAL;VAR month:CARDINAL):BOOLEAN;

    VAR found : BOOLEAN;
        k   : CARDINAL;

    BEGIN

       month := 0;
       found := FALSE;
       Capitalize (s);
       WHILE (month <= 11) AND NOT found DO
          found := TRUE;
          FOR k := 0 TO 2 DO
             found := found AND (CAP (monthstrings[month*3+k]) = s[i+k])
          END;
          INC (month);
       END;

       RETURN found

    END GetMonth;

VAR tim : TIME;

BEGIN

tim.CentiSecond := 0;

(* Get the time into a time record *)

IF (LengthC (ttime) < 18)                OR
   NOT Get2 (ttime,  0, tim.Day)         OR
   NOT GetMonth (ttime, 3, tim.Month)    OR
   NOT Get2 (ttime,  7, tim.Year)        OR
   NOT Get2 (ttime, 10, tim.Hour)        OR
   NOT Get2 (ttime, 13, tim.Minute)      OR
   NOT Get2 (ttime, 16, tim.Second)      OR
   NOT ValidTime (tim) THEN

   RETURN TimeError (BadTimeString)

ELSE

   PutTime (tim, ts);
   RETURN 0

END;

END BinaryTimeOfTextualTime;


(* ------------------------------------------------------------------------- *)

PROCEDURE StandardTimeOfBinaryTime (VAR stime       : ARRAY OF CHAR;
                                    VAR stimelength : CARDINAL;
                                    ts              : TimeStamp) : INTEGER;

(*
   Convert the given timestamp into a standard time string
   e.g. "1985-02-17 11:23:12.14"
*)

VAR timestring : ARRAY [0..21] OF CHAR;
    time       : TIME;

BEGIN

IF NOT ValidTimeStamp (ts) THEN
   RETURN TimeError (InvalidBinaryTime)
END;

GetTime (ts, time);

(* Set up the format of the string *)

CopyLC ("1985-02-17 11:23:12.14", timestring);

(* Plant in particular values *)

Plant2 (timestring,  0, 19);
Plant2 (timestring,  2, time.Year);
Plant2 (timestring,  5, time.Month);
Plant2 (timestring,  8, time.Day);
Plant2 (timestring, 11, time.Hour);
Plant2 (timestring, 14, time.Minute);
Plant2 (timestring, 17, time.Second);
Plant2 (timestring, 20, time.CentiSecond);

CopyCC (timestring, stime);
stimelength := LengthC (stime);

RETURN 0


END StandardTimeOfBinaryTime;



(* ------------------------------------------------------------------------- *)

PROCEDURE TextualTimeOfBinaryTime (VAR stime       : ARRAY OF CHAR;
                                   VAR stimelength : CARDINAL;
                                   ts              : TimeStamp) : INTEGER;

(*
   Convert the given timestamp into a textual time string
     e.g. "16 May 84 20:54:19"
*)

VAR timestring : ARRAY [0..17] OF CHAR;
    time       : TIME;
    i,mx       : CARDINAL;

BEGIN

IF NOT ValidTimeStamp (ts) THEN
   RETURN TimeError (InvalidBinaryTime)
END;

GetTime (ts, time);

(* Set up the format of the string *)

CopyLC ("16 May 84 20:54:19", timestring);
(* Plant in particular values *)

Plant2 (timestring,  0, time.Day);

mx := (time.Month-1)*3;
FOR i := 0 TO 2 DO
   timestring [3+i] := monthstrings [mx+i]
END;
Plant2 (timestring,  7, time.Year);
Plant2 (timestring, 10, time.Hour);
Plant2 (timestring, 13, time.Minute);
Plant2 (timestring, 16, time.Second);

CopyCC (timestring, stime);
stimelength := LengthC (stime);

RETURN 0

END TextualTimeOfBinaryTime;



(* ------------------------------------------------------------------------- *)

PROCEDURE Time (VAR thetime : ARRAY OF CHAR;
                VAR length  : CARDINAL) : INTEGER;

(*
   Return the time portion of the textual format of the current time
*)
VAR timestring : ARRAY [0..17] OF CHAR;
    time       : TIME;
    ts         : TimeStamp;
    res        : INTEGER;
    tlength    : CARDINAL;

BEGIN

res := BinaryTime (ts);

IF res >= 0 THEN
   res := TextualTimeOfBinaryTime (timestring, tlength, ts);
   ExtractCC (timestring, 10, 18, thetime);
   length := LengthC (thetime);
END;

RETURN res

END Time;



(* ------------------------------------------------------------------------- *)

PROCEDURE StandardTime (VAR thetime : ARRAY OF CHAR;
                        VAR length  : CARDINAL) : INTEGER;

(*
   Return the current time in standard format
*)

VAR ts         : TimeStamp;
    res        : INTEGER;

BEGIN

res := BinaryTime (ts);

IF res >= 0 THEN
   res := StandardTimeOfBinaryTime (thetime, length, ts);
END;

RETURN res

END StandardTime;



(* ------------------------------------------------------------------------- *)

PROCEDURE Date (VAR thedate : ARRAY OF CHAR;
                VAR length  : CARDINAL) : INTEGER;

(*
   Returns the date portion of current time in textual format
*)

VAR timestring : ARRAY [0..17] OF CHAR;
    time       : TIME;
    ts         : TimeStamp;
    res        : INTEGER;
    tlength    : CARDINAL;

BEGIN

res := BinaryTime (ts);

IF res >= 0 THEN
   res := TextualTimeOfBinaryTime (timestring, tlength, ts);
   ExtractCC (timestring, 0, 9, thedate);
   length := LengthC (thedate);
END;

RETURN res


END Date;



(* ------------------------------------------------------------------------- *)

PROCEDURE TimeAndDate (VAR thetimeanddate : ARRAY OF CHAR;
                       VAR length         : CARDINAL) : INTEGER;

(*
   Returns current time and date in textual format
*)


VAR timestring : ARRAY [0..17] OF CHAR;
    time       : TIME;
    ts         : TimeStamp;
    res        : INTEGER;
    tlength    : CARDINAL;

BEGIN

res := BinaryTime (ts);

IF res >= 0 THEN
   res := TextualTimeOfBinaryTime (timestring, tlength, ts);
   CopyCC (timestring, thetimeanddate);
   length := LengthC (thetimeanddate);
END;

RETURN res


END TimeAndDate;




(* ========================================================================= *)





PROCEDURE XBinaryTime (VAR ts : TimeStamp);

VAR res : INTEGER;
BEGIN

res := BinaryTime (ts);
IF res < 0 THEN
   SystemSignal (res, 1)
ELSE
   RETURN
END

END XBinaryTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE XSetBinaryTime (ts : TimeStamp);

VAR res : INTEGER;
BEGIN

res := SetBinaryTime (ts);
IF res < 0 THEN
   SystemSignal (res, 1)
ELSE
   RETURN
END

END XSetBinaryTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE XBinaryTimeOfStandardTime (VAR ts : TimeStamp;
                                     stime : ARRAY OF CHAR );

VAR res : INTEGER;
BEGIN

res := BinaryTimeOfStandardTime (ts, stime);
IF res < 0 THEN
   SystemSignal (res, 3)
ELSE
   RETURN
END

END XBinaryTimeOfStandardTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE XBinaryTimeOfTextualTime (VAR ts : TimeStamp;
                                    ttime : ARRAY OF CHAR );

VAR res : INTEGER;
BEGIN

res := BinaryTimeOfTextualTime (ts, ttime);
IF res < 0 THEN
   SystemSignal (res, 3)
ELSE
   RETURN
END

END XBinaryTimeOfTextualTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE XStandardTimeOfBinaryTime (VAR stime       : ARRAY OF CHAR;
                                     ts              : TimeStamp) : CARDINAL;

VAR res : INTEGER;
    stimelength : CARDINAL;
BEGIN

res := StandardTimeOfBinaryTime (stime, stimelength, ts);
IF res < 0 THEN
   SystemSignal (res, 3)
ELSE
   RETURN stimelength
END

END XStandardTimeOfBinaryTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE XTextualTimeOfBinaryTime (VAR stime       : ARRAY OF CHAR;
                                    ts              : TimeStamp) : CARDINAL;

VAR res : INTEGER;
    stimelength : CARDINAL;

BEGIN

res := TextualTimeOfBinaryTime (stime, stimelength, ts);
IF res < 0 THEN
   SystemSignal (res, 3)
ELSE
   RETURN stimelength
END

END XTextualTimeOfBinaryTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE XTime (VAR thetime : ARRAY OF CHAR) : CARDINAL;

VAR res : INTEGER;
    length  : CARDINAL;
BEGIN

res := Time (thetime, length);
IF res < 0 THEN
   SystemSignal (res, 2)
ELSE
   RETURN length
END

END XTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE XStandardTime (VAR thetime : ARRAY OF CHAR) : CARDINAL;

VAR res : INTEGER;
    length  : CARDINAL;
BEGIN

res := StandardTime (thetime, length);
IF res < 0 THEN
   SystemSignal (res, 2)
ELSE
   RETURN length
END

END XStandardTime;




(* ------------------------------------------------------------------------- *)

PROCEDURE XDate (VAR thedate : ARRAY OF CHAR) : CARDINAL;

VAR res : INTEGER;
    length  : CARDINAL;

BEGIN

res := Date (thedate, length);
IF res < 0 THEN
   SystemSignal (res, 2)
ELSE
   RETURN length
END

END XDate;




(* ------------------------------------------------------------------------- *)

PROCEDURE XTimeAndDate (VAR thetimeanddate : ARRAY OF CHAR) : CARDINAL;

VAR res : INTEGER;
    length : CARDINAL;
BEGIN

res := TimeAndDate (thetimeanddate, length);
IF res < 0 THEN
   SystemSignal (res, 2)
ELSE
   RETURN length
END

END XTimeAndDate;



(* ------------------------------------------------------------------------- *)

BEGIN

monthstrings := "JanFebMarAprMayJunJulAugSepOctNovDec";

dmonth[1]  := 31;   dmonth[2]  := 28;   dmonth[3]  := 31;
dmonth[4]  := 30;   dmonth[5]  := 31;   dmonth[6]  := 30;
dmonth[7]  := 31;   dmonth[8]  := 31;   dmonth[9]  := 30;
dmonth[10] := 31;   dmonth[11] := 30;   dmonth[12] := 31;

InstallPANOSHandler();

                                            
END TimeAndDate.