{ ********************************************************************* Copyright (C) 1997, 1998 Gertjan Schouten This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ********************************************************************* System Utilities For Free Pascal } {==============================================================================} { internal functions } {==============================================================================} Function DoEncodeDate(Year, Month, Day: Word): longint; Var D : TDateTime; begin If TryEncodeDate(Year,Month,Day,D) then Result:=Trunc(D) else Result:=0; end; function DoEncodeTime(Hour, Minute, Second, MilliSecond: word): TDateTime; begin If not TryEncodeTime(Hour,Minute,Second,MilliSecond,Result) then Result:=0; end; {==============================================================================} { Public functions } {==============================================================================} { ComposeDateTime converts a Date and a Time into one TDateTime } function ComposeDateTime(Date,Time : TDateTime) : TDateTime; begin if Date < 0 then Result := trunc(Date) - Abs(frac(Time)) else Result := trunc(Date) + Abs(frac(Time)); end; { DateTimeToTimeStamp converts DateTime to a TTimeStamp } function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp; begin result.Time := Round(abs(Frac(DateTime)) * MSecsPerDay); result.Date := DateDelta + trunc(DateTime); end ; { TimeStampToDateTime converts TimeStamp to a TDateTime value } function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime; begin Result := ComposeDateTime(TimeStamp.Date - DateDelta,TimeStamp.Time / MSecsPerDay) end; { MSecsToTimeStamp } function MSecsToTimeStamp(MSecs: comp): TTimeStamp; begin result.Date := Trunc(msecs / msecsperday); msecs:= msecs-comp(result.date)*msecsperday; result.Time := Round(MSecs); end ; { TimeStampToMSecs } function TimeStampToMSecs(const TimeStamp: TTimeStamp): comp; begin result := TimeStamp.Time + comp(timestamp.date)*msecsperday; end ; Function TryEncodeDate(Year,Month,Day : Word; Out Date : TDateTime) : Boolean; var c, ya: cardinal; begin Result:=(Year>0) and (Year<10000) and (Month in [1..12]) and (Day>0) and (Day<=MonthDays[IsleapYear(Year),Month]); If Result then begin if month > 2 then Dec(Month,3) else begin Inc(Month,9); Dec(Year); end; c:= Year DIV 100; ya:= Year - 100*c; Date := (146097*c) SHR 2 + (1461*ya) SHR 2 + (153*cardinal(Month)+2) DIV 5 + cardinal(Day); // Note that this line can't be part of the line above, since TDateTime is // signed and c and ya are not Date := Date - 693900; end end; function TryEncodeTime(Hour, Min, Sec, MSec:word; Out Time : TDateTime) : boolean; begin Result:=(Hour<24) and (Min<60) and (Sec<60) and (MSec<1000); If Result then Time:=TDateTime(cardinal(Hour)*3600000+cardinal(Min)*60000+cardinal(Sec)*1000+MSec)/MSecsPerDay; end; { EncodeDate packs three variables Year, Month and Day into a TDateTime value the result is the number of days since 12/30/1899 } function EncodeDate(Year, Month, Day: word): TDateTime; begin If Not TryEncodeDate(Year,Month,Day,Result) then Raise EConvertError.CreateFmt('%d-%d-%d is not a valid date specification', [Year,Month,Day]); end; { EncodeTime packs four variables Hour, Minute, Second and MilliSecond into a TDateTime value } function EncodeTime(Hour, Minute, Second, MilliSecond:word):TDateTime; begin If not TryEncodeTime(Hour,Minute,Second,MilliSecond,Result) then Raise EConvertError.CreateFmt('%d:%d:%d.%d is not a valid time specification', [Hour,Minute,Second,MilliSecond]); end; { DecodeDate unpacks the value Date into three values: Year, Month and Day } procedure DecodeDate(Date: TDateTime; out Year, Month, Day: word); var ly,ld,lm,j : cardinal; begin if Date <= -datedelta then // If Date is before 1-1-1 then return 0-0-0 begin Year := 0; Month := 0; Day := 0; end else begin j := pred((Trunc(System.Int(Date)) + 693900) SHL 2); ly:= j DIV 146097; j:= j - 146097 * cardinal(ly); ld := j SHR 2; j:=(ld SHL 2 + 3) DIV 1461; ld:= (cardinal(ld) SHL 2 + 7 - 1461*j) SHR 2; lm:=(5 * ld-3) DIV 153; ld:= (5 * ld +2 - 153*lm) DIV 5; ly:= 100 * cardinal(ly) + j; if lm < 10 then inc(lm,3) else begin dec(lm,9); inc(ly); end; year:=ly; month:=lm; day:=ld; end; end; function DecodeDateFully(const DateTime: TDateTime; out Year, Month, Day, DOW: Word): Boolean; begin DecodeDate(DateTime,Year,Month,Day); DOW:=DayOfWeek(DateTime); Result:=IsLeapYear(Year); end; { DecodeTime unpacks Time into four values: Hour, Minute, Second and MilliSecond } procedure DecodeTime(Time: TDateTime; out Hour, Minute, Second, MilliSecond: word); Var l : cardinal; begin l := Round(abs(Frac(time)) * MSecsPerDay); Hour := l div 3600000; l := l mod 3600000; Minute := l div 60000; l := l mod 60000; Second := l div 1000; l := l mod 1000; MilliSecond := l; end; { DateTimeToSystemTime converts DateTime value to SystemTime } procedure DateTimeToSystemTime(DateTime: TDateTime; out SystemTime: TSystemTime); begin DecodeDate(DateTime, SystemTime.Year, SystemTime.Month, SystemTime.Day); DecodeTime(DateTime, SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond); end ; { SystemTimeToDateTime converts SystemTime to a TDateTime value } function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime; begin result := ComposeDateTime(DoEncodeDate(SystemTime.Year, SystemTime.Month, SystemTime.Day), DoEncodeTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond)); end ; { DayOfWeek returns the Day of the week (sunday is day 1) } function DayOfWeek(DateTime: TDateTime): integer; begin Result := 1 + (Abs(Trunc(DateTime) - 1) mod 7); end ; { Date returns the current Date } function Date: TDateTime; var SystemTime: TSystemTime; begin GetLocalTime(SystemTime); result := DoEncodeDate(SystemTime.Year, SystemTime.Month, SystemTime.Day); end ; { Time returns the current Time } function Time: TDateTime; var SystemTime: TSystemTime; begin GetLocalTime(SystemTime); Result := DoEncodeTime(SystemTime.Hour,SystemTime.Minute,SystemTime.Second,SystemTime.MilliSecond); end ; { Now returns the current Date and Time } function Now: TDateTime; var SystemTime: TSystemTime; begin GetLocalTime(SystemTime); result := systemTimeToDateTime(SystemTime); end; { IncMonth increments DateTime with NumberOfMonths months, NumberOfMonths can be less than zero } function IncMonth(const DateTime: TDateTime; NumberOfMonths: integer = 1 ): TDateTime; var Year, Month, Day : word; begin DecodeDate(DateTime, Year, Month, Day); IncAMonth(Year, Month, Day, NumberOfMonths); result := ComposeDateTime(DoEncodeDate(Year, Month, Day), DateTime); end ; { IncAMonth is the same as IncMonth, but operates on decoded date } procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1); var TempMonth, S: Integer; begin If NumberOfMonths>=0 then s:=1 else s:=-1; inc(Year,(NumberOfMonths div 12)); TempMonth:=Month+(NumberOfMonths mod 12)-1; if (TempMonth>11) or (TempMonth<0) then begin Dec(TempMonth, S*12); Inc(Year, S); end; Month:=TempMonth+1; { Months from 1 to 12 } If (Day>MonthDays[IsLeapYear(Year)][Month]) then Day:=MonthDays[IsLeapYear(Year)][Month]; end; { IsLeapYear returns true if Year is a leap year } function IsLeapYear(Year: Word): boolean; begin Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0)); end; { DateToStr returns a string representation of Date using ShortDateFormat } function DateToStr(Date: TDateTime): string; begin result := FormatDateTime('ddddd', Date); end ; { TimeToStr returns a string representation of Time using LongTimeFormat } function TimeToStr(Time: TDateTime): string; begin result := FormatDateTime('tt', Time); end ; { DateTimeToStr returns a string representation of DateTime using LongDateTimeFormat } function DateTimeToStr(DateTime: TDateTime): string; begin result := FormatDateTime('c', DateTime); end ; { StrToDate converts the string S to a TDateTime value if S does not represent a valid date value an EConvertError will be raised } function StrToDate(const S: string): TDateTime; var df:string; d,m,y,ly:word; n,i:longint; c:word; dp,mp,yp,which : Byte; s1:string[4]; values:array[1..3] of longint; LocalTime:tsystemtime; YearMoreThenTwoDigits : boolean; begin YearMoreThenTwoDigits := False; df := UpperCase(ShortDateFormat); { Determine order of D,M,Y } yp:=0; mp:=0; dp:=0; Which:=0; i:=0; while (i3 then Raise EConvertError.Create('Illegal format string'); { Get actual values } for i := 1 to 3 do values[i] := 0; s1 := ''; n := 0; for i := 1 to length(s) do begin if s[i] in ['0'..'9'] then s1 := s1 + s[i]; { space can be part of the shortdateformat, and is defaultly in slovak windows, therefor it shouldn't be taken as separator (unless so specified) and ignored } if (DateSeparator <> ' ') and (s[i] = ' ') then Continue; if (s[i] = dateseparator) or ((i = length(s)) and (s[i] in ['0'..'9'])) then begin inc(n); if n>3 then Raise EConvertError.Create('Invalid date format'); // Check if the year has more then two digits (if n=yp, then we are evaluating the year.) if (n=yp) and (length(s1)>2) then YearMoreThenTwoDigits := True; val(s1, values[n], c); if c<>0 then Raise EConvertError.Create('Invalid date format'); s1 := ''; end else if not (s[i] in ['0'..'9']) then Raise EConvertError.Create('Invalid date format'); end ; // Fill in values. getLocalTime(LocalTime); ly := LocalTime.Year; If N=3 then begin y:=values[yp]; m:=values[mp]; d:=values[dp]; end Else begin Y:=ly; If n<2 then begin d:=values[1]; m := LocalTime.Month; end else If dp= 0) and (y < 100) and not YearMoreThenTwoDigits then begin ly := ly - TwoDigitYearCenturyWindow; Inc(Y, ly div 100 * 100); if (TwoDigitYearCenturyWindow > 0) and (Y < ly) then Inc(Y, 100); end; Result := EncodeDate(y, m, d); end ; { StrToTime converts the string S to a TDateTime value if S does not represent a valid time value an EConvertError will be raised } function StrToTime(const s: string): TDateTime; var Len, Current: integer; PM: integer; function GetElement: integer; var j, c: integer; begin result := -1; Inc(Current); while (result = -1) and (Current <= Len) do begin if S[Current] in ['0'..'9'] then begin j := Current; while (Current < Len) and (s[Current + 1] in ['0'..'9']) do Inc(Current); val(copy(S, j, 1 + Current - j), result, c); end else if ((TimeAMString<>'') and (S[Current] = TimeAMString[1])) or (S[Current] in ['a', 'A']) then begin pm:=1; Current := 1 + Len; end else if ((TimePMString<>'') and (S[Current] = TimePMString[1])) or (S[Current] in ['p', 'P']) then begin Current := 1 + Len; PM := 2; end else if (S[Current] = TimeSeparator) or (S[Current] = ' ') then Inc(Current) else raise EConvertError.Create('Invalid Time format'); end ; end ; var i: integer; TimeValues: array[0..4] of integer; begin Current := 0; Len := length(s); PM := 0; for i:=0 to 4 do timevalues[i]:=0; i := 0; TimeValues[i] := GetElement; while (i < 5) and (TimeValues[i] <> -1) do begin i := i + 1; TimeValues[i] := GetElement; end ; If (i<5) and (TimeValues[I]=-1) then TimeValues[I]:=0; if PM=2 then begin if (TimeValues[0] <> 12) then Inc(TimeValues[0], 12); end else begin if (pm=1) and ((TimeValues[0]=12)) then TimeValues[0]:=0; end; result := EncodeTime(TimeValues[0], TimeValues[1], TimeValues[2], TimeValues[3]); end ; { StrToDateTime converts the string S to a TDateTime value if S does not represent a valid date and/or time value an EConvertError will be raised } function StrToDateTime(const s: string): TDateTime; var i, j, k, l: integer; sd, st: string; begin l := Length(s); i := 1; while (i <= l) and (s[i] = ' ') do Inc(i); j := i; while (j <= l) and (s[j] <> ' ') do Inc(j); k := j; while (k <= l) and (s[k] = ' ') do Inc(k); sd := Copy(s, i, j - i); st := Copy(s, k, l); if (st = '') and (Pos(TimeSeparator, sd) > 0) then begin st := sd; sd := ''; end; if (sd <> '') and (st <> '') then Result := ComposeDateTime(StrToDate(sd), StrToTime(st)) else if st = '' then Result := StrToDate(sd) else Result := StrToTime(st); end ; { FormatDateTime formats DateTime to the given format string FormatStr } function FormatDateTime(FormatStr: string; DateTime: TDateTime): string; var ResultLen: integer; ResultBuffer: array[0..255] of char; ResultCurrent: pchar; procedure StoreStr(Str: pchar; Len: integer); begin if ResultLen + Len < SizeOf(ResultBuffer) then begin StrMove(ResultCurrent, Str, Len); ResultCurrent := ResultCurrent + Len; ResultLen := ResultLen + Len; end ; end ; procedure StoreString(const Str: string); var Len: integer; begin Len := Length(Str); if ResultLen + Len < SizeOf(ResultBuffer) then begin // strmove not safe StrMove(ResultCurrent, pchar(Str), Len); ResultCurrent := ResultCurrent + Len; ResultLen := ResultLen + Len; end; end; procedure StoreInt(Value, Digits: integer); var S: string; Len: integer; begin S := IntToStr(Value); Len := Length(S); if Len < Digits then begin S := copy('0000', 1, Digits - Len) + S; Len := Digits; end ; StoreStr(pchar(@S[1]), Len); end ; var Year, Month, Day, DayOfWeek, Hour, Minute, Second, MilliSecond: word; procedure StoreFormat(const FormatStr: string); var Token,lastformattoken: char; FormatCurrent: pchar; FormatEnd: pchar; Count: integer; Clock12: boolean; P: pchar; tmp:integer; begin FormatCurrent := Pchar(pointer(FormatStr)); FormatEnd := FormatCurrent + Length(FormatStr); Clock12 := false; P := FormatCurrent; while P < FormatEnd do begin Token := UpCase(P^); if Token in ['"', ''''] then begin P := P + 1; while (P < FormatEnd) and (P^ <> Token) do P := P + 1; end else if Token = 'A' then begin if (StrLIComp(P, 'A/P', 3) = 0) or (StrLIComp(P, 'AMPM', 4) = 0) or (StrLIComp(P, 'AM/PM', 5) = 0) then begin Clock12 := true; break; end ; end ; P := P + 1; end ; token:=#255; lastformattoken:=' '; while FormatCurrent < FormatEnd do begin Token := UpCase(FormatCurrent^); Count := 1; P := FormatCurrent + 1; case Token of '''', '"': begin while (P < FormatEnd) and (p^ <> Token) do P := P + 1; P := P + 1; Count := P - FormatCurrent; StoreStr(FormatCurrent + 1, Count - 2); end ; 'A': begin if StrLIComp(FormatCurrent, 'AMPM', 4) = 0 then begin Count := 4; if Hour < 12 then StoreString(TimeAMString) else StoreString(TimePMString); end else if StrLIComp(FormatCurrent, 'AM/PM', 5) = 0 then begin Count := 5; if Hour < 12 then StoreStr('am', 2) else StoreStr('pm', 2); end else if StrLIComp(FormatCurrent, 'A/P', 3) = 0 then begin Count := 3; if Hour < 12 then StoreStr('a', 1) else StoreStr('p', 1); end else Raise EConvertError.Create('Illegal character in format string'); end ; '/': StoreStr(@DateSeparator, 1); ':': StoreStr(@TimeSeparator, 1); ' ', 'C', 'D', 'H', 'M', 'N', 'S', 'T', 'Y','Z' : begin while (P < FormatEnd) and (UpCase(P^) = Token) do P := P + 1; Count := P - FormatCurrent; case Token of ' ': StoreStr(FormatCurrent, Count); 'Y': begin if Count>2 then StoreInt(Year, 4) else StoreInt(Year mod 100, 2); end; 'M': begin if lastformattoken='H' then begin if Count = 1 then StoreInt(Minute, 0) else StoreInt(Minute, 2); end else begin case Count of 1: StoreInt(Month, 0); 2: StoreInt(Month, 2); 3: StoreString(ShortMonthNames[Month]); 4: StoreString(LongMonthNames[Month]); end; end; end; 'D': begin case Count of 1: StoreInt(Day, 0); 2: StoreInt(Day, 2); 3: StoreString(ShortDayNames[DayOfWeek]); 4: StoreString(LongDayNames[DayOfWeek]); 5: StoreFormat(ShortDateFormat); 6: StoreFormat(LongDateFormat); end ; end ; 'H': begin if Clock12 then begin tmp:=hour mod 12; if tmp=0 then tmp:=12; if Count = 1 then StoreInt(tmp, 0) else StoreInt(tmp, 2); end else begin if Count = 1 then StoreInt(Hour, 0) else StoreInt(Hour, 2); end ; end ; 'N': begin if Count = 1 then StoreInt(Minute, 0) else StoreInt(Minute, 2); end ; 'S': begin if Count = 1 then StoreInt(Second, 0) else StoreInt(Second, 2); end ; 'Z': begin if Count = 1 then StoreInt(MilliSecond, 0) else StoreInt(MilliSecond, 3); end ; 'T': begin if Count = 1 then StoreFormat(ShortTimeFormat) else StoreFormat(LongTimeFormat); end ; 'C': begin StoreFormat(ShortDateFormat); if (Hour<>0) or (Minute<>0) or (Second<>0) then begin StoreString(' '); StoreFormat(LongTimeFormat); end; end; end; lastformattoken:=token; end; else StoreStr(@Token, 1); end ; FormatCurrent := FormatCurrent + Count; end ; end ; begin DecodeDateFully(DateTime, Year, Month, Day, DayOfWeek); DecodeTime(DateTime, Hour, Minute, Second, MilliSecond); ResultLen := 0; ResultCurrent := @ResultBuffer[0]; StoreFormat(FormatStr); ResultBuffer[ResultLen] := #0; result := StrPas(@ResultBuffer[0]); end ; { DateTimeToString formats DateTime to the given format in FormatStr } procedure DateTimeToString(out Result: string; const FormatStr: string; const DateTime: TDateTime); begin Result := FormatDateTime(FormatStr, DateTime); end ; Function DateTimeToFileDate(DateTime : TDateTime) : Longint; Var YY,MM,DD,H,m,s,msec : Word; begin Decodedate (DateTime,YY,MM,DD); DecodeTime (DateTime,h,m,s,msec); {$ifndef unix} If (YY<1980) or (YY>2099) then Result:=0 else begin Result:=(s shr 1) or (m shl 5) or (h shl 11); Result:=Result or longint(DD shl 16 or (MM shl 21) or (word(YY-1980) shl 25)); end; {$else unix} Result:=LocalToEpoch(yy,mm,dd,h,m,s); {$endif unix} end; function CurrentYear:Word; var yy,mm,dd : word; begin Decodedate(now,yy,mm,dd); Result:=yy; end; Function FileDateToDateTime (Filedate : Longint) : TDateTime; {$ifndef unix} Var Date,Time : Word; begin Date:=FileDate shr 16; Time:=FileDate and $ffff; Result:=ComposeDateTime(EncodeDate((Date shr 9) + 1980,(Date shr 5) and 15, Date and 31), EncodeTime(Time shr 11, (Time shr 5) and 63, (Time and 31) shl 1,0)); end; {$else unix} var y, mon, d, h, min, s: word; begin EpochToLocal(FileDate,y,mon,d,h,min,s); Result:=ComposeDateTime(EncodeDate(y,mon,d),EncodeTime(h,min,s,0)); end; {$endif unix} // ieuw. These should be written to work without exceptions? function TryStrToDate(const S: string; out Value: TDateTime): Boolean; begin result:=true; try value:=StrToDate(s); except on EConvertError do result:=false end; end; // function TryStrToDate(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean; function TryStrToTime(const S: string; out Value: TDateTime): Boolean; begin result:=true; try value:=StrToTime(s); except on EConvertError do result:=false end; end; // function TryStrToTime(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean; function TryStrToDateTime(const S: string; out Value: TDateTime): Boolean; begin result:=true; try value:=StrToDateTime(s); except on EConvertError do result:=false end; end; // function TryStrToDateTime(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean; function StrToDateDef(const S: string; const Defvalue : TDateTime): TDateTime; begin if not TryStrToDate(s,Result) Then result:=defvalue; end; function StrToTimeDef(const S: string; const Defvalue : TDateTime): TDateTime; begin if not TryStrToTime(s,Result) Then result:=defvalue; end; function StrToDateTimeDef(const S: string; const Defvalue : TDateTime): TDateTime; begin if not TryStrToDateTime(s,Result) Then result:=defvalue; end; procedure ReplaceTime(var dati:TDateTime; NewTime : TDateTime);inline; begin dati:= ComposeDateTime(dati, newtime); end; procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime); inline; var tmp : TDateTime; begin tmp:=NewDate; ReplaceTime(tmp,DateTime); DateTime:=tmp; end;