sysutils.pp 55 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by Florian Klaempfl
  4. member of the Free Pascal development team
  5. SysUtils unit for win32
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. {$IFNDEF FPC_DOTTEDUNITS}
  13. unit SysUtils;
  14. {$ENDIF FPC_DOTTEDUNITS}
  15. interface
  16. {$MODE objfpc}
  17. {$MODESWITCH OUT}
  18. {$IFDEF UNICODERTL}
  19. {$MODESWITCH UNICODESTRINGS}
  20. {$ELSE}
  21. {$H+}
  22. {$ENDIF}
  23. {$modeswitch typehelpers}
  24. {$modeswitch advancedrecords}
  25. {$IFDEF FPC_DOTTEDUNITS}
  26. uses
  27. WinApi.Windows;
  28. {$ELSE FPC_DOTTEDUNITS}
  29. uses
  30. windows;
  31. {$ENDIF FPC_DOTTEDUNITS}
  32. {$DEFINE HAS_SLEEP}
  33. {$DEFINE HAS_OSERROR}
  34. {$DEFINE HAS_OSCONFIG}
  35. {$DEFINE HAS_OSUSERDIR}
  36. {$DEFINE HAS_CREATEGUID}
  37. {$DEFINE HAS_LOCALTIMEZONEOFFSET}
  38. {$DEFINE HAS_GETTICKCOUNT}
  39. {$DEFINE HAS_GETTICKCOUNT64}
  40. {$DEFINE HAS_FILEDATETIME}
  41. {$DEFINE OS_FILESETDATEBYNAME}
  42. {$DEFINE HAS_FILEGETDATETIMEINFO}
  43. {$DEFINE HAS_INVALIDHANDLE}
  44. const
  45. INVALID_HANDLE_VALUE = {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.INVALID_HANDLE_VALUE;
  46. // this target has an fileflush implementation, don't include dummy
  47. {$DEFINE SYSUTILS_HAS_FILEFLUSH_IMPL}
  48. { used OS file system APIs use unicodestring }
  49. {$define SYSUTILS_HAS_UNICODESTR_FILEUTIL_IMPL}
  50. { OS has an ansistring/single byte environment variable API }
  51. {$define SYSUTILS_HAS_ANSISTR_ENVVAR_IMPL}
  52. { OS has a unicodestring/two byte environment variable API }
  53. {$define SYSUTILS_HAS_UNICODESTR_ENVVAR_IMPL}
  54. { Include platform independent interface part }
  55. {$i sysutilh.inc}
  56. type
  57. TSystemTime = {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.TSystemTime;
  58. EWin32Error = class(Exception)
  59. public
  60. ErrorCode : DWORD;
  61. end;
  62. Var
  63. Win32Platform : Longint;
  64. Win32MajorVersion,
  65. Win32MinorVersion,
  66. Win32BuildNumber : dword;
  67. Win32CSDVersion : ShortString; // CSD record is 128 bytes only?
  68. const
  69. MaxEraCount = 7;
  70. var
  71. EraNames: array [1..MaxEraCount] of String;
  72. EraYearOffsets: array [1..MaxEraCount] of Integer;
  73. { Compatibility with Delphi }
  74. function Win32Check(res:boolean):boolean;inline;
  75. function WinCheck(res:boolean):boolean;
  76. function CheckWin32Version(Major,Minor : Integer ): Boolean;
  77. function CheckWin32Version(Major : Integer): Boolean;
  78. Procedure RaiseLastWin32Error;
  79. function GetFileVersion(const AFileName: Ansistring): Cardinal;
  80. function GetFileVersion(const AFileName: UnicodeString): Cardinal;
  81. procedure GetFormatSettings;
  82. procedure GetLocaleFormatSettings(LCID: Integer; var FormatSettings: TFormatSettings); platform;
  83. implementation
  84. {$IFDEF FPC_DOTTEDUNITS}
  85. uses
  86. System.SysConst,
  87. WinApi.WinDirs;
  88. {$ELSE FPC_DOTTEDUNITS}
  89. uses
  90. sysconst,
  91. windirs;
  92. {$ENDIF FPC_DOTTEDUNITS}
  93. var
  94. FindExInfoDefaults : TFINDEX_INFO_LEVELS = FindExInfoStandard;
  95. FindFirstAdditionalFlags : DWord = 0;
  96. function WinCheck(res:boolean):boolean;
  97. begin
  98. if not res then
  99. RaiseLastOSError;
  100. result:=res;
  101. end;
  102. function Win32Check(res:boolean):boolean;inline;
  103. begin
  104. result:=WinCheck(res);
  105. end;
  106. procedure RaiseLastWin32Error;
  107. begin
  108. RaiseLastOSError;
  109. end;
  110. function CheckWin32Version(Major : Integer): Boolean;
  111. begin
  112. Result:=CheckWin32Version(Major,0)
  113. end;
  114. function CheckWin32Version(Major,Minor: Integer): Boolean;
  115. begin
  116. Result:=(Win32MajorVersion>dword(Major)) or
  117. ((Win32MajorVersion=dword(Major)) and (Win32MinorVersion>=dword(Minor)));
  118. end;
  119. function GetFileVersion(const AFileName:Ansistring):Cardinal;
  120. var
  121. { useful only as long as we don't need to touch different stack pages }
  122. buf : array[0..3071] of byte;
  123. bufp : pointer;
  124. valsize,
  125. size : DWORD;
  126. valrec : PVSFixedFileInfo;
  127. begin
  128. result:=$fffffff;
  129. size:=GetFileVersionInfoSizeA(PAnsiChar(AFileName),nil);
  130. bufp:=@buf;
  131. if size>sizeof(buf) then
  132. bufp:=getmem(size);
  133. if GetFileVersionInfoA(PAnsiChar(AFileName),0,size,bufp) then
  134. if VerQueryValue(bufp,'\',valrec,valsize) then
  135. result:=valrec^.dwFileVersionMS;
  136. if bufp<>@buf then
  137. freemem(bufp);
  138. end;
  139. function GetFileVersion(const AFileName:UnicodeString):Cardinal;
  140. var
  141. { useful only as long as we don't need to touch different stack pages }
  142. buf : array[0..3071] of byte;
  143. bufp : pointer;
  144. valsize,
  145. size : DWORD;
  146. valrec : PVSFixedFileInfo;
  147. begin
  148. result:=$fffffff;
  149. size:=GetFileVersionInfoSizeW(PUnicodeChar(AFileName),nil);
  150. bufp:=@buf;
  151. if size>sizeof(buf) then
  152. bufp:=getmem(size);
  153. if GetFileVersionInfoW(PUnicodeChar(AFileName),0,size,bufp) then
  154. if VerQueryValue(bufp,'\',valrec,valsize) then
  155. result:=valrec^.dwFileVersionMS;
  156. if bufp<>@buf then
  157. freemem(bufp);
  158. end;
  159. {$define HASCREATEGUID}
  160. {$define HASEXPANDUNCFILENAME}
  161. {$DEFINE FPC_NOGENERICANSIROUTINES}
  162. {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
  163. {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
  164. function ConvertEraYearString(Count ,Year,Month,Day : integer) : string; forward;
  165. function ConvertEraString(Count ,Year,Month,Day : integer) : string; forward;
  166. { Include platform independent implementation part }
  167. {$i sysutils.inc}
  168. function GetTempFileName(Dir,Prefix: PAnsiChar; uUnique: DWORD; TempFileName: PAnsiChar):DWORD;
  169. begin
  170. Result:= {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.GetTempFileNameA(Dir,Prefix,uUnique,TempFileName);
  171. end;
  172. { UUID generation. }
  173. function CoCreateGuid(out guid: TGUID): HResult; stdcall; external 'ole32.dll' name 'CoCreateGuid';
  174. function SysCreateGUID(out Guid: TGUID): Integer;
  175. begin
  176. Result := Integer(CoCreateGuid(Guid));
  177. end;
  178. function ExpandUNCFileName (const filename:rawbytestring) : rawbytestring;
  179. { returns empty string on errors }
  180. var
  181. u: unicodestring;
  182. begin
  183. { prevent data loss due to unsupported characters in ansi code page }
  184. u:=ExpandUNCFileName(unicodestring(filename));
  185. widestringmanager.Unicode2AnsiMoveProc(punicodechar(u),result,DefaultRTLFileSystemCodePage,length(u));
  186. end;
  187. function ExpandUNCFileName (const filename:unicodestring) : unicodestring;
  188. { returns empty string on errors }
  189. var
  190. s : unicodestring;
  191. size : dword;
  192. rc : dword;
  193. buf : pwidechar;
  194. begin
  195. s := ExpandFileName (filename);
  196. s := s + #0;
  197. size := max_path;
  198. getmem(buf,size);
  199. try
  200. rc := WNetGetUniversalNameW (pwidechar(s), UNIVERSAL_NAME_INFO_LEVEL, buf, @size);
  201. if rc=ERROR_MORE_DATA then
  202. begin
  203. buf:=reallocmem(buf,size);
  204. rc := WNetGetUniversalNameW (pwidechar(s), UNIVERSAL_NAME_INFO_LEVEL, buf, @size);
  205. end;
  206. if rc = NO_ERROR then
  207. Result := PRemoteNameInfoW(buf)^.lpUniversalName
  208. else if rc = ERROR_NOT_CONNECTED then
  209. Result := filename
  210. else
  211. Result := '';
  212. finally
  213. freemem(buf);
  214. end;
  215. end;
  216. {****************************************************************************
  217. File Functions
  218. ****************************************************************************}
  219. const
  220. AccessMode: array[0..2] of Cardinal = (
  221. GENERIC_READ,
  222. GENERIC_WRITE,
  223. GENERIC_READ or GENERIC_WRITE or FILE_WRITE_ATTRIBUTES);
  224. ShareModes: array[0..4] of Integer = (
  225. 0,
  226. 0,
  227. FILE_SHARE_READ,
  228. FILE_SHARE_WRITE,
  229. FILE_SHARE_READ or FILE_SHARE_WRITE);
  230. function FileFlush(Handle: THandle): Boolean;
  231. begin
  232. Result:= FlushFileBuffers(Handle);
  233. end;
  234. Function FileOpen (Const FileName : unicodestring; Mode : Integer) : THandle;
  235. begin
  236. result := CreateFileW(PWideChar(FileName), dword(AccessMode[Mode and 3]),
  237. dword(ShareModes[(Mode and $F0) shr 4]), nil, OPEN_EXISTING,
  238. FILE_ATTRIBUTE_NORMAL, 0);
  239. //if fail api return feInvalidHandle (INVALIDE_HANDLE=feInvalidHandle=-1)
  240. end;
  241. Function FileCreate (Const FileName : UnicodeString) : THandle;
  242. begin
  243. FileCreate:=FileCreate(FileName, fmShareExclusive, 0);
  244. end;
  245. Function FileCreate (Const FileName : UnicodeString; Rights:longint) : THandle;
  246. begin
  247. FileCreate:=FileCreate(FileName, fmShareExclusive, Rights);
  248. end;
  249. Function FileCreate (Const FileName : UnicodeString; ShareMode : Integer; Rights : Integer) : THandle;
  250. begin
  251. Result := CreateFileW(PwideChar(FileName), GENERIC_READ or GENERIC_WRITE,
  252. dword(ShareModes[(ShareMode and $F0) shr 4]), nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
  253. end;
  254. Function FileRead (Handle : THandle; out Buffer; Count : longint) : Longint;
  255. Var
  256. res : dword;
  257. begin
  258. if ReadFile(Handle, Buffer, Count, res, nil) then
  259. FileRead:=Res
  260. else
  261. FileRead:=-1;
  262. end;
  263. Function FileWrite (Handle : THandle; const Buffer; Count : Longint) : Longint;
  264. Var
  265. Res : dword;
  266. begin
  267. if WriteFile(Handle, Buffer, Count, Res, nil) then
  268. FileWrite:=Res
  269. else
  270. FileWrite:=-1;
  271. end;
  272. Function FileSeek (Handle : THandle;FOffset,Origin : Longint) : Longint;
  273. begin
  274. Result := longint(SetFilePointer(Handle, FOffset, nil, Origin));
  275. end;
  276. Function FileSeek (Handle : THandle; FOffset: Int64; Origin: Longint) : Int64;
  277. var
  278. rslt: Int64Rec;
  279. begin
  280. rslt := Int64Rec(FOffset);
  281. rslt.lo := SetFilePointer(Handle, rslt.lo, @rslt.hi, Origin);
  282. if (rslt.lo = $FFFFFFFF) and (GetLastError <> 0) then
  283. rslt.hi := $FFFFFFFF;
  284. Result := Int64(rslt);
  285. end;
  286. Procedure FileClose (Handle : THandle);
  287. begin
  288. CloseHandle(Handle);
  289. end;
  290. Function FileTruncate (Handle : THandle;Size: Int64) : boolean;
  291. begin
  292. {
  293. Result:=longint(SetFilePointer(handle,Size,nil,FILE_BEGIN))<>-1;
  294. }
  295. if FileSeek (Handle, Size, FILE_BEGIN) = Size then
  296. Result:=SetEndOfFile(handle)
  297. else
  298. Result := false;
  299. end;
  300. Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):longbool;
  301. var
  302. lft : TFileTime;
  303. begin
  304. DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,@lft) and
  305. LocalFileTimeToFileTime(lft,Wtime);
  306. end;
  307. Function WinToDosTime (Var Wtime : TFileTime;var DTime:longint):longbool;
  308. var
  309. lft : TFileTime;
  310. begin
  311. WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
  312. FileTimeToDosDateTime(lft,Longrec(Dtime).Hi,LongRec(DTIME).lo);
  313. end;
  314. Function FileAge (Const FileName : UnicodeString): Int64;
  315. var
  316. Handle: THandle;
  317. FindData: TWin32FindDataW;
  318. tmpdtime : longint;
  319. begin
  320. Handle := FindFirstFileW(Pwidechar(FileName), FindData);
  321. if Handle <> INVALID_HANDLE_VALUE then
  322. begin
  323. {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.FindClose(Handle);
  324. if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
  325. If WinToDosTime(FindData.ftLastWriteTime,tmpdtime) then
  326. begin
  327. result:=tmpdtime;
  328. exit;
  329. end;
  330. end;
  331. Result := -1;
  332. end;
  333. type
  334. TSymLinkResult = (
  335. slrOk,
  336. slrNoSymLink,
  337. slrError
  338. );
  339. function FileGetSymLinkTargetInt(const FileName: UnicodeString; out SymLinkRec: TUnicodeSymLinkRec; RaiseErrorOnMissing: Boolean): TSymLinkResult;
  340. { reparse point specific declarations from Windows headers }
  341. const
  342. IO_REPARSE_TAG_MOUNT_POINT = $A0000003;
  343. IO_REPARSE_TAG_SYMLINK = $A000000C;
  344. ERROR_REPARSE_TAG_INVALID = 4393;
  345. FSCTL_GET_REPARSE_POINT = $900A8;
  346. MAXIMUM_REPARSE_DATA_BUFFER_SIZE = 16 * 1024;
  347. SYMLINK_FLAG_RELATIVE = 1;
  348. FILE_FLAG_OPEN_REPARSE_POINT = $200000;
  349. FILE_READ_EA = $8;
  350. type
  351. TReparseDataBuffer = record
  352. ReparseTag: ULONG;
  353. ReparseDataLength: Word;
  354. Reserved: Word;
  355. SubstituteNameOffset: Word;
  356. SubstituteNameLength: Word;
  357. PrintNameOffset: Word;
  358. PrintNameLength: Word;
  359. case ULONG of
  360. IO_REPARSE_TAG_MOUNT_POINT: (
  361. PathBufferMount: array[0..4095] of WCHAR);
  362. IO_REPARSE_TAG_SYMLINK: (
  363. Flags: ULONG;
  364. PathBufferSym: array[0..4095] of WCHAR);
  365. end;
  366. const
  367. CShareAny = FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE;
  368. COpenReparse = FILE_FLAG_OPEN_REPARSE_POINT or FILE_FLAG_BACKUP_SEMANTICS;
  369. CVolumePrefix = 'Volume';
  370. CGlobalPrefix = '\\?\';
  371. var
  372. HFile, Handle: THandle;
  373. PBuffer: ^TReparseDataBuffer;
  374. BytesReturned: DWORD;
  375. guid: TGUID;
  376. begin
  377. Result := slrError;
  378. SymLinkRec := Default(TUnicodeSymLinkRec);
  379. HFile := CreateFileW(PUnicodeChar(FileName), FILE_READ_EA, CShareAny, Nil, OPEN_EXISTING, COpenReparse, 0);
  380. if HFile <> INVALID_HANDLE_VALUE then
  381. try
  382. GetMem(PBuffer, MAXIMUM_REPARSE_DATA_BUFFER_SIZE);
  383. try
  384. if DeviceIoControl(HFile, FSCTL_GET_REPARSE_POINT, Nil, 0,
  385. PBuffer, MAXIMUM_REPARSE_DATA_BUFFER_SIZE, @BytesReturned, Nil) then begin
  386. case PBuffer^.ReparseTag of
  387. IO_REPARSE_TAG_MOUNT_POINT: begin
  388. SymLinkRec.TargetName := WideCharLenToString(
  389. @PBuffer^.PathBufferMount[4 { skip start '\??\' } +
  390. PBuffer^.SubstituteNameOffset div SizeOf(WCHAR)],
  391. PBuffer^.SubstituteNameLength div SizeOf(WCHAR) - 4);
  392. if (Length(SymLinkRec.TargetName) = Length(CVolumePrefix) + 2 { brackets } + 32 { guid } + 4 { - } + 1 { \ }) and
  393. (Copy(SymLinkRec.TargetName, 1, Length(CVolumePrefix)) = CVolumePrefix) and
  394. TryStringToGUID(String(Copy(SymLinkRec.TargetName, Length(CVolumePrefix) + 1, Length(SymLinkRec.TargetName) - Length(CVolumePrefix) - 1)), guid) then
  395. SymLinkRec.TargetName := CGlobalPrefix + SymLinkRec.TargetName;
  396. end;
  397. IO_REPARSE_TAG_SYMLINK: begin
  398. SymLinkRec.TargetName := WideCharLenToString(
  399. @PBuffer^.PathBufferSym[PBuffer^.PrintNameOffset div SizeOf(WCHAR)],
  400. PBuffer^.PrintNameLength div SizeOf(WCHAR));
  401. if (PBuffer^.Flags and SYMLINK_FLAG_RELATIVE) <> 0 then
  402. SymLinkRec.TargetName := ExpandFileName(ExtractFilePath(FileName) + SymLinkRec.TargetName);
  403. end;
  404. end;
  405. if SymLinkRec.TargetName <> '' then begin
  406. { the fields of WIN32_FILE_ATTRIBUTE_DATA match with the first fields of WIN32_FIND_DATA }
  407. if GetFileAttributesExW(PUnicodeChar(SymLinkRec.TargetName), GetFileExInfoStandard, @SymLinkRec.FindData) then begin
  408. SymLinkRec.Attr := SymLinkRec.FindData.dwFileAttributes;
  409. SymLinkRec.Size := QWord(SymLinkRec.FindData.nFileSizeHigh) shl 32 + QWord(SymLinkRec.FindData.nFileSizeLow);
  410. end else if RaiseErrorOnMissing then
  411. raise EDirectoryNotFoundException.Create(SysErrorMessage(GetLastOSError))
  412. else
  413. SymLinkRec.TargetName := '';
  414. end else begin
  415. SetLastError(ERROR_REPARSE_TAG_INVALID);
  416. Result := slrNoSymLink;
  417. end;
  418. end else
  419. SetLastError(ERROR_REPARSE_TAG_INVALID);
  420. finally
  421. FreeMem(PBuffer);
  422. end;
  423. finally
  424. CloseHandle(HFile);
  425. end;
  426. if SymLinkRec.TargetName <> '' then
  427. Result := slrOk
  428. end;
  429. function FileGetSymLinkTarget(const FileName: UnicodeString; out SymLinkRec: TUnicodeSymLinkRec): Boolean;
  430. begin
  431. Result := FileGetSymLinkTargetInt(FileName, SymLinkRec, False) = slrOk;
  432. end;
  433. function FileOrDirExists(const FileOrDirName: UnicodeString; CheckDir: Boolean; FollowLink: Boolean): Boolean;
  434. const
  435. CDirAttributes: array[Boolean] of DWORD = (0, FILE_ATTRIBUTE_DIRECTORY);
  436. function FoundByEnum: Boolean;
  437. var
  438. FindData: TWin32FindDataW;
  439. Handle: THandle;
  440. begin
  441. { FindFirstFileEx is faster than FindFirstFile }
  442. Handle := FindFirstFileExW(PUnicodeChar(FileOrDirName), FindExInfoDefaults , @FindData,
  443. FindExSearchNameMatch, Nil, 0);
  444. Result := Handle <> INVALID_HANDLE_VALUE;
  445. if Result then begin
  446. {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.FindClose(Handle);
  447. Result := (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = CDirAttributes[CheckDir];
  448. end;
  449. end;
  450. const
  451. CNotExistsErrors = [
  452. ERROR_FILE_NOT_FOUND,
  453. ERROR_PATH_NOT_FOUND,
  454. ERROR_INVALID_NAME, // protects from names in the form of masks like '*'
  455. ERROR_INVALID_DRIVE,
  456. ERROR_NOT_READY,
  457. ERROR_INVALID_PARAMETER,
  458. ERROR_BAD_PATHNAME,
  459. ERROR_BAD_NETPATH,
  460. ERROR_BAD_NET_NAME
  461. ];
  462. var
  463. Attr : DWord;
  464. slr : TUnicodeSymLinkRec;
  465. res : TSymLinkResult;
  466. begin
  467. Attr := GetFileAttributesW(PUnicodeChar(FileOrDirName));
  468. if Attr = INVALID_FILE_ATTRIBUTES then
  469. Result := not (GetLastError in CNotExistsErrors) and FoundByEnum
  470. else begin
  471. Result := (Attr and FILE_ATTRIBUTE_DIRECTORY) = CDirAttributes[CheckDir];
  472. if Result and FollowLink and ((Attr and FILE_ATTRIBUTE_REPARSE_POINT) <> 0) then begin
  473. res := FileGetSymLinkTargetInt(FileOrDirName, slr, False);
  474. case res of
  475. slrOk:
  476. Result := FileOrDirExists(slr.TargetName, CheckDir, False);
  477. slrNoSymLink:
  478. Result := True;
  479. else
  480. Result := False;
  481. end;
  482. end;
  483. end;
  484. end;
  485. Function FileExists (Const FileName : UnicodeString; FollowLink : Boolean) : Boolean;
  486. begin
  487. Result := FileOrDirExists(FileName, False, FollowLink);
  488. end;
  489. Function DirectoryExists (Const Directory : UnicodeString; FollowLink : Boolean) : Boolean;
  490. begin
  491. Result := FileOrDirExists(Directory, True, FollowLink);
  492. end;
  493. Function FindMatch(var f: TAbstractSearchRec; var Name: UnicodeString) : Longint;
  494. var
  495. tmpdtime : longint;
  496. begin
  497. { Find file with correct attribute }
  498. While (F.FindData.dwFileAttributes and cardinal(F.ExcludeAttr))<>0 do
  499. begin
  500. if not FindNextFileW (F.FindHandle,F.FindData) then
  501. begin
  502. Result:=GetLastError;
  503. exit;
  504. end;
  505. end;
  506. { Convert some attributes back }
  507. WinToDosTime(F.FindData.ftLastWriteTime,tmpdtime);
  508. F.Time:=tmpdtime;
  509. f.size:=F.FindData.NFileSizeLow+(qword(maxdword)+1)*F.FindData.NFileSizeHigh;
  510. f.attr:=F.FindData.dwFileAttributes;
  511. Name:=F.FindData.cFileName;
  512. Result:=0;
  513. end;
  514. Procedure InternalFindClose (var Handle: THandle; var FindData: TFindData);
  515. begin
  516. if Handle <> INVALID_HANDLE_VALUE then
  517. begin
  518. {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.FindClose(Handle);
  519. Handle:=INVALID_HANDLE_VALUE;
  520. end;
  521. end;
  522. type
  523. TGetFinalPathNameByHandle = function(aHandle : THandle; Buf : LPSTR; BufSize : DWord; Flags : DWord) : DWORD;
  524. var
  525. GetFinalPathNameByHandle:TGetFinalPathNameByHandle=nil;
  526. Const
  527. VOLUME_NAME_NT = $2;
  528. Function FollowSymlink(const aLink: String): String;
  529. Var
  530. Attrs: Cardinal;
  531. aHandle: THandle;
  532. oFlags: DWord;
  533. Buf : Array[0..Max_Path] of AnsiChar;
  534. Len : Integer;
  535. begin
  536. Result:='';
  537. FillChar(Buf,MAX_PATH+1,0);
  538. if Not FileExists(aLink,False) then
  539. exit;
  540. if not CheckWin32Version(6, 0) or not(assigned(GetFinalPathNameByHandle)) then
  541. exit;
  542. Attrs:=GetFileAttributes(PAnsiChar(aLink));
  543. if (Attrs=INVALID_FILE_ATTRIBUTES) or ((Attrs and faSymLink)=0) then
  544. exit;
  545. oFLags:=0;
  546. // https://learn.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilea
  547. if (Attrs and faDirectory)=faDirectory then
  548. oFlags:=FILE_FLAG_BACKUP_SEMANTICS;
  549. aHandle:=CreateFile(PAnsiChar(aLink),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,oFlags,0);
  550. if aHandle=INVALID_HANDLE_VALUE then
  551. exit;
  552. try
  553. Len:=GetFinalPathNameByHandle(aHandle,@Buf,MAX_PATH,VOLUME_NAME_NT);
  554. If Len<=0 then
  555. exit;
  556. Result:=StrPas(PAnsiChar(@Buf));
  557. finally
  558. CloseHandle(aHandle);
  559. end;
  560. end;
  561. Function InternalFindFirst (Const Path : UnicodeString; Attr : Longint; out Rslt : TAbstractSearchRec; var Name : UnicodeString) : Longint;
  562. begin
  563. Name:=Path;
  564. Rslt.Attr:=attr;
  565. Rslt.ExcludeAttr:=(not Attr) and ($1e);
  566. { $1e = faHidden or faSysFile or faVolumeID or faDirectory }
  567. { FindFirstFile is a Win32 Call }
  568. Rslt.FindHandle:=FindFirstFileExW(PUnicodeChar(Path), FindExInfoDefaults , @Rslt.FindData,
  569. FindExSearchNameMatch, Nil, FindFirstAdditionalFlags);
  570. If Rslt.FindHandle=Invalid_Handle_value then
  571. begin
  572. Result:=GetLastError;
  573. exit;
  574. end;
  575. { Find file with correct attribute }
  576. Result:=FindMatch(Rslt,Name);
  577. if (Result<>0) then
  578. InternalFindClose(Rslt.FindHandle,Rslt.FindData);
  579. end;
  580. Function InternalFindNext (Var Rslt : TAbstractSearchRec; var Name: UnicodeString) : Longint;
  581. begin
  582. if FindNextFileW(Rslt.FindHandle, Rslt.FindData) then
  583. Result := FindMatch(Rslt, Name)
  584. else
  585. Result := GetLastError;
  586. end;
  587. function FileGetDateTimeInfo(const FileName: string;
  588. out DateTime: TDateTimeInfoRec; FollowLink: Boolean = True): Boolean;
  589. var
  590. Data: TWin32FindDataW;
  591. FN: unicodestring;
  592. begin
  593. Result := False;
  594. SetLastError(ERROR_SUCCESS);
  595. FN:=FileName;
  596. if Not GetFileAttributesExW(PWideChar(FileName), GetFileExInfoStandard, @Data) then
  597. exit;
  598. if ((Data.dwFileAttributes and faSymlink)=faSymlink) then
  599. begin
  600. if FollowLink then
  601. begin
  602. FN:=FollowSymlink(FileName);
  603. if FN='' then
  604. exit;
  605. if not GetFileAttributesExW(PWideChar(FN), GetFileExInfoStandard, @Data) then
  606. exit;
  607. end;
  608. end;
  609. DateTime.Data:=Data;
  610. Result:=True;
  611. end;
  612. Function FileGetDate (Handle : THandle) : Int64;
  613. Var
  614. FT : TFileTime;
  615. tmpdtime : longint;
  616. begin
  617. If GetFileTime(Handle,nil,nil,@ft) and
  618. WinToDosTime(FT,tmpdtime) then
  619. begin
  620. result:=tmpdtime;
  621. exit;
  622. end;
  623. Result:=-1;
  624. end;
  625. Function FileGetDate (Handle : THandle; out FileDateTime: TDateTime) : Boolean;
  626. Var
  627. FT : TFileTime;
  628. begin
  629. Result :=
  630. GetFileTime(Handle,nil,nil,@ft) and
  631. FindDataTimeToDateTime(FT, FileDateTime);
  632. end;
  633. Function FileGetDateUTC (Handle : THandle; out FileDateTimeUTC: TDateTime) : Boolean;
  634. Var
  635. FT : TFileTime;
  636. begin
  637. Result :=
  638. GetFileTime(Handle,nil,nil,@ft) and
  639. FindDataTimeToUTC(FT, FileDateTimeUTC);
  640. end;
  641. Function FileSetDate (Handle : THandle;Age : Int64) : Longint;
  642. Var
  643. FT: TFileTime;
  644. begin
  645. Result := 0;
  646. if DosToWinTime(Age,FT) and
  647. SetFileTime(Handle, nil, nil, @FT) then
  648. Exit;
  649. Result := GetLastError;
  650. end;
  651. Function FileSetDate (Handle : THandle; const FileDateTime: TDateTime) : Longint;
  652. var
  653. FT: TFiletime;
  654. LT: TFiletime;
  655. ST: TSystemTime;
  656. begin
  657. DateTimeToSystemTime(FileDateTime,ST);
  658. if SystemTimeToFileTime(ST,LT) and LocalFileTimeToFileTime(LT,FT)
  659. and SetFileTime(Handle,nil,nil,@FT) then
  660. Result:=0
  661. else
  662. Result:=GetLastError;
  663. end;
  664. Function FileSetDateUTC (Handle : THandle; const FileDateTimeUTC: TDateTime) : Longint;
  665. var
  666. FT: TFiletime;
  667. ST: TSystemTime;
  668. begin
  669. DateTimeToSystemTime(FileDateTimeUTC,ST);
  670. if SystemTimeToFileTime(ST,FT) and SetFileTime(Handle,nil,nil,@FT) then
  671. Result:=0
  672. else
  673. Result:=GetLastError;
  674. end;
  675. {$IFDEF OS_FILESETDATEBYNAME}
  676. Function FileSetDate (Const FileName : UnicodeString;Age : Int64) : Longint;
  677. Var
  678. fd : THandle;
  679. begin
  680. FD := CreateFileW (PWideChar (FileName), GENERIC_READ or GENERIC_WRITE,
  681. FILE_SHARE_WRITE, nil, OPEN_EXISTING,
  682. FILE_FLAG_BACKUP_SEMANTICS, 0);
  683. If (Fd<>feInvalidHandle) then
  684. try
  685. Result:=FileSetDate(fd,Age);
  686. finally
  687. FileClose(fd);
  688. end
  689. else
  690. Result:=GetLastOSError;
  691. end;
  692. Function FileSetDate (Const FileName : UnicodeString;const FileDateTime : TDateTime) : Longint;
  693. Var
  694. fd : THandle;
  695. begin
  696. FD := CreateFileW (PWideChar (FileName), GENERIC_READ or GENERIC_WRITE,
  697. FILE_SHARE_WRITE, nil, OPEN_EXISTING,
  698. FILE_FLAG_BACKUP_SEMANTICS, 0);
  699. If (Fd<>feInvalidHandle) then
  700. try
  701. Result:=FileSetDate(fd,FileDateTime);
  702. finally
  703. FileClose(fd);
  704. end
  705. else
  706. Result:=GetLastOSError;
  707. end;
  708. Function FileSetDateUTC (Const FileName : UnicodeString;const FileDateTimeUTC : TDateTime) : Longint;
  709. Var
  710. fd : THandle;
  711. begin
  712. FD := CreateFileW (PWideChar (FileName), GENERIC_READ or GENERIC_WRITE,
  713. FILE_SHARE_WRITE, nil, OPEN_EXISTING,
  714. FILE_FLAG_BACKUP_SEMANTICS, 0);
  715. If (Fd<>feInvalidHandle) then
  716. try
  717. Result:=FileSetDateUTC(fd,FileDateTimeUTC);
  718. finally
  719. FileClose(fd);
  720. end
  721. else
  722. Result:=GetLastOSError;
  723. end;
  724. {$ENDIF}
  725. Function FileGetAttr (Const FileName : UnicodeString) : Longint;
  726. begin
  727. Result:=Longint(GetFileAttributesW(PWideChar(FileName)));
  728. end;
  729. Function FileSetAttr (Const Filename : UnicodeString; Attr: longint) : Longint;
  730. begin
  731. if SetFileAttributesW(PWideChar(FileName), Attr) then
  732. Result:=0
  733. else
  734. Result := GetLastError;
  735. end;
  736. Function DeleteFile (Const FileName : UnicodeString) : Boolean;
  737. begin
  738. Result:={$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.DeleteFileW(PWidechar(FileName));
  739. end;
  740. Function RenameFile (Const OldName, NewName : UnicodeString) : Boolean;
  741. begin
  742. Result := MoveFileW(PWideChar(OldName), PWideChar(NewName));
  743. end;
  744. {****************************************************************************
  745. Disk Functions
  746. ****************************************************************************}
  747. type
  748. TGetDiskFreeSpaceEx = function(drive:PAnsiChar;var availableforcaller,total,free):longbool;stdcall;
  749. var
  750. GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
  751. function diskfree(drive : byte) : int64;
  752. var
  753. disk : array[1..4] of AnsiChar;
  754. secs,bytes,
  755. free,total : dword;
  756. qwtotal,qwfree,qwcaller : int64;
  757. begin
  758. if drive=0 then
  759. begin
  760. disk[1]:='\';
  761. disk[2]:=#0;
  762. end
  763. else
  764. begin
  765. disk[1]:=chr(drive+64);
  766. disk[2]:=':';
  767. disk[3]:='\';
  768. disk[4]:=#0;
  769. end;
  770. if assigned(GetDiskFreeSpaceEx) then
  771. begin
  772. if GetDiskFreeSpaceEx(@disk[1],qwcaller,qwtotal,qwfree) then
  773. diskfree:=qwfree
  774. else
  775. diskfree:=-1;
  776. end
  777. else
  778. begin
  779. if GetDiskFreeSpace(@disk[1],secs,bytes,free,total) then
  780. diskfree:=int64(free)*secs*bytes
  781. else
  782. diskfree:=-1;
  783. end;
  784. end;
  785. function disksize(drive : byte) : int64;
  786. var
  787. disk : array[1..4] of AnsiChar;
  788. secs,bytes,
  789. free,total : dword;
  790. qwtotal,qwfree,qwcaller : int64;
  791. begin
  792. if drive=0 then
  793. begin
  794. disk[1]:='\';
  795. disk[2]:=#0;
  796. end
  797. else
  798. begin
  799. disk[1]:=chr(drive+64);
  800. disk[2]:=':';
  801. disk[3]:='\';
  802. disk[4]:=#0;
  803. end;
  804. if assigned(GetDiskFreeSpaceEx) then
  805. begin
  806. if GetDiskFreeSpaceEx(@disk[1],qwcaller,qwtotal,qwfree) then
  807. disksize:=qwtotal
  808. else
  809. disksize:=-1;
  810. end
  811. else
  812. begin
  813. if GetDiskFreeSpace(@disk[1],secs,bytes,free,total) then
  814. disksize:=int64(total)*secs*bytes
  815. else
  816. disksize:=-1;
  817. end;
  818. end;
  819. {****************************************************************************
  820. Time Functions
  821. ****************************************************************************}
  822. Procedure GetLocalTime(var SystemTime: TSystemTime);
  823. begin
  824. {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}windows.Getlocaltime(SystemTime);
  825. end;
  826. function GetUniversalTime(var SystemTime: TSystemTime): Boolean;
  827. begin
  828. {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}windows.GetSystemTime(SystemTime);
  829. Result:=True;
  830. end;
  831. function GetLocalTimeOffset: Integer;
  832. var
  833. TZInfo: TTimeZoneInformation;
  834. begin
  835. case GetTimeZoneInformation(TZInfo) of
  836. TIME_ZONE_ID_UNKNOWN:
  837. Result := TZInfo.Bias;
  838. TIME_ZONE_ID_STANDARD:
  839. Result := TZInfo.Bias + TZInfo.StandardBias;
  840. TIME_ZONE_ID_DAYLIGHT:
  841. Result := TZInfo.Bias + TZInfo.DaylightBias;
  842. else
  843. Result := 0;
  844. end;
  845. end;
  846. type
  847. TGetTimeZoneInformationForYear = function(wYear: USHORT; lpDynamicTimeZoneInformation: PDynamicTimeZoneInformation;
  848. var lpTimeZoneInformation: TTimeZoneInformation): BOOL;stdcall;
  849. var
  850. GetTimeZoneInformationForYear:TGetTimeZoneInformationForYear=nil;
  851. function GetLocalTimeOffset(const DateTime: TDateTime; const InputIsUTC: Boolean; out Offset: Integer): Boolean;
  852. var
  853. Year: Integer;
  854. const
  855. DaysPerWeek = 7;
  856. // MonthOf and YearOf are not available in SysUtils
  857. function MonthOf(const AValue: TDateTime): Word;
  858. var
  859. Y,D : Word;
  860. begin
  861. DecodeDate(AValue,Y,Result,D);
  862. end;
  863. function YearOf(const AValue: TDateTime): Word;
  864. var
  865. D,M : Word;
  866. begin
  867. DecodeDate(AValue,Result,D,M);
  868. end;
  869. function RelWeekDayToDateTime(const SysTime: TSystemTime): TDateTime;
  870. var
  871. WeekDay, IncDays: Integer;
  872. begin
  873. // get first day in month
  874. Result := EncodeDate(Year, SysTime.Month, 1);
  875. WeekDay := DayOfWeek(Result)-1;
  876. // get the correct first weekday in month
  877. IncDays := SysTime.wDayOfWeek-WeekDay;
  878. if IncDays<0 then
  879. Inc(IncDays, DaysPerWeek);
  880. // inc weeks
  881. Result := Result+IncDays+DaysPerWeek*(SysTime.Day-1);
  882. // SysTime.DayOfWeek=5 means the last one - check if we are not in the next month
  883. while (MonthOf(Result)>SysTime.Month) do
  884. Result := Result-DaysPerWeek;
  885. Result := Result+EncodeTime(SysTime.Hour, SysTime.Minute, SysTime.Second, SysTime.Millisecond);
  886. end;
  887. var
  888. TZInfo: TTimeZoneInformation;
  889. DSTStart, DSTEnd: TDateTime;
  890. begin
  891. if not Assigned(GetTimeZoneInformationForYear) then
  892. Exit(False);
  893. Year := YearOf(DateTime);
  894. TZInfo := Default(TTimeZoneInformation);
  895. if not GetTimeZoneInformationForYear(Year, nil, TZInfo) then
  896. Exit(False);
  897. if (TZInfo.StandardDate.Month>0) and (TZInfo.DaylightDate.Month>0) then
  898. begin // there is DST
  899. // DaylightDate and StandardDate are local times
  900. DSTStart := RelWeekDayToDateTime(TZInfo.DaylightDate);
  901. DSTEnd := RelWeekDayToDateTime(TZInfo.StandardDate);
  902. if InputIsUTC then
  903. begin
  904. DSTStart := DSTStart + (TZInfo.Bias+TZInfo.StandardBias)/MinsPerDay;
  905. DSTEnd := DSTEnd + (TZInfo.Bias+TZInfo.DaylightBias)/MinsPerDay;
  906. end;
  907. if (DSTStart<=DateTime) and (DateTime<DSTEnd) then
  908. Offset := TZInfo.Bias+TZInfo.DaylightBias
  909. else
  910. Offset := TZInfo.Bias+TZInfo.StandardBias;
  911. end else // no DST
  912. Offset := TZInfo.Bias;
  913. Result := True;
  914. end;
  915. function GetTickCount: LongWord;
  916. begin
  917. Result := {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.GetTickCount;
  918. end;
  919. {$IFNDEF WINCE}
  920. type
  921. TGetTickCount64 = function : QWord; stdcall;
  922. var
  923. WinGetTickCount64: TGetTickCount64 = Nil;
  924. {$ENDIF}
  925. function GetTickCount64: QWord;
  926. begin
  927. {$IFNDEF WINCE}
  928. if Assigned(WinGetTickCount64) then
  929. Exit(WinGetTickCount64());
  930. { on Vista and newer there is a GetTickCount64 implementation }
  931. if Win32MajorVersion >= 6 then begin
  932. WinGetTickCount64 := TGetTickCount64(GetProcAddress(GetModuleHandle('kernel32.dll'), 'GetTickCount64'));
  933. Result := WinGetTickCount64();
  934. end else
  935. {$ENDIF}
  936. Result := {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.GetTickCount;
  937. end;
  938. {****************************************************************************
  939. Misc Functions
  940. ****************************************************************************}
  941. procedure sysbeep;
  942. begin
  943. MessageBeep(0);
  944. end;
  945. {****************************************************************************
  946. Locale Functions
  947. ****************************************************************************}
  948. function GetLocaleStr(LID, LT: Longint; const Def: string): AnsiString;
  949. var
  950. L: Integer;
  951. Buf: unicodestring;
  952. begin
  953. L := GetLocaleInfoW(LID, LT, nil, 0);
  954. if L > 0 then
  955. begin
  956. SetLength(Buf,L-1); // L includes terminating NULL
  957. if l>1 Then
  958. L := GetLocaleInfoW(LID, LT, @Buf[1], L);
  959. result:=buf;
  960. end
  961. else
  962. Result := Def;
  963. end;
  964. function GetLocaleChar(LID, LT: Longint; Def: AnsiChar): AnsiChar;
  965. var
  966. Buf: array[0..3] of AnsiChar; // sdate allows 4 chars.
  967. begin
  968. if GetLocaleInfoA(LID, LT, Buf, sizeof(buf)) > 0 then
  969. Result := Buf[0]
  970. else
  971. Result := Def;
  972. end;
  973. function ConvertEraString(Count ,Year,Month,Day : integer) : string;
  974. var
  975. ASystemTime: TSystemTime;
  976. wbuf: array[0..100] of WideChar;
  977. ALCID : LCID;
  978. begin
  979. Result := ''; if (Count<=0) then exit;
  980. DateTimeToSystemTime(EncodeDate(Year,Month,Day),ASystemTime);
  981. ALCID := GetThreadLocale;
  982. // ALCID := SysLocale.DefaultLCID;
  983. if GetDateFormatW(ALCID , DATE_USE_ALT_CALENDAR
  984. , @ASystemTime, PWChar('gg')
  985. , @wbuf, SizeOf(wbuf)) > 0 then
  986. begin
  987. if Count = 1 then
  988. wbuf[1] := #0;
  989. Result := string(WideString(wbuf));
  990. end;
  991. end;
  992. function ConvertEraYearString(Count ,Year,Month,Day : integer) : string;
  993. var
  994. ALCID : LCID;
  995. ASystemTime : TSystemTime;
  996. AFormatText : string;
  997. buf : array[0..100] of AnsiChar;
  998. begin
  999. Result := '';
  1000. DateTimeToSystemTime(EncodeDate(Year,Month,Day),ASystemTime);
  1001. if Count <= 2 then
  1002. AFormatText := 'yy'
  1003. else
  1004. AFormatText := 'yyyy';
  1005. ALCID := GetThreadLocale;
  1006. // ALCID := SysLocale.DefaultLCID;
  1007. if GetDateFormatA(ALCID, DATE_USE_ALT_CALENDAR
  1008. , @ASystemTime, PAnsiChar(AFormatText)
  1009. , @buf, SizeOf(buf)) > 0 then
  1010. begin
  1011. Result := buf;
  1012. if (Count = 1) and (Result[1] = '0') then
  1013. Result := Copy(Result, 2, Length(Result)-1);
  1014. end;
  1015. end;
  1016. Function GetLocaleInt(LID,TP,Def: LongInt): LongInt;
  1017. Var
  1018. S: String;
  1019. C: Integer;
  1020. Begin
  1021. S:=GetLocaleStr(LID,TP,'0');
  1022. Val(S,Result,C);
  1023. If C<>0 Then
  1024. Result:=Def;
  1025. End;
  1026. function EnumEraNames(Names: PAnsiChar): WINBOOL; stdcall;
  1027. var
  1028. i : integer;
  1029. begin
  1030. Result := False;
  1031. for i := Low(EraNames) to High(EraNames) do
  1032. if (EraNames[i] = '') then
  1033. begin
  1034. EraNames[i] := Names;
  1035. Result := True;
  1036. break;
  1037. end;
  1038. end;
  1039. function EnumEraYearOffsets(YearOffsets: PAnsiChar): WINBOOL; stdcall;
  1040. var
  1041. i : integer;
  1042. begin
  1043. Result := False;
  1044. for i := Low(EraYearOffsets) to High(EraYearOffsets) do
  1045. if (EraYearOffsets[i] = -1) then
  1046. begin
  1047. EraYearOffsets[i] := StrToIntDef(YearOffsets, 0);
  1048. Result := True;
  1049. break;
  1050. end;
  1051. end;
  1052. procedure GetEraNamesAndYearOffsets;
  1053. var
  1054. ACALID : CALID;
  1055. ALCID : LCID;
  1056. buf : array[0..10] of AnsiChar;
  1057. i : integer;
  1058. begin
  1059. for i:= 1 to MaxEraCount do
  1060. begin
  1061. EraNames[i] := ''; EraYearOffsets[i] := -1;
  1062. end;
  1063. ALCID := GetThreadLocale;
  1064. if GetLocaleInfoA(ALCID , LOCALE_IOPTIONALCALENDAR, buf, sizeof(buf)) <= 0 then exit;
  1065. ACALID := StrToIntDef(buf,1);
  1066. if ACALID in [3..5] then
  1067. begin
  1068. EnumCalendarInfoA(@EnumEraNames, ALCID, ACALID , CAL_SERASTRING);
  1069. EnumCalendarInfoA(@EnumEraYearOffsets, ALCID, ACALID, CAL_IYEAROFFSETRANGE);
  1070. end;
  1071. (*
  1072. 1 CAL_GREGORIAN Gregorian (localized)
  1073. 2 CAL_GREGORIAN_US Gregorian (English strings always)
  1074. 3 CAL_JAPAN Japanese Emperor Era
  1075. 4 CAL_TAIWAN Taiwan Calendar
  1076. 5 CAL_KOREA Korean Tangun Era
  1077. 6 CAL_HIJRI Hijri (Arabic Lunar)
  1078. 7 CAL_THAI Thai
  1079. 8 CAL_HEBREW Hebrew (Lunar)
  1080. 9 CAL_GREGORIAN_ME_FRENCH Gregorian Middle East French
  1081. 10 CAL_GREGORIAN_ARABIC Gregorian Arabic
  1082. 11 CAL_GREGORIAN_XLIT_ENGLISH Gregorian transliterated English
  1083. 12 CAL_GREGORIAN_XLIT_FRENCH Gregorian transliterated French
  1084. 23 CAL_UMALQURA Windows Vista or later: Um Al Qura (Arabic lunar) calendar
  1085. *)
  1086. end;
  1087. procedure GetLocaleFormatSettings(LCID: Integer; var FormatSettings: TFormatSettings);
  1088. function FixSeparator(const Format: string; const FromSeparator, ToSeparator: AnsiChar): string;
  1089. var
  1090. R: PAnsiChar;
  1091. begin
  1092. if (Format='') or (FromSeparator=ToSeparator) then
  1093. Exit(Format);
  1094. Result := Copy(Format, 1);
  1095. R := PAnsiChar(Result);
  1096. while R^<>#0 do
  1097. begin
  1098. if R^=FromSeparator then
  1099. R^:=ToSeparator;
  1100. Inc(R);
  1101. end;
  1102. end;
  1103. var
  1104. HF : Shortstring;
  1105. LID : {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.LCID;
  1106. I,Day : longint;
  1107. begin
  1108. LID := LCID;
  1109. with FormatSettings do
  1110. begin
  1111. { Date stuff }
  1112. for I := 1 to 12 do
  1113. begin
  1114. ShortMonthNames[I]:=GetLocaleStr(LID,LOCALE_SABBREVMONTHNAME1+I-1,ShortMonthNames[i]);
  1115. LongMonthNames[I]:=GetLocaleStr(LID,LOCALE_SMONTHNAME1+I-1,LongMonthNames[i]);
  1116. end;
  1117. for I := 1 to 7 do
  1118. begin
  1119. Day := (I + 5) mod 7;
  1120. ShortDayNames[I]:=GetLocaleStr(LID,LOCALE_SABBREVDAYNAME1+Day,ShortDayNames[i]);
  1121. LongDayNames[I]:=GetLocaleStr(LID,LOCALE_SDAYNAME1+Day,LongDayNames[i]);
  1122. end;
  1123. DateSeparator := GetLocaleChar(LID, LOCALE_SDATE, '/');
  1124. ShortDateFormat := FixSeparator(GetLocaleStr(LID, LOCALE_SSHORTDATE, 'm/d/yy'), DateSeparator, '/');
  1125. LongDateFormat := FixSeparator(GetLocaleStr(LID, LOCALE_SLONGDATE, 'mmmm d, yyyy'), DateSeparator, '/');
  1126. { Time stuff }
  1127. TimeSeparator := GetLocaleChar(LID, LOCALE_STIME, ':');
  1128. TimeAMString := GetLocaleStr(LID, LOCALE_S1159, 'AM');
  1129. TimePMString := GetLocaleStr(LID, LOCALE_S2359, 'PM');
  1130. if StrToIntDef(GetLocaleStr(LID, LOCALE_ITLZERO, '0'), 0) = 0 then
  1131. HF:='h'
  1132. else
  1133. HF:='hh';
  1134. ShortTimeFormat := HF+':nn';
  1135. LongTimeFormat := HF + ':nn:ss';
  1136. { 12-hour system support }
  1137. if GetLocaleInt(LID, LOCALE_ITIME, 1) = 0 then
  1138. begin
  1139. LongTimeFormat := LongTimeFormat + ' AMPM';
  1140. ShortTimeFormat := ShortTimeFormat + ' AMPM';
  1141. end;
  1142. { Currency stuff }
  1143. CurrencyString:=GetLocaleStr(LID, LOCALE_SCURRENCY, '');
  1144. CurrencyFormat:=StrToIntDef(GetLocaleStr(LID, LOCALE_ICURRENCY, '0'), 0);
  1145. NegCurrFormat:=StrToIntDef(GetLocaleStr(LID, LOCALE_INEGCURR, '0'), 0);
  1146. { Number stuff }
  1147. ThousandSeparator:=GetLocaleChar(LID, LOCALE_STHOUSAND, ',');
  1148. DecimalSeparator:=GetLocaleChar(LID, LOCALE_SDECIMAL, '.');
  1149. CurrencyDecimals:=StrToIntDef(GetLocaleStr(LID, LOCALE_ICURRDIGITS, '0'), 0);
  1150. ListSeparator := GetLocaleChar(LID, LOCALE_SLIST, ',');
  1151. end;
  1152. end;
  1153. procedure GetFormatSettings;
  1154. begin
  1155. GetlocaleFormatSettings(GetThreadLocale, DefaultFormatSettings);
  1156. end;
  1157. Procedure InitLeadBytes;
  1158. var
  1159. I,B,C,E: Byte;
  1160. Info: TCPInfo;
  1161. begin
  1162. GetCPInfo(CP_ACP,Info);
  1163. I:=0;
  1164. With Info do
  1165. begin
  1166. B:=LeadByte[i];
  1167. E:=LeadByte[i+1];
  1168. while (I<MAX_LEADBYTES) and (B<>0) and (E<>0) do
  1169. begin
  1170. for C:=B to E do
  1171. Include(LeadBytes,AnsiChar(C));
  1172. Inc(I,2);
  1173. if (I<MAX_LEADBYTES) then
  1174. begin
  1175. B:=LeadByte[i];
  1176. E:=LeadByte[i+1];
  1177. end;
  1178. end;
  1179. end;
  1180. end;
  1181. Procedure InitInternational;
  1182. var
  1183. {$if defined(CPU386) or defined(CPUX86_64)}
  1184. { A call to GetSystemMetrics changes the value of the 8087 Control Word on
  1185. Pentium4 with WinXP SP2 }
  1186. old8087CW: word;
  1187. {$endif}
  1188. DefaultCustomLocaleID : LCID; // typedef DWORD LCID;
  1189. DefaultCustomLanguageID : Word; // typedef WORD LANGID;
  1190. begin
  1191. /// workaround for Windows 7 bug, see bug report #18574
  1192. SetThreadLocale(GetUserDefaultLCID);
  1193. InitInternationalGeneric;
  1194. {$if defined(CPU386) or defined(CPUX86_64)}
  1195. old8087CW:=Get8087CW;
  1196. {$endif}
  1197. SysLocale.MBCS:=GetSystemMetrics(SM_DBCSENABLED)<>0;
  1198. SysLocale.RightToLeft:=GetSystemMetrics(SM_MIDEASTENABLED)<>0;
  1199. SysLocale.DefaultLCID := $0409;
  1200. SysLocale.PriLangID := LANG_ENGLISH;
  1201. SysLocale.SubLangID := SUBLANG_ENGLISH_US;
  1202. // probably needs update with getthreadlocale. post 2.0.2
  1203. DefaultCustomLocaleID := GetThreadLocale;
  1204. if DefaultCustomLocaleID <> 0 then
  1205. begin
  1206. { Locale Identifiers
  1207. +-------------+---------+-------------------------+
  1208. | Reserved | Sort ID | Language ID |
  1209. +-------------+---------+-------------------------+
  1210. 31 20 19 16 15 0 bit }
  1211. DefaultCustomLanguageID := DefaultCustomLocaleID and $FFFF; // 2^16
  1212. if DefaultCustomLanguageID <> 0 then
  1213. begin
  1214. SysLocale.DefaultLCID := DefaultCustomLocaleID;
  1215. { Language Identifiers
  1216. +-------------------------+-------------------------+
  1217. | SubLanguage ID | Primary Language ID |
  1218. +-------------------------+-------------------------+
  1219. 15 10 9 0 bit }
  1220. SysLocale.PriLangID := DefaultCustomLanguageID and $3ff; // 2^10
  1221. SysLocale.SubLangID := DefaultCustomLanguageID shr 10;
  1222. end;
  1223. end;
  1224. {$if defined(CPU386) or defined(CPUX86_64)}
  1225. Set8087CW(old8087CW);
  1226. {$endif}
  1227. GetFormatSettings;
  1228. if SysLocale.FarEast then GetEraNamesAndYearOffsets;
  1229. end;
  1230. {****************************************************************************
  1231. Target Dependent
  1232. ****************************************************************************}
  1233. function SysErrorMessage(ErrorCode: Integer): String;
  1234. var
  1235. MsgBuffer: PWideChar;
  1236. Msg: UnicodeString;
  1237. len: longint;
  1238. begin
  1239. len := FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM or
  1240. FORMAT_MESSAGE_IGNORE_INSERTS or
  1241. FORMAT_MESSAGE_ALLOCATE_BUFFER,
  1242. nil,
  1243. ErrorCode,
  1244. MakeLangId(LANG_NEUTRAL, SUBLANG_DEFAULT),
  1245. PWideChar(@MsgBuffer),
  1246. 0,
  1247. nil);
  1248. // Remove trailing #13#10
  1249. if (len > 1) and (MsgBuffer[len - 2] = #13) and (MsgBuffer[len - 1] = #10) then
  1250. Dec(len, 2);
  1251. SetString(Msg, PUnicodeChar(MsgBuffer), len);
  1252. LocalFree(HLOCAL(MsgBuffer));
  1253. Result := Msg;
  1254. end;
  1255. {****************************************************************************
  1256. Initialization code
  1257. ****************************************************************************}
  1258. {$push}
  1259. { GetEnvironmentStrings cannot be checked by CheckPointer function }
  1260. {$checkpointer off}
  1261. Function GetEnvironmentVariable(Const EnvVar : AnsiString) : AnsiString;
  1262. var
  1263. oemenvvar, oemstr : RawByteString;
  1264. i, hplen : longint;
  1265. hp,p : PAnsiChar;
  1266. begin
  1267. oemenvvar:=uppercase(envvar);
  1268. SetCodePage(oemenvvar,CP_OEMCP);
  1269. Result:='';
  1270. p:=GetEnvironmentStringsA;
  1271. hp:=p;
  1272. while hp^<>#0 do
  1273. begin
  1274. oemstr:=hp;
  1275. { cache length, may change after uppercasing depending on code page }
  1276. hplen:=length(oemstr);
  1277. { all environment variables are encoded in the oem code page }
  1278. SetCodePage(oemstr,CP_OEMCP,false);
  1279. i:=pos('=',oemstr);
  1280. if uppercase(copy(oemstr,1,i-1))=oemenvvar then
  1281. begin
  1282. Result:=copy(oemstr,i+1,length(oemstr)-i);
  1283. break;
  1284. end;
  1285. { next string entry}
  1286. hp:=hp+hplen+1;
  1287. end;
  1288. FreeEnvironmentStringsA(p);
  1289. end;
  1290. Function GetEnvironmentVariable(Const EnvVar : UnicodeString) : UnicodeString;
  1291. var
  1292. s, upperenv : Unicodestring;
  1293. i : longint;
  1294. hp,p : pwidechar;
  1295. begin
  1296. Result:='';
  1297. p:=GetEnvironmentStringsW;
  1298. hp:=p;
  1299. upperenv:=uppercase(envvar);
  1300. while hp^<>#0 do
  1301. begin
  1302. s:=hp;
  1303. i:=pos('=',s);
  1304. if uppercase(copy(s,1,i-1))=upperenv then
  1305. begin
  1306. Result:=copy(s,i+1,length(s)-i);
  1307. break;
  1308. end;
  1309. { next string entry}
  1310. hp:=hp+strlen(hp)+1;
  1311. end;
  1312. FreeEnvironmentStringsW(p);
  1313. end;
  1314. Function GetEnvironmentVariableCount : Integer;
  1315. var
  1316. hp,p : PAnsiChar;
  1317. begin
  1318. Result:=0;
  1319. p:=GetEnvironmentStringsA;
  1320. hp:=p;
  1321. If (Hp<>Nil) then
  1322. while hp^<>#0 do
  1323. begin
  1324. Inc(Result);
  1325. hp:=hp+strlen(hp)+1;
  1326. end;
  1327. FreeEnvironmentStringsA(p);
  1328. end;
  1329. Function GetEnvironmentString(Index : Integer) : RTLString;
  1330. var
  1331. hp,p : PAnsiChar;
  1332. {$if SIZEOF(CHAR)=2}
  1333. tmpstr : RawByteString;
  1334. {$endif}
  1335. begin
  1336. Result:='';
  1337. p:=GetEnvironmentStringsA;
  1338. hp:=p;
  1339. If (Hp<>Nil) then
  1340. begin
  1341. while (hp^<>#0) and (Index>1) do
  1342. begin
  1343. Dec(Index);
  1344. hp:=hp+strlen(hp)+1;
  1345. end;
  1346. If (hp^<>#0) then
  1347. begin
  1348. {$if SIZEOF(CHAR)=2}
  1349. tmpstr:=hp;
  1350. SetCodePage(tmpstr,CP_OEMCP,false);
  1351. Result:=tmpstr;
  1352. {$else}
  1353. Result:=hp;
  1354. SetCodePage(RawByteString(Result),CP_OEMCP,false);
  1355. {$endif}
  1356. end;
  1357. end;
  1358. FreeEnvironmentStringsA(p);
  1359. end;
  1360. {$pop}
  1361. function ExecuteProcess(Const Path: RawByteString; Const ComLine: RawByteString;Flags:TExecuteFlags=[]):integer;
  1362. begin
  1363. result:=ExecuteProcess(Unicodestring(Path),UnicodeString(ComLine),Flags);
  1364. end;
  1365. function ExecuteProcess(Const Path: UnicodeString; Const ComLine: UnicodeString;Flags:TExecuteFlags=[]):integer;
  1366. // win specific function
  1367. var
  1368. SI: TStartupInfoW;
  1369. PI: TProcessInformation;
  1370. Proc : THandle;
  1371. l : DWord;
  1372. CommandLine : unicodestring;
  1373. e : EOSError;
  1374. ExecInherits : longbool;
  1375. begin
  1376. FillChar(SI, SizeOf(SI), 0);
  1377. SI.cb:=SizeOf(SI);
  1378. SI.wShowWindow:=1;
  1379. { always surround the name of the application by quotes
  1380. so that long filenames will always be accepted. But don't
  1381. do it if there are already double quotes, since Win32 does not
  1382. like double quotes which are duplicated!
  1383. }
  1384. if pos('"',path)=0 then
  1385. CommandLine:='"'+path+'"'
  1386. else
  1387. CommandLine:=path;
  1388. if ComLine <> '' then
  1389. CommandLine:=Commandline+' '+ComLine+#0
  1390. else
  1391. CommandLine := CommandLine + #0;
  1392. ExecInherits:=ExecInheritsHandles in Flags;
  1393. if not CreateProcessW(nil, pwidechar(CommandLine),
  1394. Nil, Nil, ExecInherits,$20, Nil, Nil, SI, PI) then
  1395. begin
  1396. e:=EOSError.CreateFmt(SExecuteProcessFailed,[CommandLine,GetLastError]);
  1397. e.ErrorCode:=GetLastError;
  1398. raise e;
  1399. end;
  1400. Proc:=PI.hProcess;
  1401. if WaitForSingleObject(Proc, dword($ffffffff)) <> $ffffffff then
  1402. begin
  1403. GetExitCodeProcess(Proc,l);
  1404. CloseHandle(Proc);
  1405. CloseHandle(PI.hThread);
  1406. result:=l;
  1407. end
  1408. else
  1409. begin
  1410. e:=EOSError.CreateFmt(SExecuteProcessFailed,[CommandLine,GetLastError]);
  1411. e.ErrorCode:=GetLastError;
  1412. CloseHandle(Proc);
  1413. CloseHandle(PI.hThread);
  1414. raise e;
  1415. end;
  1416. end;
  1417. function ExecuteProcess(Const Path: RawByteString; Const ComLine: Array of RawByteString;Flags:TExecuteFlags=[]):integer;
  1418. var
  1419. CommandLine: UnicodeString;
  1420. I: integer;
  1421. begin
  1422. Commandline := '';
  1423. for I := 0 to High (ComLine) do
  1424. if Pos (' ', ComLine [I]) <> 0 then
  1425. CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
  1426. else
  1427. CommandLine := CommandLine + ' ' + Comline [I];
  1428. ExecuteProcess := ExecuteProcess (UnicodeString(Path), CommandLine,Flags);
  1429. end;
  1430. function ExecuteProcess(Const Path: UnicodeString; Const ComLine: Array of UnicodeString;Flags:TExecuteFlags=[]):integer;
  1431. var
  1432. CommandLine: UnicodeString;
  1433. I: integer;
  1434. begin
  1435. Commandline := '';
  1436. for I := 0 to High (ComLine) do
  1437. if Pos (' ', ComLine [I]) <> 0 then
  1438. CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
  1439. else
  1440. CommandLine := CommandLine + ' ' + Comline [I];
  1441. ExecuteProcess := ExecuteProcess (Path,CommandLine,Flags);
  1442. end;
  1443. Procedure Sleep(Milliseconds : Cardinal);
  1444. begin
  1445. {$IFDEF FPC_DOTTEDUNITS}WinApi.{$ENDIF}Windows.Sleep(MilliSeconds)
  1446. end;
  1447. Function GetLastOSError : Integer;
  1448. begin
  1449. Result:=GetLastError;
  1450. end;
  1451. {****************************************************************************
  1452. Initialization code
  1453. ****************************************************************************}
  1454. var
  1455. kernel32dll : THandle;
  1456. Procedure LoadVersionInfo;
  1457. // and getfreespaceex
  1458. Var
  1459. versioninfo : TOSVERSIONINFO;
  1460. begin
  1461. GetDiskFreeSpaceEx:=nil;
  1462. versioninfo.dwOSVersionInfoSize:=sizeof(versioninfo);
  1463. GetVersionEx(versioninfo);
  1464. Win32Platform:=versionInfo.dwPlatformId;
  1465. Win32MajorVersion:=versionInfo.dwMajorVersion;
  1466. Win32MinorVersion:=versionInfo.dwMinorVersion;
  1467. Win32BuildNumber:=versionInfo.dwBuildNumber;
  1468. Move (versioninfo.szCSDVersion ,Win32CSDVersion[1],128);
  1469. win32CSDVersion[0]:=chr(strlen(PAnsiChar(@versioninfo.szCSDVersion)));
  1470. kernel32dll:=GetModuleHandle('kernel32');
  1471. if kernel32dll<>0 then
  1472. GetDiskFreeSpaceEx:=TGetDiskFreeSpaceEx(GetProcAddress(kernel32dll,'GetDiskFreeSpaceExA'));
  1473. if Win32MajorVersion<6 then
  1474. FindExInfoDefaults := FindExInfoStandard; // also searches SFNs. XP only.
  1475. if (Win32MajorVersion>=6) and (Win32MinorVersion>=1) then
  1476. FindFirstAdditionalFlags := FIND_FIRST_EX_LARGE_FETCH; // win7 and 2008R2+
  1477. // GetTimeZoneInformationForYear is supported only on Vista and newer
  1478. if (kernel32dll<>0) and (Win32MajorVersion>=6) then
  1479. GetTimeZoneInformationForYear:=TGetTimeZoneInformationForYear(GetProcAddress(kernel32dll,'GetTimeZoneInformationForYear'));
  1480. if (kernel32dll<>0) then
  1481. GetFinalPathNameByHandle:=TGetFinalPathNameByHandle(GetProcAddress(kernel32dll,'GetFinalPathNameByHandleA'));
  1482. end;
  1483. Function GetAppConfigDir(Global : Boolean) : String;
  1484. begin
  1485. If Global then
  1486. Result:=GetWindowsSpecialDir(CSIDL_COMMON_APPDATA)
  1487. else
  1488. Result:=GetWindowsSpecialDir(CSIDL_LOCAL_APPDATA);
  1489. If (Result<>'') then
  1490. begin
  1491. if VendorName<>'' then
  1492. Result:=IncludeTrailingPathDelimiter(Result+VendorName);
  1493. Result:=IncludeTrailingPathDelimiter(Result+ApplicationName);
  1494. end
  1495. else
  1496. Result:=IncludeTrailingPathDelimiter(DGetAppConfigDir(Global));
  1497. end;
  1498. Function GetAppConfigFile(Global : Boolean; SubDir : Boolean) : String;
  1499. begin
  1500. result:=DGetAppConfigFile(Global,SubDir);
  1501. end;
  1502. Function GetUserDir : String;
  1503. begin
  1504. Result:=GetWindowsSpecialDir(CSIDL_PROFILE);
  1505. end;
  1506. Procedure InitSysConfigDir;
  1507. begin
  1508. SetLength(SysConfigDir, MAX_PATH);
  1509. SetLength(SysConfigDir, GetWindowsDirectoryA(PAnsiChar(SysConfigDir), MAX_PATH));
  1510. end;
  1511. {****************************************************************************
  1512. Target Dependent WideString stuff
  1513. ****************************************************************************}
  1514. { This is the case of Win9x. Limited to current locale of course, but it's better
  1515. than not working at all. }
  1516. function DoCompareStringA(P1, P2: PWideChar; L1, L2: PtrUInt; Flags: DWORD): PtrInt;
  1517. var
  1518. a1, a2: AnsiString;
  1519. begin
  1520. if L1>0 then
  1521. widestringmanager.Wide2AnsiMoveProc(P1,a1,DefaultSystemCodePage,L1);
  1522. if L2>0 then
  1523. widestringmanager.Wide2AnsiMoveProc(P2,a2,DefaultSystemCodePage,L2);
  1524. SetLastError(0);
  1525. Result:=CompareStringA(LOCALE_USER_DEFAULT,Flags,PAnsiChar(a1),
  1526. length(a1),PAnsiChar(a2),length(a2))-2;
  1527. end;
  1528. function DoCompareStringW(P1, P2: PWideChar; L1, L2: PtrUInt; Flags: DWORD): PtrInt;
  1529. begin
  1530. SetLastError(0);
  1531. Result:=CompareStringW(LOCALE_USER_DEFAULT,Flags,P1,L1,P2,L2)-2;
  1532. if GetLastError=0 then
  1533. Exit;
  1534. if GetLastError=ERROR_CALL_NOT_IMPLEMENTED then // Win9x case
  1535. Result:=DoCompareStringA(P1, P2, L1, L2, Flags);
  1536. if GetLastError<>0 then
  1537. RaiseLastOSError;
  1538. end;
  1539. const
  1540. WinAPICompareFlags : array [TCompareOption] of LongWord
  1541. = ({LINGUISTIC_IGNORECASE, LINGUISTIC_IGNOREDIACRITIC, }NORM_IGNORECASE{,
  1542. NORM_IGNOREKANATYPE, NORM_IGNORENONSPACE, NORM_IGNORESYMBOLS, NORM_IGNOREWIDTH,
  1543. NORM_LINGUISTIC_CASING, SORT_DIGITSASNUMBERS, SORT_STRINGSORT});
  1544. function Win32CompareWideString(const s1, s2 : WideString; Options : TCompareOptions) : PtrInt;
  1545. Var
  1546. O : LongWord;
  1547. CO : TCompareOption;
  1548. begin
  1549. O:=0;
  1550. for CO in TCompareOption do
  1551. if CO in Options then
  1552. O:=O or WinAPICompareFlags[CO];
  1553. Result:=DoCompareStringW(PWideChar(s1), PWideChar(s2), Length(s1), Length(s2), O);
  1554. end;
  1555. function Win32CompareTextWideString(const s1, s2 : WideString) : PtrInt;
  1556. begin
  1557. Result:=DoCompareStringW(PWideChar(s1), PWideChar(s2), Length(s1), Length(s2), NORM_IGNORECASE);
  1558. end;
  1559. function Win32AnsiUpperCase(const s: AnsiString): AnsiString;
  1560. begin
  1561. if length(s)>0 then
  1562. begin
  1563. result:=s;
  1564. UniqueString(result);
  1565. CharUpperBuffA(PAnsiChar(result),length(result));
  1566. end
  1567. else
  1568. result:='';
  1569. end;
  1570. function Win32AnsiLowerCase(const s: AnsiString): AnsiString;
  1571. begin
  1572. if length(s)>0 then
  1573. begin
  1574. result:=s;
  1575. UniqueString(result);
  1576. CharLowerBuffA(PAnsiChar(result),length(result));
  1577. end
  1578. else
  1579. result:='';
  1580. end;
  1581. function Win32AnsiCompareStr(const S1, S2: AnsiString): PtrInt;
  1582. begin
  1583. result:=CompareStringA(LOCALE_USER_DEFAULT,0,PAnsiChar(s1),length(s1),
  1584. PAnsiChar(s2),length(s2))-2;
  1585. end;
  1586. function Win32AnsiCompareText(const S1, S2: AnsiString): PtrInt;
  1587. begin
  1588. result:=CompareStringA(LOCALE_USER_DEFAULT,NORM_IGNORECASE,PAnsiChar(s1),length(s1),
  1589. PAnsiChar(s2),length(s2))-2;
  1590. end;
  1591. function Win32AnsiStrComp(S1, S2: PAnsiChar): PtrInt;
  1592. begin
  1593. result:=CompareStringA(LOCALE_USER_DEFAULT,0,s1,-1,s2,-1)-2;
  1594. end;
  1595. function Win32AnsiStrIComp(S1, S2: PAnsiChar): PtrInt;
  1596. begin
  1597. result:=CompareStringA(LOCALE_USER_DEFAULT,NORM_IGNORECASE,s1,-1,s2,-1)-2;
  1598. end;
  1599. function Win32AnsiStrLComp(S1, S2: PAnsiChar; MaxLen: PtrUInt): PtrInt;
  1600. begin
  1601. result:=CompareStringA(LOCALE_USER_DEFAULT,0,s1,maxlen,s2,maxlen)-2;
  1602. end;
  1603. function Win32AnsiStrLIComp(S1, S2: PAnsiChar; MaxLen: PtrUInt): PtrInt;
  1604. begin
  1605. result:=CompareStringA(LOCALE_USER_DEFAULT,NORM_IGNORECASE,s1,maxlen,s2,maxlen)-2;
  1606. end;
  1607. function Win32AnsiStrLower(Str: PAnsiChar): PAnsiChar;
  1608. begin
  1609. CharLowerA(str);
  1610. result:=str;
  1611. end;
  1612. function Win32AnsiStrUpper(Str: PAnsiChar): PAnsiChar;
  1613. begin
  1614. CharUpperA(str);
  1615. result:=str;
  1616. end;
  1617. function Win32CompareUnicodeString(const s1, s2 : UnicodeString; Options : TCompareOptions) : PtrInt;
  1618. Var
  1619. O : LongWord;
  1620. CO : TCompareOption;
  1621. begin
  1622. O:=0;
  1623. for CO in TCompareOption do
  1624. if CO in Options then
  1625. O:=O or WinAPICompareFlags[CO];
  1626. Result:=DoCompareStringW(PWideChar(s1), PWideChar(s2), Length(s1), Length(s2), O);
  1627. end;
  1628. function Win32CompareTextUnicodeString(const s1, s2 : UnicodeString) : PtrInt;
  1629. begin
  1630. Result:=DoCompareStringW(PWideChar(s1), PWideChar(s2), Length(s1), Length(s2), NORM_IGNORECASE);
  1631. end;
  1632. { there is a similiar procedure in the system unit which inits the fields which
  1633. are relevant already for the system unit }
  1634. procedure InitWin32Widestrings;
  1635. begin
  1636. { return value: number of code points in the string. Whenever an invalid
  1637. code point is encountered, all characters part of this invalid code point
  1638. are considered to form one "character" and the next character is
  1639. considered to be the start of a new (possibly also invalid) code point }
  1640. //!!! CharLengthPCharProc : function(const Str: PAnsiChar): PtrInt;
  1641. { return value:
  1642. -1 if incomplete or invalid code point
  1643. 0 if NULL character,
  1644. > 0 if that's the length in bytes of the code point }
  1645. //!!!! CodePointLengthProc : function(const Str: PAnsiChar; MaxLookAead: PtrInt): Ptrint;
  1646. widestringmanager.CompareWideStringProc:=@Win32CompareWideString;
  1647. widestringmanager.UpperAnsiStringProc:=@Win32AnsiUpperCase;
  1648. widestringmanager.LowerAnsiStringProc:=@Win32AnsiLowerCase;
  1649. widestringmanager.CompareStrAnsiStringProc:=@Win32AnsiCompareStr;
  1650. widestringmanager.CompareTextAnsiStringProc:=@Win32AnsiCompareText;
  1651. widestringmanager.StrCompAnsiStringProc:=@Win32AnsiStrComp;
  1652. widestringmanager.StrICompAnsiStringProc:=@Win32AnsiStrIComp;
  1653. widestringmanager.StrLCompAnsiStringProc:=@Win32AnsiStrLComp;
  1654. widestringmanager.StrLICompAnsiStringProc:=@Win32AnsiStrLIComp;
  1655. widestringmanager.StrLowerAnsiStringProc:=@Win32AnsiStrLower;
  1656. widestringmanager.StrUpperAnsiStringProc:=@Win32AnsiStrUpper;
  1657. widestringmanager.CompareUnicodeStringProc:=@Win32CompareUnicodeString;
  1658. end;
  1659. { Platform-specific exception support }
  1660. function WinExceptionObject(code: Longint; const rec: TExceptionRecord): Exception;
  1661. var
  1662. entry: PExceptMapEntry;
  1663. begin
  1664. entry := FindExceptMapEntry(code);
  1665. if assigned(entry) then
  1666. result:=entry^.cls.CreateRes(entry^.msg)
  1667. else
  1668. result:=EExternalException.CreateResFmt(@SExternalException,[rec.ExceptionCode]);
  1669. if result is EExternal then
  1670. EExternal(result).FExceptionRecord:=rec;
  1671. end;
  1672. function WinExceptionClass(code: longint): ExceptClass;
  1673. var
  1674. entry: PExceptMapEntry;
  1675. begin
  1676. entry := FindExceptMapEntry(code);
  1677. if assigned(entry) then
  1678. result:=entry^.cls
  1679. else
  1680. result:=EExternalException;
  1681. end;
  1682. Initialization
  1683. InitWin32Widestrings;
  1684. InitExceptions; { Initialize exceptions. OS independent }
  1685. {$ifdef mswindows} { Keeps exe size down for systems that do not use SEH }
  1686. ExceptObjProc:=@WinExceptionObject;
  1687. ExceptClsProc:=@WinExceptionClass;
  1688. {$endif mswindows}
  1689. InitLeadBytes;
  1690. InitInternational; { Initialize internationalization settings }
  1691. LoadVersionInfo;
  1692. InitSysConfigDir;
  1693. OnBeep:=@SysBeep;
  1694. Finalization
  1695. FreeTerminateProcs;
  1696. DoneExceptions;
  1697. end.