dati.inc 48 KB

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