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 >
Wrap
Pascal/Delphi Source File
|
1998-11-16
|
11KB
|
448 lines
{****************************************************************************)
(*> <*)
(*> Telegard Bulletin Board System <*)
(*> Copyright 1994-1998 by Tim Strike. All rights reserved. <*)
(*> <*)
(*> Module name: DATETIME.PAS <*)
(*> Module purpose: Date and time routines. <*)
(*> <*)
(****************************************************************************}
{$A+,B+,E-,F+,I-,N-,O-,V-}
unit dtime;
interface
uses
dos;
type
datetimerec= { date/time storage }
record
year, month, day, hour, min, sec, sec100, dow : word;
end;
dfmtrec = array[0..2] of byte;
const
dtable : array[1..12] of byte = (31,28,31,30,31,30,31,31,30,31,30,31);
mlong : array[1..12] of string[25] = ('January','February','March','April','May','June',
'July','August','September','October','November','December');
mshort : array[1..12] of string[3] = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
dlong : array[0..6] of string[20] = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
dshort : array[0..6] of string[3] = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
tlong : array[0..1] of string[2] = ('am','pm');
tshort : array[0..1] of string[1] = ('a','p');
sep : array[1..2] of char = ('/',':');
{$IFNDEF DATE}
dfmt : array[0..3] of dfmtrec = ((4,1,7),(7,1,4),(1,4,7),(4,7,1));
{$ENDIF}
function dayofweek ( day,mth,year:longint ):byte;
function dt2unix ( dt:datetimerec ):longint;
procedure getdatetime ( var dt:datetimerec );
function ltime : longint;
function rtime : longint;
function stime : string;
function runix (l:longint):longint;
function strftime ( fmt:string; dt:datetimerec ):string;
function strftimel ( fmt:string; l:longint ):string;
procedure unix2dt ( t:longint; var dt:datetimerec );
procedure incmonth ( var dt:datetimerec );
procedure incday ( var dt:datetimerec );
function ndatefmt ( tt:byte ):string; { format type }
Function str2fmt ( s:string;tt:byte):string; { MM/DD/YY to format }
Function fmt2str ( s:string;tt:byte ):string; { format to MM/DD/YY }
Function unix2fmt ( l:longint;tt:byte):string; { unixdate to format }
procedure setsep ( c1,c2:char );
procedure setday ( nn:byte;s,s1:string );
procedure setmonth ( nn:byte;s,s1:string );
procedure settime ( s,s1,s2,s3:string );
function ctime ( l:longint): string;
function etime ( l:longint): string;
procedure convertdate ( dt:datetime; var dt1:datetimerec );
implementation
{*---------------------------------------------------------------------------*}
procedure convertdate( dt:datetime; var dt1:datetimerec );
begin
{$IFDEF OS2}
dt1.year := dt.year;
dt1.month := dt.month;
dt1.day := dt.day;
dt1.hour := dt.hour;
dt1.min := dt.min;
dt1.sec := dt.sec;
{$ELSE}
move(dt, dt1, sizeof(datetime));
{$ENDIF}
end;
procedure setsep( c1,c2 : char );
begin
sep[1] := c1;
sep[2] := c2;
end;
procedure setday(nn:byte;s,s1:string);
begin
dshort[nn] := s;
dlong[nn] := s1;
end;
procedure setmonth(nn:byte;s,s1:string);
begin
mshort[nn]:=s;
mlong[nn]:=s1;
end;
procedure settime(s,s1,s2,s3:string);
begin
tshort[0]:=s;
tshort[1]:=s1;
tlong[0]:=s2;
tlong[1]:=s3;
end;
function ndatefmt(tt:byte):string;
BEGIN
{$IFDEF DATE}
case tt of
1 : ndatefmt:='DD'+sep[1]+'MM'+sep[1]+'YYYY';
2 : ndatefmt:='YYYY'+sep[1]+'MM'+sep[1]+'DD';
else ndatefmt:='MM'+sep[1]+'DD'+sep[1]+'YYYY';
END; { Case }
{$ELSE}
case tt of
1 : ndatefmt:='DD'+sep[1]+'MM'+sep[1]+'YY';
2 : ndatefmt:='YY'+sep[1]+'MM'+sep[1]+'DD';
else ndatefmt:='MM'+sep[1]+'DD'+sep[1]+'YY';
END; { Case }
{$ENDIF}
END;
Function str2fmt(s:string;tt:byte):string;
var df:dfmtrec;
BEGIN
if s <> '' then
begin
{$IFDEF DATE}
case tt of
0 : str2fmt := s;
1 : str2fmt:=copy(s,4,2)+sep[1]+copy(s,1,2)+sep[1]+copy(s,7,4);
2 : str2fmt:=copy(s,7,4)+sep[1]+copy(s,1,2)+sep[1]+copy(s,4,2);
end;
{$ELSE}
if ((tt=1) or (tt=2)) then df:=dfmt[tt-1] else df:=dfmt[2];
str2fmt:=copy(s,df[0],2)+sep[1]+copy(s,df[1],2)+sep[1]+copy(s,df[2],2);
{$ENDIF}
end
else
str2fmt:=s;
END;
Function fmt2str(s:string;tt:byte):string;
var df:dfmtrec;
BEGIN
if s <> '' then
begin
{$IFDEF DATE}
case tt of
0 : fmt2str:=s;
1 : fmt2str:=copy(s,4,2)+'/'+copy(s,1,2)+'/'+copy(s,7,4);
2 : fmt2str:=copy(s,6,2)+'/'+copy(s,9,2)+'/'+copy(s,1,4);
end;
{$ELSE}
if (tt = 1) then df:=dfmt[0] else
if (tt=2) then df:=dfmt[3] else
df:=dfmt[2];
fmt2str:=copy(s,df[0],2)+'/'+copy(s,df[1],2)+'/'+copy(s,df[2],2);
{$ENDIF}
end
else fmt2str:=s;
END;
Function unix2fmt(l:longint;tt:byte):string;
BEGIN
{$IFDEF DATE}
unix2fmt:=str2fmt(strftimel('%m/%d/%Y',l),tt);
{$ELSE}
unix2fmt:=str2fmt(strftimel('%m/%d/%y',l),tt);
{$ENDIF}
END;
function dayofweek(day,mth,year:longint):byte;
VAR n1,n2,dow : longint;
BEGIN
if mth < 3 then
begin
Inc(mth, 10);
Dec(year);
end
else
Dec(mth, 2);
n1 := year div 100;
n2 := year mod 100;
dow := (((26 * mth - 2) div 10) + day + n2 + (n2 div 4) + (n1 div 4) - (2 * n1)) mod 7;
if dow < 0 then
dayofweek := dow + 7
else dayofweek := dow;
END;
function dt2unix(dt:datetimerec):longint;
var x:longint;
begin
dtable[2]:=28;
if dt.year >= 1970 then
BEGIN
if ((dt.year mod 4)=0) then dtable[2]:=29;
x:=dt.day-1;
while (dt.month > 1) do
BEGIN
dec(dt.month,1);
inc(x,dtable[dt.month]);
END;
while (dt.year > 1970) do
BEGIN
dec(dt.year,1);
inc(x,365);
if ((dt.year mod 4)=0) then x:=x+1;
END;
x:=(x*24)+dt.hour;
x:=(x*60)+dt.min;
x:=(x*60)+dt.sec;
dt2unix:=x;
END;
end;
{*---------------------------------------------------------------------------*}
{*
** Convert Unix-style time to date/time structure.
*}
procedure unix2dt(t:longint; var dt:datetimerec);
begin
fillchar(dt,sizeof(datetimerec),0);
dtable[2]:=28;
dt.year:=1970;
dt.month:=1;
dt.day:=1;
if t > 0 then
BEGIN
dt.sec := t mod 60; t := t div 60;
dt.min := t mod 60; t := t div 60;
dt.hour := t mod 24; t := t div 24;
dt.day := 0;
while ((t > 364) and ((dt.year mod 4)<>0))
or ((t > 365) and ((dt.year mod 4)=0)) do
BEGIN
if ((dt.year mod 4)=0) then t:=t-1;
inc(dt.year,1);
dec(t,365);
END;
if ((dt.year mod 4)=0) then dtable[2]:=29;
while t >= dtable[dt.month] do
BEGIN
dec(t,dtable[dt.month]);
inc(dt.month,1);
END;
dt.day := t+1;
END;
dt.dow:=dayofweek(dt.day,dt.month,dt.year);
end;
{*---------------------------------------------------------------------------*}
{*
** Obtain current date and time in date/time structure.
*}
procedure getdatetime(var dt:datetimerec);
{$IFDEF OS2}
var year,month,day,dow,
hour,min,sec,sec100:longint;
{$ELSE}
var year,month,day,dow,
hour,min,sec,sec100:word;
{$ENDIF}
begin
getdate(year,month,day,dow);
dt.year:=year;
dt.month:=month;
dt.day:=day;
dt.dow:=dow;
gettime(hour,min,sec,sec100);
dt.hour:=hour;
dt.min:=min;
dt.sec:=sec;
dt.sec100:=sec100;
end;
{*---------------------------------------------------------------------------*}
{*
** Return current date and time as Unix-style time (number of seconds since
** January 1, 1970).
*}
function ltime:longint;
var dt:datetimerec;
begin
getdatetime(dt);
ltime:=dt2unix(dt);
end;
function rtime:longint;
var dt:datetimerec;
begin
getdatetime(dt);
dt.hour:=0;
dt.min:=0;
dt.sec:=0;
rtime:=dt2unix(dt);
end;
{*---------------------------------------------------------------------------*}
{*
** %a Abbreviated weekday name.
** %b Abbreviated month name.
** %B long month name
** %d Day of month (1-31) with leading zero
** %D Day of month (1-31) without leading zero
** %h Hour (0-23) with leading zero.
** %I Hour (1-12) without leading zero.
** %m Month (1-12) with leading zero.
** %n Minute (0-59) with leading zero.
** %p "a" or "p".
** %s Second (0-59) with leading zero.
** %w Weekday (0-6, Sunday is 0).
** %y Year without century (00-99).
** %Y Year with century.
**
** All other characters written to output string unchanged.
*}
function strftime(fmt:string; dt:datetimerec):string;
var s:string;
i,value:integer;
c:char;
function itos(number,pad:integer):string;
var s:string;
begin
str(number,s);
while (length(s)<pad) do
s:='0'+s;
itos:=s;
end;
begin
s:='';
for i:=1 to length(fmt) do begin
c:=fmt[i];
if (c<>'%') then
s:=s+c
else begin
inc(i);
c:=fmt[i];
case c of
'a':s:=s+dshort[dt.dow];
'b':s:=s+mshort[dt.month];
'B':s:=s+mlong[dt.month];
'd':s:=s+itos(dt.day,2);
'D':s:=s+itos(dt.day,0);
'h':s:=s+itos(dt.hour,2);
'H':s:=s+itos(dt.hour,0);
'I':begin
value := (dt.hour mod 12);
if (value=0) then
value:=12;
s:=s+itos(value,0);
end;
'm':s:=s+itos(dt.month,2);
'n':s:=s+itos(dt.min,2);
'p':s:=s+tshort[dt.hour div 12];
's':s:=s+itos(dt.sec,2);
'w':s:=s+itos(dt.dow,0);
'y':begin
value:= dt.year mod 100;
s:=s+itos(value,2);
end;
'Y':s:=s+itos(dt.year,4);
else s := s+'%'+c;
end;
end;
end;
strftime:=s;
end;
{*---------------------------------------------------------------------------*}
{*
** Convert Unix-style time to formatted string. Uses the strftime function
** (above).
*}
function strftimel(fmt:string; l:longint):string;
var dt:datetimerec;
begin
unix2dt(l,dt);
strftimel:=strftime(fmt,dt);
end;
procedure incmonth(var dt:datetimerec);
begin
if dt.month = 12 then
begin
dt.month:=01;
inc(dt.year,1);
end
else
inc(dt.month,1);
end;
procedure incday(var dt:datetimerec);
begin
dtable[2]:=28;
if dt.day >= dtable[dt.month] then
begin
dt.day:=01;
incmonth(dt);
end
else
inc(dt.day,1);
end;
function runix(l:longint):longint;
begin
runix := l - (l MOD 86400);
end;
function stime:string;
begin
{$IFDEF DATE}
stime:=strftimel('%m/%d/%Y',ltime);
{$ELSE}
stime:=strftimel('%m/%d/%y',ltime);
{$ENDIF}
end;
function ctime(l:longint):string;
begin
ctime:=strftimel('%h'+sep[2]+'%n'+sep[2]+'%s',l);
end;
function etime(l:longint):string;
begin
etime:=strftimel('%a %d %b %Y %I'+sep[2]+'%n%p',l);
end;
end.