dati.inc 44 KB

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