dati.inc 44 KB

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