dati.inc 48 KB

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