sysutils.pas 93 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516
  1. {
  2. This file is part of the Pas2JS run time library.
  3. Copyright (c) 2017 by Mattias Gaertner
  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. unit SysUtils;
  11. {$mode objfpc}
  12. interface
  13. uses
  14. RTLConsts, js;
  15. procedure FreeAndNil(var Obj);
  16. type
  17. TProcedure = procedure;
  18. {*****************************************************************************
  19. Various types
  20. *****************************************************************************}
  21. type
  22. { TFloatRec }
  23. TFloatRec = Record
  24. Exponent: Integer;
  25. Negative: Boolean;
  26. Digits: Array Of Char;
  27. End;
  28. TEndian = (Little,Big);
  29. TFileName = String;
  30. TByteArray = array [0..32767] of Byte;
  31. TWordArray = array [0..16383] of Word;
  32. TBytes = Array of byte;
  33. TStringArray = array of string;
  34. TMonthNameArray = array [1..12] of string;
  35. TDayTable = array [1..12] of Word;
  36. TWeekNameArray = array [1..7] of string;
  37. TMonthNames = TMonthNameArray;
  38. TDayNames = array[0..6] of string;
  39. {*****************************************************************************
  40. Exception handling
  41. *****************************************************************************}
  42. { Exception }
  43. Exception = class(TObject)
  44. private
  45. fMessage: String;
  46. fHelpContext: Integer;
  47. public
  48. constructor Create(const Msg: String); reintroduce;
  49. constructor CreateFmt(const Msg: string; const Args: array of jsvalue);
  50. constructor CreateHelp(const Msg: String; AHelpContext: Integer);
  51. constructor CreateFmtHelp(const Msg: string; const Args: array of jsvalue; AHelpContext: Integer);
  52. function ToString: String; override;
  53. property HelpContext: Integer read fHelpContext write fHelpContext;
  54. property Message: String read fMessage write fMessage;
  55. end;
  56. ExceptClass = class of Exception;
  57. EExternal = class(Exception);
  58. { General math errors }
  59. EMathError = class(EExternal);
  60. EInvalidOp = class(EMathError);
  61. EZeroDivide = class(EMathError);
  62. EOverflow = class(EMathError);
  63. EUnderflow = class(EMathError);
  64. EAbort = class(Exception);
  65. EInvalidCast = class(Exception);
  66. EAssertionFailed = class(Exception);
  67. EObjectCheck = class(Exception);
  68. { String conversion errors }
  69. EConvertError = class(Exception);
  70. EFormatError = class(Exception);
  71. { integer math exceptions }
  72. EInterror = Class(EExternal);
  73. EDivByZero = Class(EIntError);
  74. ERangeError = Class(EIntError);
  75. EIntOverflow = Class(EIntError);
  76. { General math errors }
  77. { Run-time and I/O Errors }
  78. EInOutError = class(Exception)
  79. public
  80. ErrorCode : Integer;
  81. end;
  82. EHeapMemoryError = class(Exception);
  83. EHeapException = EHeapMemoryError;
  84. EExternalException = class(EExternal);
  85. EInvalidPointer = Class(EHeapMemoryError);
  86. EOutOfMemory = Class(EHeapMemoryError);
  87. { EVariantError }
  88. EVariantError = Class(Exception)
  89. ErrCode : longint;
  90. Constructor CreateCode(Code : Longint);
  91. end;
  92. EAccessViolation = Class(EExternal);
  93. EBusError = Class(EAccessViolation);
  94. EPrivilege = class(EExternal);
  95. EStackOverflow = class(EExternal);
  96. EControlC = class(EExternal);
  97. { String conversion errors }
  98. { Other errors }
  99. EAbstractError = Class(Exception);
  100. EPropReadOnly = class(Exception);
  101. EPropWriteOnly = class(Exception);
  102. EIntfCastError = class(Exception);
  103. EInvalidContainer = class(Exception);
  104. EInvalidInsert = class(Exception);
  105. EPackageError = class(Exception);
  106. EOSError = class(Exception)
  107. public
  108. ErrorCode: Longint;
  109. end;
  110. ESafecallException = class(Exception);
  111. ENoThreadSupport = Class(Exception);
  112. ENoWideStringSupport = Class(Exception);
  113. ENotImplemented = class(Exception);
  114. EArgumentException = class(Exception);
  115. EArgumentOutOfRangeException = class(EArgumentException);
  116. EArgumentNilException = class(EArgumentException);
  117. EPathTooLongException = class(Exception);
  118. ENotSupportedException = class(Exception);
  119. EDirectoryNotFoundException = class(Exception);
  120. EFileNotFoundException = class(Exception);
  121. EPathNotFoundException = class(Exception);
  122. ENoConstructException = class(Exception);
  123. var
  124. RTLEInvalidCast: ExceptClass external name 'rtl.EInvalidCast';
  125. //function GetTickCount: Integer;
  126. {*****************************************************************************
  127. String function
  128. *****************************************************************************}
  129. Const
  130. EmptyStr = '';
  131. EmptyWideStr = ''; // No difference here.
  132. HexDisplayPrefix: string = '$';
  133. LeadBytes = [] unimplemented;
  134. Function CharInSet(Ch: Char;Const CSet : array of char) : Boolean;
  135. function LeftStr(const S: string; Count: Integer): String; assembler;
  136. function RightStr(const S: string; Count: Integer): String; assembler;
  137. function Trim(const S: String): String; assembler;
  138. function TrimLeft(const S: String): String; assembler;
  139. function TrimRight(const S: String): String; assembler;
  140. function UpperCase(const s: String): String; assembler; overload;
  141. function LowerCase(const s: String): String; assembler; overload;
  142. function CompareStr(const s1, s2: String): Integer; assembler;
  143. function SameStr(const s1, s2: String): Boolean; assembler;
  144. function CompareText(const s1, s2: String): Integer; assembler;
  145. function SameText(const s1, s2: String): Boolean; assembler;
  146. function AnsiCompareText(const s1, s2: String): Integer; assembler;
  147. function AnsiSameText(const s1, s2: String): Boolean; assembler;
  148. function AnsiCompareStr(const s1, s2: String): Integer;
  149. procedure AppendStr(var Dest: String; const S: string);
  150. function Format(const Fmt: String; const Args: array of JSValue): String;
  151. // JavaScript built-in functions
  152. function LocaleCompare(const s1, s2, locales: String): Boolean; assembler; overload;
  153. function NormalizeStr(const S: String; const Norm: String = 'NFC'): String; assembler; overload; // not in IE
  154. function IsValidIdent(const Ident: string; AllowDots: Boolean = False; StrictDots: Boolean = False): Boolean;
  155. Type
  156. TStringReplaceFlag = (rfReplaceAll, rfIgnoreCase);
  157. TReplaceFlag = TStringReplaceFlag;
  158. TStringReplaceFlags = set of TStringReplaceFlag;
  159. TReplaceFlags = TStringReplaceFlags;
  160. function StringReplace(aOriginal, aSearch, aReplace : string; Flags : TStringReplaceFlags) : String;
  161. function QuoteString(aOriginal : String; AQuote : Char) : String;
  162. function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean;
  163. function AdjustLineBreaks(const S: string): string;
  164. function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle): string;
  165. function WrapText(const Line, BreakStr: string; const BreakChars: Array of char; MaxCol: Integer): string;
  166. function WrapText(const Line: string; MaxCol: Integer): string;
  167. { *****************************************************************************
  168. Integer conversions
  169. *****************************************************************************}
  170. function IntToStr(const Value: Integer): string;
  171. Function TryStrToInt(const S : String; Out res : Integer) : Boolean;
  172. Function TryStrToInt(const S : String; Out res : NativeInt) : Boolean;
  173. Function StrToIntDef(const S : String; Const aDef : Integer) : Integer;
  174. Function StrToIntDef(const S : String; Const aDef : NativeInt) : NativeInt;
  175. Function StrToInt(const S : String) : Integer;
  176. Function StrToNativeInt(const S : String) : NativeInt;
  177. // For compatibility
  178. Function StrToInt64(const S : String) : NativeLargeInt;
  179. Function StrToInt64Def(const S : String; ADefault : NativeLargeInt) : NativeLargeInt;
  180. Function TryStrToInt64(const S : String; Out res : NativeLargeInt) : Boolean;
  181. Function StrToQWord(const S : String) : NativeLargeUInt;
  182. Function StrToQWordDef(const S : String; ADefault : NativeLargeUInt) : NativeLargeUInt;
  183. Function TryStrToQWord(const S : String; Out res : NativeLargeUInt) : Boolean;
  184. Function StrToUInt64(const S : String) : NativeLargeUInt;
  185. Function StrToUInt64Def(const S : String; ADefault : NativeLargeUInt) : NativeLargeUInt;
  186. Function TryStrToUInt64(const S : String; Out res : NativeLargeUInt) : Boolean;
  187. Function StrToDWord(const S : String) : DWord;
  188. Function StrToDWordDef(const S : String; ADefault : DWord) : DWord;
  189. Function TryStrToDWord(const S : String; Out res : DWord) : Boolean;
  190. function IntToHex(Value: NativeInt; Digits: integer): string;
  191. { *****************************************************************************
  192. Float conversions
  193. *****************************************************************************}
  194. const
  195. MaxCurrency {: Currency } = 922337203685477.0000;
  196. MinCurrency {: Currency } = -922337203685477.0000;
  197. Type
  198. TFloatFormat = (ffFixed,ffGeneral,ffExponent,ffNumber);
  199. Function FloatToDecimal(Value : double; Precision, Decimals : integer) : TFloatRec;
  200. Function FloatToStr(Value: Double): String;
  201. Function FloatToStrF(const Value : double; format: TFloatFormat; Precision, Digits: Integer): String;
  202. Function TryStrToFloat(const S : String; Out res : Double) : Boolean;
  203. Function StrToFloatDef(const S : String; Const aDef : Double) : Double;
  204. Function StrToFloat(const S : String) : Double;
  205. Function FormatFloat (Fmt : String; aValue : Double) : String;
  206. { *****************************************************************************
  207. Boolean conversions
  208. *****************************************************************************}
  209. Var
  210. TrueBoolStrs, FalseBoolStrs : Array of String;
  211. function StrToBool(const S: String): Boolean;
  212. function BoolToStr(B: Boolean; UseBoolStrs:Boolean=False): string;
  213. function BoolToStr(B: Boolean; const TrueS, FalseS: String): string;
  214. function StrToBoolDef(const S: String; Default: Boolean): Boolean;
  215. function TryStrToBool(const S: String; out Value: Boolean): Boolean;
  216. {*****************************************************************************
  217. OS/Environment
  218. *****************************************************************************}
  219. Const
  220. ConfigExtension : String = '.cfg';
  221. SysConfigDir : String = '';
  222. type
  223. TOnGetEnvironmentVariable = function(Const EnvVar: String): String;
  224. TOnGetEnvironmentString = function(Index: Integer): String;
  225. TOnGetEnvironmentVariableCount = function: Integer;
  226. var
  227. OnGetEnvironmentVariable: TOnGetEnvironmentVariable;
  228. OnGetEnvironmentString: TOnGetEnvironmentString;
  229. OnGetEnvironmentVariableCount: TOnGetEnvironmentVariableCount;
  230. function GetEnvironmentVariable(Const EnvVar: String): String;
  231. function GetEnvironmentVariableCount: Integer;
  232. function GetEnvironmentString(Index: Integer): String;
  233. procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
  234. Procedure Abort;
  235. {*****************************************************************************
  236. Events
  237. *****************************************************************************}
  238. Type
  239. TEventType = (etCustom,etInfo,etWarning,etError,etDebug);
  240. TEventTypes = Set of TEventType;
  241. {*****************************************************************************
  242. Date and time
  243. *****************************************************************************}
  244. Type
  245. TDateTime = double;
  246. TTime = TDateTime;
  247. TDate = TDateTime;
  248. TSystemTime = record
  249. Year, Month, Day, DayOfWeek: word;
  250. Hour, Minute, Second, MilliSecond: word;
  251. end ;
  252. TTimeStamp = record
  253. Time: longint; { Number of milliseconds since midnight }
  254. Date: longint; { One plus number of days since 1/1/0001 }
  255. end ;
  256. Var
  257. TimeSeparator : char;
  258. DateSeparator : char;
  259. ShortDateFormat : string;
  260. LongDateFormat : string;
  261. ShortTimeFormat : string;
  262. LongTimeFormat : string;
  263. DecimalSeparator : string;
  264. ThousandSeparator : string;
  265. TimeAMString : string;
  266. TimePMString : string;
  267. const
  268. HoursPerDay = 24;
  269. MinsPerHour = 60;
  270. SecsPerMin = 60;
  271. MSecsPerSec = 1000;
  272. MinsPerDay = HoursPerDay * MinsPerHour;
  273. SecsPerDay = MinsPerDay * SecsPerMin;
  274. MSecsPerDay = SecsPerDay * MSecsPerSec;
  275. MaxDateTime: TDateTime = 2958465.99999999;
  276. MinDateTime: TDateTime = -693593.99999999;
  277. JulianEpoch = TDateTime(-2415018.5);
  278. UnixEpoch = JulianEpoch + TDateTime(2440587.5);
  279. DateDelta = 693594; // Days between 1/1/0001 and 12/31/1899
  280. UnixDateDelta = 25569;
  281. { True=Leapyear }
  282. Var
  283. MonthDays : array [Boolean] of TDayTable;
  284. ShortMonthNames : TMonthNames;
  285. LongMonthNames : TMonthNames;
  286. ShortDayNames : TDayNames;
  287. LongDayNames : TDayNames;
  288. var
  289. TwoDigitYearCenturyWindow : word ;
  290. { Threshold to be subtracted from year before age-detection.}
  291. function DateTimeToJSDate(aDateTime : TDateTime) : TJSDate;
  292. function JSDateToDateTime(aDate : TJSDate) : TDateTime;
  293. function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;
  294. function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime;
  295. function MSecsToTimeStamp(MSecs: NativeInt): TTimeStamp;
  296. function TimeStampToMSecs(const TimeStamp: TTimeStamp): NativeInt;
  297. function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean;
  298. function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean;
  299. function EncodeDate(Year, Month, Day :word): TDateTime;
  300. function EncodeTime(Hour, Minute, Second, MilliSecond:word): TDateTime;
  301. function ComposeDateTime(Date,Time : TDateTime) : TDateTime;
  302. procedure DecodeDate(Date: TDateTime; out Year, Month, Day: word);
  303. function DecodeDateFully(const DateTime: TDateTime; out Year, Month, Day, DOW: Word): Boolean;
  304. procedure DecodeTime(Time: TDateTime; out Hour, Minute, Second, MilliSecond: word);
  305. procedure DateTimeToSystemTime(DateTime: TDateTime; out SystemTime: TSystemTime);
  306. function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime;
  307. function DayOfWeek(DateTime: TDateTime): integer;
  308. function Date: TDateTime;
  309. function Time: TDateTime;
  310. function Now: TDateTime;
  311. function IncMonth(const DateTime: TDateTime; NumberOfMonths: integer = 1 ): TDateTime;
  312. procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1);
  313. function IsLeapYear(Year: Word): boolean;
  314. function DateToStr(Date: TDateTime): string;
  315. // function DateToStr(Date: TDateTime; const FormatSettings: TFormatSettings): string;
  316. function TimeToStr(Time: TDateTime): string;
  317. // function TimeToStr(Time: TDateTime; const FormatSettings: TFormatSettings): string;
  318. function DateTimeToStr(DateTime: TDateTime; ForceTimeIfZero : Boolean = False): string;
  319. // function DateTimeToStr(DateTime: TDateTime; const FormatSettings: TFormatSettings; ForceTimeIfZero : Boolean = False): string;
  320. function StrToDate(const S: String): TDateTime;
  321. function StrToDate(const S: String; separator : char): TDateTime;
  322. function StrToDate(const S: String; const useformat : string; separator : char): TDateTime;
  323. //function StrToDate(const S: string; FormatSettings : TFormatSettings): TDateTime;
  324. function StrToTime(const S: String): TDateTime;
  325. function StrToTime(const S: String; separator : char): TDateTime;
  326. // function StrToTime(const S: string; FormatSettings : TFormatSettings): TDateTime;
  327. function StrToDateTime(const S: String): TDateTime;
  328. //function StrToDateTime(const s: ShortString; const FormatSettings : TFormatSettings): TDateTime;
  329. function FormatDateTime(const FormatStr: string; const DateTime: TDateTime): string;
  330. // function FormatDateTime(const FormatStr: string; DateTime: TDateTime; const FormatSettings: TFormatSettings; Options : TFormatDateTimeOptions = []): string;
  331. function TryStrToDate(const S: String; out Value: TDateTime): Boolean;
  332. function TryStrToDate(const S: String; out Value: TDateTime; separator : char): Boolean;
  333. function TryStrToDate(const S: String; out Value: TDateTime; const useformat : string; separator : char): Boolean;
  334. // function TryStrToDate(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
  335. function TryStrToTime(const S: String; out Value: TDateTime): Boolean;
  336. function TryStrToTime(const S: String; out Value: TDateTime; separator : char): Boolean;
  337. function TryStrToDateTime(const S: String; out Value: TDateTime): Boolean;
  338. // function TryStrToTime(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
  339. // function TryStrToDateTime(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
  340. function StrToDateDef(const S: String; const Defvalue : TDateTime): TDateTime;
  341. function StrToDateDef(const S: String; const Defvalue : TDateTime; separator : char): TDateTime;
  342. function StrToTimeDef(const S: String; const Defvalue : TDateTime): TDateTime;
  343. function StrToTimeDef(const S: String; const Defvalue : TDateTime; separator : char): TDateTime;
  344. function StrToDateTimeDef(const S: String; const Defvalue : TDateTime): TDateTime;
  345. function CurrentYear:Word;
  346. procedure ReplaceTime(var dati: TDateTime; NewTime : TDateTime);
  347. procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime);
  348. Function FloatToDateTime (Const Value : Extended) : TDateTime;
  349. {*****************************************************************************
  350. File Paths
  351. *****************************************************************************}
  352. type
  353. PathStr = String;
  354. //function ExtractFilePath(const FileName: PathStr): PathStr;
  355. implementation
  356. procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
  357. Var
  358. S : String;
  359. begin
  360. S:='Application raised an exception '+ExceptObject.ClassName;
  361. if ExceptObject is Exception then
  362. S:=S+' : '+Exception(ExceptObject).Message;
  363. {$IFDEF BROWSER}
  364. asm
  365. window.alert(S);
  366. end;
  367. {$ENDIF}
  368. {$IFDEF NODEJS}
  369. Writeln(S);
  370. {$ENDIF}
  371. if ExceptAddr=nil then;
  372. end;
  373. Const
  374. SAbortError = 'Operation aborted';
  375. procedure Abort;
  376. begin
  377. Raise EAbort.Create(SAbortError);
  378. end;
  379. Function CharInSet(Ch: Char;Const CSet : array of char) : Boolean;
  380. Var
  381. I : integer;
  382. begin
  383. Result:=False;
  384. I:=Length(CSet)-1;
  385. While (Not Result) and (I>=0) do
  386. begin
  387. Result:=(Ch=CSet[i]);
  388. Dec(I);
  389. end;
  390. end;
  391. function LeftStr(const S: string; Count: Integer): String; assembler;
  392. asm
  393. return (Count>0) ? S.substr(0,Count) : "";
  394. end;
  395. function RightStr(const S: string; Count: Integer): String; assembler;
  396. asm
  397. var l = S.length;
  398. return (Count<1) ? "" : ( Count>=l ? S : S.substr(l-Count));
  399. end;
  400. function Trim(const S: String): String; assembler;
  401. asm
  402. return S.trim();
  403. end;
  404. function TrimLeft(const S: String): String; assembler;
  405. asm
  406. return S.replace(/^[\s\uFEFF\xA0\x00-\x1f]+/,'');
  407. end;
  408. function TrimRight(const S: String): String; assembler;
  409. asm
  410. return S.replace(/[\s\uFEFF\xA0\x00-\x1f]+$/,'');
  411. end;
  412. function IntToStr(const Value: Integer): string;
  413. begin
  414. Result:=str(Value);
  415. end;
  416. Function FloatToDecimal(Value : double; Precision, Decimals : integer) : TFloatRec;
  417. Const
  418. Rounds = '234567890';
  419. var
  420. Buffer: String; //Though str func returns only 25 chars, this might change in the future
  421. InfNan: string;
  422. Error, N, L, Start, C: Integer;
  423. GotNonZeroBeforeDot, BeforeDot : boolean;
  424. begin
  425. if Value=0 then ;
  426. SetLength(Result.Digits,19);
  427. asm
  428. Buffer=Value.toPrecision(21); // Double precision
  429. end;
  430. N := 1;
  431. L := Length(Buffer);
  432. while Buffer[N]=' ' do
  433. Inc(N);
  434. Result.Negative := (Buffer[N] = '-');
  435. if Result.Negative then
  436. Inc(N)
  437. else if (Buffer[N] = '+') then
  438. inc(N);
  439. { special cases for Inf and Nan }
  440. if (L>=N+2) then
  441. begin
  442. InfNan:=copy(Buffer,N,3);
  443. if (InfNan='Inf') then
  444. begin
  445. Result.Digits[0]:=#0;
  446. Result.Exponent:=32767;
  447. exit
  448. end;
  449. if (InfNan='Nan') then
  450. begin
  451. Result.Digits[0]:=#0;
  452. Result.Exponent:=-32768;
  453. exit
  454. end;
  455. end;
  456. Start := N; //Start of digits
  457. Result.Exponent := 0; BeforeDot := true;
  458. GotNonZeroBeforeDot := false;
  459. while (L>=N) and (Buffer[N]<>'E') do
  460. begin
  461. if Buffer[N]='.' then
  462. BeforeDot := false
  463. else
  464. begin
  465. if BeforeDot then
  466. begin // Currently this is always 1 char
  467. Inc(Result.Exponent);
  468. Result.Digits[N-Start] := Buffer[N];
  469. if Buffer[N] <> '0' then
  470. GotNonZeroBeforeDot := true;
  471. end
  472. else
  473. Result.Digits[N-Start-1] := Buffer[N]
  474. end;
  475. Inc(N);
  476. end;
  477. Inc(N); // Pass through 'E'
  478. if N<=L then
  479. begin
  480. Val(Copy(Buffer, N, L-N+1), C, Error); // Get exponent after 'E'
  481. Inc(Result.Exponent, C);
  482. end;
  483. // Calculate number of digits we have from str
  484. if BeforeDot then
  485. N := N - Start - 1
  486. else
  487. N := N - Start - 2;
  488. L := Length(Result.Digits);
  489. if N<L then
  490. Result.Digits[N]:='0'; //Zero remaining space
  491. if Decimals + Result.Exponent < Precision Then //After this it is the same as in FloatToDecimal
  492. N := Decimals + Result.Exponent
  493. Else
  494. N := Precision;
  495. if N >= L Then
  496. N := L-1;
  497. if N = 0 Then
  498. begin
  499. if Result.Digits[0] >= '5' Then
  500. begin
  501. Result.Digits[0] := '1';
  502. Result.Digits[1] := #0;
  503. Inc(Result.Exponent);
  504. end
  505. Else
  506. Result.Digits[0] := #0;
  507. end //N=0
  508. Else if N > 0 Then
  509. begin
  510. if Result.Digits[N] >= '5' Then
  511. begin
  512. Repeat
  513. Result.Digits[N] := #0;
  514. Dec(N);
  515. // Writeln(N,': ',Result.Digits[N],', Rounding to : ',Rounds[StrToInt(Result.Digits[N])]);
  516. Result.Digits[N]:=Rounds[StrToInt(Result.Digits[N])];
  517. Until (N = 0) Or (Result.Digits[N] < ':');
  518. If Result.Digits[0] = ':' Then
  519. begin
  520. Result.Digits[0] := '1';
  521. Inc(Result.Exponent);
  522. end;
  523. end
  524. Else
  525. begin
  526. Result.Digits[N] := '0';
  527. While (N > -1) And (Result.Digits[N] = '0') Do
  528. begin
  529. Result.Digits[N] := #0;
  530. Dec(N);
  531. end;
  532. end;
  533. end //N>0
  534. Else
  535. Result.Digits[0] := #0;
  536. if (Result.Digits[0] = #0) and
  537. not GotNonZeroBeforeDot then
  538. begin
  539. Result.Exponent := 0;
  540. Result.Negative := False;
  541. end;
  542. end;
  543. function FloatToStr(Value: Double): String;
  544. begin
  545. Result:=FloatToStrF(Value,ffGeneral,15,0);
  546. end;
  547. Function TryStrToFloat(const S : String; Out res : Double) : Boolean;
  548. Var
  549. J : JSValue;
  550. N : String;
  551. begin
  552. N:=S;
  553. // Delocalize
  554. if (ThousandSeparator <>'') then
  555. N:=StringReplace(N,ThousandSeparator,'',[rfReplaceAll]);
  556. if (DecimalSeparator<>'.') then
  557. N:=StringReplace(N,DecimalSeparator,'.',[]);
  558. J:=parseFloat(N);
  559. Result:=Not jsIsNaN(J);
  560. if Result then
  561. Res:=Double(J);
  562. end;
  563. Function StrToFloatDef(const S : String; Const aDef : Double) : Double;
  564. begin
  565. if not TryStrToFloat(S,Result) then
  566. Result:=aDef;
  567. end;
  568. Function StrToFloat(const S : String) : Double;
  569. begin
  570. if not TryStrToFloat(S,Result) then
  571. Raise EConvertError.CreateFmt(SErrInvalidFloat,[S]);
  572. end;
  573. function FormatFloat(Fmt: String; aValue: Double): String;
  574. Type
  575. TPosArray = Array of Integer;
  576. const
  577. MaxPrecision = 18; // Extended precision
  578. var
  579. // Input in usable format
  580. E : Extended; // Value as extended.
  581. FV: TFloatRec; // Value as floatrec.
  582. Section : String; // Format can contain 3 sections, semicolon separated: Pos;Neg;Zero. This is the one to use.
  583. SectionLength : Integer; // Length of section.
  584. // Calculated based on section. Static during output
  585. ThousandSep: Boolean; // Thousands separator detected in format ?
  586. IsScientific: Boolean; // Use Scientific notation ? (E detected in format)
  587. DecimalPos: Integer; // Position of decimal point in pattern.
  588. FirstDigit: Integer; // First actual digit in input (# or 0), relative to decimal point
  589. LastDigit: Integer; // Last required (0) digit, relative to decimal point
  590. RequestedDigits: Integer; // Number of requested digits, # and 0 alike
  591. ExpSize : Integer; // Number of digits in exponent
  592. Available: Integer; // Available digits in FV.
  593. // These change during output loop
  594. Current: Integer; // Current digit in available digits
  595. PadZeroes: Integer; // Difference in requested digits before comma and exponent, needs to be padded with zeroes.
  596. DistToDecimal: Integer; // Place of current digit, relative to decimal point taking in account PadZeroes!
  597. Procedure InitVars;
  598. begin
  599. E:=aValue;
  600. Section:='';
  601. SectionLength:=0;
  602. ThousandSep:=false;
  603. IsScientific:=false;
  604. DecimalPos:=0;
  605. FirstDigit:=MaxInt;
  606. LastDigit:=0;
  607. RequestedDigits:=0;
  608. ExpSize:=0;
  609. Available:=-1;
  610. end;
  611. procedure ToResult(const AChar: Char);
  612. begin
  613. Result:=Result+AChar;
  614. end;
  615. procedure AddToResult(const AStr: String);
  616. begin
  617. Result:=Result+AStr;
  618. end;
  619. procedure WriteDigit(ADigit: Char);
  620. // Write a digit to result, prepend with decimalseparator or append with 1000 separator
  621. begin
  622. if ADigit=#0 then exit;
  623. // Writeln('WriteDigit: ',ADigit,', DistToDecimal: ',DistToDecimal);
  624. Dec(DistToDecimal);
  625. // -1 -> we've arrived behind the decimal
  626. if (DistToDecimal=-1) then
  627. begin
  628. AddToResult(DecimalSeparator);
  629. ToResult(ADigit);
  630. end
  631. else
  632. begin
  633. // We're still before the decimal.
  634. ToResult(ADigit);
  635. if ThousandSep and ((DistToDecimal mod 3)=0) and (DistToDecimal>1) then
  636. AddToResult(ThousandSeparator);
  637. end;
  638. end;
  639. Function GetDigit : Char;
  640. // Return next digit from available digits.
  641. // May return #0 if none available.
  642. // Will return '0' if applicable.
  643. begin
  644. // Writeln(' DistToDecimal <= LastDigit : ',DistToDecimal,' < ',LastDigit,' have digit: ',Current<=Available, '(',Current,')');
  645. Result:=#0;
  646. if (Current<=Available) then
  647. begin
  648. Result:=FV.Digits[Current];
  649. Inc(Current);
  650. end
  651. else if (DistToDecimal <= LastDigit) then
  652. Dec(DistToDecimal)
  653. else
  654. Result:='0';
  655. // Writeln('GetDigit ->: ',Result);
  656. end;
  657. procedure CopyDigit;
  658. // Copy a digit (#, 0) to the output with the correct value
  659. begin
  660. // Writeln('CopyDigit ');
  661. if (PadZeroes=0) then
  662. WriteDigit(GetDigit) // No shift needed, just copy what is available.
  663. else if (PadZeroes<0) then
  664. begin
  665. // We must prepend zeroes
  666. Inc(PadZeroes);
  667. if (DistToDecimal<=FirstDigit) then
  668. WriteDigit('0')
  669. else
  670. Dec(DistToDecimal);
  671. end
  672. else
  673. begin
  674. // We must append zeroes
  675. while PadZeroes > 0 do
  676. begin
  677. WriteDigit(GetDigit);
  678. Dec(PadZeroes);
  679. end;
  680. WriteDigit(GetDigit);
  681. end;
  682. end;
  683. Function GetSections(Var SP : TPosArray) : Integer;
  684. var
  685. FL : Integer;
  686. i : Integer;
  687. C,Q : Char;
  688. inQuote : Boolean;
  689. begin
  690. Result:=1;
  691. SP[1]:=-1;
  692. SP[2]:=-1;
  693. SP[3]:=-1;
  694. inQuote:=False;
  695. Q:=#0;
  696. I:=1;
  697. FL:=Length(Fmt);
  698. while (I<=FL) do
  699. begin
  700. C:=Fmt[I];
  701. case C of
  702. ';':
  703. begin
  704. if not InQuote then
  705. begin
  706. if Result>3 then
  707. Raise Exception.Create('Invalid float format');
  708. SP[Result]:=I+1;
  709. Inc(Result);
  710. end;
  711. end;
  712. '"','''':
  713. begin
  714. if InQuote then
  715. InQuote:=C<>Q
  716. else
  717. begin
  718. InQuote:=True;
  719. Q:=C;
  720. end;
  721. end;
  722. end;
  723. Inc(I);
  724. end;
  725. if SP[Result]=-1 then
  726. SP[Result]:=FL+1;
  727. end;
  728. Procedure AnalyzeFormat;
  729. var
  730. I,Len: Integer;
  731. Q,C: Char;
  732. InQuote : Boolean;
  733. begin
  734. Len:=Length(Section);
  735. I:=1;
  736. InQuote:=False;
  737. Q:=#0;
  738. while (I<=Len) do
  739. begin
  740. C:=Section[i];
  741. if C in ['"',''''] then
  742. begin
  743. if InQuote then
  744. InQuote:=C<>Q
  745. else
  746. begin
  747. InQuote:=True;
  748. Q:=C;
  749. end;
  750. end
  751. else if not InQuote then
  752. case C of
  753. '.':
  754. if (DecimalPos=0) then
  755. DecimalPos:=RequestedDigits+1;
  756. ',':
  757. ThousandSep:=ThousandSeparator<>#0;
  758. 'e', 'E':
  759. begin
  760. Inc(I);
  761. if (I<Len) then
  762. begin
  763. C:=Section[i];
  764. IsScientific:=C in ['-','+'];
  765. if IsScientific then
  766. while (I<Len) and (Section[i+1]='0') do
  767. begin
  768. Inc(ExpSize);
  769. Inc(I);
  770. end;
  771. if ExpSize>4 then
  772. ExpSize:=4;
  773. end;
  774. end;
  775. '#':
  776. Inc(RequestedDigits);
  777. '0':
  778. begin
  779. if RequestedDigits<FirstDigit then
  780. FirstDigit:=RequestedDigits+1;
  781. Inc(RequestedDigits);
  782. LastDigit:=RequestedDigits+1;
  783. end;
  784. end;
  785. Inc(I);
  786. end;
  787. if DecimalPos=0 then
  788. DecimalPos:=RequestedDigits+1;
  789. // Writeln('LastDigit: ',DecimalPos,'-',LastDigit);
  790. LastDigit:=DecimalPos-LastDigit;
  791. if LastDigit>0 then
  792. LastDigit:=0;
  793. // Writeln('FirstDigit: ',DecimalPos,'-',FirstDigit);
  794. FirstDigit:=DecimalPos-FirstDigit;
  795. if FirstDigit<0 then
  796. FirstDigit:=0;
  797. end;
  798. Function ValueOutSideScope : Boolean;
  799. begin
  800. With FV do
  801. Result:=((Exponent >= 18) and (not IsScientific)) or (Exponent = $7FF) or (Exponent = $800)
  802. end;
  803. Procedure CalcRunVars;
  804. Var
  805. D,P: Integer;
  806. begin
  807. if IsScientific then
  808. begin
  809. P:=RequestedDigits;
  810. D:=9999;
  811. end
  812. else
  813. begin
  814. P:=MaxPrecision;
  815. D:=RequestedDigits-DecimalPos+1;
  816. end;
  817. FV:=FloatToDecimal(aValue,P,D);
  818. DistToDecimal:=DecimalPos-1;
  819. if IsScientific then
  820. PadZeroes:=0 // No padding.
  821. else
  822. begin
  823. PadZeroes:=FV.Exponent-(DecimalPos-1);
  824. if (PadZeroes>=0) then
  825. DistToDecimal:=FV.Exponent
  826. end;
  827. // Writeln('PadZeroes : ',PadZeroes, ', DistToDecimal : ',DistToDecimal);
  828. Available:=-1;
  829. while (Available<High(FV.Digits)) and (FV.Digits[Available+1]<>#0) do
  830. Inc(Available);
  831. // Writeln('Available: ',Available);
  832. end;
  833. Function FormatExponent(ASign: Char; aExponent: Integer) : String;
  834. begin
  835. Result:=IntToStr(aExponent);
  836. Result:=StringOfChar('0',ExpSize-Length(Result))+Result;
  837. if (aExponent<0) then
  838. Result:='-'+Result
  839. else if (aExponent>0) and (aSign='+') then
  840. Result:=aSign+Result;
  841. end;
  842. var
  843. I,S : Integer;
  844. C,Q : Char;
  845. PA : TPosArray;
  846. InLiteral : Boolean;
  847. begin
  848. SetLength(PA,4);
  849. Result:='';
  850. Initvars;
  851. // What section to use ?
  852. if (E>0) then
  853. S:=1
  854. else if (E<0) then
  855. S:=2
  856. else
  857. S:=3;
  858. PA[0]:=0;
  859. I:=GetSections(PA);
  860. if (I<S) or (PA[S]-PA[S-1]=0) then
  861. S:=1;
  862. // Extract correct section
  863. SectionLength:=PA[S]-PA[S-1]-1;
  864. Section:=Copy(Fmt,PA[S-1]+1,SectionLength);
  865. SetLength(Section,SectionLength);
  866. // Writeln('Section ',I,' : "',Section,'" ',SectionLength);
  867. AnalyzeFormat;
  868. // Writeln('RequestedDigits: ',RequestedDigits,', DecimalPos : ',DecimalPos,', LastDigit: ',LastDigit,', FirstDigit: ',FirstDigit);
  869. CalcRunVars;
  870. // If we cannot process value using current settings, fallback
  871. if (SectionLength=0) or ValueOutSideScope then
  872. begin
  873. asm
  874. Section=E.toPrecision(15);
  875. end;
  876. Result:=Section;
  877. end;
  878. // Get Started
  879. I:=1;
  880. Current:=0;
  881. Q:=' ';
  882. InLiteral:=False;
  883. if (FV.Negative) and (S=1) then
  884. ToResult('-');
  885. while (I<=SectionLength) do
  886. begin
  887. C:=Section[i];
  888. // Writeln('Analyzing pos ',I,': "',C,'"');
  889. If (C in ['"', '''']) then
  890. begin
  891. if InLiteral then
  892. InLiteral:=C<>Q
  893. else
  894. begin
  895. inLiteral:=True;
  896. Q:=C;
  897. end;
  898. end
  899. else if InLiteral then
  900. ToResult(C)
  901. else
  902. case C of
  903. '0', '#':
  904. CopyDigit;
  905. '.', ',':
  906. ; // Do nothing, handled by CopyDigit
  907. 'e', 'E':
  908. begin
  909. ToResult(C); // Always needed
  910. Inc(I);
  911. if I<=Length(Section) then
  912. begin
  913. C:=Section[I];
  914. if (C in ['+','-']) then
  915. begin
  916. AddToResult(FormatExponent(C,FV.Exponent-DecimalPos+1));
  917. // Skip rest
  918. while (I<SectionLength) and (Section[i+1]='0') do
  919. Inc(I);
  920. end;
  921. end;
  922. end;
  923. else
  924. ToResult(C);
  925. end;
  926. Inc(i);
  927. end;
  928. end;
  929. function StrToBool(const S: String): Boolean;
  930. begin
  931. if not(TryStrToBool(S,Result)) then
  932. raise EConvertError.CreateFmt(SInvalidBoolean,[S]);
  933. end;
  934. procedure CheckBoolStrs;
  935. begin
  936. if Length(TrueBoolStrs)=0 then
  937. begin
  938. SetLength(TrueBoolStrs,1);
  939. TrueBoolStrs[0]:='True';
  940. end;
  941. if Length(FalseBoolStrs)=0 then
  942. begin
  943. SetLength(FalseBoolStrs,1);
  944. FalseBoolStrs[0]:='False';
  945. end;
  946. end;
  947. function BoolToStr(B: Boolean; UseBoolStrs: Boolean): string;
  948. begin
  949. if UseBoolStrs Then
  950. begin
  951. CheckBoolStrs;
  952. if B then
  953. Result:=TrueBoolStrs[0]
  954. else
  955. Result:=FalseBoolStrs[0];
  956. end else
  957. if B then
  958. Result:='-1'
  959. else
  960. Result:='0';
  961. end;
  962. function BoolToStr(B: Boolean; const TrueS, FalseS: String): string;
  963. begin
  964. if B then Result:=TrueS else Result:=FalseS;
  965. end;
  966. function StrToBoolDef(const S: String; Default: Boolean): Boolean;
  967. begin
  968. if not TryStrToBool(S,Result) then
  969. Result:=Default;
  970. end;
  971. function TryStrToBool(const S: String; out Value: Boolean): Boolean;
  972. Var
  973. Temp : String;
  974. I : Longint;
  975. D : Double;
  976. Code: integer;
  977. begin
  978. Temp:=uppercase(S);
  979. Val(Temp,D,code);
  980. Result:=true;
  981. If Code=0 then
  982. Value:=(D<>0.0)
  983. else
  984. begin
  985. CheckBoolStrs;
  986. for I:=low(TrueBoolStrs) to High(TrueBoolStrs) do
  987. if Temp=uppercase(TrueBoolStrs[I]) then
  988. begin
  989. Value:=true;
  990. exit;
  991. end;
  992. for I:=low(FalseBoolStrs) to High(FalseBoolStrs) do
  993. if Temp=uppercase(FalseBoolStrs[I]) then
  994. begin
  995. Value:=false;
  996. exit;
  997. end;
  998. Result:=false;
  999. end;
  1000. end;
  1001. function UpperCase(const s: String): String; assembler;
  1002. asm
  1003. return s.toUpperCase();
  1004. end;
  1005. function LowerCase(const s: String): String; assembler;
  1006. asm
  1007. return s.toLowerCase();
  1008. end;
  1009. function CompareStr(const s1, s2: String): Integer; assembler;
  1010. asm
  1011. var l1 = s1.length;
  1012. var l2 = s2.length;
  1013. if (l1<=l2){
  1014. var s = s2.substr(0,l1);
  1015. if (s1<s){ return -1;
  1016. } else if (s1>s){ return 1;
  1017. } else { return l1<l2 ? -1 : 0; };
  1018. } else {
  1019. var s = s1.substr(0,l2);
  1020. if (s<s2){ return -1;
  1021. } else { return 1; };
  1022. };
  1023. end;
  1024. function SameStr(const s1, s2: String): Boolean; assembler;
  1025. asm
  1026. return s1 == s2;
  1027. end;
  1028. function CompareText(const s1, s2: String): Integer; assembler;
  1029. asm
  1030. var l1 = s1.toLowerCase();
  1031. var l2 = s2.toLowerCase();
  1032. if (l1>l2){ return 1;
  1033. } else if (l1<l2){ return -1;
  1034. } else { return 0; }
  1035. end;
  1036. function SameText(const s1, s2: String): Boolean; assembler;
  1037. asm
  1038. return s1.toLowerCase() == s2.toLowerCase();
  1039. end;
  1040. function AnsiCompareText(const s1, s2: String): Integer; assembler;
  1041. asm
  1042. return s1.localeCompare(s2);
  1043. end;
  1044. function AnsiSameText(const s1, s2: String): Boolean; assembler;
  1045. asm
  1046. return s1.localeCompare(s2) == 0;
  1047. end;
  1048. function AnsiCompareStr(const s1, s2: String): Integer;
  1049. begin
  1050. {$IFDEF ECMAScript6}
  1051. Result:=CompareText(TJSString(s1).normalize(),TJSString(s1).normalize());
  1052. {$ELSE}
  1053. Result:=CompareText(s1,s2);
  1054. {$ENDIF}
  1055. end;
  1056. procedure AppendStr(var Dest: String; const S: string);
  1057. begin
  1058. Dest:=Dest+S;
  1059. end;
  1060. Const
  1061. feInvalidFormat = 1;
  1062. feMissingArgument = 2;
  1063. feInvalidArgIndex = 3;
  1064. Procedure DoFormatError (ErrCode : Longint;const fmt: String);
  1065. begin
  1066. //!! must be changed to contain format string...
  1067. Case ErrCode of
  1068. feInvalidFormat : raise EConvertError.Createfmt(SInvalidFormat,[Fmt]);
  1069. feMissingArgument : raise EConvertError.Createfmt(SArgumentMissing,[Fmt]);
  1070. feInvalidArgIndex : raise EConvertError.Createfmt(SInvalidArgIndex,[Fmt]);
  1071. end;
  1072. end;
  1073. Const
  1074. maxdigits = 15;
  1075. Function ReplaceDecimalSep(S: String; Const DS : string) : string;
  1076. Var
  1077. P : Integer;
  1078. begin
  1079. P:=Pos('.',S);
  1080. if P>0 then
  1081. Result:=Copy(S,1,P-1)+DS+Copy(S,P+1,Length(S)-P)
  1082. else
  1083. Result:=S;
  1084. end;
  1085. function FormatGeneralFloat(Value : double; Precision : Integer; DS : String) : string;
  1086. Var
  1087. P, PE, Q, Exponent: Integer;
  1088. Begin
  1089. If (Precision = -1) Or (Precision > maxdigits) Then
  1090. Precision := maxdigits;
  1091. { First convert to scientific format, with correct precision }
  1092. Str(Value:precision+7, Result);
  1093. { Delete leading spaces }
  1094. Result:=TrimLeft(Result);
  1095. P:=Pos('.',Result);
  1096. if P=0 then
  1097. exit;
  1098. { Consider removing exponent }
  1099. PE:=Pos('E',Result);
  1100. if PE=0 then
  1101. begin
  1102. Result:=ReplaceDecimalSep(Result,DS);
  1103. exit;
  1104. end;
  1105. { Read exponent }
  1106. Q:=PE+2;
  1107. Exponent := 0;
  1108. while (Q <= Length(Result)) do
  1109. begin
  1110. Exponent := Exponent*10 + Ord(Result[Q])-Ord('0');
  1111. Inc(Q);
  1112. end;
  1113. if Result[PE+1] = '-' then
  1114. Exponent := -Exponent;
  1115. if (P+Exponent < PE) and (Exponent > -6) then
  1116. begin
  1117. { OK to remove exponent }
  1118. SetLength(Result,PE-1); { Trim exponent }
  1119. if Exponent >= 0 then
  1120. begin
  1121. { Shift point to right }
  1122. for Q := 0 to Exponent-1 do
  1123. begin
  1124. Result[P] := Result[P+1];
  1125. Inc(P);
  1126. end;
  1127. Result[P] := '.';
  1128. P := 1;
  1129. if Result[P] = '-' then
  1130. Inc(P);
  1131. while (Result[P] = '0') and (P < Length(Result)) and (Copy(Result,P+1,Length(DS))<>DS) do
  1132. { Trim leading zeros; conversion above should not give any, but occasionally does
  1133. because of rounding }
  1134. System.Delete(Result,P,1);
  1135. end
  1136. else
  1137. begin
  1138. { Add zeros at start }
  1139. Insert(Copy('00000',1,-Exponent),Result,P-1);
  1140. Result[P-Exponent] := Result[P-Exponent-1]; { Copy leading digit }
  1141. Result[P] := '.';
  1142. if Exponent <> -1 then
  1143. Result[P-Exponent-1] := '0';
  1144. end;
  1145. { Remove trailing zeros }
  1146. Q := Length(Result);
  1147. while (Q > 0) and (Result[Q] = '0') do
  1148. Dec(Q);
  1149. if Result[Q] = DS then
  1150. Dec(Q); { Remove trailing decimal point }
  1151. if (Q = 0) or ((Q=1) and (Result[1] = '-')) then
  1152. Result := '0'
  1153. else
  1154. SetLength(Result,Q);
  1155. end
  1156. else
  1157. begin
  1158. { Need exponent, but remove superfluous characters }
  1159. { Delete trailing zeros }
  1160. while Result[PE-1] = '0' do
  1161. begin
  1162. System.Delete(Result,PE-1,1);
  1163. Dec(PE);
  1164. end;
  1165. { If number ends in decimal point, remove it }
  1166. if Result[PE-1] = DS then
  1167. begin
  1168. System.Delete(Result,PE-1,1);
  1169. Dec(PE);
  1170. end;
  1171. { delete superfluous + in exponent }
  1172. if Result[PE+1]='+' then
  1173. System.Delete(Result,PE+1,1)
  1174. else
  1175. Inc(PE);
  1176. while Result[PE+1] = '0' do
  1177. { Delete leading zeros in exponent }
  1178. System.Delete(Result,PE+1,1)
  1179. end;
  1180. Result:=ReplaceDecimalSep(Result,DS)
  1181. end;
  1182. function FormatExponentFloat(Value : double; Precision,Digits : Integer;DS : String) : string;
  1183. Var
  1184. P: Integer;
  1185. Begin
  1186. DS:=DecimalSeparator;
  1187. If (Precision = -1) Or (Precision > maxdigits) Then
  1188. Precision := maxdigits;
  1189. Str(Value:Precision+7, Result);
  1190. { Delete leading spaces }
  1191. while Result[1] = ' ' do
  1192. System.Delete(Result, 1, 1);
  1193. P:=Pos('E',Result);
  1194. if P=0 then
  1195. begin
  1196. Result:=ReplaceDecimalSep(Result,DS);
  1197. exit;
  1198. end;
  1199. Inc(P, 2);
  1200. if Digits > 4 then
  1201. Digits:=4;
  1202. Digits:=Length(Result) - P - Digits + 1;
  1203. if Digits < 0 then
  1204. insert(copy('0000',1,-Digits),Result,P)
  1205. else
  1206. while (Digits > 0) and (Result[P] = '0') do
  1207. begin
  1208. System.Delete(Result, P, 1);
  1209. if P > Length(Result) then
  1210. begin
  1211. System.Delete(Result, P - 2, 2);
  1212. break;
  1213. end;
  1214. Dec(Digits);
  1215. end;
  1216. Result:=ReplaceDecimalSep(Result,DS);
  1217. End;
  1218. function FormatFixedFloat(Value : double; Digits : Integer; DS : String) : string;
  1219. Begin
  1220. If Digits = -1 Then
  1221. Digits := 2
  1222. Else If Digits > 18 Then
  1223. Digits := 18;
  1224. Str(Value:0:Digits, Result);
  1225. if (Result<>'') and (Result[1]=' ') then
  1226. Delete(Result,1,1);
  1227. Result:=ReplaceDecimalSep(Result,DS);
  1228. end;
  1229. function FormatNumberFloat(Value : double; Digits : Integer; DS,TS : String) : string;
  1230. Var
  1231. P : integer;
  1232. Begin
  1233. If Digits = -1 Then
  1234. Digits := 2
  1235. else If Digits > maxdigits Then
  1236. Digits := maxdigits;
  1237. Str(Value:0:Digits, Result);
  1238. if (Result<>'') and (Result[1]=' ') then
  1239. Delete(Result,1,1);
  1240. P:=Pos('.',Result);
  1241. Result:=ReplaceDecimalSep(Result,DS);
  1242. Dec(P,3);
  1243. if (TS<>'') and (TS<>#0) then
  1244. While (P>1) Do
  1245. Begin
  1246. If (Result[P-1] <> '-') Then
  1247. Insert(TS, Result, P);
  1248. Dec(P, 3);
  1249. End;
  1250. End;
  1251. Function FloatToStrF(const Value : double; format: TFloatFormat; Precision, Digits: Integer): String;
  1252. Var
  1253. DS: string;
  1254. function RemoveLeadingNegativeSign(var AValue: String): Boolean;
  1255. // removes negative sign in case when result is zero eg. -0.00
  1256. var
  1257. i: PtrInt;
  1258. TS: String;
  1259. StartPos: PtrInt;
  1260. begin
  1261. Result:=False;
  1262. StartPos := 2;
  1263. TS := ThousandSeparator;
  1264. for i :=StartPos to length(AValue) do
  1265. begin
  1266. Result := (AValue[i] in ['0', DS, 'E', '+']) or (aValue=TS);
  1267. if not Result then
  1268. break;
  1269. end;
  1270. if (Result) then
  1271. Delete(AValue, 1, 1);
  1272. end;
  1273. Begin
  1274. DS:=DecimalSeparator;
  1275. Case format Of
  1276. ffGeneral:
  1277. Result:=FormatGeneralFloat(Value,Precision,DS);
  1278. ffExponent:
  1279. Result:=FormatExponentFloat(Value,Precision,Digits,DS);
  1280. ffFixed:
  1281. Result:=FormatFixedFloat(Value,Digits,DS);
  1282. ffNumber:
  1283. Result:=FormatNumberFloat(Value,Digits,DS,ThousandSeparator);
  1284. // ffCurrency: not supported
  1285. end;
  1286. if (length(Result)>1) and (Result[1]='-') then
  1287. RemoveLeadingNegativeSign(Result);
  1288. end;
  1289. function Format (const Fmt: String; const Args: array of jsvalue): String;
  1290. Var ChPos,OldPos,ArgPos,DoArg,Len : SizeInt;
  1291. Hs,ToAdd : String;
  1292. Index : SizeInt;
  1293. Width,Prec : Longint;
  1294. Left : Boolean;
  1295. Fchar : char;
  1296. vq : nativeint;
  1297. {
  1298. ReadFormat reads the format string. It returns the type character in
  1299. uppercase, and sets index, Width, Prec to their correct values,
  1300. or -1 if not set. It sets Left to true if left alignment was requested.
  1301. In case of an error, DoFormatError is called.
  1302. }
  1303. Function ReadFormat : Char;
  1304. Var Value : NativeInt;
  1305. Procedure ReadInteger;
  1306. var
  1307. Code: integer;
  1308. ArgN: SizeInt;
  1309. begin
  1310. If Value<>-1 then exit; // Was already read.
  1311. OldPos:=ChPos;
  1312. While (ChPos<=Len) and
  1313. (Fmt[ChPos]<='9') and (Fmt[ChPos]>='0') do inc(ChPos);
  1314. If ChPos>len then
  1315. DoFormatError(feInvalidFormat,Fmt);
  1316. If Fmt[ChPos]='*' then
  1317. begin
  1318. if Index=-1 then
  1319. ArgN:=Argpos
  1320. else
  1321. begin
  1322. ArgN:=Index;
  1323. Inc(Index);
  1324. end;
  1325. If (ChPos>OldPos) or (ArgN>High(Args)) then
  1326. DoFormatError(feInvalidFormat,Fmt);
  1327. ArgPos:=ArgN+1;
  1328. if IsNumber(Args[ArgN]) and IsInteger(Args[ArgN]) then
  1329. Value:=Integer(Args[ArgN])
  1330. else
  1331. DoFormatError(feInvalidFormat,Fmt);
  1332. Inc(ChPos);
  1333. end
  1334. else
  1335. begin
  1336. If (OldPos<ChPos) Then
  1337. begin
  1338. Val (Copy(Fmt,OldPos,ChPos-OldPos),value,code);
  1339. // This should never happen !!
  1340. If Code>0 then DoFormatError (feInvalidFormat,Fmt);
  1341. end
  1342. else
  1343. Value:=-1;
  1344. end;
  1345. end;
  1346. Procedure ReadIndex;
  1347. begin
  1348. If Fmt[ChPos]<>':' then
  1349. ReadInteger
  1350. else
  1351. value:=0; // Delphi undocumented behaviour, assume 0, #11099
  1352. If Fmt[ChPos]=':' then
  1353. begin
  1354. If Value=-1 then DoFormatError(feMissingArgument,Fmt);
  1355. Index:=Value;
  1356. Value:=-1;
  1357. Inc(ChPos);
  1358. end;
  1359. end;
  1360. Procedure ReadLeft;
  1361. begin
  1362. If Fmt[ChPos]='-' then
  1363. begin
  1364. left:=True;
  1365. Inc(ChPos);
  1366. end
  1367. else
  1368. Left:=False;
  1369. end;
  1370. Procedure ReadWidth;
  1371. begin
  1372. ReadInteger;
  1373. If Value<>-1 then
  1374. begin
  1375. Width:=Value;
  1376. Value:=-1;
  1377. end;
  1378. end;
  1379. Procedure ReadPrec;
  1380. begin
  1381. If Fmt[ChPos]='.' then
  1382. begin
  1383. inc(ChPos);
  1384. ReadInteger;
  1385. If Value=-1 then
  1386. Value:=0;
  1387. prec:=Value;
  1388. end;
  1389. end;
  1390. begin
  1391. Index:=-1;
  1392. Width:=-1;
  1393. Prec:=-1;
  1394. Value:=-1;
  1395. inc(ChPos);
  1396. If Fmt[ChPos]='%' then
  1397. begin
  1398. Result:='%';
  1399. exit; // VP fix
  1400. end;
  1401. ReadIndex;
  1402. ReadLeft;
  1403. ReadWidth;
  1404. ReadPrec;
  1405. Result:=Upcase(Fmt[ChPos]);
  1406. end;
  1407. function Checkarg (AT : TJSValueType; err:boolean):boolean;
  1408. {
  1409. Check if argument INDEX is of correct type (AT)
  1410. If Index=-1, ArgPos is used, and argpos is augmented with 1
  1411. DoArg is set to the argument that must be used.
  1412. }
  1413. begin
  1414. result:=false;
  1415. if Index=-1 then
  1416. DoArg:=Argpos
  1417. else
  1418. DoArg:=Index;
  1419. ArgPos:=DoArg+1;
  1420. If (Doarg>High(Args)) or (GetValueTYpe(Args[Doarg])<>AT) then
  1421. begin
  1422. if err then
  1423. DoFormatError(feInvalidArgindex,Fmt);
  1424. dec(ArgPos);
  1425. exit;
  1426. end;
  1427. result:=true;
  1428. end;
  1429. begin
  1430. Result:='';
  1431. Len:=Length(Fmt);
  1432. ChPos:=1;
  1433. OldPos:=1;
  1434. ArgPos:=0;
  1435. While ChPos<=len do
  1436. begin
  1437. While (ChPos<=Len) and (Fmt[ChPos]<>'%') do
  1438. inc(ChPos);
  1439. If ChPos>OldPos Then
  1440. Result:=Result+Copy(Fmt,OldPos,ChPos-Oldpos);
  1441. If ChPos<Len then
  1442. begin
  1443. FChar:=ReadFormat;
  1444. {$ifdef fmtdebug}
  1445. DumpFormat(FCHar);
  1446. {$endif}
  1447. Case FChar of
  1448. 'D' : begin
  1449. Checkarg(jvtinteger,true);
  1450. toAdd:=IntToStr(NativeInt(Args[DoArg]));
  1451. Width:=Abs(width);
  1452. Index:=Prec-Length(ToAdd);
  1453. If ToAdd[1]<>'-' then
  1454. ToAdd:=StringOfChar('0',Index)+ToAdd
  1455. else
  1456. // + 1 to accomodate for - sign in length !!
  1457. Insert(StringOfChar('0',Index+1),toadd,2);
  1458. end;
  1459. 'U' : begin
  1460. Checkarg(jvtinteger,True);
  1461. if NativeInt(Args[Doarg])<0 then
  1462. DoFormatError(feInvalidArgindex,Fmt);
  1463. Toadd:=IntToStr(NativeInt(Args[Doarg]));
  1464. Width:=Abs(width);
  1465. Index:=Prec-Length(ToAdd);
  1466. ToAdd:=StringOfChar('0',Index)+ToAdd
  1467. end;
  1468. 'E' : begin
  1469. if CheckArg(jvtFloat,false) or CheckArg(jvtInteger,True) then
  1470. ToAdd:=FloatToStrF(Double(Args[doarg]),ffFixed,9999,Prec);
  1471. end;
  1472. 'F' : begin
  1473. if CheckArg(jvtFloat,false) or CheckArg(jvtInteger,True) then
  1474. ToAdd:=FloatToStrF(Double(Args[doarg]),ffFixed,9999,Prec);
  1475. end;
  1476. 'G' : begin
  1477. if CheckArg(jvtFloat,false) or CheckArg(jvtInteger,True) then
  1478. ToAdd:=FloatToStrF(Double(Args[doarg]),ffGeneral,Prec,3);
  1479. end;
  1480. 'N' : begin
  1481. if CheckArg(jvtFloat,false) or CheckArg(jvtInteger,True) then
  1482. ToAdd:=FloatToStrF(Double(Args[doarg]),ffNumber,9999,Prec);
  1483. end;
  1484. 'M' : begin
  1485. if CheckArg(jvtFloat,false) or CheckArg(jvtInteger,True) then
  1486. ToAdd:=FloatToStrF(Double(Args[doarg]),ffNumber,9999,Prec);
  1487. end;
  1488. 'S' : begin
  1489. CheckArg(jvtString,true);
  1490. hs:=String(Args[doarg]);
  1491. Index:=Length(hs);
  1492. If (Prec<>-1) and (Index>Prec) then
  1493. Index:=Prec;
  1494. ToAdd:=Copy(hs,1,Index);
  1495. end;
  1496. 'P' : Begin
  1497. CheckArg(jvtInteger,true);
  1498. ToAdd:=IntToHex(NativeInt(Args[DoArg]),31);
  1499. end;
  1500. 'X' : begin
  1501. Checkarg(jvtinteger,true);
  1502. vq:=nativeInt(Args[Doarg]);
  1503. index:=31; // May need to adjust to NativeInt
  1504. If Prec>index then
  1505. ToAdd:=IntToHex(vq,index)
  1506. else
  1507. begin
  1508. // determine minimum needed number of hex digits.
  1509. Index:=1;
  1510. While (NativeInt(1) shl (Index*4)<=vq) and (index<16) do
  1511. inc(Index);
  1512. If Index>Prec then
  1513. Prec:=Index;
  1514. ToAdd:=IntToHex(vq,Prec);
  1515. end;
  1516. end;
  1517. '%': ToAdd:='%';
  1518. end;
  1519. If Width<>-1 then
  1520. If Length(ToAdd)<Width then
  1521. If not Left then
  1522. ToAdd:=StringOfChar(' ',Width-Length(ToAdd))+ToAdd
  1523. else
  1524. ToAdd:=ToAdd+StringOfChar(' ',Width-Length(ToAdd));
  1525. Result:=Result+ToAdd;
  1526. end;
  1527. inc(ChPos);
  1528. Oldpos:=ChPos;
  1529. end;
  1530. end;
  1531. function LocaleCompare(const s1, s2, locales: String): Boolean; assembler;
  1532. asm
  1533. return s1.localeCompare(s2,locales) == 0;
  1534. end;
  1535. function NormalizeStr(const S: String; const Norm: String): String; assembler;
  1536. asm
  1537. return S.normalize(Norm);
  1538. end;
  1539. function IsValidIdent(const Ident: string; AllowDots: Boolean = False; StrictDots: Boolean = False): Boolean;
  1540. const
  1541. Alpha = ['A'..'Z', 'a'..'z', '_'];
  1542. AlphaNum = Alpha + ['0'..'9'];
  1543. Dot = '.';
  1544. var
  1545. First: Boolean;
  1546. I, Len: Integer;
  1547. begin
  1548. Len := Length(Ident);
  1549. if Len < 1 then
  1550. Exit(False);
  1551. First := True;
  1552. Result:=false;
  1553. I:=1;
  1554. While I<=len do
  1555. begin
  1556. if First then
  1557. begin
  1558. if not (Ident[I] in Alpha) then exit;
  1559. First := False;
  1560. end
  1561. else if AllowDots and (Ident[I] = Dot) then
  1562. begin
  1563. if StrictDots then
  1564. begin
  1565. if I >= Len then exit;
  1566. First := True;
  1567. end;
  1568. end
  1569. else
  1570. if not (Ident[I] in AlphaNum) then exit;
  1571. I:=I+1;
  1572. end;
  1573. Result:=true;
  1574. end;
  1575. procedure FreeAndNil(var Obj);
  1576. var
  1577. o: TObject;
  1578. begin
  1579. o:=TObject(Obj);
  1580. if o=nil then exit;
  1581. TObject(Obj):=nil;
  1582. o.Destroy;
  1583. end;
  1584. { EVariantError }
  1585. constructor EVariantError.CreateCode(Code: Longint);
  1586. begin
  1587. ErrCode:=Code;
  1588. end;
  1589. { Exception }
  1590. constructor Exception.Create(const Msg: String);
  1591. begin
  1592. fMessage:=Msg;
  1593. end;
  1594. constructor Exception.CreateFmt(const Msg: string; const Args: array of JSValue);
  1595. begin
  1596. //writeln('Exception.CreateFmt START ',ClassName,' "',Msg,'" Args=',Args);
  1597. fMessage:=Format(Msg,Args);
  1598. //writeln('Exception.CreateFmt END ',ClassName,' "',Msg,'" fMessage=',fMessage);
  1599. end;
  1600. constructor Exception.CreateHelp(const Msg: String; AHelpContext: Integer);
  1601. begin
  1602. fMessage:=Msg;
  1603. fHelpContext:=AHelpContext;
  1604. end;
  1605. constructor Exception.CreateFmtHelp(const Msg: string;
  1606. const Args: array of JSValue; AHelpContext: Integer);
  1607. begin
  1608. fMessage:=Format(Msg,Args);
  1609. fHelpContext:=AHelpContext;
  1610. end;
  1611. function Exception.ToString: String;
  1612. begin
  1613. Result:=ClassName+': '+Message;
  1614. end;
  1615. Const
  1616. RESpecials = '([\[\]\(\)\\\.\*])';
  1617. Function StringReplace(aOriginal, aSearch, aReplace : string; Flags : TStringReplaceFlags) : String;
  1618. Var
  1619. REFlags : String;
  1620. REString : String;
  1621. begin
  1622. REFlags:='';
  1623. if rfReplaceAll in flags then
  1624. ReFlags:='g';
  1625. if rfIgnoreCase in flags then
  1626. ReFlags:=ReFlags+'i';
  1627. REString:=TJSString(aSearch).replace(TJSRegexp.new(RESpecials,'g'),'\$1');
  1628. Result:=TJSString(aOriginal).replace(TJSRegexp.new(REString,REFlags),aReplace);
  1629. end;
  1630. Function QuoteString(aOriginal : String; AQuote : Char) : String;
  1631. Var
  1632. REString : String;
  1633. begin
  1634. REString:=TJSString(aQuote).replace(TJSRegexp.new(aOriginal,'g'),'\\$1');
  1635. Result:=AQuote+TJSString(aOriginal).replace(TJSRegexp.new(REString,'g'),'$1\$1')+AQuote;
  1636. end;
  1637. function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean;
  1638. begin
  1639. Result:=False;
  1640. if (Index>0) and (Index<=Length(S)) then
  1641. Result:=Pos(S[Index],Delimiters)<>0; // Note we don't do MBCS yet
  1642. end;
  1643. function AdjustLineBreaks(const S: string): string;
  1644. begin
  1645. Result:=AdjustLineBreaks(S,DefaultTextLineBreakStyle);
  1646. end;
  1647. function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle): string;
  1648. var
  1649. I,L: Longint;
  1650. Res : String;
  1651. Procedure Add(C : Char);
  1652. begin
  1653. Res:=Res+C;
  1654. end;
  1655. begin
  1656. I:=0;
  1657. L:=Length(S);
  1658. Result:='';
  1659. While (I<=L) do
  1660. case S[I] of
  1661. #10: begin
  1662. if Style in [tlbsCRLF,tlbsCR] then
  1663. Add(#13);
  1664. if Style=tlbsCRLF then
  1665. Add(#10);
  1666. Inc(I);
  1667. end;
  1668. #13: begin
  1669. if Style=tlbsCRLF then
  1670. Add(#13);
  1671. Add(#10);
  1672. Inc(I);
  1673. if S[I]=#10 then
  1674. Inc(I);
  1675. end;
  1676. else
  1677. Add(S[i]);
  1678. Inc(I);
  1679. end;
  1680. Result:=Res;
  1681. end;
  1682. function WrapText(const Line, BreakStr: string; const BreakChars: Array of char; MaxCol: Integer): string;
  1683. const
  1684. Quotes = ['''', '"'];
  1685. Var
  1686. L : String;
  1687. C,LQ,BC : Char;
  1688. P,BLen,Len : Integer;
  1689. HB,IBC : Boolean;
  1690. begin
  1691. Result:='';
  1692. L:=Line;
  1693. Blen:=Length(BreakStr);
  1694. If (BLen>0) then
  1695. BC:=BreakStr[1]
  1696. else
  1697. BC:=#0;
  1698. Len:=Length(L);
  1699. While (Len>0) do
  1700. begin
  1701. P:=1;
  1702. LQ:=#0;
  1703. HB:=False;
  1704. IBC:=False;
  1705. While ((P<=Len) and ((P<=MaxCol) or not IBC)) and ((LQ<>#0) or Not HB) do
  1706. begin
  1707. C:=L[P];
  1708. If (C=LQ) then
  1709. LQ:=#0
  1710. else If (C in Quotes) then
  1711. LQ:=C;
  1712. If (LQ<>#0) then
  1713. Inc(P)
  1714. else
  1715. begin
  1716. HB:=((C=BC) and (BreakStr=Copy(L,P,BLen)));
  1717. If HB then
  1718. Inc(P,Blen)
  1719. else
  1720. begin
  1721. If (P>=MaxCol) then
  1722. IBC:=CharInSet(C,BreakChars);
  1723. Inc(P);
  1724. end;
  1725. end;
  1726. // Writeln('"',C,'" : IBC : ',IBC,' HB : ',HB,' LQ : ',LQ,' P>MaxCol : ',P>MaxCol);
  1727. end;
  1728. Result:=Result+Copy(L,1,P-1);
  1729. Delete(L,1,P-1);
  1730. Len:=Length(L);
  1731. If (Len>0) and Not HB then
  1732. Result:=Result+BreakStr;
  1733. end;
  1734. end;
  1735. function WrapText(const Line: string; MaxCol: Integer): string;
  1736. begin
  1737. Result:=WrapText(Line,sLineBreak, [' ', '-', #9], MaxCol);
  1738. end;
  1739. function GetEnvironmentVariable(const EnvVar: String): String;
  1740. begin
  1741. if Assigned(OnGetEnvironmentVariable) then
  1742. Result:=OnGetEnvironmentVariable(EnvVar)
  1743. else
  1744. Result:='';
  1745. end;
  1746. function GetEnvironmentVariableCount: Integer;
  1747. begin
  1748. if Assigned(OnGetEnvironmentVariableCount) then
  1749. Result:=OnGetEnvironmentVariableCount()
  1750. else
  1751. Result:=0;
  1752. end;
  1753. function GetEnvironmentString(Index: Integer): String;
  1754. begin
  1755. if Assigned(OnGetEnvironmentString) then
  1756. Result:=OnGetEnvironmentString(Index)
  1757. else
  1758. Result:='';
  1759. end;
  1760. { Date/Time routines}
  1761. Function DoEncodeDate(Year, Month, Day: Word): longint;
  1762. Var
  1763. D : TDateTime;
  1764. begin
  1765. If TryEncodeDate(Year,Month,Day,D) then
  1766. Result:=Trunc(D)
  1767. else
  1768. Result:=0;
  1769. end;
  1770. function DoEncodeTime(Hour, Minute, Second, MilliSecond: word): TDateTime;
  1771. begin
  1772. If not TryEncodeTime(Hour,Minute,Second,MilliSecond,Result) then
  1773. Result:=0;
  1774. end;
  1775. Function DateTimeToJSDate(aDateTime : TDateTime) : TJSDate;
  1776. Var
  1777. Y,M,D,h,n,s,z : Word;
  1778. begin
  1779. DecodeDate(Trunc(aDateTime),Y,M,D);
  1780. DecodeTime(Frac(aDateTime),H,N,S,Z);
  1781. Result:=TJSDate.New(Y,M,D,h,n,s,z);
  1782. end;
  1783. Function JSDatetoDateTime(ADate: TJSDate) : TDateTime;
  1784. begin
  1785. Result:=EncodeDate(ADate.FullYear,ADate.Month+1,ADate.Date) +
  1786. EncodeTime(ADate.Hours,ADate.Minutes,ADate.Seconds,ADate.Milliseconds);
  1787. end;
  1788. { ComposeDateTime converts a Date and a Time into one TDateTime }
  1789. function ComposeDateTime(Date,Time : TDateTime) : TDateTime;
  1790. begin
  1791. if Date < 0 then
  1792. Result := trunc(Date) - Abs(frac(Time))
  1793. else
  1794. Result := trunc(Date) + Abs(frac(Time));
  1795. end;
  1796. Function TryEncodeDate(Year,Month,Day : Word; Out Date : TDateTime) : Boolean;
  1797. var
  1798. c, ya: LongWord;
  1799. begin
  1800. Result:=(Year>0) and (Year<10000) and
  1801. (Month >= 1) and (Month<=12) and
  1802. (Day>0) and (Day<=MonthDays[IsleapYear(Year),Month]);
  1803. If Result then
  1804. begin
  1805. if month > 2 then
  1806. Dec(Month,3)
  1807. else
  1808. begin
  1809. Inc(Month,9);
  1810. Dec(Year);
  1811. end;
  1812. c:= Year DIV 100;
  1813. ya:= Year - 100*c;
  1814. Date := (146097*c) SHR 2 + (1461*ya) SHR 2 + (153*LongWord(Month)+2) DIV 5 + LongWord(Day);
  1815. // Note that this line can't be part of the line above, since TDateTime is
  1816. // signed and c and ya are not
  1817. Date := Date - 693900;
  1818. end
  1819. end;
  1820. function TryEncodeTime(Hour, Min, Sec, MSec:word; Out Time : TDateTime) : boolean;
  1821. begin
  1822. Result:=(Hour<24) and (Min<60) and (Sec<60) and (MSec<1000);
  1823. If Result then
  1824. Time:=TDateTime(LongWord(Hour)*3600000+LongWord(Min)*60000+LongWord(Sec)*1000+MSec)/MSecsPerDay;
  1825. end;
  1826. { EncodeDate packs three variables Year, Month and Day into a
  1827. TDateTime value the result is the number of days since 12/30/1899 }
  1828. function EncodeDate(Year, Month, Day: word): TDateTime;
  1829. begin
  1830. If Not TryEncodeDate(Year,Month,Day,Result) then
  1831. Raise EConvertError.CreateFmt('%s-%s-%s is not a valid date specification',
  1832. [IntToStr(Year),IntToStr(Month),IntToStr(Day)]);
  1833. end;
  1834. { EncodeTime packs four variables Hour, Minute, Second and MilliSecond into
  1835. a TDateTime value }
  1836. function EncodeTime(Hour, Minute, Second, MilliSecond:word):TDateTime;
  1837. begin
  1838. If not TryEncodeTime(Hour,Minute,Second,MilliSecond,Result) then
  1839. Raise EConvertError.CreateFmt('%s:%s:%s.%s is not a valid time specification',
  1840. [IntToStr(Hour),IntToStr(Minute),IntToStr(Second),IntToStr(MilliSecond)]);
  1841. end;
  1842. { DecodeDate unpacks the value Date into three values:
  1843. Year, Month and Day }
  1844. procedure DecodeDate(Date: TDateTime; out Year, Month, Day: word);
  1845. var
  1846. ly,ld,lm,j : LongWord;
  1847. begin
  1848. if Date <= -datedelta then // If Date is before 1-1-1 then return 0-0-0
  1849. begin
  1850. Year := 0;
  1851. Month := 0;
  1852. Day := 0;
  1853. end
  1854. else
  1855. begin
  1856. if Date>0 then
  1857. Date:=(Date+(1/(msecsperday*2)))
  1858. else
  1859. Date:=Date-(1/(msecsperday*2));
  1860. if Date>MaxDateTime then
  1861. Date:=MaxDateTime;
  1862. // Raise EConvertError.CreateFmt('%f is not a valid TDatetime encoding, maximum value is %f.',[Date,MaxDateTime]);
  1863. j := ((Trunc(Date) + 693900) SHL 2)-1;
  1864. ly:= j DIV 146097;
  1865. j:= j - 146097 * LongWord(ly);
  1866. ld := j SHR 2;
  1867. j:=(ld SHL 2 + 3) DIV 1461;
  1868. ld:= ((ld SHL 2) + 7 - 1461*j) SHR 2;
  1869. lm:=(5 * ld-3) DIV 153;
  1870. ld:= (5 * ld +2 - 153*lm) DIV 5;
  1871. ly:= 100 * LongWord(ly) + j;
  1872. if lm < 10 then
  1873. inc(lm,3)
  1874. else
  1875. begin
  1876. dec(lm,9);
  1877. inc(ly);
  1878. end;
  1879. year:=ly;
  1880. month:=lm;
  1881. day:=ld;
  1882. end;
  1883. end;
  1884. function DecodeDateFully(const DateTime: TDateTime; out Year, Month, Day, DOW: Word): Boolean;
  1885. begin
  1886. DecodeDate(DateTime,Year,Month,Day);
  1887. DOW:=DayOfWeek(DateTime);
  1888. Result:=IsLeapYear(Year);
  1889. end;
  1890. { DateTimeToTimeStamp converts DateTime to a TTimeStamp }
  1891. function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;
  1892. Var
  1893. D : Double;
  1894. begin
  1895. D:=DateTime * Double(MSecsPerDay);
  1896. if D<0 then
  1897. D:=D-0.5
  1898. else
  1899. D:=D+0.5;
  1900. result.Time := Trunc(Abs(Trunc(D)) Mod MSecsPerDay);
  1901. result.Date := DateDelta + (Trunc(D) div MSecsPerDay);
  1902. end;
  1903. { TimeStampToDateTime converts TimeStamp to a TDateTime value }
  1904. function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime;
  1905. begin
  1906. Result := ComposeDateTime(TimeStamp.Date - DateDelta,TimeStamp.Time/MSecsPerDay)
  1907. end;
  1908. { MSecsToTimeStamp }
  1909. function MSecsToTimeStamp(MSecs: NativeInt): TTimeStamp;
  1910. begin
  1911. result.Date := Trunc(msecs/msecsperday);
  1912. msecs:= msecs-NativeInt(result.date)*msecsperday;
  1913. result.Time := Round(MSecs);
  1914. end;
  1915. function TimeStampToMSecs(const TimeStamp: TTimeStamp): NativeInt;
  1916. begin
  1917. result := TimeStamp.Time + (timestamp.date*msecsperday);
  1918. end ;
  1919. { DecodeTime unpacks Time into four values:
  1920. Hour, Minute, Second and MilliSecond }
  1921. procedure DecodeTime(Time: TDateTime; out Hour, Minute, Second, MilliSecond: word);
  1922. Var
  1923. l : LongWord;
  1924. begin
  1925. l := DateTimeToTimeStamp(Time).Time;
  1926. Hour := l div 3600000;
  1927. l := l mod 3600000;
  1928. Minute := l div 60000;
  1929. l := l mod 60000;
  1930. Second := l div 1000;
  1931. l := l mod 1000;
  1932. MilliSecond := l;
  1933. end;
  1934. { DateTimeToSystemTime converts DateTime value to SystemTime }
  1935. procedure DateTimeToSystemTime(DateTime: TDateTime; out SystemTime: TSystemTime);
  1936. begin
  1937. DecodeDateFully(DateTime, SystemTime.Year, SystemTime.Month, SystemTime.Day,SystemTime.DayOfWeek);
  1938. DecodeTime(DateTime, SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond);
  1939. Dec(SystemTime.DayOfWeek);
  1940. end ;
  1941. { SystemTimeToDateTime converts SystemTime to a TDateTime value }
  1942. function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime;
  1943. begin
  1944. result := ComposeDateTime(DoEncodeDate(SystemTime.Year, SystemTime.Month, SystemTime.Day),
  1945. DoEncodeTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond));
  1946. end ;
  1947. function DayOfWeek(DateTime: TDateTime): integer;
  1948. begin
  1949. Result := 1 + ((Trunc(DateTime) - 1) mod 7);
  1950. If (Result<=0) then
  1951. Inc(Result,7);
  1952. end;
  1953. function Now: TDateTime;
  1954. begin
  1955. Result:=JSDateToDateTime(TJSDate.New());
  1956. end;
  1957. function Date: TDateTime;
  1958. begin
  1959. Result:=Trunc(Now);
  1960. end;
  1961. function Time: TDateTime;
  1962. begin
  1963. Result:=Now-Date;
  1964. end ;
  1965. { IncMonth increments DateTime with NumberOfMonths months,
  1966. NumberOfMonths can be less than zero }
  1967. function IncMonth(const DateTime: TDateTime; NumberOfMonths: integer = 1 ): TDateTime;
  1968. var
  1969. Year, Month, Day : word;
  1970. begin
  1971. DecodeDate(DateTime, Year, Month, Day);
  1972. IncAMonth(Year, Month, Day, NumberOfMonths);
  1973. result := ComposeDateTime(DoEncodeDate(Year, Month, Day), DateTime);
  1974. end ;
  1975. { IncAMonth is the same as IncMonth, but operates on decoded date }
  1976. procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1);
  1977. var
  1978. TempMonth, S: Integer;
  1979. begin
  1980. If NumberOfMonths>=0 then
  1981. s:=1
  1982. else
  1983. s:=-1;
  1984. inc(Year,(NumberOfMonths div 12));
  1985. TempMonth:=Month+(NumberOfMonths mod 12)-1;
  1986. if (TempMonth>11) or
  1987. (TempMonth<0) then
  1988. begin
  1989. Dec(TempMonth, S*12);
  1990. Inc(Year, S);
  1991. end;
  1992. Month:=TempMonth+1; { Months from 1 to 12 }
  1993. If (Day>MonthDays[IsLeapYear(Year)][Month]) then
  1994. Day:=MonthDays[IsLeapYear(Year)][Month];
  1995. end;
  1996. { IsLeapYear returns true if Year is a leap year }
  1997. function IsLeapYear(Year: Word): boolean;
  1998. begin
  1999. Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
  2000. end;
  2001. { DateToStr returns a string representation of Date using ShortDateFormat }
  2002. function DateToStr(Date: TDateTime): string;
  2003. begin
  2004. Result:=FormatDateTime('ddddd', Date);
  2005. end ;
  2006. { TimeToStr returns a string representation of Time using LongTimeFormat }
  2007. function TimeToStr(Time: TDateTime): string;
  2008. begin
  2009. Result:=FormatDateTime('tt',Time);
  2010. end ;
  2011. { DateTimeToStr returns a string representation of DateTime using LongDateTimeFormat }
  2012. Var
  2013. DateTimeToStrFormat : Array[Boolean] of string ;
  2014. function DateTimeToStr(DateTime: TDateTime; ForceTimeIfZero : Boolean = False): string;
  2015. begin
  2016. Result:=FormatDateTime(DateTimeToStrFormat[ForceTimeIfZero], DateTime)
  2017. end ;
  2018. { StrToDate converts the string S to a TDateTime value
  2019. if S does not represent a valid date value
  2020. an EConvertError will be raised }
  2021. function IntStrToDate(Out ErrorMsg : String; const S: String; const useformat : string; separator : char): TDateTime;
  2022. Const
  2023. WhiteSpace = ' '#8#9#10#12#13;
  2024. Digits = '0123456789';
  2025. procedure FixErrorMsg(const errmarg : String);
  2026. begin
  2027. ErrorMsg:=Format(SInvalidDateFormat,[errmarg]);
  2028. end;
  2029. var
  2030. df:string;
  2031. d,m,y,ly,ld,lm:word;
  2032. n,i,len:longint;
  2033. c: integer;
  2034. dp,mp,yp,which : Byte;
  2035. s1:string;
  2036. values: array of integer;
  2037. YearMoreThenTwoDigits : boolean;
  2038. begin
  2039. SetLength(values,4);
  2040. Result:=0;
  2041. Len:=Length(S);
  2042. ErrorMsg:='';
  2043. While (Len>0) and (Pos(S[Len],WhiteSpace)>0) do
  2044. Dec(len);
  2045. if (Len=0) then
  2046. begin
  2047. FixErrorMsg(S);
  2048. exit;
  2049. end;
  2050. YearMoreThenTwoDigits := False;
  2051. if separator = #0 then
  2052. if (DateSeparator<>#0) then
  2053. separator := DateSeparator
  2054. else
  2055. separator:='-';
  2056. // Writeln('Separator: ',Separator);
  2057. df := UpperCase(useFormat);
  2058. { Determine order of D,M,Y }
  2059. yp:=0;
  2060. mp:=0;
  2061. dp:=0;
  2062. Which:=0;
  2063. i:=0;
  2064. while (i<Length(df)) and (Which<3) do
  2065. begin
  2066. inc(i);
  2067. Case df[i] of
  2068. 'Y' :
  2069. if yp=0 then
  2070. begin
  2071. Inc(Which);
  2072. yp:=which;
  2073. end;
  2074. 'M' :
  2075. if mp=0 then
  2076. begin
  2077. Inc(Which);
  2078. mp:=which;
  2079. end;
  2080. 'D' :
  2081. if dp=0 then
  2082. begin
  2083. Inc(Which);
  2084. dp:=which;
  2085. end;
  2086. end;
  2087. end;
  2088. // Writeln('YP: ',Yp,', MP: ',Mp,', DP: ',DP);
  2089. for i := 1 to 3 do
  2090. values[i] := 0;
  2091. s1 := '';
  2092. n := 0;
  2093. for i := 1 to len do
  2094. begin
  2095. if Pos(s[i],Digits)>0 then
  2096. s1 := s1 + s[i];
  2097. { space can be part of the shortdateformat, and is defaultly in slovak
  2098. windows, therefor it shouldn't be taken as separator (unless so specified)
  2099. and ignored }
  2100. if (Separator <> ' ') and (s[i] = ' ') then
  2101. Continue;
  2102. if (s[i] = separator) or ((i = len) and (Pos(s[i],Digits)>0)) then
  2103. begin
  2104. inc(n);
  2105. if n>3 then
  2106. begin
  2107. // Writeln('More than 3 separators');
  2108. FixErrorMsg(S);
  2109. exit;
  2110. end;
  2111. // Check if the year has more then two digits (if n=yp, then we are evaluating the year.)
  2112. if (n=yp) and (length(s1)>2) then YearMoreThenTwoDigits := True;
  2113. val(s1, values[n], c);
  2114. if c<>0 then
  2115. begin
  2116. // Writeln('S1 not a number ',S1);
  2117. FixErrorMsg(s);
  2118. Exit;
  2119. end;
  2120. s1 := '';
  2121. end
  2122. else if (Pos(s[i],Digits)=0) then
  2123. begin
  2124. // Writeln('Not a number at pos ',I,' ',S[i]);
  2125. FixErrorMsg(s);
  2126. Exit;
  2127. end;
  2128. end ;
  2129. // Writeln('Which : ',Which,' N : ',N);
  2130. if (Which<3) and (N>Which) then
  2131. begin
  2132. FixErrorMsg(s);
  2133. Exit;
  2134. end;
  2135. // Fill in values.
  2136. DecodeDate(Date,Ly,LM,LD);
  2137. If N=3 then
  2138. begin
  2139. y:=values[yp];
  2140. m:=values[mp];
  2141. d:=values[dp];
  2142. end
  2143. Else
  2144. begin
  2145. Y:=ly;
  2146. If n<2 then
  2147. begin
  2148. d:=values[1];
  2149. m := LM;
  2150. end
  2151. else
  2152. If dp<mp then
  2153. begin
  2154. d:=values[1];
  2155. m:=values[2];
  2156. end
  2157. else
  2158. begin
  2159. d:=values[2];
  2160. m:=values[1];
  2161. end;
  2162. end;
  2163. if (y >= 0) and (y < 100) and not YearMoreThenTwoDigits then
  2164. begin
  2165. ly := ly - TwoDigitYearCenturyWindow;
  2166. Inc(Y, ly div 100 * 100);
  2167. if (TwoDigitYearCenturyWindow > 0) and (Y < ly) then
  2168. Inc(Y, 100);
  2169. end;
  2170. if not TryEncodeDate(y, m, d, result) then
  2171. errormsg:=SErrInvalidDate;
  2172. end;
  2173. function StrToDate(const S: String; const useformat : string; separator : char): TDateTime;
  2174. Var
  2175. MSg : String;
  2176. begin
  2177. Result:=IntStrToDate(Msg,S,useFormat,Separator);
  2178. If (Msg<>'') then
  2179. Raise EConvertError.Create(Msg);
  2180. end;
  2181. function StrToDate(const S: String; separator : char): TDateTime;
  2182. begin
  2183. result := StrToDate(S,ShortDateFormat,separator)
  2184. end;
  2185. function StrToDate(const S: String): TDateTime;
  2186. begin
  2187. result := StrToDate(S,ShortDateFormat,#0);
  2188. end;
  2189. function StrToDate(const S: String): TDateTime;
  2190. begin
  2191. result := StrToDate(S,ShortDateFormat,#0);
  2192. end;
  2193. { StrToTime converts the string S to a TDateTime value
  2194. if S does not represent a valid time value an
  2195. EConvertError will be raised }
  2196. function IntStrToTime(Out ErrorMsg : String; const S: String; Len : integer; separator : char): TDateTime;
  2197. const
  2198. AMPM_None = 0;
  2199. AMPM_AM = 1;
  2200. AMPM_PM = 2;
  2201. tiHour = 0;
  2202. tiMin = 1;
  2203. tiSec = 2;
  2204. tiMSec = 3;
  2205. type
  2206. TTimeValues = array of Word;
  2207. var
  2208. AmPm: integer;
  2209. TimeValues: TTimeValues;
  2210. function SplitElements(out TimeValues: TTimeValues; out AmPm: Integer): Boolean;
  2211. //Strict version. It does not allow #32 as Separator, it will treat it as whitespace always
  2212. const
  2213. Digits = '0123456789';
  2214. var
  2215. Cur, Offset, ElemLen, Err, TimeIndex, FirstSignificantDigit: Integer;
  2216. Value: Integer;
  2217. DigitPending, MSecPending: Boolean;
  2218. AmPmStr: String;
  2219. CurChar: Char;
  2220. I : Integer;
  2221. allowedchars : string;
  2222. begin
  2223. Result := False;
  2224. AmPm := AMPM_None; //No Am or PM in string found yet
  2225. MSecPending := False;
  2226. TimeIndex := 0; //indicating which TTimeValue must be filled next
  2227. For I:=tiHour to tiMSec do
  2228. TimeValues[i]:=0;
  2229. Cur := 1;
  2230. //skip leading blanks
  2231. While (Cur < Len) and (S[Cur] =#32) do Inc(Cur);
  2232. Offset := Cur;
  2233. //First non-blank cannot be Separator or DecimalSeparator
  2234. if (Cur > Len - 1) or (S[Cur] = Separator) or (S[Cur] = Decimalseparator) then
  2235. begin
  2236. // Writeln('Error in sep S[Cur]',S[Cur],' ',separator,' ',GetDecimalSeparator);
  2237. Exit;
  2238. end;
  2239. DigitPending := (Pos(S[Cur],Digits)>0);
  2240. While (Cur <= Len) do
  2241. begin
  2242. //writeln;
  2243. // writeln('Main While loop: Cur = ',Cur,' S[Cur] = "',S[Cur],'" Len = ',Len,' separator : ',Separator);
  2244. CurChar := S[Cur];
  2245. if Pos(CurChar,Digits)>0 then
  2246. begin//Digits
  2247. //HH, MM, SS, or Msec?
  2248. // writeln('Digit: ', CurChar);
  2249. //Digits are only allowed after starting Am/PM or at beginning of string or after Separator
  2250. //and TimeIndex must be <= tiMSec
  2251. //Uncomment "or (#32 = Separator)" and it will allllow #32 as separator
  2252. if (not (DigitPending {or (#32 = Separator)})) or (TimeIndex > tiMSec) then
  2253. begin
  2254. // Writeln('DigitPending',ElemLen);
  2255. Exit;
  2256. end;
  2257. OffSet := Cur;
  2258. if (CurChar <> '0') then FirstSignificantDigit := OffSet else FirstSignificantDigit := -1;
  2259. while (Cur < Len) and (Pos(S[Cur + 1],Digits)>0) do
  2260. begin
  2261. //Mark first Digit that is not '0'
  2262. if (FirstSignificantDigit = -1) and (S[Cur] <> '0') then FirstSignificantDigit := Cur;
  2263. Inc(Cur);
  2264. end;
  2265. if (FirstSignificantDigit = -1) then FirstSignificantDigit := Cur;
  2266. ElemLen := 1+ Cur - FirstSignificantDigit;
  2267. // writeln(' S[FirstSignificantDigit] = ',S[FirstSignificantDigit], ' S[Cur] = ',S[Cur],' ElemLen = ',ElemLen,' -> ', S[Offset], ElemLen);
  2268. // writeln(' Cur = ',Cur);
  2269. //this way we know that Val() will never overflow Value !
  2270. if (ElemLen <= 2) or ((ElemLen <= 3) and (TimeIndex = tiMSec) ) then
  2271. begin
  2272. Val(Copy(S,FirstSignificantDigit, ElemLen), Value, Err);
  2273. // writeln(' Value = ',Value,' HH = ',TimeValues[0],' MM = ',TimeValues[1],' SS = ',TimeValues[2],' MSec = ',Timevalues[3]);
  2274. //This is safe now, because we know Value < High(Word)
  2275. TimeValues[TimeIndex] := Value;
  2276. Inc(TimeIndex);
  2277. DigitPending := False;
  2278. end
  2279. else
  2280. begin
  2281. // Writeln('Wrong elemlen: ',ElemLen, ' timeIndex: ',timeindex);
  2282. Exit; //Value to big, so it must be a wrong timestring
  2283. end;
  2284. end//Digits
  2285. else if (CurChar = #32) then
  2286. begin
  2287. //writeln('#32');
  2288. //just skip, but we must adress this, or it will be parsed by either AM/PM or Separator
  2289. end
  2290. else if (CurChar = Separator) then
  2291. begin
  2292. // writeln('Separator ',Separator);
  2293. if DigitPending or (TimeIndex > tiSec) then
  2294. begin
  2295. // Writeln ('DigitPending ',DigitPending,' or (TimeIndex',Timeindex,' > tiSec,', tiSec,')');
  2296. Exit;
  2297. end;
  2298. DigitPending := True;
  2299. MSecPending := False;
  2300. end
  2301. else if (CurChar = DecimalSeparator) then
  2302. begin
  2303. //writeln('DecimalSeparator');
  2304. if DigitPending or MSecPending or (TimeIndex <> tiMSec) then
  2305. begin
  2306. // Writeln('DigitPending ',DigitPending,' or MSecPending ',MSecPending,' (',TimeIndex,',Timeindex, >', tiMSec,' tiSec)');
  2307. Exit;
  2308. end;
  2309. DigitPending := True;
  2310. MSecPending := True;
  2311. end
  2312. else
  2313. begin//AM/PM?
  2314. //None of the above, so this char _must_ be the start of AM/PM string
  2315. //If we already have found AM/PM or we expect a digit then then timestring must be wrong at this point
  2316. //writeln('AM/PM?');
  2317. if (AmPm <> AMPM_None) or DigitPending then
  2318. begin
  2319. // Writeln('AmPm <> AMPM_None) or DigitPending');
  2320. Exit;
  2321. end;
  2322. OffSet := Cur;
  2323. allowedchars:=DecimalSeparator+' ';
  2324. if Separator<>#0 then
  2325. allowedchars:=allowedchars+Separator;
  2326. while (Cur < Len -1) and (Pos(S[Cur + 1],AllowedChars)=0)
  2327. and (Pos(S[Cur + 1],Digits)=0) do Inc(Cur);
  2328. ElemLen := 1 + Cur - OffSet;
  2329. // writeln(' S[Offset] = ',S[1+Offset], ' S[Cur] = ',S[Cur],' ElemLen = ',ElemLen,' -> ', S[1+Offset], ElemLen);
  2330. // writeln(' Cur = ',Cur, 'S =',S);
  2331. AmPmStr := Copy(S,1+OffSet, ElemLen);
  2332. // writeln('AmPmStr = ',ampmstr,' (',length(ampmstr),')');
  2333. //We must compare to TimeAMString before hardcoded 'AM' for delphi compatibility
  2334. //Also it is perfectly legal, though insane to have TimeAMString = 'PM' and vice versa
  2335. if (CompareText(AmPmStr, TimeAMString) = 0) then AmPm := AMPM_AM
  2336. else if (CompareText(AmPmStr, TimePMString) = 0) then AmPm := AMPM_PM
  2337. else if (CompareText(AmPmStr, 'AM') = 0) then AmPm := AMPM_AM
  2338. else if (CompareText(AmPmStr, 'PM') = 0) then AmPm := AMPM_PM
  2339. else
  2340. begin
  2341. // Writeln('No timestring ',AmPmStr);
  2342. Exit; //If text does not match any of these, timestring must be wrong;
  2343. end;
  2344. //if AM/PM is at beginning of string, then a digit is mandatory after it
  2345. if (TimeIndex = tiHour) then
  2346. begin
  2347. DigitPending := True;
  2348. end
  2349. //otherwise, no more TimeValues allowed after this
  2350. else
  2351. begin
  2352. TimeIndex := tiMSec + 1;
  2353. DigitPending := False;
  2354. end;
  2355. end;//AM/PM
  2356. Inc(Cur)
  2357. end;//while
  2358. //If we arrive here, parsing the elements has been successfull
  2359. //if not at least Hours specified then input is not valid
  2360. //when am/pm is specified Hour must be <= 12 and not 0
  2361. if (TimeIndex = tiHour) or ((AmPm <> AMPM_None) and ((TimeValues[tiHour] > 12) or (TimeValues[tiHour] = 0))) or DigitPending then
  2362. Exit;
  2363. Result := True;
  2364. end;
  2365. begin
  2366. setlength(timevalues,4);
  2367. if separator = #0 then
  2368. if (TimeSeparator<>#0) then
  2369. separator := TimeSeparator
  2370. else
  2371. separator:=':';
  2372. AmPm := AMPM_None;
  2373. if not SplitElements(TimeValues, AmPm) then
  2374. begin
  2375. ErrorMsg:=Format(SErrInvalidTimeFormat,[S]);
  2376. Exit;
  2377. end;
  2378. if (AmPm=AMPM_PM) and (TimeValues[tiHour]<>12) then Inc(TimeValues[tiHour], 12)
  2379. else if (AmPm=AMPM_AM) and (TimeValues[tiHour]=12) then TimeValues[tiHour]:=0;
  2380. // Writeln( TimeValues[tiHour], TimeValues[tiMin], TimeValues[tiSec], TimeValues[tiMSec]);
  2381. if not TryEncodeTime(TimeValues[tiHour], TimeValues[tiMin], TimeValues[tiSec], TimeValues[tiMSec], result) Then
  2382. ErrorMsg:=Format(SErrInvalidTimeFormat,[S]);
  2383. end ;
  2384. function StrToTime(const s: String; separator : char): TDateTime;
  2385. Var
  2386. Msg : String;
  2387. begin
  2388. Result:=IntStrToTime(Msg,S,Length(S),Separator);
  2389. If (Msg<>'') then
  2390. Raise EConvertError.Create(Msg);
  2391. end;
  2392. function StrToTime(const s: String): TDateTime;
  2393. begin
  2394. result:= StrToTime(s, TimeSeparator);
  2395. end;
  2396. { StrToDateTime converts the string S to a TDateTime value
  2397. if S does not represent a valid date and/or time value
  2398. an EConvertError will be raised }
  2399. function SplitDateTimeStr(DateTimeStr: String; out DateStr, TimeStr: String): Integer;
  2400. { Helper function for StrToDateTime
  2401. Pre-condition
  2402. Date is before Time
  2403. If either Date or Time is omitted then see what fits best, a time or a date (issue #0020522)
  2404. Date and Time are separated by whitespace (space Tab, Linefeed or carriage return)
  2405. FS.DateSeparator can be the same as FS.TimeSeparator (issue #0020522)
  2406. If they are both #32 and TrimWhite(DateTimeStr) contains a #32 a date is assumed.
  2407. Post-condition
  2408. DateStr holds date as string or is empty
  2409. TimeStr holds time as string or is empty
  2410. Result = number of strings returned, 0 = error
  2411. }
  2412. const
  2413. WhiteSpace = #9#10#13#32;
  2414. var
  2415. p: Integer;
  2416. DummyDT: TDateTime;
  2417. begin
  2418. Result := 0;
  2419. DateStr := '';
  2420. TimeStr := '';
  2421. DateTimeStr := Trim(DateTimeStr);
  2422. if Length(DateTimeStr) = 0 then exit;
  2423. if (DateSeparator = #32) and (TimeSeparator = #32) and (Pos(#32, DateTimeStr) > 0) then
  2424. begin
  2425. DateStr:=DateTimeStr;
  2426. {
  2427. Assume a date: dd [mm [yy]].
  2428. Really fancy would be counting the number of whitespace occurrences and decide
  2429. and split accordingly
  2430. }
  2431. Exit(1);
  2432. end;
  2433. p:=1;
  2434. //find separator
  2435. if (DateSeparator<>#32) then
  2436. begin
  2437. while (p<Length(DateTimeStr)) and (not (Pos(DateTimeStr[p+1],WhiteSpace)>0)) do
  2438. Inc(p);
  2439. end
  2440. else
  2441. begin
  2442. p:=Pos(TimeSeparator, DateTimeStr);
  2443. if (p<>0) then
  2444. repeat
  2445. Dec(p);
  2446. until (p=0) or (Pos(DateTimeStr[p],WhiteSpace)>0);
  2447. end;
  2448. //Always fill DateStr, it eases the algorithm later
  2449. if (p=0) then
  2450. p:=Length(DateTimeStr);
  2451. DateStr:=Copy(DateTimeStr,1,p);
  2452. TimeStr:=Trim(Copy(DateTimeStr,p+1,100));
  2453. if (Length(TimeStr)<>0) then
  2454. Result:=2
  2455. else
  2456. begin
  2457. Result:=1; //found 1 string
  2458. // 2 cases when DateTimeStr only contains a time:
  2459. // Date/time separator differ, and string contains a timeseparator
  2460. // Date/time separators are equal, but transformation to date fails.
  2461. if ((DateSeparator<>TimeSeparator) and (Pos(TimeSeparator,DateStr) > 0))
  2462. or ((DateSeparator=TimeSeparator) and (not TryStrToDate(DateStr, DummyDT))) then
  2463. begin
  2464. TimeStr := DateStr;
  2465. DateStr := '';
  2466. end;
  2467. end;
  2468. end;
  2469. function StrToDateTime(const s: String): TDateTime;
  2470. var
  2471. TimeStr, DateStr: String;
  2472. PartsFound: Integer;
  2473. begin
  2474. PartsFound := SplitDateTimeStr(S, DateStr, TimeStr);
  2475. case PartsFound of
  2476. 0: Result:=StrToDate('');
  2477. 1: if (Length(DateStr) > 0) then
  2478. Result := StrToDate(DateStr,ShortDateFormat,DateSeparator)
  2479. else
  2480. Result := StrToTime(TimeStr);
  2481. 2: Result := ComposeDateTime(StrTodate(DateStr,ShortDateFormat,DateSeparator),
  2482. StrToTime(TimeStr));
  2483. end;
  2484. end;
  2485. Function FormatDateTime(const FormatStr: string; const DateTime: TDateTime) : String;
  2486. procedure StoreStr(APos,Len: Integer);
  2487. begin
  2488. // Writeln('StoreStr: ',Result,'+',Copy(FormatStr,APos,Len));
  2489. Result:=Result+Copy(FormatStr,APos,Len);
  2490. end;
  2491. procedure StoreString(const AStr: string);
  2492. begin
  2493. // Writeln('StoreString: ',Result,'+',AStr);
  2494. Result:=Result+AStr;
  2495. end;
  2496. procedure StoreInt(Value, Digits: Integer);
  2497. var
  2498. S: string;
  2499. begin
  2500. S:=IntToStr(Value);
  2501. While (Length(S)<Digits) do
  2502. S:='0'+S;
  2503. StoreString(S);
  2504. end;
  2505. var
  2506. Year, Month, Day, DayOfWeek, Hour, Minute, Second, MilliSecond: word;
  2507. procedure StoreFormat(const FormatStr: string; Nesting: Integer; TimeFlag: Boolean);
  2508. var
  2509. Token, lastformattoken, prevlasttoken: char;
  2510. Count: integer;
  2511. Clock12: boolean;
  2512. tmp: integer;
  2513. isInterval: Boolean;
  2514. P,FormatCurrent,FormatEnd : Integer;
  2515. begin
  2516. if Nesting > 1 then // 0 is original string, 1 is included FormatString
  2517. Exit;
  2518. FormatCurrent := 1;
  2519. FormatEnd := Length(FormatStr);
  2520. Clock12 := false;
  2521. isInterval := false;
  2522. // look for unquoted 12-hour clock token
  2523. P:=1;
  2524. while P<=FormatEnd do
  2525. begin
  2526. Token := FormatStr[P];
  2527. case Token of
  2528. '''', '"':
  2529. begin
  2530. Inc(P);
  2531. while (P < FormatEnd) and (FormatStr[P]<>Token) do
  2532. Inc(P);
  2533. end;
  2534. 'A', 'a':
  2535. begin
  2536. if (CompareText(Copy(FormatStr,P,3),'A/P')=0) or
  2537. (CompareText(Copy(FormatStr,P,4),'AMPM')=0) or
  2538. (CompareText(Copy(FormatStr,P,5),'AM/PM')=0) then
  2539. begin
  2540. Clock12 := true;
  2541. break;
  2542. end;
  2543. end;
  2544. end; // case
  2545. Inc(P);
  2546. end ;
  2547. token := #255;
  2548. lastformattoken := ' ';
  2549. prevlasttoken := 'H';
  2550. while FormatCurrent <= FormatEnd do
  2551. begin
  2552. Token := UpperCase(FormatStr[FormatCurrent])[1];
  2553. // Writeln('Treating token at pos ',FormatCurrent,', : ',Token,' (',FormatStr,')');
  2554. Count := 1;
  2555. P := FormatCurrent + 1;
  2556. case Token of
  2557. '''', '"':
  2558. begin
  2559. while (P < FormatEnd) and (FormatStr[P]<>Token) do
  2560. Inc(P);
  2561. Inc(P);
  2562. Count := P - FormatCurrent;
  2563. StoreStr(FormatCurrent + 1, Count - 2);
  2564. end ;
  2565. 'A':
  2566. begin
  2567. if CompareText(Copy(FormatStr,FormatCurrent,4), 'AMPM') = 0 then
  2568. begin
  2569. Count := 4;
  2570. if Hour < 12 then
  2571. StoreString(TimeAMString)
  2572. else
  2573. StoreString(TimePMString);
  2574. end
  2575. else if CompareText(Copy(FormatStr,FormatCurrent,5), 'AM/PM') = 0 then
  2576. begin
  2577. Count := 5;
  2578. if Hour < 12 then StoreStr(FormatCurrent, 2)
  2579. else StoreStr(FormatCurrent+3, 2);
  2580. end
  2581. else if CompareText(Copy(FormatStr,FormatCurrent,3), 'A/P') = 0 then
  2582. begin
  2583. Count := 3;
  2584. if Hour < 12 then StoreStr(FormatCurrent, 1)
  2585. else StoreStr(FormatCurrent+2, 1);
  2586. end
  2587. else
  2588. raise EConvertError.Create('Illegal character in format string');
  2589. end ;
  2590. '/':
  2591. begin
  2592. // Writeln('Detected date separator');
  2593. StoreString(DateSeparator);
  2594. end;
  2595. ':': StoreString(TimeSeparator);
  2596. ' ', 'C', 'D', 'H', 'M', 'N', 'S', 'T', 'Y', 'Z', 'F' :
  2597. begin
  2598. // Writeln(FormatCurrent,' Special Token: ',Token,', Count: ',Count,', P: ',P);
  2599. while (P <= FormatEnd) and (UpperCase(FormatStr[P]) = Token) do
  2600. Inc(P);
  2601. Count := P - FormatCurrent;
  2602. // Writeln(FormatCurrent,' Special Token: ',Token,', Count: ',Count,', P: ',P);
  2603. case Token of
  2604. ' ': StoreStr(FormatCurrent, Count);
  2605. 'Y': begin
  2606. if Count > 2 then
  2607. StoreInt(Year, 4)
  2608. else
  2609. StoreInt(Year mod 100, 2);
  2610. end;
  2611. 'M': begin
  2612. if isInterval and ((prevlasttoken = 'H') or TimeFlag) then
  2613. StoreInt(Minute + (Hour + trunc(abs(DateTime))*24)*60, 0)
  2614. else
  2615. if (lastformattoken = 'H') or TimeFlag then
  2616. begin
  2617. if Count = 1 then
  2618. StoreInt(Minute, 0)
  2619. else
  2620. StoreInt(Minute, 2);
  2621. end
  2622. else
  2623. begin
  2624. case Count of
  2625. 1: StoreInt(Month, 0);
  2626. 2: StoreInt(Month, 2);
  2627. 3: StoreString(ShortMonthNames[Month]);
  2628. else
  2629. StoreString(LongMonthNames[Month]);
  2630. end;
  2631. end;
  2632. end;
  2633. 'D': begin
  2634. case Count of
  2635. 1: StoreInt(Day, 0);
  2636. 2: StoreInt(Day, 2);
  2637. 3: StoreString(ShortDayNames[DayOfWeek]);
  2638. 4: StoreString(LongDayNames[DayOfWeek]);
  2639. 5: StoreFormat(ShortDateFormat, Nesting+1, False);
  2640. else
  2641. StoreFormat(LongDateFormat, Nesting+1, False);
  2642. end ;
  2643. end ;
  2644. 'H':
  2645. if isInterval then
  2646. StoreInt(Hour + trunc(abs(DateTime))*24, 0)
  2647. else
  2648. if Clock12 then
  2649. begin
  2650. tmp := hour mod 12;
  2651. if tmp=0 then tmp:=12;
  2652. if Count = 1 then
  2653. StoreInt(tmp, 0)
  2654. else
  2655. StoreInt(tmp, 2);
  2656. end
  2657. else begin
  2658. if Count = 1 then
  2659. StoreInt(Hour, 0)
  2660. else
  2661. StoreInt(Hour, 2);
  2662. end;
  2663. 'N': if isInterval then
  2664. StoreInt(Minute + (Hour + trunc(abs(DateTime))*24)*60, 0)
  2665. else
  2666. if Count = 1 then
  2667. StoreInt(Minute, 0)
  2668. else
  2669. StoreInt(Minute, 2);
  2670. 'S': if isInterval then
  2671. StoreInt(Second + (Minute + (Hour + trunc(abs(DateTime))*24)*60)*60, 0)
  2672. else
  2673. if Count = 1 then
  2674. StoreInt(Second, 0)
  2675. else
  2676. StoreInt(Second, 2);
  2677. 'Z': if Count = 1 then
  2678. StoreInt(MilliSecond, 0)
  2679. else
  2680. StoreInt(MilliSecond, 3);
  2681. 'T': if Count = 1 then
  2682. StoreFormat(ShortTimeFormat, Nesting+1, True)
  2683. else
  2684. StoreFormat(LongTimeFormat, Nesting+1, True);
  2685. 'C': begin
  2686. StoreFormat(ShortDateFormat, Nesting+1, False);
  2687. if (Hour<>0) or (Minute<>0) or (Second<>0) then
  2688. begin
  2689. StoreString(' ');
  2690. StoreFormat(LongTimeFormat, Nesting+1, True);
  2691. end;
  2692. end;
  2693. 'F': begin
  2694. StoreFormat(ShortDateFormat, Nesting+1, False);
  2695. StoreString(' ');
  2696. StoreFormat(LongTimeFormat, Nesting+1, True);
  2697. end;
  2698. end;
  2699. prevlasttoken := lastformattoken;
  2700. lastformattoken := token;
  2701. end;
  2702. else
  2703. StoreString(Token);
  2704. end ;
  2705. Inc(FormatCurrent, Count);
  2706. end;
  2707. end;
  2708. begin
  2709. DecodeDateFully(DateTime, Year, Month, Day, DayOfWeek);
  2710. DecodeTime(DateTime, Hour, Minute, Second, MilliSecond);
  2711. // Writeln(DateTime,'->',Year,',', Month, ',',Day, ',',DayOfWeek,',',Hour, ',',Minute, ',',Second, ',',MilliSecond);
  2712. if FormatStr <> '' then
  2713. StoreFormat(FormatStr, 0, False)
  2714. else
  2715. StoreFormat('C', 0, False);
  2716. end ;
  2717. function CurrentYear: Word;
  2718. begin
  2719. Result:=TJSDate.New().FullYear;
  2720. end;
  2721. function TryStrToDate(const S: String; out Value: TDateTime): Boolean;
  2722. begin
  2723. result := TryStrToDate(S, Value, #0);
  2724. end;
  2725. function TryStrToDate(const S: String; out Value: TDateTime;
  2726. const useformat : string; separator : char = #0): Boolean;
  2727. Var
  2728. Msg : String;
  2729. begin
  2730. Result:=Length(S)<>0;
  2731. If Result then
  2732. begin
  2733. Value:=IntStrToDate(Msg,S,useformat,Separator);
  2734. Result:=(Msg='');
  2735. end;
  2736. end;
  2737. function TryStrToDate(const S: String; out Value: TDateTime): Boolean;
  2738. begin
  2739. Result:=TryStrToDate(S,Value,ShortDateFormat,#0);
  2740. end;
  2741. function TryStrToDate(const S: String; out Value: TDateTime; separator : char): Boolean;
  2742. begin
  2743. Result:=TryStrToDate(S,Value,ShortDateFormat,Separator);
  2744. end;
  2745. function TryStrToTime(const S: String; out Value: TDateTime; separator : char): Boolean;
  2746. Var
  2747. Msg : String;
  2748. begin
  2749. Result:=Length(S)<>0;
  2750. If Result then
  2751. begin
  2752. Value:=IntStrToTime(Msg,S,Length(S),Separator);
  2753. Result:=(Msg='');
  2754. end;
  2755. end;
  2756. function TryStrToTime(const S: String; out Value: TDateTime): Boolean;
  2757. begin
  2758. result:=TryStrToTime(S,Value,#0);
  2759. end;
  2760. function TryStrToDateTime(const S: String; out Value: TDateTime): Boolean;
  2761. var
  2762. I: integer;
  2763. dtdate, dttime :TDateTime;
  2764. begin
  2765. result:=false;
  2766. I:=Pos(TimeSeparator,S);
  2767. If (I>0) then
  2768. begin
  2769. While (I>0) and (S[I]<>' ') do
  2770. Dec(I);
  2771. If I>0 then
  2772. begin
  2773. if not TryStrToDate(Copy(S,1,I-1),dtdate) then
  2774. exit;
  2775. if not TryStrToTime(Copy(S,i+1, Length(S)-i),dttime) then
  2776. exit;
  2777. Value:=ComposeDateTime(dtdate,dttime);
  2778. result:=true;
  2779. end
  2780. else
  2781. result:=TryStrToTime(s,Value);
  2782. end
  2783. else
  2784. result:=TryStrToDate(s,Value);
  2785. end;
  2786. function StrToDateDef(const S: String; const Defvalue : TDateTime): TDateTime;
  2787. begin
  2788. result := StrToDateDef(S,DefValue,#0);
  2789. end;
  2790. function StrToTimeDef(const S: String; const Defvalue : TDateTime): TDateTime;
  2791. begin
  2792. result := StrToTimeDef(S,DefValue,#0);
  2793. end;
  2794. function StrToDateTimeDef(const S: String; const Defvalue : TDateTime): TDateTime;
  2795. begin
  2796. if not TryStrToDateTime(s,Result) Then
  2797. result:=defvalue;
  2798. end;
  2799. function StrToDateDef(const S: String; const Defvalue : TDateTime; separator : char): TDateTime;
  2800. begin
  2801. if not TryStrToDate(s,Result, separator) Then
  2802. result:=defvalue;
  2803. end;
  2804. function StrToTimeDef(const S: String; const Defvalue : TDateTime; separator : char): TDateTime;
  2805. begin
  2806. if not TryStrToTime(s,Result, separator) Then
  2807. result:=defvalue;
  2808. end;
  2809. procedure ReplaceTime(var dati:TDateTime; NewTime : TDateTime);
  2810. begin
  2811. dati:= ComposeDateTime(dati, newtime);
  2812. end;
  2813. procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime);
  2814. var
  2815. tmp : TDateTime;
  2816. begin
  2817. tmp:=NewDate;
  2818. ReplaceTime(tmp,DateTime);
  2819. DateTime:=tmp;
  2820. end;
  2821. Function FloatToDateTime (Const Value : Extended) : TDateTime;
  2822. begin
  2823. If (Value<MinDateTime) or (Value>MaxDateTime) then
  2824. Raise EConvertError.CreateFmt (SInvalidDateTime,[FloatToStr(Value)]);
  2825. Result:=Value;
  2826. end;
  2827. { ---------------------------------------------------------------------
  2828. Integer/Ordinal related
  2829. ---------------------------------------------------------------------}
  2830. Function TryStrToInt(const S : String; Out res : Integer) : Boolean;
  2831. Var
  2832. NI : NativeInt;
  2833. begin
  2834. Result:=TryStrToInt(S,NI);
  2835. if Result then
  2836. res:=NI;
  2837. end;
  2838. Function TryStrToInt(const S : String; Out res : NativeInt) : Boolean;
  2839. Var
  2840. Radix : Integer = 10;
  2841. F,N : String;
  2842. J : JSValue;
  2843. begin
  2844. N:=S;
  2845. F:=Copy(N,1,1);
  2846. if (F='$') then
  2847. Radix:=16
  2848. else if (F='&') then
  2849. Radix:=8
  2850. else if (F='%') then
  2851. Radix:=2;
  2852. If Radix<>10 then
  2853. Delete(N,1,1);
  2854. J:=parseInt(N,Radix);
  2855. Result:=Not jsIsNan(j);
  2856. if Result then
  2857. res:=NativeInt(J);
  2858. end;
  2859. Function StrToIntDef(const S : String; Const aDef : Integer) : Integer;
  2860. Var
  2861. R : NativeInt;
  2862. begin
  2863. if TryStrToInt(S,R) then
  2864. Result:=R
  2865. else
  2866. Result:=aDef;
  2867. end;
  2868. Function StrToIntDef(const S : String; Const aDef : NativeInt) : NativeInt;
  2869. Var
  2870. R : NativeInt;
  2871. begin
  2872. if TryStrToInt(S,R) then
  2873. Result:=R
  2874. else
  2875. Result:=aDef;
  2876. end;
  2877. Function StrToInt(const S : String) : Integer;
  2878. Var
  2879. R : NativeInt;
  2880. begin
  2881. if not TryStrToInt(S,R) then
  2882. Raise EConvertError.CreateFmt(SErrInvalidInteger,[S]);
  2883. Result:=R;
  2884. end;
  2885. Function StrToNativeInt(const S : String) : NativeInt;
  2886. begin
  2887. if not TryStrToInt(S,Result) then
  2888. Raise EConvertError.CreateFmt(SErrInvalidInteger,[S]);
  2889. end;
  2890. Function StrToInt64(const S : String) : NativeLargeInt;
  2891. Var
  2892. N : NativeInt;
  2893. begin
  2894. if not TryStrToInt(S,N) then
  2895. Raise EConvertError.CreateFmt(SErrInvalidInteger,[S]);
  2896. Result:=N;
  2897. end;
  2898. Function TryStrToInt64(const S : String; Out res : NativeLargeInt) : Boolean;
  2899. Var
  2900. R : nativeint;
  2901. begin
  2902. Result:=TryStrToInt(S,R);
  2903. If Result then
  2904. Res:=R;
  2905. end;
  2906. Function StrToInt64Def(const S : String; ADefault : NativeLargeInt) : NativeLargeInt;
  2907. begin
  2908. if TryStrToInt64(S,Result) then
  2909. Result:=ADefault;
  2910. end;
  2911. Function StrToQWord(const S : String) : NativeLargeUInt;
  2912. Var
  2913. N : NativeInt;
  2914. begin
  2915. if (not TryStrToInt(S,N)) or (N<0) then
  2916. Raise EConvertError.CreateFmt(SErrInvalidInteger,[S]);
  2917. Result:=N;
  2918. end;
  2919. Function TryStrToQWord(const S : String; Out res : NativeLargeUInt) : Boolean;
  2920. Var
  2921. R : nativeint;
  2922. begin
  2923. Result:=TryStrToInt(S,R) and (R>=0);
  2924. If Result then
  2925. Res:=R;
  2926. end;
  2927. Function StrToQWordDef(const S : String; ADefault : NativeLargeUInt) : NativeLargeUInt;
  2928. begin
  2929. if Not TryStrToQword(S,Result) then
  2930. Result:=ADefault;
  2931. end;
  2932. Function StrToUInt64(const S : String) : NativeLargeUInt;
  2933. Var
  2934. N : NativeInt;
  2935. begin
  2936. if (not TryStrToInt(S,N)) or (N<0) then
  2937. Raise EConvertError.CreateFmt(SErrInvalidInteger,[S]);
  2938. Result:=N;
  2939. end;
  2940. Function TryStrToUInt64(const S : String; Out res : NativeLargeUInt) : Boolean;
  2941. Var
  2942. R : nativeint;
  2943. begin
  2944. Result:=TryStrToInt(S,R) and (R>=0);
  2945. If Result then
  2946. Res:=R;
  2947. end;
  2948. Function StrToUInt64Def(const S : String; ADefault : NativeLargeUInt) : NativeLargeUInt;
  2949. begin
  2950. if Not TryStrToUInt64(S,Result) then
  2951. Result:=ADefault;
  2952. end;
  2953. Function TryStrToDWord(const S : String; Out res : DWord) : Boolean;
  2954. Var
  2955. R : nativeint;
  2956. begin
  2957. Result:=TryStrToInt(S,R) and (R>=0) and (R<=DWord($FFFFFFFF));
  2958. If Result then
  2959. Res:=R;
  2960. end;
  2961. Function StrToDWord(const S : String) : DWord;
  2962. begin
  2963. if not TryStrToDWord(S,Result) then
  2964. Raise EConvertError.CreateFmt(SErrInvalidInteger,[S]);
  2965. end;
  2966. Function StrToDWordDef(const S : String; ADefault : DWord) : DWord;
  2967. begin
  2968. if Not TryStrToDWord(S,Result) then
  2969. Result:=ADefault;
  2970. end;
  2971. function IntToHex(Value: NativeInt; Digits: integer): string;
  2972. const
  2973. HexDigits = '0123456789ABCDEF';
  2974. begin
  2975. If Digits=0 then
  2976. Digits:=1;
  2977. Result:='';
  2978. While Value>0 do
  2979. begin
  2980. result:=HexDigits[(value and 15)+1]+Result;
  2981. value := value shr 4;
  2982. end ;
  2983. while (Length(Result)<Digits) do
  2984. Result:='0'+Result;
  2985. end;
  2986. initialization
  2987. LongDayNames[0]:='Sunday';
  2988. LongDayNames[1]:='Monday';
  2989. LongDayNames[2]:='Tuesday';
  2990. LongDayNames[3]:='Wednesday';
  2991. LongDayNames[4]:='Thursday';
  2992. LongDayNames[5]:='Friday';
  2993. LongDayNames[6]:='Saturday';
  2994. ShortDayNames[0]:='Sun';
  2995. ShortDayNames[1]:='Mon';
  2996. ShortDayNames[2]:='Tue';
  2997. ShortDayNames[3]:='Wed';
  2998. ShortDayNames[4]:='Thu';
  2999. ShortDayNames[5]:='Fri';
  3000. ShortDayNames[6]:='Sat';
  3001. ShortMonthNames[1]:='Jan';
  3002. ShortMonthNames[2]:='Feb';
  3003. ShortMonthNames[3]:='Mar';
  3004. ShortMonthNames[4]:='Apr';
  3005. ShortMonthNames[5]:='May';
  3006. ShortMonthNames[6]:='Jun';
  3007. ShortMonthNames[7]:='Jul';
  3008. ShortMonthNames[8]:='Aug';
  3009. ShortMonthNames[9]:='Sep';
  3010. ShortMonthNames[10]:='Oct';
  3011. ShortMonthNames[11]:='Nov';
  3012. ShortMonthNames[12]:='Dec';
  3013. LongMonthNames[1]:='January';
  3014. LongMonthNames[2]:='February';
  3015. LongMonthNames[3]:='March';
  3016. LongMonthNames[4]:='April';
  3017. LongMonthNames[5]:='May';
  3018. LongMonthNames[6]:='June';
  3019. LongMonthNames[7]:='July';
  3020. LongMonthNames[8]:='August';
  3021. LongMonthNames[9]:='September';
  3022. LongMonthNames[10]:='October';
  3023. LongMonthNames[11]:='November';
  3024. LongMonthNames[12]:='December';
  3025. MonthDays[True][1]:=31;
  3026. MonthDays[True][2]:=29;
  3027. MonthDays[True][3]:=31;
  3028. MonthDays[True][4]:=30;
  3029. MonthDays[True][5]:=31;
  3030. MonthDays[True][6]:=30;
  3031. MonthDays[True][7]:=31;
  3032. MonthDays[True][8]:=31;
  3033. MonthDays[True][9]:=30;
  3034. MonthDays[True][10]:=31;
  3035. MonthDays[True][11]:=30;
  3036. MonthDays[True][12]:=31;
  3037. MonthDays[False][1]:=31;
  3038. MonthDays[False][2]:=28;
  3039. MonthDays[False][3]:=31;
  3040. MonthDays[False][4]:=30;
  3041. MonthDays[False][5]:=31;
  3042. MonthDays[False][6]:=30;
  3043. MonthDays[False][7]:=31;
  3044. MonthDays[False][8]:=31;
  3045. MonthDays[False][9]:=30;
  3046. MonthDays[False][10]:=31;
  3047. MonthDays[False][11]:=30;
  3048. MonthDays[False][12]:=31;
  3049. DateTimeToStrFormat[False]:='c';
  3050. DateTimeToStrFormat[True]:='f';
  3051. RTLEInvalidCast:=EInvalidCast;
  3052. DateSeparator:='-';
  3053. TimeSeparator:=':';
  3054. ShortDateFormat:='yyyy-mm-dd';
  3055. LongDateFormat:='ddd, yyyy-mm-dd';
  3056. ShortTimeFormat:='hh:nn';
  3057. LongTimeFormat:='hh:nn:ss';
  3058. DecimalSeparator:='.';
  3059. TimeAMString := 'AM';
  3060. TimePMString := 'PM';
  3061. TwoDigitYearCenturyWindow:=50;
  3062. end.