dati.inc 48 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607
  1. {
  2. *********************************************************************
  3. Copyright (C) 1997, 1998 Gertjan Schouten
  4. See the file COPYING.FPC, included in this distribution,
  5. for details about the copyright.
  6. This program is distributed in the hope that it will be useful,
  7. but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  9. **********************************************************************
  10. System Utilities For Free Pascal
  11. }
  12. {==============================================================================}
  13. { internal functions }
  14. {==============================================================================}
  15. Function DoEncodeDate(Year, Month, Day: Word): longint;
  16. Var
  17. D : TDateTime;
  18. begin
  19. If TryEncodeDate(Year,Month,Day,D) then
  20. Result:=Trunc(D)
  21. else
  22. Result:=0;
  23. end;
  24. function DoEncodeTime(Hour, Minute, Second, MilliSecond: word): TDateTime;
  25. begin
  26. If not TryEncodeTime(Hour,Minute,Second,MilliSecond,Result) then
  27. Result:=0;
  28. end;
  29. {==============================================================================}
  30. { Public functions }
  31. {==============================================================================}
  32. { ComposeDateTime converts a Date and a Time into one TDateTime }
  33. function ComposeDateTime(Date,Time : TDateTime) : TDateTime;
  34. begin
  35. if Date < 0 then Result := trunc(Date) - Abs(frac(Time))
  36. else Result := trunc(Date) + Abs(frac(Time));
  37. end;
  38. { DateTimeToTimeStamp converts DateTime to a TTimeStamp }
  39. function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;
  40. Var
  41. D : Double;
  42. begin
  43. D:=DateTime * Single(MSecsPerDay);
  44. if D<0 then
  45. D:=D-0.5
  46. else
  47. D:=D+0.5;
  48. result.Time := Abs(Trunc(D)) Mod MSecsPerDay;
  49. result.Date := DateDelta + Trunc(D) div MSecsPerDay;
  50. end;
  51. { TimeStampToDateTime converts TimeStamp to a TDateTime value }
  52. function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime;
  53. begin
  54. Result := ComposeDateTime(TimeStamp.Date - DateDelta,TimeStamp.Time / MSecsPerDay)
  55. end;
  56. { MSecsToTimeStamp }
  57. function MSecsToTimeStamp(MSecs: comp): TTimeStamp;
  58. var
  59. D1:Int64;
  60. begin
  61. D1:=Trunc(msecs);
  62. result.Date := D1 div msecsperday;
  63. result.Time := D1 - result.date * msecsperday;
  64. end;
  65. { TimeStampToMSecs }
  66. function TimeStampToMSecs(const TimeStamp: TTimeStamp): comp;
  67. begin
  68. result := TimeStamp.Time + comp(timestamp.date)*msecsperday;
  69. end;
  70. Function TryEncodeDate(Year,Month,Day : Word; Out Date : TDateTime) : Boolean;
  71. var
  72. c, ya: cardinal;
  73. begin
  74. Result:=(Year>0) and (Year<10000) and
  75. (Month in [1..12]) and
  76. (Day>0) and (Day<=MonthDays[IsleapYear(Year),Month]);
  77. If Result then
  78. begin
  79. if month > 2 then
  80. Dec(Month,3)
  81. else
  82. begin
  83. Inc(Month,9);
  84. Dec(Year);
  85. end;
  86. c:= Year DIV 100;
  87. ya:= Year - 100*c;
  88. Date := (146097*c) SHR 2 + (1461*ya) SHR 2 + (153*cardinal(Month)+2) DIV 5 + cardinal(Day);
  89. // Note that this line can't be part of the line above, since TDateTime is
  90. // signed and c and ya are not
  91. Date := Date - 693900;
  92. end
  93. end;
  94. function TryEncodeTime(Hour, Min, Sec, MSec:word; Out Time : TDateTime) : boolean;
  95. begin
  96. Result:=(Hour<24) and (Min<60) and (Sec<60) and (MSec<1000);
  97. If Result then
  98. Time:=TDateTime(cardinal(Hour)*3600000+cardinal(Min)*60000+cardinal(Sec)*1000+MSec)/MSecsPerDay;
  99. end;
  100. { EncodeDate packs three variables Year, Month and Day into a
  101. TDateTime value the result is the number of days since 12/30/1899 }
  102. function EncodeDate(Year, Month, Day: word): TDateTime;
  103. begin
  104. If Not TryEncodeDate(Year,Month,Day,Result) then
  105. Raise EConvertError.CreateFmt('%d-%d-%d is not a valid date specification',
  106. [Year,Month,Day]);
  107. end;
  108. { EncodeTime packs four variables Hour, Minute, Second and MilliSecond into
  109. a TDateTime value }
  110. function EncodeTime(Hour, Minute, Second, MilliSecond:word):TDateTime;
  111. begin
  112. If not TryEncodeTime(Hour,Minute,Second,MilliSecond,Result) then
  113. Raise EConvertError.CreateFmt('%d:%d:%d.%d is not a valid time specification',
  114. [Hour,Minute,Second,MilliSecond]);
  115. end;
  116. { DecodeDate unpacks the value Date into three values:
  117. Year, Month and Day }
  118. procedure DecodeDate(Date: TDateTime; out Year, Month, Day: word);
  119. var
  120. ly,ld,lm,j : cardinal;
  121. begin
  122. if Date <= -datedelta then // If Date is before 1-1-1 then return 0-0-0
  123. begin
  124. Year := 0;
  125. Month := 0;
  126. Day := 0;
  127. end
  128. else
  129. begin
  130. if Date>0 then
  131. Date:=Date+1/(msecsperday*2)
  132. else
  133. Date:=Date-1/(msecsperday*2);
  134. if Date>MaxDateTime then
  135. Date:=MaxDateTime;
  136. // Raise EConvertError.CreateFmt('%f is not a valid TDatetime encoding, maximum value is %f.',[Date,MaxDateTime]);
  137. j := pred((longint(Trunc(System.Int(Date))) + 693900) SHL 2);
  138. ly:= j DIV 146097;
  139. j:= j - 146097 * cardinal(ly);
  140. ld := j SHR 2;
  141. j:=(ld SHL 2 + 3) DIV 1461;
  142. ld:= (cardinal(ld) SHL 2 + 7 - 1461*j) SHR 2;
  143. lm:=(5 * ld-3) DIV 153;
  144. ld:= (5 * ld +2 - 153*lm) DIV 5;
  145. ly:= 100 * cardinal(ly) + j;
  146. if lm < 10 then
  147. inc(lm,3)
  148. else
  149. begin
  150. dec(lm,9);
  151. inc(ly);
  152. end;
  153. year:=ly;
  154. month:=lm;
  155. day:=ld;
  156. end;
  157. end;
  158. function DecodeDateFully(const DateTime: TDateTime; out Year, Month, Day, DOW: Word): Boolean;
  159. begin
  160. DecodeDate(DateTime,Year,Month,Day);
  161. DOW:=DayOfWeek(DateTime);
  162. Result:=IsLeapYear(Year);
  163. end;
  164. { DecodeTime unpacks Time into four values:
  165. Hour, Minute, Second and MilliSecond }
  166. procedure DecodeTime(Time: TDateTime; out Hour, Minute, Second, MilliSecond: word);
  167. Var
  168. l : cardinal;
  169. begin
  170. l := DateTimeToTimeStamp(Time).Time;
  171. Hour := l div 3600000;
  172. l := l mod 3600000;
  173. Minute := l div 60000;
  174. l := l mod 60000;
  175. Second := l div 1000;
  176. l := l mod 1000;
  177. MilliSecond := l;
  178. end;
  179. { DateTimeToSystemTime converts DateTime value to SystemTime }
  180. procedure DateTimeToSystemTime(DateTime: TDateTime; out SystemTime: TSystemTime);
  181. begin
  182. DecodeDateFully(DateTime, SystemTime.Year, SystemTime.Month, SystemTime.Day,SystemTime.DayOfWeek);
  183. DecodeTime(DateTime, SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond);
  184. Dec(SystemTime.DayOfWeek);
  185. end ;
  186. { SystemTimeToDateTime converts SystemTime to a TDateTime value }
  187. function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime;
  188. begin
  189. result := ComposeDateTime(DoEncodeDate(SystemTime.Year, SystemTime.Month, SystemTime.Day),
  190. DoEncodeTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond));
  191. end ;
  192. { DayOfWeek returns the Day of the week (sunday is day 1) }
  193. function DayOfWeek(DateTime: TDateTime): integer;
  194. begin
  195. Result := 1 + ((Trunc(DateTime) - 1) mod 7);
  196. If (Result<=0) then
  197. Inc(Result,7);
  198. end;
  199. { Date returns the current Date }
  200. function Date: TDateTime;
  201. var
  202. SystemTime: TSystemTime;
  203. begin
  204. GetLocalTime(SystemTime);
  205. result := DoEncodeDate(SystemTime.Year, SystemTime.Month, SystemTime.Day);
  206. end ;
  207. { Time returns the current Time }
  208. function Time: TDateTime;
  209. var
  210. SystemTime: TSystemTime;
  211. begin
  212. GetLocalTime(SystemTime);
  213. Result := DoEncodeTime(SystemTime.Hour,SystemTime.Minute,SystemTime.Second,SystemTime.MilliSecond);
  214. end ;
  215. { Now returns the current Date and Time }
  216. function Now: TDateTime;
  217. var
  218. SystemTime: TSystemTime;
  219. begin
  220. GetLocalTime(SystemTime);
  221. result := systemTimeToDateTime(SystemTime);
  222. end;
  223. { NowUTC returns the current UTC Date and Time if available on the OS. If not, local date is returned }
  224. function NowUTC: TDateTime;
  225. var
  226. SystemTime: TSystemTime;
  227. begin
  228. if not GetUniversalTime(SystemTime) then
  229. GetLocalTime(SystemTime);
  230. result := systemTimeToDateTime(SystemTime);
  231. end;
  232. { IncMonth increments DateTime with NumberOfMonths months,
  233. NumberOfMonths can be less than zero }
  234. function IncMonth(const DateTime: TDateTime; NumberOfMonths: integer = 1 ): TDateTime;
  235. var
  236. Year, Month, Day : word;
  237. begin
  238. DecodeDate(DateTime, Year, Month, Day);
  239. IncAMonth(Year, Month, Day, NumberOfMonths);
  240. result := ComposeDateTime(DoEncodeDate(Year, Month, Day), DateTime);
  241. end ;
  242. { IncAMonth is the same as IncMonth, but operates on decoded date }
  243. procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1);
  244. var
  245. TempMonth, S: Integer;
  246. begin
  247. If NumberOfMonths>=0 then
  248. s:=1
  249. else
  250. s:=-1;
  251. inc(Year,(NumberOfMonths div 12));
  252. TempMonth:=Month+(NumberOfMonths mod 12)-1;
  253. if (TempMonth>11) or
  254. (TempMonth<0) then
  255. begin
  256. Dec(TempMonth, S*12);
  257. Inc(Year, S);
  258. end;
  259. Month:=TempMonth+1; { Months from 1 to 12 }
  260. If (Day>MonthDays[IsLeapYear(Year)][Month]) then
  261. Day:=MonthDays[IsLeapYear(Year)][Month];
  262. end;
  263. { IsLeapYear returns true if Year is a leap year }
  264. function IsLeapYear(Year: Word): boolean;
  265. begin
  266. Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
  267. end;
  268. { DateToStr returns a string representation of Date using ShortDateFormat }
  269. function DateToStr(Date: TDateTime): string;
  270. begin
  271. DateTimeToString(Result, 'ddddd', Date);
  272. end ;
  273. function DateToStr(Date: TDateTime; const FormatSettings: TFormatSettings): string;
  274. begin
  275. DateTimeToString(result, FormatSettings.ShortDateFormat, Date, FormatSettings);
  276. end;
  277. { TimeToStr returns a string representation of Time using LongTimeFormat }
  278. function TimeToStr(Time: TDateTime): string;
  279. begin
  280. DateTimeToString(Result, 'tt', Time);
  281. end ;
  282. function TimeToStr(Time: TDateTime; const FormatSettings: TFormatSettings): string;
  283. begin
  284. DateTimeToString(Result, FormatSettings.LongTimeFormat, Time, FormatSettings);
  285. end;
  286. { DateTimeToStr returns a string representation of DateTime using ShortDateFormat and LongTimeFormat }
  287. Const
  288. DateTimeToStrFormat : Array[Boolean] of string = ('c','f');
  289. function DateTimeToStr(DateTime: TDateTime; ForceTimeIfZero : Boolean = False): string;
  290. begin
  291. DateTimeToString(Result, DateTimeToStrFormat[ForceTimeIfZero], DateTime)
  292. end ;
  293. function DateTimeToStr(DateTime: TDateTime; const FormatSettings: TFormatSettings; ForceTimeIfZero : Boolean = False): string;
  294. begin
  295. DateTimeToString(Result, DateTimeToStrFormat[ForceTimeIfZero], DateTime ,FormatSettings);
  296. end;
  297. { StrToDate converts the string S to a TDateTime value
  298. if S does not represent a valid date value
  299. an EConvertError will be raised }
  300. function IntStrToDate(Out ErrorMsg : AnsiString; const S: PChar; Len : integer; const useformat : string; const defs:TFormatSettings; separator : char = #0): TDateTime;
  301. const SInvalidDateFormat = '"%s" is not a valid date format';
  302. procedure FixErrorMsg(const errm :ansistring;const errmarg : ansistring);
  303. begin
  304. errormsg:=format(errm,[errmarg]);
  305. end;
  306. var
  307. df:string;
  308. d,m,y,ly:integer;
  309. n,i:longint;
  310. c:word;
  311. dp,mp,yp,which : Byte;
  312. s1:string;
  313. values:array[0..3] of longint;
  314. LocalTime:tsystemtime;
  315. YearMoreThenTwoDigits : boolean;
  316. begin
  317. ErrorMsg:=''; Result:=0;
  318. While (Len>0) and (S[Len-1] in [' ',#8,#9,#10,#12,#13]) do
  319. Dec(len);
  320. if (Len=0) then
  321. begin
  322. FixErrorMsg(SInvalidDateFormat,'');
  323. exit;
  324. end;
  325. YearMoreThenTwoDigits := False;
  326. if separator = #0 then
  327. separator := defs.DateSeparator;
  328. df := UpperCase(useFormat);
  329. { Determine order of D,M,Y }
  330. yp:=0;
  331. mp:=0;
  332. dp:=0;
  333. Which:=0;
  334. i:=0;
  335. while (i<Length(df)) and (Which<3) do
  336. begin
  337. inc(i);
  338. Case df[i] of
  339. 'Y' :
  340. if yp=0 then
  341. begin
  342. Inc(Which);
  343. yp:=which;
  344. end;
  345. 'M' :
  346. if mp=0 then
  347. begin
  348. Inc(Which);
  349. mp:=which;
  350. end;
  351. 'D' :
  352. if dp=0 then
  353. begin
  354. Inc(Which);
  355. dp:=which;
  356. end;
  357. end;
  358. end;
  359. for i := 1 to 3 do
  360. values[i] := 0;
  361. s1 := '';
  362. n := 0;
  363. dec(len);
  364. for i := 0 to len do
  365. begin
  366. if s[i] in ['0'..'9'] then
  367. s1 := s1 + s[i];
  368. { space can be part of the shortdateformat, and is defaultly in slovak
  369. windows, therefor it shouldn't be taken as separator (unless so specified)
  370. and ignored }
  371. if (Separator <> ' ') and (s[i] = ' ') then
  372. Continue;
  373. if (s[i] = separator) or ((i = len) and (s[i] in ['0'..'9'])) then
  374. begin
  375. inc(n);
  376. if n>3 then
  377. begin
  378. FixErrorMsg(SInvalidDateFormat,s);
  379. exit;
  380. end;
  381. // Check if the year has more then two digits (if n=yp, then we are evaluating the year.)
  382. if (n=yp) and (length(s1)>2) then YearMoreThenTwoDigits := True;
  383. val(s1, values[n], c);
  384. // Writeln(s1,'->',values[n]);
  385. if c<>0 then
  386. begin
  387. FixErrorMsg(SInvalidDateFormat,s);
  388. Exit;
  389. end;
  390. s1 := '';
  391. end
  392. else if not (s[i] in ['0'..'9']) then
  393. begin
  394. FixErrorMsg(SInvalidDateFormat,s);
  395. Exit;
  396. end;
  397. end ;
  398. if (Which<3) and (N>Which) then
  399. begin
  400. FixErrorMsg(SInvalidDateFormat,s);
  401. Exit;
  402. end;
  403. // Fill in values.
  404. getLocalTime(LocalTime);
  405. ly := LocalTime.Year;
  406. for I:=1 to 3 do
  407. if values[i]>high(Word) then
  408. begin
  409. errormsg:='Invalid date';
  410. exit;
  411. end;
  412. If N=3 then
  413. begin
  414. y:=values[yp];
  415. m:=values[mp];
  416. d:=values[dp];
  417. end
  418. Else
  419. begin
  420. Y:=ly;
  421. If n<2 then
  422. begin
  423. d:=values[1];
  424. m := LocalTime.Month;
  425. end
  426. else
  427. If dp<mp then
  428. begin
  429. d:=values[1];
  430. m:=values[2];
  431. end
  432. else
  433. begin
  434. d:=values[2];
  435. m:=values[1];
  436. end;
  437. end;
  438. if (y >= 0) and (y < 100) and not YearMoreThenTwoDigits then
  439. begin
  440. ly := ly - defs.TwoDigitYearCenturyWindow;
  441. Inc(Y, ly div 100 * 100);
  442. if (defs.TwoDigitYearCenturyWindow > 0) and (Y < ly) then
  443. Inc(Y, 100);
  444. end;
  445. if not TryEncodeDate(y, m, d, result) then
  446. errormsg:='Invalid date';
  447. end;
  448. function StrToDate(const S: PChar; Len : integer; const useformat : string; separator : char = #0): TDateTime;
  449. Var
  450. MSg : AnsiString;
  451. begin
  452. Result:=IntStrToDate(Msg,S,Len,useFormat,DefaultFormatSettings,Separator);
  453. If (Msg<>'') then
  454. Raise EConvertError.Create(Msg);
  455. end;
  456. function StrToDate(const S: string; FormatSettings: TFormatSettings): TDateTime;
  457. var
  458. Msg: AnsiString;
  459. begin
  460. Result:=IntStrToDate(Msg,PChar(S),Length(S),FormatSettings.ShortDateFormat,FormatSettings);
  461. if Msg<>'' then
  462. raise EConvertError.Create(Msg);
  463. end;
  464. function StrToDate(const S: ShortString; const useformat : string; separator : char = #0): TDateTime;
  465. begin
  466. // S[1] always exists for shortstring. Length 0 will trigger an error.
  467. result := StrToDate(@S[1],Length(s),UseFormat,separator);
  468. end;
  469. function StrToDate(const S: AnsiString; const useformat : string; separator : char = #0): TDateTime;
  470. begin
  471. result := StrToDate(PChar(S),Length(s),UseFormat,separator);
  472. end;
  473. function StrToDate(const S: ShortString; separator : char): TDateTime;
  474. begin
  475. // S[1] always exists for shortstring. Length 0 will trigger an error.
  476. result := StrToDate(@S[1],Length(s),DefaultFormatSettings.ShortDateFormat,separator)
  477. end;
  478. function StrToDate(const S: ShortString): TDateTime;
  479. begin
  480. // S[1] always exists for shortstring. Length 0 will trigger an error.
  481. result := StrToDate(@S[1],Length(s),DefaultFormatSettings.ShortDateFormat,#0);
  482. end;
  483. function StrToDate(const S: AnsiString; separator : char): TDateTime;
  484. begin
  485. result := StrToDate(Pchar(S),Length(s),DefaultFormatSettings.ShortDateFormat,separator)
  486. end;
  487. function StrToDate(const S: AnsiString): TDateTime;
  488. begin
  489. result := StrToDate(Pchar(S),Length(s),DefaultFormatSettings.ShortDateFormat,#0);
  490. end;
  491. { StrToTime converts the string S to a TDateTime value
  492. if S does not represent a valid time value an
  493. EConvertError will be raised }
  494. function IntStrToTime(Out ErrorMsg : AnsiString; const S: PChar; Len : integer;const defs:TFormatSettings; separator : char = #0): TDateTime;
  495. const
  496. AMPM_None = 0;
  497. AMPM_AM = 1;
  498. AMPM_PM = 2;
  499. tiHour = 0;
  500. tiMin = 1;
  501. tiSec = 2;
  502. tiMSec = 3;
  503. type
  504. TTimeValues = array[tiHour..tiMSec] of Word;
  505. var
  506. AmPm: integer;
  507. TimeValues: TTimeValues;
  508. function StrPas(Src : PChar; len: integer = 0) : ShortString;
  509. begin
  510. //this is unsafe for len > 255, it will trash memory (I tested this)
  511. //reducing it is safe, since whenever we use this a string > 255 is invalid anyway
  512. if len > 255 then len := 255;
  513. SetLength(Result, len);
  514. move(src[0],result[1],len);
  515. end;
  516. function SplitElements(out TimeValues: TTimeValues; out AmPm: Integer): Boolean;
  517. //Strict version. It does not allow #32 as Separator, it will treat it as whitespace always
  518. const
  519. Digits = ['0'..'9'];
  520. var
  521. Cur, Offset, ElemLen, Err, TimeIndex, FirstSignificantDigit: Integer;
  522. Value: Word;
  523. DigitPending, MSecPending: Boolean;
  524. AmPmStr: ShortString;
  525. CurChar: Char;
  526. begin
  527. Result := False;
  528. AmPm := AMPM_None; //No Am or PM in string found yet
  529. MSecPending := False;
  530. TimeIndex := 0; //indicating which TTimeValue must be filled next
  531. FillChar(TimeValues, SizeOf(TTimeValues), 0);
  532. Cur := 0;
  533. //skip leading blanks
  534. While (Cur < Len) and (S[Cur] =#32) do Inc(Cur);
  535. Offset := Cur;
  536. //First non-blank cannot be Separator or DecimalSeparator
  537. if (Cur > Len - 1) or (S[Cur] = Separator) or (S[Cur] = defs.Decimalseparator) then Exit;
  538. DigitPending := (S[Cur] in Digits);
  539. While (Cur < Len) do
  540. begin
  541. //writeln;
  542. //writeln('Main While loop: Cur = ',Cur,' S[Cur] = "',S[Cur],'" Len = ',Len);
  543. CurChar := S[Cur];
  544. if CurChar in Digits then
  545. begin//Digits
  546. //HH, MM, SS, or Msec?
  547. //writeln('Digit');
  548. //Digits are only allowed after starting Am/PM or at beginning of string or after Separator
  549. //and TimeIndex must be <= tiMSec
  550. //Uncomment "or (#32 = Separator)" and it will allllow #32 as separator
  551. if (not (DigitPending {or (#32 = Separator)})) or (TimeIndex > tiMSec) then Exit;
  552. OffSet := Cur;
  553. if (CurChar <> '0') then FirstSignificantDigit := OffSet else FirstSignificantDigit := -1;
  554. while (Cur < Len -1) and (S[Cur + 1] in Digits) do
  555. begin
  556. //Mark first Digit that is not '0'
  557. if (FirstSignificantDigit = -1) and (S[Cur] <> '0') then FirstSignificantDigit := Cur;
  558. Inc(Cur);
  559. end;
  560. if (FirstSignificantDigit = -1) then FirstSignificantDigit := Cur;
  561. ElemLen := 1 + Cur - FirstSignificantDigit;
  562. //writeln(' S[FirstSignificantDigit] = ',S[FirstSignificantDigit], ' S[Cur] = ',S[Cur],' ElemLen = ',ElemLen,' -> ', StrPas(S + Offset, ElemLen));
  563. //writeln(' Cur = ',Cur);
  564. //this way we know that Val() will never overflow Value !
  565. if (ElemLen <= 2) or ((ElemLen <= 3) and (TimeIndex = tiMSec) ) then
  566. begin
  567. Val(StrPas(S + FirstSignificantDigit, ElemLen), Value, Err);
  568. //writeln(' Value = ',Value,' HH = ',TimeValues[0],' MM = ',TimeValues[1],' SS = ',TimeValues[2],' MSec = ',Timevalues[3]);
  569. //This is safe now, because we know Value < High(Word)
  570. TimeValues[TimeIndex] := Value;
  571. Inc(TimeIndex);
  572. DigitPending := False;
  573. end
  574. else Exit; //Value to big, so it must be a wrong timestring
  575. end//Digits
  576. else if (CurChar = #32) then
  577. begin
  578. //writeln('#32');
  579. //just skip, but we must adress this, or it will be parsed by either AM/PM or Separator
  580. end
  581. else if (CurChar = Separator) then
  582. begin
  583. //writeln('Separator');
  584. if DigitPending or (TimeIndex > tiSec) then Exit;
  585. DigitPending := True;
  586. MSecPending := False;
  587. end
  588. else if (CurChar = defs.DecimalSeparator) then
  589. begin
  590. //writeln('DecimalSeparator');
  591. if DigitPending or MSecPending or (TimeIndex <> tiMSec) then Exit;
  592. DigitPending := True;
  593. MSecPending := True;
  594. end
  595. else
  596. begin//AM/PM?
  597. //None of the above, so this char _must_ be the start of AM/PM string
  598. //If we already have found AM/PM or we expect a digit then then timestring must be wrong at this point
  599. //writeln('AM/PM?');
  600. if (AmPm <> AMPM_None) or DigitPending then Exit;
  601. OffSet := Cur;
  602. while (Cur < Len -1) and (not (S[Cur + 1] in [Separator, #32, defs.DecimalSeparator]))
  603. and not (S[Cur + 1] in Digits) do Inc(Cur);
  604. ElemLen := 1 + Cur - OffSet;
  605. //writeln(' S[Offset] = ',S[Offset], ' S[Cur] = ',S[Cur],' ElemLen = ',ElemLen,' -> ', StrPas(S + Offset, ElemLen));
  606. //writeln(' Cur = ',Cur);
  607. AmPmStr := StrPas(S + OffSet, ElemLen);
  608. //writeln('AmPmStr = ',ampmstr,' (',length(ampmstr),')');
  609. //We must compare to TimeAMString before hardcoded 'AM' for delphi compatibility
  610. //Also it is perfectly legal, though insane to have TimeAMString = 'PM' and vice versa
  611. if (AnsiCompareText(AmPmStr, defs.TimeAMString) = 0) then AmPm := AMPM_AM
  612. else if (AnsiCompareText(AmPmStr, defs.TimePMString) = 0) then AmPm := AMPM_PM
  613. else if (CompareText(AmPmStr, 'AM') = 0) then AmPm := AMPM_AM
  614. else if (CompareText(AmPmStr, 'PM') = 0) then AmPm := AMPM_PM
  615. else Exit; //If text does not match any of these, timestring must be wrong;
  616. //if AM/PM is at beginning of string, then a digit is mandatory after it
  617. if (TimeIndex = tiHour) then
  618. begin
  619. DigitPending := True;
  620. end
  621. //otherwise, no more TimeValues allowed after this
  622. else
  623. begin
  624. TimeIndex := tiMSec + 1;
  625. DigitPending := False;
  626. end;
  627. end;//AM/PM
  628. Inc(Cur)
  629. end;//while
  630. //If we arrive here, parsing the elements has been successfull
  631. //if not at least Hours specified then input is not valid
  632. //when am/pm is specified Hour must be <= 12 and not 0
  633. if (TimeIndex = tiHour) or ((AmPm <> AMPM_None) and ((TimeValues[tiHour] > 12) or (TimeValues[tiHour] = 0))) or DigitPending then Exit;
  634. Result := True;
  635. end;
  636. begin
  637. if separator = #0 then
  638. separator := defs.TimeSeparator;
  639. AmPm := AMPM_None;
  640. if not SplitElements(TimeValues, AmPm) then
  641. begin
  642. ErrorMsg:=Format(SErrInvalidTimeFormat,[StrPas(S, Len)]);
  643. Exit;
  644. end;
  645. if (AmPm=AMPM_PM) and (TimeValues[tiHour]<>12) then Inc(TimeValues[tiHour], 12)
  646. else if (AmPm=AMPM_AM) and (TimeValues[tiHour]=12) then TimeValues[tiHour]:=0;
  647. if not TryEncodeTime(TimeValues[tiHour], TimeValues[tiMin], TimeValues[tiSec], TimeValues[tiMSec], result) Then
  648. //errormsg:='Invalid time.';
  649. ErrorMsg:=Format(SErrInvalidTimeFormat,[StrPas(S, Len)]);
  650. end ;
  651. function StrToTime(const S: PChar; Len : integer; separator : char = #0): TDateTime;
  652. Var
  653. Msg : AnsiString;
  654. begin
  655. Result:=IntStrToTime(Msg,S,Len,DefaultFormatSettings,Separator);
  656. If (Msg<>'') then
  657. Raise EConvertError.Create(Msg);
  658. end;
  659. function StrToTime(const S: string; FormatSettings : TFormatSettings): TDateTime;
  660. Var
  661. Msg : AnsiString;
  662. begin
  663. Result:=IntStrToTime(Msg, PChar(S), length(S), FormatSettings, #0);
  664. If (Msg<>'') then
  665. Raise EConvertError.Create(Msg);
  666. end;
  667. function StrToTime(const s: ShortString; separator : char): TDateTime;
  668. begin
  669. // S[1] always exists for shortstring. Length 0 will trigger an error.
  670. result := StrToTime(@s[1], length(s), separator);
  671. end;
  672. function StrToTime(const s: AnsiString; separator : char): TDateTime;
  673. begin
  674. result := StrToTime(PChar(S), length(s), separator);
  675. end;
  676. function StrToTime(const s: ShortString): TDateTime;
  677. begin
  678. // S[1] always exists for shortstring. Length 0 will trigger an error.
  679. result := StrToTime(@s[1], length(s), #0);
  680. end;
  681. function StrToTime(const s: AnsiString): TDateTime;
  682. begin
  683. result:= StrToTime(PChar(s), length(s), #0);
  684. end;
  685. { StrToDateTime converts the string S to a TDateTime value
  686. if S does not represent a valid date and/or time value
  687. an EConvertError will be raised }
  688. function SplitDateTimeStr(DateTimeStr: AnsiString; const FS: TFormatSettings; out DateStr, TimeStr: AnsiString): Integer;
  689. { Helper function for StrToDateTime
  690. Pre-condition
  691. Date is before Time
  692. If either Date or Time is omitted then see what fits best, a time or a date (issue #0020522)
  693. Date and Time are separated by whitespace (space Tab, Linefeed or carriage return)
  694. FS.DateSeparator can be the same as FS.TimeSeparator (issue #0020522)
  695. If they are both #32 and TrimWhite(DateTimeStr) contains a #32 a date is assumed.
  696. Post-condition
  697. DateStr holds date as string or is empty
  698. TimeStr holds time as string or is empty
  699. Result = number of strings returned, 0 = error
  700. }
  701. const
  702. WhiteSpace = [#9,#10,#13,#32];
  703. Space : String = #32; // String, to avoid error 'Cannot decide what overload to call'
  704. var
  705. p: Integer;
  706. DummyDT: TDateTime;
  707. begin
  708. Result := 0;
  709. DateStr := '';
  710. TimeStr := '';
  711. DateTimeStr := Trim(DateTimeStr);
  712. if Length(DateTimeStr) = 0 then exit;
  713. if (FS.DateSeparator = #32) and (FS.TimeSeparator = #32) and (Pos(#32, DateTimeStr) > 0) then
  714. begin
  715. DateStr:=DateTimeStr;
  716. {
  717. Assume a date: dd [mm [yy]].
  718. Really fancy would be counting the number of whitespace occurrences and decide
  719. and split accordingly
  720. }
  721. Exit(1);
  722. end;
  723. p:=1;
  724. //find separator
  725. if Pos(Space,FS.DateSeparator)=0 then
  726. begin
  727. while (p<Length(DateTimeStr)) and (not (DateTimeStr[p+1] in WhiteSpace)) do
  728. Inc(p);
  729. end
  730. else
  731. begin
  732. p:=Pos(FS.TimeSeparator, DateTimeStr);
  733. if (p<>0) then
  734. repeat
  735. Dec(p);
  736. until (p=0) or (DateTimeStr[p] in WhiteSpace);
  737. end;
  738. //Always fill DateStr, it eases the algorithm later
  739. if (p=0) then
  740. p:=Length(DateTimeStr);
  741. DateStr:=Copy(DateTimeStr,1,p);
  742. TimeStr:=Trim(Copy(DateTimeStr,p+1,MaxInt));
  743. if (Length(TimeStr)<>0) then
  744. Result:=2
  745. else
  746. begin
  747. Result:=1; //found 1 string
  748. // 2 cases when DateTimeStr only contains a time:
  749. // Date/time separator differ, and string contains a timeseparator
  750. // Date/time separators are equal, but transformation to date fails.
  751. if ((FS.DateSeparator<>FS.TimeSeparator) and (Pos(FS.TimeSeparator,DateStr) > 0))
  752. or ((FS.DateSeparator=FS.TimeSeparator) and (not TryStrToDate(DateStr, DummyDT, FS))) then
  753. begin
  754. TimeStr := DateStr;
  755. DateStr := '';
  756. end;
  757. end;
  758. end;
  759. function StrToDateTime(const s: AnsiString; const FormatSettings : TFormatSettings): TDateTime;
  760. var
  761. TimeStr, DateStr: AnsiString;
  762. PartsFound: Integer;
  763. begin
  764. PartsFound := SplitDateTimeStr(S, FormatSettings, DateStr, TimeStr);
  765. case PartsFound of
  766. 0: Result:=StrToDate('');
  767. 1: if (Length(DateStr) > 0) then
  768. Result := StrToDate(DateStr, FormatSettings.ShortDateFormat,FormatSettings.DateSeparator)
  769. else
  770. Result := StrToTime(TimeStr, FormatSettings);
  771. 2: Result := ComposeDateTime(StrTodate(DateStr,FormatSettings.ShortDateFormat,FormatSettings.DateSeparator),
  772. StrToTime(TimeStr,FormatSettings));
  773. end;
  774. end;
  775. function StrToDateTime(const s: AnsiString): TDateTime;
  776. begin
  777. Result:=StrToDateTime(S,DefaultFormatSettings);
  778. end;
  779. function StrToDateTime(const s: ShortString; const FormatSettings : TFormatSettings): TDateTime;
  780. var
  781. A : AnsiString;
  782. begin
  783. A:=S;
  784. Result:=StrToDateTime(A,FormatSettings);
  785. end;
  786. { FormatDateTime formats DateTime to the given format string FormatStr }
  787. function FormatDateTime(const FormatStr: string; DateTime: TDateTime; Options : TFormatDateTimeOptions = []): string;
  788. begin
  789. DateTimeToString(Result, FormatStr, DateTime, DefaultFormatSettings,Options);
  790. end;
  791. function FormatDateTime(const FormatStr: string; DateTime: TDateTime; const FormatSettings: TFormatSettings; Options : TFormatDateTimeOptions = []): string;
  792. begin
  793. DateTimeToString(Result, FormatStr, DateTime, FormatSettings,Options);
  794. end;
  795. { DateTimeToString formats DateTime to the given format in FormatStr }
  796. procedure DateTimeToString(out Result: string; const FormatStr: string;
  797. const DateTime: TDateTime; Options : TFormatDateTimeOptions = []);
  798. begin
  799. DateTimeToString(Result, FormatStr, DateTime, DefaultFormatSettings, Options);
  800. end;
  801. procedure DateTimeToString(out Result: string; const FormatStr: string; const DateTime: TDateTime;
  802. const FormatSettings: TFormatSettings; Options : TFormatDateTimeOptions = []);
  803. var
  804. ResultLen: integer;
  805. ResultBuffer: array[0..255] of char;
  806. ResultCurrent: pchar;
  807. {$if defined(win32) or defined(win64)}
  808. isEnable_E_Format : Boolean;
  809. isEnable_G_Format : Boolean;
  810. eastasiainited : boolean;
  811. procedure InitEastAsia;
  812. var ALCID : LCID;
  813. PriLangID , SubLangID : Word;
  814. begin
  815. ALCID := GetThreadLocale;
  816. PriLangID := ALCID and $3FF;
  817. if (PriLangID>0) then
  818. SubLangID := (ALCID and $FFFF) shr 10
  819. else
  820. begin
  821. PriLangID := SysLocale.PriLangID;
  822. SubLangID := SysLocale.SubLangID;
  823. end;
  824. isEnable_E_Format := (PriLangID = LANG_JAPANESE)
  825. or
  826. (PriLangID = LANG_KOREAN)
  827. or
  828. ((PriLangID = LANG_CHINESE)
  829. and
  830. (SubLangID = SUBLANG_CHINESE_TRADITIONAL)
  831. );
  832. isEnable_G_Format := (PriLangID = LANG_JAPANESE)
  833. or
  834. ((PriLangID = LANG_CHINESE)
  835. and
  836. (SubLangID = SUBLANG_CHINESE_TRADITIONAL)
  837. );
  838. eastasiainited :=true;
  839. end;
  840. {$endif win32 or win64}
  841. procedure StoreStr(Str: PChar; Len: Integer);
  842. begin
  843. if ResultLen + Len < SizeOf(ResultBuffer) then
  844. begin
  845. StrMove(ResultCurrent, Str, Len);
  846. ResultCurrent := ResultCurrent + Len;
  847. ResultLen := ResultLen + Len;
  848. end;
  849. end;
  850. procedure StoreString(const Str: string);
  851. var Len: integer;
  852. begin
  853. Len := Length(Str);
  854. if ResultLen + Len < SizeOf(ResultBuffer) then
  855. begin
  856. StrMove(ResultCurrent, pchar(Str), Len);
  857. ResultCurrent := ResultCurrent + Len;
  858. ResultLen := ResultLen + Len;
  859. end;
  860. end;
  861. procedure StoreInt(Value, Digits: Integer);
  862. var
  863. S: string[16];
  864. Len: integer;
  865. begin
  866. System.Str(Value:Digits, S);
  867. for Len := 1 to Length(S) do
  868. begin
  869. if S[Len] = ' ' then
  870. S[Len] := '0'
  871. else
  872. Break;
  873. end;
  874. StoreStr(pchar(@S[1]), Length(S));
  875. end ;
  876. var
  877. Year, Month, Day, DayOfWeek, Hour, Minute, Second, MilliSecond: word;
  878. procedure StoreFormat(const FormatStr: string; Nesting: Integer; TimeFlag: Boolean);
  879. var
  880. Token, lastformattoken, prevlasttoken: char;
  881. FormatCurrent: pchar;
  882. FormatEnd: pchar;
  883. Count: integer;
  884. Clock12: boolean;
  885. P: pchar;
  886. tmp: integer;
  887. isInterval: Boolean;
  888. begin
  889. if Nesting > 1 then // 0 is original string, 1 is included FormatString
  890. Exit;
  891. FormatCurrent := PChar(FormatStr);
  892. FormatEnd := FormatCurrent + Length(FormatStr);
  893. Clock12 := false;
  894. isInterval := false;
  895. P := FormatCurrent;
  896. // look for unquoted 12-hour clock token
  897. while P < FormatEnd do
  898. begin
  899. Token := P^;
  900. case Token of
  901. '''', '"':
  902. begin
  903. Inc(P);
  904. while (P < FormatEnd) and (P^ <> Token) do
  905. Inc(P);
  906. end;
  907. 'A', 'a':
  908. begin
  909. if (StrLIComp(P, 'A/P', 3) = 0) or
  910. (StrLIComp(P, 'AMPM', 4) = 0) or
  911. (StrLIComp(P, 'AM/PM', 5) = 0) then
  912. begin
  913. Clock12 := true;
  914. break;
  915. end;
  916. end;
  917. end; // case
  918. Inc(P);
  919. end ;
  920. token := #255;
  921. lastformattoken := ' ';
  922. prevlasttoken := 'H';
  923. while FormatCurrent < FormatEnd do
  924. begin
  925. Token := UpCase(FormatCurrent^);
  926. Count := 1;
  927. P := FormatCurrent + 1;
  928. case Token of
  929. '''', '"':
  930. begin
  931. while (P < FormatEnd) and (p^ <> Token) do
  932. Inc(P);
  933. Inc(P);
  934. Count := P - FormatCurrent;
  935. StoreStr(FormatCurrent + 1, Count - 2);
  936. end ;
  937. 'A':
  938. begin
  939. if StrLIComp(FormatCurrent, 'AMPM', 4) = 0 then
  940. begin
  941. Count := 4;
  942. if Hour < 12 then
  943. StoreString(FormatSettings.TimeAMString)
  944. else
  945. StoreString(FormatSettings.TimePMString);
  946. end
  947. else if StrLIComp(FormatCurrent, 'AM/PM', 5) = 0 then
  948. begin
  949. Count := 5;
  950. if Hour < 12 then StoreStr(FormatCurrent, 2)
  951. else StoreStr(FormatCurrent+3, 2);
  952. end
  953. else if StrLIComp(FormatCurrent, 'A/P', 3) = 0 then
  954. begin
  955. Count := 3;
  956. if Hour < 12 then StoreStr(FormatCurrent, 1)
  957. else StoreStr(FormatCurrent+2, 1);
  958. end
  959. else
  960. raise EConvertError.Create('Illegal character in format string');
  961. end ;
  962. '/': if FormatSettings.DateSeparator<>#0 then StoreStr(@FormatSettings.DateSeparator, 1);
  963. ':': if FormatSettings.TimeSeparator<>#0 then StoreStr(@FormatSettings.TimeSeparator, 1);
  964. '[': if (fdoInterval in Options) then isInterval := true else StoreStr(FormatCurrent, 1);
  965. ']': if (fdoInterval in Options) then isInterval := false else StoreStr(FormatCurrent, 1);
  966. ' ', 'C', 'D', 'H', 'M', 'N', 'S', 'T', 'Y', 'Z', 'F' {$IFDEF MSWindows}, 'G', 'E'{$ENDIF MSWindows} :
  967. begin
  968. while (P < FormatEnd) and (UpCase(P^) = Token) do
  969. Inc(P);
  970. Count := P - FormatCurrent;
  971. case Token of
  972. ' ': StoreStr(FormatCurrent, Count);
  973. 'Y': begin
  974. if Count > 2 then
  975. StoreInt(Year, 4)
  976. else
  977. StoreInt(Year mod 100, 2);
  978. end;
  979. 'M': begin
  980. if isInterval and ((prevlasttoken = 'H') or TimeFlag) then
  981. StoreInt(Minute + (Hour + trunc(abs(DateTime))*24)*60, 0)
  982. else
  983. if (lastformattoken = 'H') or TimeFlag then
  984. begin
  985. if Count = 1 then
  986. StoreInt(Minute, 0)
  987. else
  988. StoreInt(Minute, 2);
  989. end
  990. else
  991. begin
  992. case Count of
  993. 1: StoreInt(Month, 0);
  994. 2: StoreInt(Month, 2);
  995. 3: StoreString(FormatSettings.ShortMonthNames[Month]);
  996. else
  997. StoreString(FormatSettings.LongMonthNames[Month]);
  998. end;
  999. end;
  1000. end;
  1001. 'D': begin
  1002. case Count of
  1003. 1: StoreInt(Day, 0);
  1004. 2: StoreInt(Day, 2);
  1005. 3: StoreString(FormatSettings.ShortDayNames[DayOfWeek]);
  1006. 4: StoreString(FormatSettings.LongDayNames[DayOfWeek]);
  1007. 5: StoreFormat(FormatSettings.ShortDateFormat, Nesting+1, False);
  1008. else
  1009. StoreFormat(FormatSettings.LongDateFormat, Nesting+1, False);
  1010. end ;
  1011. end ;
  1012. 'H':
  1013. if isInterval then
  1014. StoreInt(Hour + trunc(abs(DateTime))*24, Count)
  1015. else
  1016. if Clock12 then
  1017. begin
  1018. tmp := hour mod 12;
  1019. if tmp=0 then tmp:=12;
  1020. if Count = 1 then
  1021. StoreInt(tmp, 0)
  1022. else
  1023. StoreInt(tmp, 2);
  1024. end
  1025. else begin
  1026. if Count = 1 then
  1027. StoreInt(Hour, 0)
  1028. else
  1029. StoreInt(Hour, 2);
  1030. end;
  1031. 'N': if isInterval then
  1032. StoreInt(Minute + (Hour + trunc(abs(DateTime))*24)*60, Count)
  1033. else
  1034. if Count = 1 then
  1035. StoreInt(Minute, 0)
  1036. else
  1037. StoreInt(Minute, 2);
  1038. 'S': if isInterval then
  1039. StoreInt(Second + (Minute + (Hour + trunc(abs(DateTime))*24)*60)*60, Count)
  1040. else
  1041. if Count = 1 then
  1042. StoreInt(Second, 0)
  1043. else
  1044. StoreInt(Second, 2);
  1045. 'Z': if Count = 1 then
  1046. StoreInt(MilliSecond, 0)
  1047. else
  1048. StoreInt(MilliSecond, 3);
  1049. 'T': if Count = 1 then
  1050. StoreFormat(FormatSettings.ShortTimeFormat, Nesting+1, True)
  1051. else
  1052. StoreFormat(FormatSettings.LongTimeFormat, Nesting+1, True);
  1053. 'C': begin
  1054. StoreFormat(FormatSettings.ShortDateFormat, Nesting+1, False);
  1055. if (Hour<>0) or (Minute<>0) or (Second<>0) then
  1056. begin
  1057. StoreString(' ');
  1058. StoreFormat(FormatSettings.LongTimeFormat, Nesting+1, True);
  1059. end;
  1060. end;
  1061. 'F': begin
  1062. StoreFormat(FormatSettings.ShortDateFormat, Nesting+1, False);
  1063. StoreString(' ');
  1064. StoreFormat(FormatSettings.LongTimeFormat, Nesting+1, True);
  1065. end;
  1066. {$if defined(win32) or defined(win64)}
  1067. 'E':
  1068. begin
  1069. if not Eastasiainited then InitEastAsia;
  1070. if Not(isEnable_E_Format) then StoreStr(FormatCurrent, 1)
  1071. else
  1072. begin
  1073. while (P < FormatEnd) and (UpCase(P^) = Token) do
  1074. P := P + 1;
  1075. Count := P - FormatCurrent;
  1076. StoreString(ConvertEraYearString(Count,Year,Month,Day));
  1077. end;
  1078. prevlasttoken := lastformattoken;
  1079. lastformattoken:=token;
  1080. end;
  1081. 'G':
  1082. begin
  1083. if not Eastasiainited then InitEastAsia;
  1084. if Not(isEnable_G_Format) then StoreStr(FormatCurrent, 1)
  1085. else
  1086. begin
  1087. while (P < FormatEnd) and (UpCase(P^) = Token) do
  1088. P := P + 1;
  1089. Count := P - FormatCurrent;
  1090. StoreString(ConvertEraString(Count,Year,Month,Day));
  1091. end;
  1092. prevlasttoken := lastformattoken;
  1093. lastformattoken:=token;
  1094. end;
  1095. {$endif win32 or win64}
  1096. end;
  1097. prevlasttoken := lastformattoken;
  1098. lastformattoken := token;
  1099. end;
  1100. else
  1101. StoreStr(@Token, 1);
  1102. end ;
  1103. Inc(FormatCurrent, Count);
  1104. end;
  1105. end;
  1106. begin
  1107. {$if defined(win32) or defined(win64)}
  1108. eastasiainited:=false;
  1109. {$endif win32 or win64}
  1110. DecodeDateFully(DateTime, Year, Month, Day, DayOfWeek);
  1111. DecodeTime(DateTime, Hour, Minute, Second, MilliSecond);
  1112. ResultLen := 0;
  1113. ResultCurrent := @ResultBuffer[0];
  1114. if FormatStr <> '' then
  1115. StoreFormat(FormatStr, 0, False)
  1116. else
  1117. StoreFormat('C', 0, False);
  1118. ResultBuffer[ResultLen] := #0;
  1119. result := StrPas(@ResultBuffer[0]);
  1120. end ;
  1121. Function DateTimeToFileDate(DateTime : TDateTime) : Int64;
  1122. Var YY,MM,DD,H,m,s,msec : Word;
  1123. begin
  1124. Decodedate (DateTime,YY,MM,DD);
  1125. DecodeTime (DateTime,h,m,s,msec);
  1126. {$ifndef unix}
  1127. If (YY<1980) or (YY>2099) then
  1128. Result:=0
  1129. else
  1130. begin
  1131. Result:=(s shr 1) or (m shl 5) or (h shl 11);
  1132. Result:=Result or longint(DD shl 16 or (MM shl 21) or (word(YY-1980) shl 25));
  1133. end;
  1134. {$else unix}
  1135. Result:=LocalToEpoch(yy,mm,dd,h,m,s);
  1136. {$endif unix}
  1137. end;
  1138. Function UniversalToFileDate(DateTime : TDateTime) : int64;
  1139. {$ifndef unix}
  1140. begin
  1141. Result := DateTimeToFileDate(UniversalTimeToLocal(DateTime));
  1142. end;
  1143. {$else unix}
  1144. Var YY,MM,DD,H,m,s,msec : Word;
  1145. begin
  1146. Decodedate (DateTime,YY,MM,DD);
  1147. DecodeTime (DateTime,h,m,s,msec);
  1148. Result:=UniversalToEpoch(yy,mm,dd,h,m,s);
  1149. end;
  1150. {$endif unix}
  1151. function CurrentYear: Word;
  1152. var
  1153. SysTime: TSystemTime;
  1154. begin
  1155. GetLocalTime(SysTime);
  1156. Result := SysTime.Year;
  1157. end;
  1158. Function FileDateToDateTime (Filedate : Int64) : TDateTime;
  1159. {$ifndef unix}
  1160. Var Date,Time : Word;
  1161. begin
  1162. Date:=FileDate shr 16;
  1163. Time:=FileDate and $ffff;
  1164. Result:=ComposeDateTime(EncodeDate((Date shr 9) + 1980,(Date shr 5) and 15, Date and 31),
  1165. EncodeTime(Time shr 11, (Time shr 5) and 63, (Time and 31) shl 1,0));
  1166. end;
  1167. {$else unix}
  1168. var
  1169. y, mon, d, h, min, s: word;
  1170. begin
  1171. EpochToLocal(FileDate,y,mon,d,h,min,s);
  1172. Result:=ComposeDateTime(EncodeDate(y,mon,d),EncodeTime(h,min,s,0));
  1173. end;
  1174. {$endif unix}
  1175. Function FileDateToUniversal (Filedate : Int64) : TDateTime;
  1176. {$ifndef unix}
  1177. begin
  1178. Result := LocalTimeToUniversal(FileDateToDateTime(Filedate));
  1179. end;
  1180. {$else unix}
  1181. var
  1182. y, mon, d, h, min, s: word;
  1183. begin
  1184. EpochToUniversal(FileDate,y,mon,d,h,min,s);
  1185. Result:=ComposeDateTime(EncodeDate(y,mon,d),EncodeTime(h,min,s,0));
  1186. end;
  1187. {$endif unix}
  1188. function TryStrToDate(const S: ShortString; out Value: TDateTime): Boolean;
  1189. begin
  1190. result := TryStrToDate(S, Value, #0);
  1191. end;
  1192. function TryStrToDate(const S: ShortString; out Value: TDateTime;
  1193. const useformat : string; separator : char = #0): Boolean;
  1194. Var
  1195. Msg : Ansistring;
  1196. begin
  1197. // S[1] always exists for shortstring. Length 0 will trigger an error.
  1198. Value:=IntStrToDate(Msg,@S[1],Length(S),useformat,defaultformatsettings,separator);
  1199. Result:=(Msg='');
  1200. end;
  1201. function TryStrToDate(const S: AnsiString; out Value: TDateTime;
  1202. const useformat : string; separator : char = #0): Boolean;
  1203. Var
  1204. Msg : Ansistring;
  1205. begin
  1206. Result:=Length(S)<>0;
  1207. If Result then
  1208. begin
  1209. Value:=IntStrToDate(Msg,PChar(S),Length(S),useformat,DefaultFormatSettings,Separator);
  1210. Result:=(Msg='');
  1211. end;
  1212. end;
  1213. function TryStrToDate(const S: ShortString; out Value: TDateTime; separator : char): Boolean;
  1214. begin
  1215. Result:=TryStrToDate(S,Value,DefaultFormatSettings.ShortDateFormat,Separator);
  1216. end;
  1217. function TryStrToDate(const S: AnsiString; out Value: TDateTime): Boolean;
  1218. begin
  1219. Result:=TryStrToDate(S,Value,DefaultFormatSettings.ShortDateFormat,#0);
  1220. end;
  1221. function TryStrToDate(const S: AnsiString; out Value: TDateTime; separator : char): Boolean;
  1222. begin
  1223. Result:=TryStrToDate(S,Value,DefaultFormatSettings.ShortDateFormat,Separator);
  1224. end;
  1225. function TryStrToDate(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
  1226. Var
  1227. Msg : Ansistring;
  1228. begin
  1229. Result:=Length(S)<>0;
  1230. If Result then
  1231. begin
  1232. Value:=IntStrToDate(Msg,PChar(S),Length(S),FormatSettings.ShortDateFormat,FormatSettings,#0);
  1233. Result:=(Msg='');
  1234. end;
  1235. end;
  1236. function TryStrToTime(const S: ShortString; out Value: TDateTime; separator : char): Boolean;
  1237. Var
  1238. Msg : AnsiString;
  1239. begin
  1240. // S[1] always exists for shortstring. Length 0 will trigger an error.
  1241. Value:=IntStrToTime(Msg,@S[1],Length(S),DefaultFormatSettings,Separator);
  1242. result:=(Msg='');
  1243. end;
  1244. function TryStrToTime(const S: ShortString; out Value: TDateTime): Boolean;
  1245. begin
  1246. Result := TryStrToTime(S,Value,#0);
  1247. end;
  1248. function TryStrToTime(const S: AnsiString; out Value: TDateTime; separator : char): Boolean;
  1249. Var
  1250. Msg : AnsiString;
  1251. begin
  1252. Result:=Length(S)<>0;
  1253. If Result then
  1254. begin
  1255. Value:=IntStrToTime(Msg,PChar(S),Length(S),DefaultFormatSettings,Separator);
  1256. Result:=(Msg='');
  1257. end;
  1258. end;
  1259. function TryStrToTime(const S: AnsiString; out Value: TDateTime): Boolean;
  1260. begin
  1261. result := TryStrToTime(S,Value,#0);
  1262. end;
  1263. function TryStrToTime(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
  1264. Var msg : AnsiString;
  1265. begin
  1266. Result:=Length(S)<>0;
  1267. If Result then
  1268. begin
  1269. Value:=IntStrToTime(Msg,PChar(S),Length(S),FormatSettings,#0);
  1270. Result:=(Msg='');
  1271. end;
  1272. end;
  1273. function TryStrToDateTime(const S: ShortString; out Value: TDateTime): Boolean;
  1274. begin
  1275. result := TryStrToDateTime(S, Value, DefaultFormatSettings);
  1276. end;
  1277. function TryStrToDateTime(const S: AnsiString; out Value: TDateTime): Boolean;
  1278. begin
  1279. result := TryStrToDateTime(S, Value, DefaultFormatSettings);
  1280. end;
  1281. function TryStrToDateTime(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
  1282. var
  1283. I: integer;
  1284. dtdate, dttime :TDateTime;
  1285. begin
  1286. result:=false;
  1287. I:=Pos(FormatSettings.TimeSeparator,S);
  1288. If (I>0) then
  1289. begin
  1290. While (I>0) and (S[I]<>' ') do
  1291. Dec(I);
  1292. If I>0 then
  1293. begin
  1294. if not TryStrToDate(Copy(S,1,I-1),dtdate,Formatsettings) then
  1295. exit;
  1296. if not TryStrToTime(Copy(S,i+1, Length(S)-i),dttime,Formatsettings) then
  1297. exit;
  1298. Value:=ComposeDateTime(dtdate,dttime);
  1299. result:=true;
  1300. end
  1301. else
  1302. result:=TryStrToTime(s,Value,Formatsettings);
  1303. end
  1304. else
  1305. result:=TryStrToDate(s,Value,Formatsettings);
  1306. end;
  1307. function StrToDateDef(const S: ShortString; const Defvalue : TDateTime): TDateTime;
  1308. begin
  1309. result := StrToDateDef(S,DefValue,#0);
  1310. end;
  1311. function StrToTimeDef(const S: ShortString; const Defvalue : TDateTime): TDateTime;
  1312. begin
  1313. result := StrToTimeDef(S,DefValue,#0);
  1314. end;
  1315. function StrToDateTimeDef(const S: ShortString; const Defvalue : TDateTime): TDateTime;
  1316. begin
  1317. Result:=StrToDateTimeDef(S,DefValue,DefaultFormatSettings);
  1318. end;
  1319. function StrToDateTimeDef(const S: AnsiString; const Defvalue : TDateTime; const FormatSettings: TFormatSettings): TDateTime;
  1320. begin
  1321. if not TryStrToDateTime(s,Result,FormatSettings) Then
  1322. result:=defvalue;
  1323. end;
  1324. function StrToDateDef(const S: ShortString; const Defvalue : TDateTime; separator : char): TDateTime;
  1325. begin
  1326. if not TryStrToDate(s,Result, separator) Then
  1327. result:=defvalue;
  1328. end;
  1329. function StrToTimeDef(const S: ShortString; const Defvalue : TDateTime; separator : char): TDateTime;
  1330. begin
  1331. if not TryStrToTime(s,Result, separator) Then
  1332. result:=defvalue;
  1333. end;
  1334. function StrToDateDef(const S: AnsiString; const Defvalue : TDateTime): TDateTime;
  1335. begin
  1336. result := StrToDateDef(S,DefValue,#0);
  1337. end;
  1338. function StrToTimeDef(const S: AnsiString; const Defvalue : TDateTime): TDateTime;
  1339. begin
  1340. result := StrToTimeDef(S,DefValue,#0);
  1341. end;
  1342. function StrToDateTimeDef(const S: AnsiString; const Defvalue : TDateTime): TDateTime;
  1343. begin
  1344. if not TryStrToDateTime(s,Result) Then
  1345. result:=defvalue;
  1346. end;
  1347. function StrToDateDef(const S: AnsiString; const Defvalue : TDateTime; separator : char): TDateTime;
  1348. begin
  1349. if not TryStrToDate(s,Result, separator) Then
  1350. result:=defvalue;
  1351. end;
  1352. function StrToTimeDef(const S: AnsiString; const Defvalue : TDateTime; separator : char): TDateTime;
  1353. begin
  1354. if not TryStrToTime(s,Result, separator) Then
  1355. result:=defvalue;
  1356. end;
  1357. procedure ReplaceTime(var dati:TDateTime; NewTime : TDateTime);inline;
  1358. begin
  1359. dati:= ComposeDateTime(dati, newtime);
  1360. end;
  1361. procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime); inline;
  1362. var
  1363. tmp : TDateTime;
  1364. begin
  1365. tmp:=NewDate;
  1366. ReplaceTime(tmp,DateTime);
  1367. DateTime:=tmp;
  1368. end;
  1369. {$IFNDEF HAS_LOCALTIMEZONEOFFSET}
  1370. Function GetLocalTimeOffset : Integer;
  1371. begin
  1372. Result:=0;
  1373. end;
  1374. function GetLocalTimeOffset(const DateTime: TDateTime; const InputIsUTC: Boolean; out Offset: Integer): Boolean;
  1375. begin
  1376. Result:=False;
  1377. end;
  1378. function GetUniversalTime(var SystemTime: TSystemTime): Boolean;
  1379. begin
  1380. Result:=False;
  1381. end;
  1382. {$ENDIF}
  1383. function GetLocalTimeOffset(const DateTime: TDateTime; const InputIsUTC: Boolean): Integer;
  1384. begin
  1385. if not GetLocalTimeOffset(DateTime, InputIsUTC, Result) then
  1386. Result:=GetLocalTimeOffset();
  1387. end;
  1388. { Conversion of UTC to local time and vice versa }
  1389. function UniversalTimeToLocal(UT: TDateTime): TDateTime;
  1390. begin
  1391. Result:=UniversalTimeToLocal(UT,-GetLocalTimeOffset(UT, True));
  1392. end;
  1393. function UniversalTimeToLocal(UT: TDateTime; TZOffset : Integer): TDateTime;
  1394. begin
  1395. if (TZOffset > 0) then
  1396. Result := UT + EncodeTime(TZOffset div 60, TZOffset mod 60, 0, 0)
  1397. else if (TZOffset < 0) then
  1398. Result := UT - EncodeTime(Abs(TZOffset) div 60, Abs(TZOffset) mod 60, 0, 0)
  1399. else
  1400. Result := UT;
  1401. end;
  1402. Function LocalTimeToUniversal(LT: TDateTime): TDateTime;
  1403. begin
  1404. Result:=LocalTimeToUniversal(LT,-GetLocalTimeOffset(LT, False));
  1405. end;
  1406. Function LocalTimeToUniversal(LT: TDateTime;TZOffset: Integer): TDateTime;
  1407. begin
  1408. if (TZOffset > 0) then
  1409. Result := LT - EncodeTime(TZOffset div 60, TZOffset mod 60, 0, 0)
  1410. else if (TZOffset < 0) then
  1411. Result := LT + EncodeTime(Abs(TZOffset) div 60, Abs(TZOffset) mod 60, 0, 0)
  1412. else
  1413. Result := LT;
  1414. end;