home *** CD-ROM | disk | FTP | other *** search
/ ftp.wwiv.com / ftp.wwiv.com.zip / ftp.wwiv.com / pub / UTILITY / USTATV20.ARJ / CLCKSTFF.PRO next >
Text File  |  1989-01-09  |  3KB  |  190 lines
  1.  
  2. function tch ( i : str) : str;
  3.  
  4. { Pads digits with leading 0 if neccessary }
  5.   begin
  6.     if length (i) > 2
  7.       then
  8.         i := copy (i, length (i) - 1, 2)
  9.       else
  10.         if length (i) = 1
  11.           then
  12.             i := '0' + i;
  13.     tch := i;
  14.   end;
  15.  
  16. function time:str;
  17.  
  18.  { Returns the current time as a string HH:MM:SS }
  19.  
  20.   var
  21.     reg : regs;
  22.     h,
  23.     m,
  24.     s   : string [4];
  25.  
  26.   begin
  27.     reg.ax := $2c00;
  28.     intr ($21, reg);
  29.     str (reg.cx shr 8, h);
  30.     str (reg.cx mod 256, m);
  31.     str (reg.dx shr 8, s);
  32.     time := tch (h) + ':' + tch (m) + ':' + tch(s);
  33.   end;
  34.  
  35. function date : str;
  36.  
  37.   var
  38.     reg : regs;
  39.     m,
  40.     d,
  41.     y   : string[4];
  42.  
  43.   begin
  44.     reg.ax := $2a00;
  45.     msdos (reg);
  46.     str (reg.cx, y);
  47.     str (reg.dx mod 256, d);
  48.     str (reg.dx shr 8, m);
  49.     date := tch (m) + '/' + tch (d) + '/' + tch(y);
  50.   end;
  51.  
  52. function value (I : str):integer;
  53.  
  54.   var
  55.     n,
  56.     n1 : integer;
  57.  
  58.   begin
  59.     val (i, n, n1);
  60.     if n1 <> 0
  61.       then
  62.         begin
  63.           i := copy (i, 1, n1-1);
  64.           val (i, n, n1)
  65.         end;
  66.     value := n;
  67.     if i = '' 
  68.       then
  69.         value := 0;
  70.   end;
  71.  
  72. function cstr (i:integer):str;
  73.  
  74.   var
  75.     c : str;
  76.  
  77.   begin
  78.     str (i, c);
  79.     cstr := c;
  80.   end;
  81.  
  82. function leapyear (yr:integer):boolean;
  83.  
  84.   begin
  85.     leapyear := (yr mod 4 = 0) and ((yr mod 100 <> 0) or
  86.     (yr mod 400 = 0));
  87.   end;
  88.  
  89. function days (mo, yr : integer):integer;
  90.  
  91.   var
  92.     d : integer;
  93.  
  94.   begin
  95.     d := value (copy ('312831303130313130313031', 1 + (mo-1) * 2, 2));
  96.     if (mo = 2) and leapyear (yr)
  97.       then
  98.         d := d + 1;
  99.     days := d;
  100.   end;
  101.  
  102. function daycount (mo, yr : integer) : integer;
  103.  
  104.   var
  105.     m, t : integer;
  106.  
  107.   begin
  108.     t := 0;
  109.     for m := 1 to (mo - 1) do
  110.       t := t + days (m, yr);
  111.     daycount := t;
  112.   end;
  113.  
  114. function daynum(dt:str):integer;
  115.  
  116.   var
  117.     d,
  118.     m,
  119.     y,
  120.     t,
  121.     c : integer;
  122.  
  123.   begin
  124.     t := 0;
  125.     m := value (copy (dt, 1, 2));
  126.     d := value (copy (dt, 4, 2));
  127.     y := value (copy (dt, 7, 2)) + 1900;
  128.     for c := 1985 to y - 1 do
  129.       if leapyear (c)
  130.         then
  131.           t := t + 366
  132.         else
  133.           t := t + 365;
  134.     t := t + daycount (m, y) + (d - 1);
  135.     daynum := t;
  136.     if y < 1985
  137.       then
  138.         daynum := 0;
  139.   end;
  140.  
  141. function dat:str;
  142.  
  143.   var
  144.     ap,
  145.     x,
  146.     y  : str;
  147.     i  : integer;
  148.  
  149.   begin
  150.     case daynum (date) mod 7 of
  151.       0: x:= 'Tue';
  152.       1: x:= 'Wed';
  153.       2: x:= 'Thu';
  154.       3: x:= 'Fri';
  155.       4: x:= 'Sat';
  156.       5: x:= 'Sun';
  157.       6: x:= 'Mon';
  158.     end;
  159.     case value (copy (date, 1, 2)) of
  160.        1: y:= 'Jan';
  161.        2: y:= 'Feb';
  162.        3: y:='Mar';
  163.        4: y:='Apr';
  164.        5: y:='May';
  165.        6: y:='Jun';
  166.        7: y:='Jul';
  167.        8: y:='Aug';
  168.        9: y:='Sep';
  169.       10: y:='Oct';
  170.       11: y:='Nov';
  171.       12: y:='Dec';
  172.     end;
  173.     x := x + ' ' + y + ' ' + copy (date, 4, 2) + ', ' + cstr (1900
  174.          + value (copy (date, 7, 2)));
  175.     y := time;
  176.     i := value (copy (y, 1, 2));
  177.     if i > 11
  178.       then
  179.         ap := 'pm'
  180.       else
  181.         ap := 'am';
  182.     if i > 12
  183.       then
  184.         i := i - 12;
  185.     if i = 0
  186.       then
  187.         i := 12;
  188.     dat := cstr (i) + copy (y, 3, 3) + ' ' + ap + '  ' + x;
  189.   end;
  190.