home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / DATABASE / MAIL20.ARK / MAILDATE.INC < prev    next >
Text File  |  1986-09-25  |  8KB  |  234 lines
  1. { MAILDATE.INC -- Date routines for Reliance Mailing List.
  2.   WPM -- 2/21/86 }
  3.  
  4. { COPYRIGHT (c) 1986, Wm Meacham, 1004 Elm Street, Austin, Tx  78703 }
  5.  
  6. type
  7.     date = record
  8.         yr : integer ; { 0 .. 9999 }
  9.         mo : integer ; { 1 .. 12 }
  10.         dy : integer ; { 1 .. 31 }
  11.       end ;
  12.  
  13.     datestring = string[10] ;  { 'MM/DD/YYYY' }
  14.  
  15. const
  16.     null_date     : date       = (yr:0 ; mo:0 ; dy:0) ;
  17.     null_date_str : datestring = 'MM/DD/YYYY' ;
  18.  
  19.  
  20. { ------------------------------------------------------------ }
  21.  
  22. function mk_dt_st (dt : date) : datestring ;
  23.   { Makes a string out of a date -- used for printing dates }
  24.     var
  25.         yr_st : string[4] ;
  26.         mo_st : string[2] ;
  27.         dy_st : string[2] ;
  28.         dt_st : datestring ;
  29.     begin
  30.         with dt do
  31.           begin
  32.             if (yr=0) and (mo=0) and (dy=0) then
  33.                 dt_st := 'MM/DD/YYYY'
  34.             else
  35.               begin
  36.                 str (yr:4,yr_st) ;
  37.                 str (mo:2,mo_st) ;
  38.                 str (dy:2,dy_st) ;
  39.                 dt_st := concat (mo_st,'/',dy_st,'/',yr_st)
  40.               end  { ELSE }
  41.           end ;  { WITH DT DO }
  42.         mk_dt_st := dt_st
  43.     end ;  { --- PROC MK_DT_ST--- }
  44.  
  45. { ------------------------------------------------------------ }
  46.  
  47. procedure write_date (dt: date ; col, row: integer) ;
  48.   { Writes date at column and row specified }
  49.     var
  50.         ds : datestring ;
  51.     begin
  52.         ds := mk_dt_st (dt) ;
  53.         write_str (ds,col,row)
  54.     end ; { --- proc WRITE_DATE --- }
  55.  
  56. { ------------------------------------------------------------ }
  57.  
  58. function leapyear (yr : integer) : boolean ;
  59. { Whether the year is a leap year or not.
  60.   The year is year and century, e.g. year 1984 is '1984,' not '84' }
  61.   begin
  62.     leapyear := ((yr mod 4 = 0) and (not(yr mod 100 = 0)))
  63.              or ( yr mod 400 = 0 )
  64.   end ;
  65.  
  66. { ------------------------------------------------------------ }
  67.  
  68. function valid_date (dt:date) : boolean ;
  69.   { Test whether date is valid }
  70.     var
  71.         bad_fld : integer ;
  72.     begin
  73.         bad_fld := 0 ;
  74.         with dt do
  75.             begin
  76.                 if (mo = 0) and (dy = 0) and (yr = 0) then
  77.                     bad_fld := 0
  78.                 else if not (mo in [1 .. 12]) then
  79.                         bad_fld := 1
  80.                 else if (dy > 31)
  81.                 or (dy < 1)
  82.                 or ((mo in [4,6,9,11]) and (dy > 30)) then
  83.                         bad_fld := 2
  84.                 else if mo = 2 then
  85.                   begin
  86.                     if (leapyear(yr) and (dy > 29))
  87.                     or ((not leapyear(yr)) and (dy > 28)) then
  88.                         bad_fld := 2
  89.                   end
  90.                 else if yr = 0 then
  91.                         bad_fld := 3
  92.             end ; { with dt do }
  93.         valid_date := (bad_fld = 0)
  94.     end ; { function valid_date }
  95.  
  96. { ------------------------------------------------------------ }
  97.  
  98. procedure read_date (var dt: date ; col, row: integer) ;
  99.  
  100.   { Read date at column and row specified.  If the user enters only
  101.     two digits for the year, the procedure plugs the century as 1900 or
  102.     2000, but the user can enter all four digits to override the plug. }
  103.  
  104.     var
  105.         savefld, bad_fld : integer ;
  106.  
  107.     procedure edit_date ;                  { Edit for valid date }
  108.         begin
  109.             bad_fld := 0 ;
  110.             with dt do
  111.                 begin
  112.                     if (mo = 0) and (dy = 0) and (yr = 0) then
  113.                         bad_fld := 0
  114.                     else if not (mo in [1 .. 12]) then
  115.                         begin
  116.                             mo  := 0 ;
  117.                             bad_fld := 1
  118.                         end
  119.                     else if (dy > 31)
  120.                     or (dy < 1)
  121.                     or ((mo in [4,6,9,11]) and (dy > 30)) then
  122.                         begin
  123.                             dy  := 0 ;
  124.                             bad_fld := 2
  125.                         end
  126.                     else if mo = 2 then
  127.                       begin
  128.                         if (leapyear(yr) and (dy > 29))
  129.                         or ((not leapyear(yr)) and (dy > 28)) then
  130.                             begin
  131.                                 dy  := 0 ;
  132.                                 bad_fld := 2
  133.                             end
  134.                       end
  135.                     else if yr = 0 then
  136.                             bad_fld := 3
  137.                 end   { WITH DT DO }
  138.         end ; { --- of EDIT_DATE --- }
  139.  
  140.     begin { READ_DATE }
  141.         savefld := fld ;                    { Save FLD for rest of screen }
  142.         fld := 1 ;                          { Set up FLD for use locally }
  143.         write_date (dt, col, row) ;
  144.         with dt do
  145.             repeat
  146.                 repeat
  147.                     case fld of
  148.                         1 : read_int (mo, 2, col, row) ;
  149.                         2 : read_int (dy, 2, col+3, row) ;
  150.                         3 : begin
  151.                               read_int (yr, 4, col+6, row) ;
  152.                               if  (yr < 0) then
  153.                                 begin
  154.                                   yr := 0 ;
  155.                                   if (fld > 3) and (fld < maxint) then
  156.                                       fld := 3
  157.                                 end
  158.                               else if not((yr = 0) and (mo = 0) and (dy = 0)) then
  159.                                 begin
  160.                                   if yr < 80 then         { Plug century }
  161.                                       yr := 2000 + yr
  162.                                   else if yr < 100 then
  163.                                       yr := 1900 + yr
  164.                                 end ;
  165.                               write_int (yr, 4, col+6, row)
  166.                             end ; { 3 }
  167.                     end ; { CASE }
  168.                 until (fld < 1) or (fld > 3) ;
  169.                 if (fld > 3) and (fld < maxint) then      { edit only }
  170.                   begin                                   { going forward }
  171.                     edit_date ;
  172.                     if not (bad_fld = 0) then   { Date is bad }
  173.                         begin
  174.                             beep ;
  175.                             fld := bad_fld
  176.                         end
  177.                   end
  178.             until (fld < 1) or (fld > 3) ;
  179.         write_date (dt,col,row) ;
  180.         if fld = 0 then                     { Restore FLD for rest of screen }
  181.                 fld := savefld - 1
  182.         else if fld = 4 then
  183.                 fld := savefld + 1
  184.  
  185.     end ; {--- of READ_DATE ---}
  186.  
  187. { ------------------------------------------------------------ }
  188.  
  189. function equal_date (dt1, dt2 : date) : boolean ;
  190.   { Tests whether two dates are equal }
  191.     begin
  192.         equal_date := (dt1.mo = dt2.mo) and (dt1.dy = dt2.dy)
  193.                       and (dt1.yr = dt2.yr)
  194.     end ;
  195.  
  196. { ------------------------------------------------------------ }
  197.  
  198. function greater_date (dt1, dt2 : date) : integer ;
  199.   { Compares two dates, returns 0 if both equal, 1 if first is
  200.     greater, 2 if second is greater.  Converts both to strings,
  201.     then compares the strings. }
  202.  
  203.     var
  204.         stdt1, stdt2 : string[8] ;
  205.         styr1, styr2 : string[4] ;
  206.         stmo1, stmo2 : string[2] ;
  207.         stdy1, stdy2 : string[2] ;
  208.  
  209.     begin
  210.         with dt1 do
  211.             begin
  212.                 str(yr:4,styr1) ;
  213.                 str(mo:2,stmo1) ;
  214.                 str(dy:2,stdy1) ;
  215.                 stdt1 := concat (styr1,stmo1,stdy1)
  216.             end ;
  217.         with dt2 do
  218.             begin
  219.                 str(yr:4,styr2) ;
  220.                 str(mo:2,stmo2) ;
  221.                 str(dy:2,stdy2) ;
  222.                 stdt2 := concat (styr2,stmo2,stdy2)
  223.             end ;
  224.         if stdt1 > stdt2 then
  225.                 greater_date := 1
  226.         else if stdt2 > stdt1 then
  227.                 greater_date := 2
  228.         else { both equal }
  229.                 greater_date := 0
  230.     end ; { --- of GREATER_DATE --- }
  231.  
  232. { ---- EOF MAILDATE.INC -------------------------------------- }
  233.  
  234.