Unit TCDate;

  { Author: Trevor J Carlsen  Released into the public domain }
  {         PO Box 568                                        }
  {         Port Hedland                                      }
  {         Western Australia 6721                            }
  {         Voice +61 91 732 026                              }

Interface

Uses Dos;

Type
  Date          = Word;
  UnixTimeStamp = LongInt;

Const
  WeekDays   : Array[0..6] of String[9] =
               ('Sunday','Monday','Tuesday','Wednesday','Thursday',
                'Friday','Saturday');
  months     : Array[1..12] of String[9] =
               ('January','February','March','April','May','June','July',
                'August','September','October','November','December');

Function DayofTheWeek(pd : date): Byte;
 { Returns the day of the week For any date  Sunday = 0 .. Sat = 6    }
 { pd = a packed date as returned by the Function PackedDate          }
 { eg...  Writeln('today is ',WeekDays[DayofTheWeek(today))];         }

Function PackedDate(yr,mth,d: Word): date;
 { Packs a date into a Word which represents the number of days since }
 { Dec 31,1899   01-01-1900 = 1                                       }

Function UnixTime(yr,mth,d,hr,min,sec: Word): UnixTimeStamp;
 { Packs a date and time into a four Byte unix style Variable which   }
 { represents the number of seconds that have elapsed since midnight  }
 { on Jan 1st 1970.                                                   }

Procedure UnPackDate(Var yr,mth,d: Word; pd : date);
 { Unpacks a Word returned by the Function PackedDate into its        }
 { respective parts of year, month and day                            }

Procedure UnPackUnix(Var yr,mth,d,hr,min,sec: Word; uts: UnixTimeStamp);
 { Unpacks a UnixTimeStamp Variable into its Component parts.         }

Function DateStr(pd: date; Format: Byte): String;
 { Unpacks a Word returned by the Function PackedDate into its        }
 { respective parts of year, month and day and then returns a String  }
 { Formatted according to the specifications required.                }
 { if the Format is > 9 then the day of the week is prefixed to the   }
 { returned String.                                                   }
 { Formats supported are:                                             }
 {     0:  dd/mm/yy                                                   }
 {     1:  mm/dd/yy                                                   }
 {     2:  dd/mm/yyyy                                                 }
 {     3:  mm/dd/yyyy                                                 }
 {     4:  [d]d xxx yyyy   (xxx is alpha month of 3 Chars)            }
 {     5:  xxx [d]d, yyyy                                             }
 {     6:  [d]d FullAlphaMth yyyy                                     }
 {     7:  FullAlphaMth [d]d, yyyy                                    }
 {     8:  [d]d-xxx-yy                                                }
 {     9:  xxx [d]d, 'yy                                              } 
 
Function ValidDate(yr,mth,d : Word; Var errorcode : Byte): Boolean;
 { Validates the date and time data to ensure no out of range errors  }
 { can occur and returns an error code to the calling Procedure. A    }
 { errorcode of zero is returned if no invalid parameter is detected. }
 { Errorcodes are as follows:                                         }

 {   Year out of range (< 1901 or > 2078) bit 0 of errorcode is set.  }
 {   Month < 1 or > 12                    bit 1 of errorcode is set.  }
 {   Day < 1 or > 31                      bit 2 of errorcode is set.  }
 {   Day out of range For month           bit 2 of errorcode is set.  }

Procedure ParseDateString(Var dstr; Var y,m,d : Word; Format : Byte);
 { Parses a date String in several Formats into its Component parts   }
 { It is the Programmer's responsibility to ensure that the String    }
 { being parsed is a valid date String in the Format expected.        }
 { Formats supported are:                                             }
 {     0:  dd/mm/yy[yy]                                               }
 {     1:  mm/dd/yy[yy]                                               } 

Function NumbofDaysInMth(y,m : Word): Byte;
 { returns the number of days in any month                            }

Function IncrMonth(pd: date; n: Word): date;
 { Increments pd by n months.                                         }

Function today : date;
 { returns the number of days since 01-01-1900                        }

Function ordDate (Y,M,D : Word):LongInt; { returns ordinal Date yyddd }

Function Dateord (S : String) : String;    { returns Date as 'yymmdd' }



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

Implementation

 Const
  TDays       : Array[Boolean,0..12] of Word =
                ((0,31,59,90,120,151,181,212,243,273,304,334,365),
                (0,31,60,91,121,152,182,213,244,274,305,335,366));
  UnixDatum   = LongInt(25568);
  SecsPerDay  = 86400;
  SecsPerHour = LongInt(3600);
  SecsPerMin  = LongInt(60);
  MinsPerHour = 60;

Function DayofTheWeek(pd : date): Byte;
  begin
    DayofTheWeek := pd mod 7;
  end; { DayofTheWeek }

Function PackedDate(yr,mth,d : Word): date;
  { valid For all years 1901 to 2078                                  }
  Var
    temp  : Word;
    lyr   : Boolean;
  begin
    lyr   := (yr mod 4 = 0);
    if yr >= 1900 then
      dec(yr,1900);
    temp  := yr * Word(365) + (yr div 4) - ord(lyr);
    inc(temp,TDays[lyr][mth-1]);
    inc(temp,d);
    PackedDate := temp;
  end;  { PackedDate }

Function UnixTime(yr,mth,d,hr,min,sec: Word): UnixTimeStamp;
  { Returns the number of seconds since 00:00 01/01/1970 }
  begin
    UnixTime := SecsPerDay * (PackedDate(yr,mth,d) - UnixDatum) +
                SecsPerHour * hr + SecsPerMin * min + sec;
  end;  { UnixTime }

Procedure UnPackDate(Var yr,mth,d: Word; pd : date);
  { valid For all years 1901 to 2078                                  }
  Var
    julian : Word;
    lyr    : Boolean;
  begin
    d      := pd;
    yr     := (LongInt(d) * 4) div 1461;
    julian := d - (yr * 365 + (yr div 4));
    inc(yr,1900);
    lyr    := (yr mod 4 = 0);
    inc(julian,ord(lyr));
    mth    := 0;
    While julian > TDays[lyr][mth] do
      inc(mth);
    d      := julian - TDays[lyr][mth-1];
  end; { UnPackDate }

Procedure UnPackUnix(Var yr,mth,d,hr,min,sec: Word; uts: UnixTimeStamp);
  Var
    temp : UnixTimeStamp;
  begin
    UnPackDate(yr,mth,d,date(uts div SecsPerDay) + UnixDatum);
    temp   := uts mod SecsPerDay;
    hr     := temp div SecsPerHour;
    min    := (temp mod SecsPerHour) div MinsPerHour;
    sec    := temp mod SecsPerMin;
  end;  { UnPackUnix }

Function DateStr(pd: date; Format: Byte): String;

  Var
    y,m,d    : Word;
    YrStr    : String[5];
    MthStr   : String[11];
    DayStr   : String[8];
    TempStr  : String[5];
  begin
    UnpackDate(y,m,d,pd);
    str(y,YrStr);
    str(m,MthStr);
    str(d,DayStr);
    TempStr := '';
    if Format > 9 then 
      TempStr := copy(WeekDays[DayofTheWeek(pd)],1,3) + ' ';
    if (Format mod 10) < 4 then begin
      if m < 10 then 
        MthStr := '0'+MthStr;
      if d < 10 then
        DayStr := '0'+DayStr;
    end;
    Case Format mod 10 of  { Force Format to a valid value }
      0: DateStr := TempStr+DayStr+'/'+MthStr+'/'+copy(YrStr,3,2);
      1: DateStr := TempStr+MthStr+'/'+DayStr+'/'+copy(YrStr,3,2);
      2: DateStr := TempStr+DayStr+'/'+MthStr+'/'+YrStr;
      3: DateStr := TempStr+MthStr+'/'+DayStr+'/'+YrStr;
      4: DateStr := TempStr+DayStr+' '+copy(months[m],1,3)+' '+YrStr;
      5: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+' '+YrStr;
      6: DateStr := TempStr+DayStr+' '+months[m]+' '+YrStr;
      7: DateStr := TempStr+months[m]+' '+DayStr+' '+YrStr;
      8: DateStr := TempStr+DayStr+'-'+copy(months[m],1,3)+'-'+copy(YrStr,3,2);
      9: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+', '''+copy(YrStr,3,2);
    end;  { Case }  
  end;  { DateStr }

Function ValidDate(yr,mth,d : Word; Var errorcode : Byte): Boolean;
  begin
    errorcode := 0;
    if (yr < 1901) or (yr > 2078) then
      errorcode := (errorcode or 1);
    if (d < 1) or (d > 31) then
      errorcode := (errorcode or 2);
    if (mth < 1) or (mth > 12) then
      errorcode := (errorcode or 4);
    Case mth of
      4,6,9,11: if d > 30 then errorcode := (errorcode or 2);
             2: if d > (28 + ord((yr mod 4) = 0)) then
                  errorcode := (errorcode or 2);
      end; {Case }
    ValidDate := (errorcode = 0);
    if errorcode <> 0 then Write(#7);
  end; { ValidDate }

Procedure ParseDateString(Var dstr; Var y,m,d : Word; Format : Byte);
  Var
    left,middle       : Word;
    errcode           : Integer;
    st                : String Absolute dstr;
  begin
    val(copy(st,1,2),left,errcode);
    val(copy(st,4,2),middle,errcode);
    val(copy(st,7,4),y,errcode);
    Case Format of
      0: begin
           d := left;
           m := middle;
         end;
      1: begin
           d := middle;
           m := left;
         end;
    end; { Case }
  end; { ParseDateString }
    
Function NumbofDaysInMth(y,m : Word): Byte;
  { valid For the years 1901 - 2078                                   }
  begin
    Case m of
      1,3,5,7,8,10,12: NumbofDaysInMth := 31;
      4,6,9,11       : NumbofDaysInMth := 30;
      2              : NumbofDaysInMth := 28 +
                       ord((y mod 4) = 0);
    end;
  end; { NumbofDaysInMth }

Function IncrMonth(pd: date; n: Word): date;
  Var y,m,d : Word;
  begin
    UnpackDate(y,m,d,pd);
    dec(m);
    inc(m,n);
    inc(y,m div 12); { if necessary increment year }
    m := succ(m mod 12);
    if d > NumbofDaysInMth(y,m) then
      d := NumbofDaysInMth(y,m);
    IncrMonth := PackedDate(y,m,d);
  end;  { IncrMonth }

Function today : date;
  Var y,m,d,dw : Word;
  begin
    GetDate(y,m,d,dw);
    today := PackedDate(y,m,d);
  end;  { today }

Function ordDate (Y,M,D : Word): LongInt;     { returns ordinal Date as yyddd }
Var LYR  : Boolean;
    TEMP : LongInt;
begin
  LYR := (Y mod 4 = 0) and (Y <> 1900);
  Dec (Y,1900);
  TEMP := LongInt(Y) * 1000;
  Inc (TEMP,TDays[LYR][M-1]);    { Compute # days through last month }
  Inc (TEMP,D);                                  { # days this month }
  ordDate := TEMP
end;  { ordDate }

Function Dateord (S : String) : String;    { returns Date as 'yymmdd' }
Var LYR   : Boolean;
    Y,M,D : Word;
    TEMP  : LongInt;
    N     : Integer;
    StoP  : Boolean;
    SW,ST : String[6];
begin
  Val (Copy(S,1,2),Y,N); Val (Copy(S,3,3),TEMP,N);
  Inc (Y,1900); LYR := (Y mod 4 = 0) and (Y <> 1900); Dec (Y,1900);
  N := 0; StoP := False;
  While not StoP and (TDays[LYR][N] < TEMP) do
    Inc (N);
  M := N;                                                     { month }
  D := TEMP-TDays[LYR][M-1];        { subtract # days thru this month }
  Str(Y:2,SW); Str(M:2,ST);
  if ST[1] = ' ' then ST[1] := '0'; SW := SW+ST;
  Str(D:2,ST);
  if ST[1] = ' ' then ST[1] := '0'; SW := SW+ST;
  Dateord := SW
end;  { Dateord }




end.  { Unit TCDate }