home *** CD-ROM | disk | FTP | other *** search
/ ftp.wwiv.com / ftp.wwiv.com.zip / ftp.wwiv.com / pub / MISC / TGARTS.ZIP / SAMPLE.ZIP / DTIME.PAS next >
Pascal/Delphi Source File  |  1998-11-16  |  11KB  |  448 lines
  1. {****************************************************************************)
  2. (*>                                                                        <*)
  3. (*>                     Telegard Bulletin Board System                     <*)
  4. (*>         Copyright 1994-1998 by Tim Strike.  All rights reserved.       <*)
  5. (*>                                                                        <*)
  6. (*>  Module name:       DATETIME.PAS                                       <*)
  7. (*>  Module purpose:    Date and time routines.                            <*)
  8. (*>                                                                        <*)
  9. (****************************************************************************}
  10.  
  11. {$A+,B+,E-,F+,I-,N-,O-,V-}
  12. unit dtime;
  13.  
  14. interface
  15.  
  16. uses
  17.   dos;
  18.  
  19. type
  20.   datetimerec=    { date/time storage }
  21.   record
  22.      year, month, day, hour, min, sec, sec100, dow : word;
  23.   end;
  24.  
  25.   dfmtrec = array[0..2] of byte;
  26.  
  27. const
  28.   dtable : array[1..12] of byte = (31,28,31,30,31,30,31,31,30,31,30,31);
  29.   mlong  : array[1..12] of string[25] = ('January','February','March','April','May','June',
  30.                                         'July','August','September','October','November','December');
  31.   mshort : array[1..12] of string[3] = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
  32.   dlong  : array[0..6] of string[20] = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
  33.   dshort : array[0..6] of string[3] = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
  34.   tlong  : array[0..1] of string[2] = ('am','pm');
  35.   tshort : array[0..1] of string[1] = ('a','p');
  36.   sep    : array[1..2] of char = ('/',':');
  37.  
  38. {$IFNDEF DATE}
  39.   dfmt   : array[0..3] of dfmtrec = ((4,1,7),(7,1,4),(1,4,7),(4,7,1));
  40. {$ENDIF}
  41.  
  42. function   dayofweek   ( day,mth,year:longint ):byte;
  43. function   dt2unix     ( dt:datetimerec ):longint;
  44. procedure  getdatetime ( var dt:datetimerec );
  45. function   ltime : longint;
  46. function   rtime : longint;
  47. function   stime : string;
  48. function   runix       (l:longint):longint;
  49. function   strftime    ( fmt:string; dt:datetimerec ):string;
  50. function   strftimel   ( fmt:string; l:longint ):string;
  51. procedure  unix2dt     ( t:longint; var dt:datetimerec );
  52. procedure  incmonth    ( var dt:datetimerec );
  53. procedure  incday      ( var dt:datetimerec );
  54. function   ndatefmt    ( tt:byte ):string;                     { format type }
  55. Function   str2fmt     ( s:string;tt:byte):string;    { MM/DD/YY to format }
  56. Function   fmt2str     ( s:string;tt:byte ):string;            { format to MM/DD/YY }
  57. Function   unix2fmt    ( l:longint;tt:byte):string;   { unixdate to format }
  58. procedure  setsep      ( c1,c2:char );
  59. procedure  setday      ( nn:byte;s,s1:string );
  60. procedure  setmonth    ( nn:byte;s,s1:string );
  61. procedure  settime     ( s,s1,s2,s3:string );
  62. function   ctime       ( l:longint): string;
  63. function   etime       ( l:longint): string;
  64. procedure  convertdate ( dt:datetime; var dt1:datetimerec );
  65.  
  66. implementation
  67.  
  68. {*---------------------------------------------------------------------------*}
  69.  
  70. procedure convertdate( dt:datetime; var dt1:datetimerec );
  71. begin
  72. {$IFDEF OS2}
  73.     dt1.year  := dt.year;
  74.     dt1.month := dt.month;
  75.     dt1.day   := dt.day;
  76.     dt1.hour  := dt.hour;
  77.     dt1.min   := dt.min;
  78.     dt1.sec   := dt.sec;
  79. {$ELSE}
  80.     move(dt, dt1, sizeof(datetime));
  81. {$ENDIF}
  82. end;
  83.  
  84. procedure setsep( c1,c2 : char );
  85. begin
  86. sep[1] := c1;
  87. sep[2] := c2;
  88. end;
  89.  
  90. procedure setday(nn:byte;s,s1:string);
  91. begin
  92. dshort[nn] := s;
  93. dlong[nn] := s1;
  94. end;
  95.  
  96. procedure setmonth(nn:byte;s,s1:string);
  97. begin
  98. mshort[nn]:=s;
  99. mlong[nn]:=s1;
  100. end;
  101.  
  102. procedure settime(s,s1,s2,s3:string);
  103. begin
  104. tshort[0]:=s;
  105. tshort[1]:=s1;
  106. tlong[0]:=s2;
  107. tlong[1]:=s3;
  108. end;
  109.  
  110. function ndatefmt(tt:byte):string;
  111. BEGIN
  112. {$IFDEF DATE}
  113. case tt of
  114.    1 : ndatefmt:='DD'+sep[1]+'MM'+sep[1]+'YYYY';
  115.    2 : ndatefmt:='YYYY'+sep[1]+'MM'+sep[1]+'DD';
  116.    else ndatefmt:='MM'+sep[1]+'DD'+sep[1]+'YYYY';
  117.    END; { Case }
  118. {$ELSE}
  119. case tt of
  120.    1 : ndatefmt:='DD'+sep[1]+'MM'+sep[1]+'YY';
  121.    2 : ndatefmt:='YY'+sep[1]+'MM'+sep[1]+'DD';
  122.    else ndatefmt:='MM'+sep[1]+'DD'+sep[1]+'YY';
  123.    END; { Case }
  124. {$ENDIF}
  125. END;
  126.  
  127. Function str2fmt(s:string;tt:byte):string;
  128. var df:dfmtrec;
  129. BEGIN
  130. if s <> '' then
  131.    begin
  132.    {$IFDEF DATE}
  133.    case tt of
  134.       0 : str2fmt := s;
  135.       1 : str2fmt:=copy(s,4,2)+sep[1]+copy(s,1,2)+sep[1]+copy(s,7,4);
  136.       2 : str2fmt:=copy(s,7,4)+sep[1]+copy(s,1,2)+sep[1]+copy(s,4,2);
  137.       end;
  138.    {$ELSE}
  139.    if ((tt=1) or (tt=2)) then df:=dfmt[tt-1] else df:=dfmt[2];
  140.    str2fmt:=copy(s,df[0],2)+sep[1]+copy(s,df[1],2)+sep[1]+copy(s,df[2],2);
  141.    {$ENDIF}
  142.    end
  143. else
  144.    str2fmt:=s;
  145. END;
  146.  
  147. Function fmt2str(s:string;tt:byte):string;
  148. var df:dfmtrec;
  149. BEGIN
  150. if s <> '' then
  151.    begin
  152.    {$IFDEF DATE}
  153.    case tt of
  154.       0 : fmt2str:=s;
  155.       1 : fmt2str:=copy(s,4,2)+'/'+copy(s,1,2)+'/'+copy(s,7,4);
  156.       2 : fmt2str:=copy(s,6,2)+'/'+copy(s,9,2)+'/'+copy(s,1,4);
  157.       end;
  158.    {$ELSE}
  159.    if (tt = 1) then df:=dfmt[0] else
  160.       if (tt=2) then df:=dfmt[3] else
  161.          df:=dfmt[2];
  162.    fmt2str:=copy(s,df[0],2)+'/'+copy(s,df[1],2)+'/'+copy(s,df[2],2);
  163.    {$ENDIF}
  164.    end
  165. else fmt2str:=s;
  166. END;
  167.  
  168. Function unix2fmt(l:longint;tt:byte):string;
  169. BEGIN
  170. {$IFDEF DATE}
  171. unix2fmt:=str2fmt(strftimel('%m/%d/%Y',l),tt);
  172. {$ELSE}
  173. unix2fmt:=str2fmt(strftimel('%m/%d/%y',l),tt);
  174. {$ENDIF}
  175. END;
  176.  
  177. function dayofweek(day,mth,year:longint):byte;
  178. VAR n1,n2,dow : longint;
  179. BEGIN
  180. if mth < 3 then
  181.    begin
  182.    Inc(mth, 10);
  183.    Dec(year);
  184.    end
  185. else
  186.    Dec(mth, 2);
  187. n1 := year div 100;
  188. n2 := year mod 100;
  189. dow := (((26 * mth - 2) div 10) + day + n2 + (n2 div 4) + (n1 div 4) - (2 * n1)) mod 7;
  190. if dow < 0 then
  191.    dayofweek := dow + 7
  192. else dayofweek := dow;
  193. END;
  194.  
  195. function dt2unix(dt:datetimerec):longint;
  196. var x:longint;
  197. begin
  198. dtable[2]:=28;
  199. if dt.year >= 1970 then
  200.    BEGIN
  201.    if ((dt.year mod 4)=0) then dtable[2]:=29;
  202.    x:=dt.day-1;
  203.    while (dt.month > 1) do
  204.       BEGIN
  205.       dec(dt.month,1);
  206.       inc(x,dtable[dt.month]);
  207.       END;
  208.    while (dt.year > 1970) do
  209.       BEGIN
  210.       dec(dt.year,1);
  211.       inc(x,365);
  212.       if ((dt.year mod 4)=0) then x:=x+1;
  213.       END;
  214.    x:=(x*24)+dt.hour;
  215.    x:=(x*60)+dt.min;
  216.    x:=(x*60)+dt.sec;
  217.    dt2unix:=x;
  218.    END;
  219. end;
  220.  
  221. {*---------------------------------------------------------------------------*}
  222.  
  223. {*
  224. **  Convert Unix-style time to date/time structure.
  225. *}
  226.  
  227. procedure unix2dt(t:longint; var dt:datetimerec);
  228. begin
  229. fillchar(dt,sizeof(datetimerec),0);
  230. dtable[2]:=28;
  231. dt.year:=1970;
  232. dt.month:=1;
  233. dt.day:=1;
  234. if t > 0 then
  235.    BEGIN
  236.    dt.sec  := t mod 60;  t := t div 60;
  237.    dt.min  := t mod 60;  t := t div 60;
  238.    dt.hour := t mod 24;  t := t div 24;
  239.    dt.day  := 0;
  240.    while ((t > 364) and ((dt.year mod 4)<>0))
  241.       or ((t > 365) and ((dt.year mod 4)=0)) do
  242.       BEGIN
  243.       if ((dt.year mod 4)=0) then t:=t-1;
  244.       inc(dt.year,1);
  245.       dec(t,365);
  246.       END;
  247.    if ((dt.year mod 4)=0) then dtable[2]:=29;
  248.    while t >= dtable[dt.month] do
  249.       BEGIN
  250.       dec(t,dtable[dt.month]);
  251.       inc(dt.month,1);
  252.       END;
  253.    dt.day := t+1;
  254.    END;
  255. dt.dow:=dayofweek(dt.day,dt.month,dt.year);
  256. end;
  257.  
  258. {*---------------------------------------------------------------------------*}
  259.  
  260. {*
  261. **  Obtain current date and time in date/time structure.
  262. *}
  263.  
  264. procedure getdatetime(var dt:datetimerec);
  265. {$IFDEF OS2}
  266. var year,month,day,dow,
  267.     hour,min,sec,sec100:longint;
  268. {$ELSE}
  269. var year,month,day,dow,
  270.     hour,min,sec,sec100:word;
  271. {$ENDIF}
  272. begin
  273. getdate(year,month,day,dow);
  274. dt.year:=year;
  275. dt.month:=month;
  276. dt.day:=day;
  277. dt.dow:=dow;
  278. gettime(hour,min,sec,sec100);
  279. dt.hour:=hour;
  280. dt.min:=min;
  281. dt.sec:=sec;
  282. dt.sec100:=sec100;
  283. end;
  284.  
  285. {*---------------------------------------------------------------------------*}
  286.  
  287. {*
  288. **  Return current date and time as Unix-style time (number of seconds since
  289. **  January 1, 1970).
  290. *}
  291.  
  292. function ltime:longint;
  293. var dt:datetimerec;
  294. begin
  295.   getdatetime(dt);
  296.   ltime:=dt2unix(dt);
  297. end;
  298.  
  299. function rtime:longint;
  300. var dt:datetimerec;
  301. begin
  302.   getdatetime(dt);
  303.   dt.hour:=0;
  304.   dt.min:=0;
  305.   dt.sec:=0;
  306.   rtime:=dt2unix(dt);
  307. end;
  308.  
  309. {*---------------------------------------------------------------------------*}
  310.  
  311. {*
  312. **        %a      Abbreviated weekday name.
  313.  
  314. **        %b      Abbreviated month name.
  315. **        %B      long month name
  316. **        %d      Day of month (1-31) with leading zero
  317. **        %D      Day of month (1-31) without leading zero
  318. **        %h      Hour (0-23) with leading zero.
  319. **        %I      Hour (1-12) without leading zero.
  320. **        %m      Month (1-12) with leading zero.
  321. **        %n      Minute (0-59) with leading zero.
  322. **        %p      "a" or "p".
  323. **        %s      Second (0-59) with leading zero.
  324. **        %w      Weekday (0-6, Sunday is 0).
  325. **        %y      Year without century (00-99).
  326. **        %Y      Year with century.
  327. **
  328. **  All other characters written to output string unchanged.
  329. *}
  330.  
  331. function strftime(fmt:string; dt:datetimerec):string;
  332. var s:string;
  333.     i,value:integer;
  334.     c:char;
  335.  
  336.   function itos(number,pad:integer):string;
  337.   var s:string;
  338.   begin
  339.     str(number,s);
  340.     while (length(s)<pad) do
  341.       s:='0'+s;
  342.     itos:=s;
  343.   end;
  344.  
  345. begin
  346.   s:='';
  347.   for i:=1 to length(fmt) do begin
  348.     c:=fmt[i];
  349.     if (c<>'%') then
  350.       s:=s+c
  351.     else begin
  352.       inc(i);
  353.       c:=fmt[i];
  354.       case c of
  355.         'a':s:=s+dshort[dt.dow];
  356.         'b':s:=s+mshort[dt.month];
  357.         'B':s:=s+mlong[dt.month];
  358.         'd':s:=s+itos(dt.day,2);
  359.         'D':s:=s+itos(dt.day,0);
  360.         'h':s:=s+itos(dt.hour,2);
  361.         'H':s:=s+itos(dt.hour,0);
  362.         'I':begin
  363.             value := (dt.hour mod 12);
  364.             if (value=0) then
  365.                value:=12;
  366.             s:=s+itos(value,0);
  367.             end;
  368.         'm':s:=s+itos(dt.month,2);
  369.         'n':s:=s+itos(dt.min,2);
  370.         'p':s:=s+tshort[dt.hour div 12];
  371.         's':s:=s+itos(dt.sec,2);
  372.         'w':s:=s+itos(dt.dow,0);
  373.         'y':begin
  374.             value:= dt.year mod 100;
  375.             s:=s+itos(value,2);
  376.             end;
  377.         'Y':s:=s+itos(dt.year,4);
  378.         else s := s+'%'+c;
  379.       end;
  380.     end;
  381.   end;
  382.   strftime:=s;
  383. end;
  384.  
  385. {*---------------------------------------------------------------------------*}
  386.  
  387. {*
  388. **  Convert Unix-style time to formatted string.  Uses the strftime function
  389. **  (above).
  390. *}
  391.  
  392. function strftimel(fmt:string; l:longint):string;
  393. var dt:datetimerec;
  394. begin
  395. unix2dt(l,dt);
  396. strftimel:=strftime(fmt,dt);
  397. end;
  398.  
  399. procedure incmonth(var dt:datetimerec);
  400. begin
  401. if dt.month = 12 then
  402.    begin
  403.    dt.month:=01;
  404.    inc(dt.year,1);
  405.    end
  406. else
  407.    inc(dt.month,1);
  408. end;
  409.  
  410. procedure incday(var dt:datetimerec);
  411. begin
  412. dtable[2]:=28;
  413. if dt.day >= dtable[dt.month] then
  414.    begin
  415.    dt.day:=01;
  416.    incmonth(dt);
  417.    end
  418. else
  419.    inc(dt.day,1);
  420. end;
  421.  
  422. function runix(l:longint):longint;
  423. begin
  424. runix := l - (l MOD 86400);
  425. end;
  426.  
  427. function stime:string;
  428. begin
  429. {$IFDEF DATE}
  430. stime:=strftimel('%m/%d/%Y',ltime);
  431. {$ELSE}
  432. stime:=strftimel('%m/%d/%y',ltime);
  433. {$ENDIF}
  434. end;
  435.  
  436. function ctime(l:longint):string;
  437. begin
  438. ctime:=strftimel('%h'+sep[2]+'%n'+sep[2]+'%s',l);
  439. end;
  440.  
  441. function etime(l:longint):string;
  442. begin
  443. etime:=strftimel('%a %d %b %Y  %I'+sep[2]+'%n%p',l);
  444. end;
  445.  
  446. end.
  447.  
  448.