dati.inc 48 KB

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