home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / datetime.swg / 0015_TCDATE.PAS.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-28  |  11.1 KB  |  312 lines
  1. Unit TCDate;
  2.  
  3.   { Author: Trevor J Carlsen  Released into the public domain }
  4.   {         PO Box 568                                        }
  5.   {         Port Hedland                                      }
  6.   {         Western Australia 6721                            }
  7.   {         Voice +61 91 732 026                              }
  8.  
  9. Interface
  10.  
  11. Uses Dos;
  12.  
  13. Type
  14.   Date          = Word;
  15.   UnixTimeStamp = LongInt;
  16.  
  17. Const
  18.   WeekDays   : Array[0..6] of String[9] =
  19.                ('Sunday','Monday','Tuesday','Wednesday','Thursday',
  20.                 'Friday','Saturday');
  21.   months     : Array[1..12] of String[9] =
  22.                ('January','February','March','April','May','June','July',
  23.                 'August','September','October','November','December');
  24.  
  25. Function DayofTheWeek(pd : date): Byte;
  26.  { Returns the day of the week For any date  Sunday = 0 .. Sat = 6    }
  27.  { pd = a packed date as returned by the Function PackedDate          }
  28.  { eg...  Writeln('today is ',WeekDays[DayofTheWeek(today))];         }
  29.  
  30. Function PackedDate(yr,mth,d: Word): date;
  31.  { Packs a date into a Word which represents the number of days since }
  32.  { Dec 31,1899   01-01-1900 = 1                                       }
  33.  
  34. Function UnixTime(yr,mth,d,hr,min,sec: Word): UnixTimeStamp;
  35.  { Packs a date and time into a four Byte unix style Variable which   }
  36.  { represents the number of seconds that have elapsed since midnight  }
  37.  { on Jan 1st 1970.                                                   }
  38.  
  39. Procedure UnPackDate(Var yr,mth,d: Word; pd : date);
  40.  { Unpacks a Word returned by the Function PackedDate into its        }
  41.  { respective parts of year, month and day                            }
  42.  
  43. Procedure UnPackUnix(Var yr,mth,d,hr,min,sec: Word; uts: UnixTimeStamp);
  44.  { Unpacks a UnixTimeStamp Variable into its Component parts.         }
  45.  
  46. Function DateStr(pd: date; Format: Byte): String;
  47.  { Unpacks a Word returned by the Function PackedDate into its        }
  48.  { respective parts of year, month and day and then returns a String  }
  49.  { Formatted according to the specifications required.                }
  50.  { if the Format is > 9 then the day of the week is prefixed to the   }
  51.  { returned String.                                                   }
  52.  { Formats supported are:                                             }
  53.  {     0:  dd/mm/yy                                                   }
  54.  {     1:  mm/dd/yy                                                   }
  55.  {     2:  dd/mm/yyyy                                                 }
  56.  {     3:  mm/dd/yyyy                                                 }
  57.  {     4:  [d]d xxx yyyy   (xxx is alpha month of 3 Chars)            }
  58.  {     5:  xxx [d]d, yyyy                                             }
  59.  {     6:  [d]d FullAlphaMth yyyy                                     }
  60.  {     7:  FullAlphaMth [d]d, yyyy                                    }
  61.  {     8:  [d]d-xxx-yy                                                }
  62.  {     9:  xxx [d]d, 'yy                                              } 
  63.  
  64. Function ValidDate(yr,mth,d : Word; Var errorcode : Byte): Boolean;
  65.  { Validates the date and time data to ensure no out of range errors  }
  66.  { can occur and returns an error code to the calling Procedure. A    }
  67.  { errorcode of zero is returned if no invalid parameter is detected. }
  68.  { Errorcodes are as follows:                                         }
  69.  
  70.  {   Year out of range (< 1901 or > 2078) bit 0 of errorcode is set.  }
  71.  {   Month < 1 or > 12                    bit 1 of errorcode is set.  }
  72.  {   Day < 1 or > 31                      bit 2 of errorcode is set.  }
  73.  {   Day out of range For month           bit 2 of errorcode is set.  }
  74.  
  75. Procedure ParseDateString(Var dstr; Var y,m,d : Word; Format : Byte);
  76.  { Parses a date String in several Formats into its Component parts   }
  77.  { It is the Programmer's responsibility to ensure that the String    }
  78.  { being parsed is a valid date String in the Format expected.        }
  79.  { Formats supported are:                                             }
  80.  {     0:  dd/mm/yy[yy]                                               }
  81.  {     1:  mm/dd/yy[yy]                                               } 
  82.  
  83. Function NumbofDaysInMth(y,m : Word): Byte;
  84.  { returns the number of days in any month                            }
  85.  
  86. Function IncrMonth(pd: date; n: Word): date;
  87.  { Increments pd by n months.                                         }
  88.  
  89. Function today : date;
  90.  { returns the number of days since 01-01-1900                        }
  91.  
  92. Function ordDate (Y,M,D : Word):LongInt; { returns ordinal Date yyddd }
  93.  
  94. Function Dateord (S : String) : String;    { returns Date as 'yymmdd' }
  95.  
  96.  
  97.  
  98. {============================================================================= }
  99.  
  100. Implementation
  101.  
  102.  Const
  103.   TDays       : Array[Boolean,0..12] of Word =
  104.                 ((0,31,59,90,120,151,181,212,243,273,304,334,365),
  105.                 (0,31,60,91,121,152,182,213,244,274,305,335,366));
  106.   UnixDatum   = LongInt(25568);
  107.   SecsPerDay  = 86400;
  108.   SecsPerHour = LongInt(3600);
  109.   SecsPerMin  = LongInt(60);
  110.   MinsPerHour = 60;
  111.  
  112. Function DayofTheWeek(pd : date): Byte;
  113.   begin
  114.     DayofTheWeek := pd mod 7;
  115.   end; { DayofTheWeek }
  116.  
  117. Function PackedDate(yr,mth,d : Word): date;
  118.   { valid For all years 1901 to 2078                                  }
  119.   Var
  120.     temp  : Word;
  121.     lyr   : Boolean;
  122.   begin
  123.     lyr   := (yr mod 4 = 0);
  124.     if yr >= 1900 then
  125.       dec(yr,1900);
  126.     temp  := yr * Word(365) + (yr div 4) - ord(lyr);
  127.     inc(temp,TDays[lyr][mth-1]);
  128.     inc(temp,d);
  129.     PackedDate := temp;
  130.   end;  { PackedDate }
  131.  
  132. Function UnixTime(yr,mth,d,hr,min,sec: Word): UnixTimeStamp;
  133.   { Returns the number of seconds since 00:00 01/01/1970 }
  134.   begin
  135.     UnixTime := SecsPerDay * (PackedDate(yr,mth,d) - UnixDatum) +
  136.                 SecsPerHour * hr + SecsPerMin * min + sec;
  137.   end;  { UnixTime }
  138.  
  139. Procedure UnPackDate(Var yr,mth,d: Word; pd : date);
  140.   { valid For all years 1901 to 2078                                  }
  141.   Var
  142.     julian : Word;
  143.     lyr    : Boolean;
  144.   begin
  145.     d      := pd;
  146.     yr     := (LongInt(d) * 4) div 1461;
  147.     julian := d - (yr * 365 + (yr div 4));
  148.     inc(yr,1900);
  149.     lyr    := (yr mod 4 = 0);
  150.     inc(julian,ord(lyr));
  151.     mth    := 0;
  152.     While julian > TDays[lyr][mth] do
  153.       inc(mth);
  154.     d      := julian - TDays[lyr][mth-1];
  155.   end; { UnPackDate }
  156.  
  157. Procedure UnPackUnix(Var yr,mth,d,hr,min,sec: Word; uts: UnixTimeStamp);
  158.   Var
  159.     temp : UnixTimeStamp;
  160.   begin
  161.     UnPackDate(yr,mth,d,date(uts div SecsPerDay) + UnixDatum);
  162.     temp   := uts mod SecsPerDay;
  163.     hr     := temp div SecsPerHour;
  164.     min    := (temp mod SecsPerHour) div MinsPerHour;
  165.     sec    := temp mod SecsPerMin;
  166.   end;  { UnPackUnix }
  167.  
  168. Function DateStr(pd: date; Format: Byte): String;
  169.  
  170.   Var
  171.     y,m,d    : Word;
  172.     YrStr    : String[5];
  173.     MthStr   : String[11];
  174.     DayStr   : String[8];
  175.     TempStr  : String[5];
  176.   begin
  177.     UnpackDate(y,m,d,pd);
  178.     str(y,YrStr);
  179.     str(m,MthStr);
  180.     str(d,DayStr);
  181.     TempStr := '';
  182.     if Format > 9 then 
  183.       TempStr := copy(WeekDays[DayofTheWeek(pd)],1,3) + ' ';
  184.     if (Format mod 10) < 4 then begin
  185.       if m < 10 then 
  186.         MthStr := '0'+MthStr;
  187.       if d < 10 then
  188.         DayStr := '0'+DayStr;
  189.     end;
  190.     Case Format mod 10 of  { Force Format to a valid value }
  191.       0: DateStr := TempStr+DayStr+'/'+MthStr+'/'+copy(YrStr,3,2);
  192.       1: DateStr := TempStr+MthStr+'/'+DayStr+'/'+copy(YrStr,3,2);
  193.       2: DateStr := TempStr+DayStr+'/'+MthStr+'/'+YrStr;
  194.       3: DateStr := TempStr+MthStr+'/'+DayStr+'/'+YrStr;
  195.       4: DateStr := TempStr+DayStr+' '+copy(months[m],1,3)+' '+YrStr;
  196.       5: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+' '+YrStr;
  197.       6: DateStr := TempStr+DayStr+' '+months[m]+' '+YrStr;
  198.       7: DateStr := TempStr+months[m]+' '+DayStr+' '+YrStr;
  199.       8: DateStr := TempStr+DayStr+'-'+copy(months[m],1,3)+'-'+copy(YrStr,3,2);
  200.       9: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+', '''+copy(YrStr,3,2);
  201.     end;  { Case }  
  202.   end;  { DateStr }
  203.  
  204. Function ValidDate(yr,mth,d : Word; Var errorcode : Byte): Boolean;
  205.   begin
  206.     errorcode := 0;
  207.     if (yr < 1901) or (yr > 2078) then
  208.       errorcode := (errorcode or 1);
  209.     if (d < 1) or (d > 31) then
  210.       errorcode := (errorcode or 2);
  211.     if (mth < 1) or (mth > 12) then
  212.       errorcode := (errorcode or 4);
  213.     Case mth of
  214.       4,6,9,11: if d > 30 then errorcode := (errorcode or 2);
  215.              2: if d > (28 + ord((yr mod 4) = 0)) then
  216.                   errorcode := (errorcode or 2);
  217.       end; {Case }
  218.     ValidDate := (errorcode = 0);
  219.     if errorcode <> 0 then Write(#7);
  220.   end; { ValidDate }
  221.  
  222. Procedure ParseDateString(Var dstr; Var y,m,d : Word; Format : Byte);
  223.   Var
  224.     left,middle       : Word;
  225.     errcode           : Integer;
  226.     st                : String Absolute dstr;
  227.   begin
  228.     val(copy(st,1,2),left,errcode);
  229.     val(copy(st,4,2),middle,errcode);
  230.     val(copy(st,7,4),y,errcode);
  231.     Case Format of
  232.       0: begin
  233.            d := left;
  234.            m := middle;
  235.          end;
  236.       1: begin
  237.            d := middle;
  238.            m := left;
  239.          end;
  240.     end; { Case }
  241.   end; { ParseDateString }
  242.     
  243. Function NumbofDaysInMth(y,m : Word): Byte;
  244.   { valid For the years 1901 - 2078                                   }
  245.   begin
  246.     Case m of
  247.       1,3,5,7,8,10,12: NumbofDaysInMth := 31;
  248.       4,6,9,11       : NumbofDaysInMth := 30;
  249.       2              : NumbofDaysInMth := 28 +
  250.                        ord((y mod 4) = 0);
  251.     end;
  252.   end; { NumbofDaysInMth }
  253.  
  254. Function IncrMonth(pd: date; n: Word): date;
  255.   Var y,m,d : Word;
  256.   begin
  257.     UnpackDate(y,m,d,pd);
  258.     dec(m);
  259.     inc(m,n);
  260.     inc(y,m div 12); { if necessary increment year }
  261.     m := succ(m mod 12);
  262.     if d > NumbofDaysInMth(y,m) then
  263.       d := NumbofDaysInMth(y,m);
  264.     IncrMonth := PackedDate(y,m,d);
  265.   end;  { IncrMonth }
  266.  
  267. Function today : date;
  268.   Var y,m,d,dw : Word;
  269.   begin
  270.     GetDate(y,m,d,dw);
  271.     today := PackedDate(y,m,d);
  272.   end;  { today }
  273.  
  274. Function ordDate (Y,M,D : Word): LongInt;     { returns ordinal Date as yyddd }
  275. Var LYR  : Boolean;
  276.     TEMP : LongInt;
  277. begin
  278.   LYR := (Y mod 4 = 0) and (Y <> 1900);
  279.   Dec (Y,1900);
  280.   TEMP := LongInt(Y) * 1000;
  281.   Inc (TEMP,TDays[LYR][M-1]);    { Compute # days through last month }
  282.   Inc (TEMP,D);                                  { # days this month }
  283.   ordDate := TEMP
  284. end;  { ordDate }
  285.  
  286. Function Dateord (S : String) : String;    { returns Date as 'yymmdd' }
  287. Var LYR   : Boolean;
  288.     Y,M,D : Word;
  289.     TEMP  : LongInt;
  290.     N     : Integer;
  291.     StoP  : Boolean;
  292.     SW,ST : String[6];
  293. begin
  294.   Val (Copy(S,1,2),Y,N); Val (Copy(S,3,3),TEMP,N);
  295.   Inc (Y,1900); LYR := (Y mod 4 = 0) and (Y <> 1900); Dec (Y,1900);
  296.   N := 0; StoP := False;
  297.   While not StoP and (TDays[LYR][N] < TEMP) do
  298.     Inc (N);
  299.   M := N;                                                     { month }
  300.   D := TEMP-TDays[LYR][M-1];        { subtract # days thru this month }
  301.   Str(Y:2,SW); Str(M:2,ST);
  302.   if ST[1] = ' ' then ST[1] := '0'; SW := SW+ST;
  303.   Str(D:2,ST);
  304.   if ST[1] = ' ' then ST[1] := '0'; SW := SW+ST;
  305.   Dateord := SW
  306. end;  { Dateord }
  307.  
  308.  
  309.  
  310.  
  311. end.  { Unit TCDate }
  312.