home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / TCSEL002 / TCDATE.PAS < prev   
Pascal/Delphi Source File  |  1992-10-16  |  10KB  |  269 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. {============================================================================= }
  93.  
  94. implementation
  95.  
  96.  const
  97.   TDays       : array[Boolean,0..12] of word =
  98.                 ((0,31,59,90,120,151,181,212,243,273,304,334,365),
  99.                 (0,31,60,91,121,152,182,213,244,274,305,335,366));
  100.   UnixDatum   = longint(25568);
  101.   SecsPerDay  = 86400;
  102.   SecsPerHour = longint(3600);
  103.   SecsPerMin  = longint(60);
  104.   MinsPerHour = 60;
  105.  
  106. function DayOfTheWeek(pd : date): byte;
  107.   begin
  108.     DayOfTheWeek := pd mod 7;
  109.   end; { DayOfTheWeek }
  110.  
  111. function PackedDate(yr,mth,d : word): date;
  112.   { valid for all years 1901 to 2078                                  }
  113.   var
  114.     temp  : word;
  115.     lyr   : boolean;
  116.   begin
  117.     lyr   := (yr mod 4 = 0);
  118.     if yr >= 1900 then
  119.       dec(yr,1900);
  120.     temp  := yr * word(365) + (yr div 4) - ord(lyr);
  121.     inc(temp,TDays[lyr][mth-1]);
  122.     inc(temp,d);
  123.     PackedDate := temp;
  124.   end;  { PackedDate }
  125.  
  126. function UnixTime(yr,mth,d,hr,min,sec: word): UnixTimeStamp;
  127.   { Returns the number of seconds since 00:00 01/01/1970 }
  128.   begin
  129.     UnixTime := SecsPerDay * (PackedDate(yr,mth,d) - UnixDatum) +
  130.                 SecsPerHour * hr + SecsPerMin * min + sec;
  131.   end;  { UnixTime }
  132.  
  133. procedure UnPackDate(var yr,mth,d: word; pd : date);
  134.   { valid for all years 1901 to 2078                                  }
  135.   var
  136.     julian : word;
  137.     lyr    : boolean;
  138.   begin
  139.     d      := pd;
  140.     yr     := (longint(d) * 4) div 1461;
  141.     julian := d - (yr * 365 + (yr div 4));
  142.     inc(yr,1900);
  143.     lyr    := (yr mod 4 = 0);
  144.     inc(julian,ord(lyr));
  145.     mth    := 0;
  146.     while julian > TDays[lyr][mth] do
  147.       inc(mth);
  148.     d      := julian - TDays[lyr][mth-1];
  149.   end; { UnPackDate }
  150.  
  151. procedure UnPackUnix(var yr,mth,d,hr,min,sec: word; uts: UnixTimeStamp);
  152.   var
  153.     temp : UnixTimeStamp;
  154.   begin
  155.     UnPackDate(yr,mth,d,date(uts div SecsPerDay) + UnixDatum);
  156.     temp   := uts mod SecsPerDay;
  157.     hr     := temp div SecsPerHour;
  158.     min    := (temp mod SecsPerHour) div MinsPerHour;
  159.     sec    := temp mod SecsPerMin;
  160.   end;  { UnPackUnix }
  161.  
  162. function DateStr(pd: date; format: byte): string;
  163.  
  164.   var
  165.     y,m,d    : word;
  166.     YrStr    : string[5];
  167.     MthStr   : string[11];
  168.     DayStr   : string[8];
  169.     TempStr  : string[5];
  170.   begin
  171.     UnpackDate(y,m,d,pd);
  172.     str(y,YrStr);
  173.     str(m,MthStr);
  174.     str(d,DayStr);
  175.     TempStr := '';
  176.     if format > 9 then 
  177.       TempStr := copy(WeekDays[DayOfTheWeek(pd)],1,3) + ' ';
  178.     if (format mod 10) < 4 then begin
  179.       if m < 10 then 
  180.         MthStr := '0'+MthStr;
  181.       if d < 10 then
  182.         DayStr := '0'+DayStr;
  183.     end;
  184.     case format mod 10 of  { force format to a valid value }
  185.       0: DateStr := TempStr+DayStr+'/'+MthStr+'/'+copy(YrStr,3,2);
  186.       1: DateStr := TempStr+MthStr+'/'+DayStr+'/'+copy(YrStr,3,2);
  187.       2: DateStr := TempStr+DayStr+'/'+MthStr+'/'+YrStr;
  188.       3: DateStr := TempStr+MthStr+'/'+DayStr+'/'+YrStr;
  189.       4: DateStr := TempStr+DayStr+' '+copy(months[m],1,3)+' '+YrStr;
  190.       5: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+' '+YrStr;
  191.       6: DateStr := TempStr+DayStr+' '+months[m]+' '+YrStr;
  192.       7: DateStr := TempStr+months[m]+' '+DayStr+' '+YrStr;
  193.       8: DateStr := TempStr+DayStr+'-'+copy(months[m],1,3)+'-'+copy(YrStr,3,2);
  194.       9: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+', '''+copy(YrStr,3,2);
  195.     end;  { case }  
  196.   end;  { DateStr }
  197.  
  198. function ValidDate(yr,mth,d : word; var errorcode : byte): boolean;
  199.   begin
  200.     errorcode := 0;
  201.     if (yr < 1901) or (yr > 2078) then
  202.       errorcode := (errorcode or 1);
  203.     if (d < 1) or (d > 31) then
  204.       errorcode := (errorcode or 2);
  205.     if (mth < 1) or (mth > 12) then
  206.       errorcode := (errorcode or 4);
  207.     case mth of
  208.       4,6,9,11: if d > 30 then errorcode := (errorcode or 2);
  209.              2: if d > (28 + ord((yr mod 4) = 0)) then
  210.                   errorcode := (errorcode or 2);
  211.       end; {case }
  212.     ValidDate := (errorcode = 0);
  213.     if errorcode <> 0 then write(#7);
  214.   end; { ValidDate }
  215.  
  216. procedure ParseDateString(var dstr; var y,m,d : word; format : byte);
  217.   var
  218.     left,middle       : word;
  219.     errcode           : integer;
  220.     st                : string absolute dstr;
  221.   begin
  222.     val(copy(st,1,2),left,errcode);
  223.     val(copy(st,4,2),middle,errcode);
  224.     val(copy(st,7,4),y,errcode);
  225.     case format of
  226.       0: begin
  227.            d := left;
  228.            m := middle;
  229.          end;
  230.       1: begin
  231.            d := middle;
  232.            m := left;
  233.          end;
  234.     end; { case }
  235.   end; { ParseDateString }
  236.     
  237. function NumbOfDaysInMth(y,m : word): byte;
  238.   { valid for the years 1901 - 2078                                   }
  239.   begin
  240.     case m of
  241.       1,3,5,7,8,10,12: NumbOfDaysInMth := 31;
  242.       4,6,9,11       : NumbOfDaysInMth := 30;
  243.       2              : NumbOfDaysInMth := 28 +
  244.                        ord((y mod 4) = 0);
  245.     end;
  246.   end; { NumbOfDaysInMth }
  247.  
  248. function IncrMonth(pd: date; n: word): date;
  249.   var y,m,d : word;
  250.   begin
  251.     UnpackDate(y,m,d,pd);
  252.     dec(m);
  253.     inc(m,n);
  254.     inc(y,m div 12); { if necessary increment year }
  255.     m := succ(m mod 12);
  256.     if d > NumbOfDaysInMth(y,m) then
  257.       d := NumbOfDaysInMth(y,m);
  258.     IncrMonth := PackedDate(y,m,d);
  259.   end;  { IncrMonth }
  260.  
  261. function Today : date;
  262.   var y,m,d,dw : word;
  263.   begin
  264.     GetDate(y,m,d,dw);
  265.     Today := PackedDate(y,m,d);
  266.   end;  { Today }
  267.  
  268. end.  { Unit TCDate }
  269.