sysutils.pp 40 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491
  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. unit sysutils;
  13. interface
  14. {$MODE objfpc}
  15. {$MODESWITCH OUT}
  16. { force ansistrings }
  17. {$H+}
  18. {$modeswitch typehelpers}
  19. {$modeswitch advancedrecords}
  20. uses
  21. windows;
  22. {$DEFINE HAS_SLEEP}
  23. {$DEFINE HAS_OSERROR}
  24. {$DEFINE HAS_OSCONFIG}
  25. {$DEFINE HAS_OSUSERDIR}
  26. {$DEFINE HAS_CREATEGUID}
  27. {$DEFINE HAS_LOCALTIMEZONEOFFSET}
  28. {$DEFINE HAS_GETTICKCOUNT}
  29. {$DEFINE HAS_GETTICKCOUNT64}
  30. {$DEFINE OS_FILESETDATEBYNAME}
  31. { used OS file system APIs use unicodestring }
  32. {$define SYSUTILS_HAS_UNICODESTR_FILEUTIL_IMPL}
  33. { OS has an ansistring/single byte environment variable API }
  34. {$define SYSUTILS_HAS_ANSISTR_ENVVAR_IMPL}
  35. { OS has a unicodestring/two byte environment variable API }
  36. {$define SYSUTILS_HAS_UNICODESTR_ENVVAR_IMPL}
  37. { Include platform independent interface part }
  38. {$i sysutilh.inc}
  39. type
  40. TSystemTime = Windows.TSystemTime;
  41. EWin32Error = class(Exception)
  42. public
  43. ErrorCode : DWORD;
  44. end;
  45. Var
  46. Win32Platform : Longint;
  47. Win32MajorVersion,
  48. Win32MinorVersion,
  49. Win32BuildNumber : dword;
  50. Win32CSDVersion : ShortString; // CSD record is 128 bytes only?
  51. const
  52. MaxEraCount = 7;
  53. var
  54. EraNames: array [1..MaxEraCount] of String;
  55. EraYearOffsets: array [1..MaxEraCount] of Integer;
  56. { Compatibility with Delphi }
  57. function Win32Check(res:boolean):boolean;inline;
  58. function WinCheck(res:boolean):boolean;
  59. function CheckWin32Version(Major,Minor : Integer ): Boolean;
  60. function CheckWin32Version(Major : Integer): Boolean;
  61. Procedure RaiseLastWin32Error;
  62. function GetFileVersion(const AFileName: string): Cardinal;
  63. function GetFileVersion(const AFileName: UnicodeString): Cardinal;
  64. procedure GetFormatSettings;
  65. procedure GetLocaleFormatSettings(LCID: Integer; var FormatSettings: TFormatSettings); platform;
  66. implementation
  67. uses
  68. sysconst,
  69. windirs;
  70. function WinCheck(res:boolean):boolean;
  71. begin
  72. if not res then
  73. RaiseLastOSError;
  74. result:=res;
  75. end;
  76. function Win32Check(res:boolean):boolean;inline;
  77. begin
  78. result:=WinCheck(res);
  79. end;
  80. procedure RaiseLastWin32Error;
  81. begin
  82. RaiseLastOSError;
  83. end;
  84. function CheckWin32Version(Major : Integer): Boolean;
  85. begin
  86. Result:=CheckWin32Version(Major,0)
  87. end;
  88. function CheckWin32Version(Major,Minor: Integer): Boolean;
  89. begin
  90. Result:=(Win32MajorVersion>dword(Major)) or
  91. ((Win32MajorVersion=dword(Major)) and (Win32MinorVersion>=dword(Minor)));
  92. end;
  93. function GetFileVersion(const AFileName:string):Cardinal;
  94. var
  95. { useful only as long as we don't need to touch different stack pages }
  96. buf : array[0..3071] of byte;
  97. bufp : pointer;
  98. fn : string;
  99. valsize,
  100. size : DWORD;
  101. h : DWORD;
  102. valrec : PVSFixedFileInfo;
  103. begin
  104. result:=$fffffff;
  105. fn:=AFileName;
  106. UniqueString(fn);
  107. size:=GetFileVersionInfoSizeA(pchar(fn),@h);
  108. if size>sizeof(buf) then
  109. begin
  110. getmem(bufp,size);
  111. try
  112. if GetFileVersionInfoA(pchar(fn),h,size,bufp) then
  113. if VerQueryValue(bufp,'\',valrec,valsize) then
  114. result:=valrec^.dwFileVersionMS;
  115. finally
  116. freemem(bufp);
  117. end;
  118. end
  119. else
  120. begin
  121. if GetFileVersionInfoA(pchar(fn),h,size,@buf) then
  122. if VerQueryValue(@buf,'\',valrec,valsize) then
  123. result:=valrec^.dwFileVersionMS;
  124. end;
  125. end;
  126. function GetFileVersion(const AFileName:UnicodeString):Cardinal;
  127. var
  128. { useful only as long as we don't need to touch different stack pages }
  129. buf : array[0..3071] of byte;
  130. bufp : pointer;
  131. fn : unicodestring;
  132. valsize,
  133. size : DWORD;
  134. h : DWORD;
  135. valrec : PVSFixedFileInfo;
  136. begin
  137. result:=$fffffff;
  138. fn:=AFileName;
  139. UniqueString(fn);
  140. size:=GetFileVersionInfoSizeW(pwidechar(fn),@h);
  141. if size>sizeof(buf) then
  142. begin
  143. getmem(bufp,size);
  144. try
  145. if GetFileVersionInfoW(pwidechar(fn),h,size,bufp) then
  146. if VerQueryValue(bufp,'\',valrec,valsize) then
  147. result:=valrec^.dwFileVersionMS;
  148. finally
  149. freemem(bufp);
  150. end;
  151. end
  152. else
  153. begin
  154. if GetFileVersionInfoW(pwidechar(fn),h,size,@buf) then
  155. if VerQueryValueW(@buf,'\',valrec,valsize) then
  156. result:=valrec^.dwFileVersionMS;
  157. end;
  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: PChar; uUnique: DWORD; TempFileName: PChar):DWORD;
  169. begin
  170. Result:= 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 FileOpen (Const FileName : unicodestring; Mode : Integer) : THandle;
  231. begin
  232. result := CreateFileW(PWideChar(FileName), dword(AccessMode[Mode and 3]),
  233. dword(ShareModes[(Mode and $F0) shr 4]), nil, OPEN_EXISTING,
  234. FILE_ATTRIBUTE_NORMAL, 0);
  235. //if fail api return feInvalidHandle (INVALIDE_HANDLE=feInvalidHandle=-1)
  236. end;
  237. Function FileCreate (Const FileName : UnicodeString) : THandle;
  238. begin
  239. FileCreate:=FileCreate(FileName, fmShareExclusive, 0);
  240. end;
  241. Function FileCreate (Const FileName : UnicodeString; Rights:longint) : THandle;
  242. begin
  243. FileCreate:=FileCreate(FileName, fmShareExclusive, Rights);
  244. end;
  245. Function FileCreate (Const FileName : UnicodeString; ShareMode : Integer; Rights : Integer) : THandle;
  246. begin
  247. Result := CreateFileW(PwideChar(FileName), GENERIC_READ or GENERIC_WRITE,
  248. dword(ShareModes[(ShareMode and $F0) shr 4]), nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
  249. end;
  250. Function FileRead (Handle : THandle; out Buffer; Count : longint) : Longint;
  251. Var
  252. res : dword;
  253. begin
  254. if ReadFile(Handle, Buffer, Count, res, nil) then
  255. FileRead:=Res
  256. else
  257. FileRead:=-1;
  258. end;
  259. Function FileWrite (Handle : THandle; const Buffer; Count : Longint) : Longint;
  260. Var
  261. Res : dword;
  262. begin
  263. if WriteFile(Handle, Buffer, Count, Res, nil) then
  264. FileWrite:=Res
  265. else
  266. FileWrite:=-1;
  267. end;
  268. Function FileSeek (Handle : THandle;FOffset,Origin : Longint) : Longint;
  269. begin
  270. Result := longint(SetFilePointer(Handle, FOffset, nil, Origin));
  271. end;
  272. Function FileSeek (Handle : THandle; FOffset: Int64; Origin: Longint) : Int64;
  273. var
  274. rslt: Int64Rec;
  275. begin
  276. rslt := Int64Rec(FOffset);
  277. rslt.lo := SetFilePointer(Handle, rslt.lo, @rslt.hi, Origin);
  278. if (rslt.lo = $FFFFFFFF) and (GetLastError <> 0) then
  279. rslt.hi := $FFFFFFFF;
  280. Result := Int64(rslt);
  281. end;
  282. Procedure FileClose (Handle : THandle);
  283. begin
  284. if Handle<=4 then
  285. exit;
  286. CloseHandle(Handle);
  287. end;
  288. Function FileTruncate (Handle : THandle;Size: Int64) : boolean;
  289. begin
  290. {
  291. Result:=longint(SetFilePointer(handle,Size,nil,FILE_BEGIN))<>-1;
  292. }
  293. if FileSeek (Handle, Size, FILE_BEGIN) = Size then
  294. Result:=SetEndOfFile(handle)
  295. else
  296. Result := false;
  297. end;
  298. Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):longbool;
  299. var
  300. lft : TFileTime;
  301. begin
  302. DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,@lft) and
  303. LocalFileTimeToFileTime(lft,Wtime);
  304. end;
  305. Function WinToDosTime (Var Wtime : TFileTime;var DTime:longint):longbool;
  306. var
  307. lft : TFileTime;
  308. begin
  309. WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
  310. FileTimeToDosDateTime(lft,Longrec(Dtime).Hi,LongRec(DTIME).lo);
  311. end;
  312. Function FileAge (Const FileName : UnicodeString): Longint;
  313. var
  314. Handle: THandle;
  315. FindData: TWin32FindDataW;
  316. begin
  317. Handle := FindFirstFileW(Pwidechar(FileName), FindData);
  318. if Handle <> INVALID_HANDLE_VALUE then
  319. begin
  320. Windows.FindClose(Handle);
  321. if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
  322. If WinToDosTime(FindData.ftLastWriteTime,Result) then
  323. exit;
  324. end;
  325. Result := -1;
  326. end;
  327. Function FileExists (Const FileName : UnicodeString) : Boolean;
  328. var
  329. Attr:Dword;
  330. begin
  331. Attr:=GetFileAttributesW(PWideChar(FileName));
  332. if Attr <> $ffffffff then
  333. Result:= (Attr and FILE_ATTRIBUTE_DIRECTORY) = 0
  334. else
  335. Result:=False;
  336. end;
  337. Function DirectoryExists (Const Directory : UnicodeString) : Boolean;
  338. var
  339. Attr:Dword;
  340. begin
  341. Attr:=GetFileAttributesW(PWideChar(Directory));
  342. if Attr <> $ffffffff then
  343. Result:= (Attr and FILE_ATTRIBUTE_DIRECTORY) > 0
  344. else
  345. Result:=False;
  346. end;
  347. Function FindMatch(var f: TAbstractSearchRec; var Name: UnicodeString) : Longint;
  348. begin
  349. { Find file with correct attribute }
  350. While (F.FindData.dwFileAttributes and cardinal(F.ExcludeAttr))<>0 do
  351. begin
  352. if not FindNextFileW (F.FindHandle,F.FindData) then
  353. begin
  354. Result:=GetLastError;
  355. exit;
  356. end;
  357. end;
  358. { Convert some attributes back }
  359. WinToDosTime(F.FindData.ftLastWriteTime,F.Time);
  360. f.size:=F.FindData.NFileSizeLow+(qword(maxdword)+1)*F.FindData.NFileSizeHigh;
  361. f.attr:=F.FindData.dwFileAttributes;
  362. Name:=F.FindData.cFileName;
  363. Result:=0;
  364. end;
  365. Procedure InternalFindClose (var Handle: THandle; var FindData: TFindData);
  366. begin
  367. if Handle <> INVALID_HANDLE_VALUE then
  368. begin
  369. Windows.FindClose(Handle);
  370. Handle:=INVALID_HANDLE_VALUE;
  371. end;
  372. end;
  373. Function InternalFindFirst (Const Path : UnicodeString; Attr : Longint; out Rslt : TAbstractSearchRec; var Name : UnicodeString) : Longint;
  374. begin
  375. Name:=Path;
  376. Rslt.Attr:=attr;
  377. Rslt.ExcludeAttr:=(not Attr) and ($1e);
  378. { $1e = faHidden or faSysFile or faVolumeID or faDirectory }
  379. { FindFirstFile is a Win32 Call }
  380. Rslt.FindHandle:=FindFirstFileW (PWideChar(Path),Rslt.FindData);
  381. If Rslt.FindHandle=Invalid_Handle_value then
  382. begin
  383. Result:=GetLastError;
  384. exit;
  385. end;
  386. { Find file with correct attribute }
  387. Result:=FindMatch(Rslt,Name);
  388. if (Result<>0) then
  389. InternalFindClose(Rslt.FindHandle,Rslt.FindData);
  390. end;
  391. Function InternalFindNext (Var Rslt : TAbstractSearchRec; var Name: UnicodeString) : Longint;
  392. begin
  393. if FindNextFileW(Rslt.FindHandle, Rslt.FindData) then
  394. Result := FindMatch(Rslt, Name)
  395. else
  396. Result := GetLastError;
  397. end;
  398. Function FileGetDate (Handle : THandle) : Longint;
  399. Var
  400. FT : TFileTime;
  401. begin
  402. If GetFileTime(Handle,nil,nil,@ft) and
  403. WinToDosTime(FT,Result) then
  404. exit;
  405. Result:=-1;
  406. end;
  407. Function FileSetDate (Handle : THandle;Age : Longint) : Longint;
  408. Var
  409. FT: TFileTime;
  410. begin
  411. Result := 0;
  412. if DosToWinTime(Age,FT) and
  413. SetFileTime(Handle, nil, nil, @FT) then
  414. Exit;
  415. Result := GetLastError;
  416. end;
  417. {$IFDEF OS_FILESETDATEBYNAME}
  418. Function FileSetDate (Const FileName : UnicodeString;Age : Longint) : Longint;
  419. Var
  420. fd : THandle;
  421. begin
  422. FD := CreateFileW (PWideChar (FileName), GENERIC_READ or GENERIC_WRITE,
  423. FILE_SHARE_WRITE, nil, OPEN_EXISTING,
  424. FILE_FLAG_BACKUP_SEMANTICS, 0);
  425. If (Fd<>feInvalidHandle) then
  426. try
  427. Result:=FileSetDate(fd,Age);
  428. finally
  429. FileClose(fd);
  430. end
  431. else
  432. Result:=GetLastOSError;
  433. end;
  434. {$ENDIF}
  435. Function FileGetAttr (Const FileName : UnicodeString) : Longint;
  436. begin
  437. Result:=Longint(GetFileAttributesW(PWideChar(FileName)));
  438. end;
  439. Function FileSetAttr (Const Filename : UnicodeString; Attr: longint) : Longint;
  440. begin
  441. if SetFileAttributesW(PWideChar(FileName), Attr) then
  442. Result:=0
  443. else
  444. Result := GetLastError;
  445. end;
  446. Function DeleteFile (Const FileName : UnicodeString) : Boolean;
  447. begin
  448. Result:=Windows.DeleteFileW(PWidechar(FileName));
  449. end;
  450. Function RenameFile (Const OldName, NewName : UnicodeString) : Boolean;
  451. begin
  452. Result := MoveFileW(PWideChar(OldName), PWideChar(NewName));
  453. end;
  454. {****************************************************************************
  455. Disk Functions
  456. ****************************************************************************}
  457. type
  458. TGetDiskFreeSpaceEx = function(drive:pchar;var availableforcaller,total,free):longbool;stdcall;
  459. var
  460. GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
  461. function diskfree(drive : byte) : int64;
  462. var
  463. disk : array[1..4] of char;
  464. secs,bytes,
  465. free,total : dword;
  466. qwtotal,qwfree,qwcaller : int64;
  467. begin
  468. if drive=0 then
  469. begin
  470. disk[1]:='\';
  471. disk[2]:=#0;
  472. end
  473. else
  474. begin
  475. disk[1]:=chr(drive+64);
  476. disk[2]:=':';
  477. disk[3]:='\';
  478. disk[4]:=#0;
  479. end;
  480. if assigned(GetDiskFreeSpaceEx) then
  481. begin
  482. if GetDiskFreeSpaceEx(@disk[1],qwcaller,qwtotal,qwfree) then
  483. diskfree:=qwfree
  484. else
  485. diskfree:=-1;
  486. end
  487. else
  488. begin
  489. if GetDiskFreeSpace(@disk[1],secs,bytes,free,total) then
  490. diskfree:=int64(free)*secs*bytes
  491. else
  492. diskfree:=-1;
  493. end;
  494. end;
  495. function disksize(drive : byte) : int64;
  496. var
  497. disk : array[1..4] of char;
  498. secs,bytes,
  499. free,total : dword;
  500. qwtotal,qwfree,qwcaller : int64;
  501. begin
  502. if drive=0 then
  503. begin
  504. disk[1]:='\';
  505. disk[2]:=#0;
  506. end
  507. else
  508. begin
  509. disk[1]:=chr(drive+64);
  510. disk[2]:=':';
  511. disk[3]:='\';
  512. disk[4]:=#0;
  513. end;
  514. if assigned(GetDiskFreeSpaceEx) then
  515. begin
  516. if GetDiskFreeSpaceEx(@disk[1],qwcaller,qwtotal,qwfree) then
  517. disksize:=qwtotal
  518. else
  519. disksize:=-1;
  520. end
  521. else
  522. begin
  523. if GetDiskFreeSpace(@disk[1],secs,bytes,free,total) then
  524. disksize:=int64(total)*secs*bytes
  525. else
  526. disksize:=-1;
  527. end;
  528. end;
  529. {****************************************************************************
  530. Time Functions
  531. ****************************************************************************}
  532. Procedure GetLocalTime(var SystemTime: TSystemTime);
  533. begin
  534. windows.Getlocaltime(SystemTime);
  535. end;
  536. function GetLocalTimeOffset: Integer;
  537. var
  538. TZInfo: TTimeZoneInformation;
  539. begin
  540. case GetTimeZoneInformation(TZInfo) of
  541. TIME_ZONE_ID_UNKNOWN:
  542. Result := TZInfo.Bias;
  543. TIME_ZONE_ID_STANDARD:
  544. Result := TZInfo.Bias + TZInfo.StandardBias;
  545. TIME_ZONE_ID_DAYLIGHT:
  546. Result := TZInfo.Bias + TZInfo.DaylightBias;
  547. else
  548. Result := 0;
  549. end;
  550. end;
  551. function GetTickCount: LongWord;
  552. begin
  553. Result := Windows.GetTickCount;
  554. end;
  555. {$IFNDEF WINCE}
  556. type
  557. TGetTickCount64 = function : QWord; stdcall;
  558. var
  559. WinGetTickCount64: TGetTickCount64 = Nil;
  560. {$ENDIF}
  561. function GetTickCount64: QWord;
  562. {$IFNDEF WINCE}
  563. var
  564. lib: THandle;
  565. {$ENDIF}
  566. begin
  567. {$IFNDEF WINCE}
  568. { on Vista and newer there is a GetTickCount64 implementation }
  569. if Win32MajorVersion >= 6 then begin
  570. if not Assigned(WinGetTickCount64) then begin
  571. lib := LoadLibrary('kernel32.dll');
  572. WinGetTickCount64 := TGetTickCount64(
  573. GetProcAddress(lib, 'GetTickCount64'));
  574. end;
  575. Result := WinGetTickCount64();
  576. end else
  577. {$ENDIF}
  578. Result := Windows.GetTickCount;
  579. end;
  580. {****************************************************************************
  581. Misc Functions
  582. ****************************************************************************}
  583. procedure sysbeep;
  584. begin
  585. MessageBeep(0);
  586. end;
  587. {****************************************************************************
  588. Locale Functions
  589. ****************************************************************************}
  590. function GetLocaleStr(LID, LT: Longint; const Def: string): ShortString;
  591. var
  592. L: Integer;
  593. Buf: array[0..255] of Char;
  594. begin
  595. L := GetLocaleInfoA(LID, LT, Buf, SizeOf(Buf));
  596. if L > 0 then
  597. SetString(Result, @Buf[0], L - 1)
  598. else
  599. Result := Def;
  600. end;
  601. function GetLocaleChar(LID, LT: Longint; Def: Char): Char;
  602. var
  603. Buf: array[0..3] of Char; // sdate allows 4 chars.
  604. begin
  605. if GetLocaleInfoA(LID, LT, Buf, sizeof(buf)) > 0 then
  606. Result := Buf[0]
  607. else
  608. Result := Def;
  609. end;
  610. function ConvertEraString(Count ,Year,Month,Day : integer) : string;
  611. var
  612. ASystemTime: TSystemTime;
  613. buf: array[0..100] of char;
  614. ALCID : LCID;
  615. PriLangID : Word;
  616. SubLangID : Word;
  617. begin
  618. Result := ''; if (Count<=0) then exit;
  619. DateTimeToSystemTime(EncodeDate(Year,Month,Day),ASystemTime);
  620. ALCID := GetThreadLocale;
  621. // ALCID := SysLocale.DefaultLCID;
  622. if GetDateFormatA(ALCID , DATE_USE_ALT_CALENDAR
  623. , @ASystemTime, PChar('gg')
  624. , @buf, SizeOf(buf)) > 0 then
  625. begin
  626. Result := buf;
  627. if Count = 1 then
  628. begin
  629. PriLangID := ALCID and $3FF;
  630. SubLangID := (ALCID and $FFFF) shr 10;
  631. case PriLangID of
  632. LANG_JAPANESE:
  633. begin
  634. Result := Copy(WideString(Result),1,1);
  635. end;
  636. LANG_CHINESE:
  637. if (SubLangID = SUBLANG_CHINESE_TRADITIONAL) then
  638. begin
  639. Result := Copy(WideString(Result),1,1);
  640. end;
  641. end;
  642. end;
  643. end;
  644. // if Result = '' then Result := StringOfChar('G',Count);
  645. end;
  646. function ConvertEraYearString(Count ,Year,Month,Day : integer) : string;
  647. var
  648. ALCID : LCID;
  649. ASystemTime : TSystemTime;
  650. AFormatText : string;
  651. buf : array[0..100] of Char;
  652. begin
  653. Result := '';
  654. DateTimeToSystemTime(EncodeDate(Year,Month,Day),ASystemTime);
  655. if Count <= 2 then
  656. AFormatText := 'yy'
  657. else
  658. AFormatText := 'yyyy';
  659. ALCID := GetThreadLocale;
  660. // ALCID := SysLocale.DefaultLCID;
  661. if GetDateFormatA(ALCID, DATE_USE_ALT_CALENDAR
  662. , @ASystemTime, PChar(AFormatText)
  663. , @buf, SizeOf(buf)) > 0 then
  664. begin
  665. Result := buf;
  666. if (Count = 1) and (Result[1] = '0') then
  667. Result := Copy(Result, 2, Length(Result)-1);
  668. end;
  669. end;
  670. Function GetLocaleInt(LID,TP,Def: LongInt): LongInt;
  671. Var
  672. S: String;
  673. C: Integer;
  674. Begin
  675. S:=GetLocaleStr(LID,TP,'0');
  676. Val(S,Result,C);
  677. If C<>0 Then
  678. Result:=Def;
  679. End;
  680. function EnumEraNames(Names: PChar): WINBOOL; stdcall;
  681. var
  682. i : integer;
  683. begin
  684. Result := False;
  685. for i := Low(EraNames) to High(EraNames) do
  686. if (EraNames[i] = '') then
  687. begin
  688. EraNames[i] := Names;
  689. Result := True;
  690. break;
  691. end;
  692. end;
  693. function EnumEraYearOffsets(YearOffsets: PChar): WINBOOL; stdcall;
  694. var
  695. i : integer;
  696. begin
  697. Result := False;
  698. for i := Low(EraYearOffsets) to High(EraYearOffsets) do
  699. if (EraYearOffsets[i] = -1) then
  700. begin
  701. EraYearOffsets[i] := StrToIntDef(YearOffsets, 0);
  702. Result := True;
  703. break;
  704. end;
  705. end;
  706. procedure GetEraNamesAndYearOffsets;
  707. var
  708. ACALID : CALID;
  709. ALCID : LCID;
  710. buf : array[0..10] of char;
  711. i : integer;
  712. begin
  713. for i:= 1 to MaxEraCount do
  714. begin
  715. EraNames[i] := ''; EraYearOffsets[i] := -1;
  716. end;
  717. ALCID := GetThreadLocale;
  718. if GetLocaleInfoA(ALCID , LOCALE_IOPTIONALCALENDAR, buf, sizeof(buf)) <= 0 then exit;
  719. ACALID := StrToIntDef(buf,1);
  720. if ACALID in [3..5] then
  721. begin
  722. EnumCalendarInfoA(@EnumEraNames, ALCID, ACALID , CAL_SERASTRING);
  723. EnumCalendarInfoA(@EnumEraYearOffsets, ALCID, ACALID, CAL_IYEAROFFSETRANGE);
  724. end;
  725. (*
  726. 1 CAL_GREGORIAN Gregorian (localized)
  727. 2 CAL_GREGORIAN_US Gregorian (English strings always)
  728. 3 CAL_JAPAN Japanese Emperor Era
  729. 4 CAL_TAIWAN Taiwan Calendar
  730. 5 CAL_KOREA Korean Tangun Era
  731. 6 CAL_HIJRI Hijri (Arabic Lunar)
  732. 7 CAL_THAI Thai
  733. 8 CAL_HEBREW Hebrew (Lunar)
  734. 9 CAL_GREGORIAN_ME_FRENCH Gregorian Middle East French
  735. 10 CAL_GREGORIAN_ARABIC Gregorian Arabic
  736. 11 CAL_GREGORIAN_XLIT_ENGLISH Gregorian transliterated English
  737. 12 CAL_GREGORIAN_XLIT_FRENCH Gregorian transliterated French
  738. 23 CAL_UMALQURA Windows Vista or later: Um Al Qura (Arabic lunar) calendar
  739. *)
  740. end;
  741. procedure GetLocaleFormatSettings(LCID: Integer; var FormatSettings: TFormatSettings);
  742. var
  743. HF : Shortstring;
  744. LID : Windows.LCID;
  745. I,Day : longint;
  746. begin
  747. LID := LCID;
  748. with FormatSettings do
  749. begin
  750. { Date stuff }
  751. for I := 1 to 12 do
  752. begin
  753. ShortMonthNames[I]:=GetLocaleStr(LID,LOCALE_SABBREVMONTHNAME1+I-1,ShortMonthNames[i]);
  754. LongMonthNames[I]:=GetLocaleStr(LID,LOCALE_SMONTHNAME1+I-1,LongMonthNames[i]);
  755. end;
  756. for I := 1 to 7 do
  757. begin
  758. Day := (I + 5) mod 7;
  759. ShortDayNames[I]:=GetLocaleStr(LID,LOCALE_SABBREVDAYNAME1+Day,ShortDayNames[i]);
  760. LongDayNames[I]:=GetLocaleStr(LID,LOCALE_SDAYNAME1+Day,LongDayNames[i]);
  761. end;
  762. DateSeparator := GetLocaleChar(LID, LOCALE_SDATE, '/');
  763. ShortDateFormat := GetLocaleStr(LID, LOCALE_SSHORTDATE, 'm/d/yy');
  764. LongDateFormat := GetLocaleStr(LID, LOCALE_SLONGDATE, 'mmmm d, yyyy');
  765. { Time stuff }
  766. TimeSeparator := GetLocaleChar(LID, LOCALE_STIME, ':');
  767. TimeAMString := GetLocaleStr(LID, LOCALE_S1159, 'AM');
  768. TimePMString := GetLocaleStr(LID, LOCALE_S2359, 'PM');
  769. if StrToIntDef(GetLocaleStr(LID, LOCALE_ITLZERO, '0'), 0) = 0 then
  770. HF:='h'
  771. else
  772. HF:='hh';
  773. // No support for 12 hour stuff at the moment...
  774. ShortTimeFormat := HF+':nn';
  775. LongTimeFormat := HF + ':nn:ss';
  776. { Currency stuff }
  777. CurrencyString:=GetLocaleStr(LID, LOCALE_SCURRENCY, '');
  778. CurrencyFormat:=StrToIntDef(GetLocaleStr(LID, LOCALE_ICURRENCY, '0'), 0);
  779. NegCurrFormat:=StrToIntDef(GetLocaleStr(LID, LOCALE_INEGCURR, '0'), 0);
  780. { Number stuff }
  781. ThousandSeparator:=GetLocaleChar(LID, LOCALE_STHOUSAND, ',');
  782. DecimalSeparator:=GetLocaleChar(LID, LOCALE_SDECIMAL, '.');
  783. CurrencyDecimals:=StrToIntDef(GetLocaleStr(LID, LOCALE_ICURRDIGITS, '0'), 0);
  784. ListSeparator := GetLocaleChar(LID, LOCALE_SLIST, ',');
  785. end;
  786. end;
  787. procedure GetFormatSettings;
  788. begin
  789. GetlocaleFormatSettings(GetThreadLocale, DefaultFormatSettings);
  790. end;
  791. Procedure InitInternational;
  792. var
  793. { A call to GetSystemMetrics changes the value of the 8087 Control Word on
  794. Pentium4 with WinXP SP2 }
  795. old8087CW: word;
  796. DefaultCustomLocaleID : LCID; // typedef DWORD LCID;
  797. DefaultCustomLanguageID : Word; // typedef WORD LANGID;
  798. begin
  799. /// workaround for Windows 7 bug, see bug report #18574
  800. SetThreadLocale(GetUserDefaultLCID);
  801. InitInternationalGeneric;
  802. old8087CW:=Get8087CW;
  803. SysLocale.MBCS:=GetSystemMetrics(SM_DBCSENABLED)<>0;
  804. SysLocale.RightToLeft:=GetSystemMetrics(SM_MIDEASTENABLED)<>0;
  805. SysLocale.DefaultLCID := $0409;
  806. SysLocale.PriLangID := LANG_ENGLISH;
  807. SysLocale.SubLangID := SUBLANG_ENGLISH_US;
  808. // probably needs update with getthreadlocale. post 2.0.2
  809. DefaultCustomLocaleID := GetThreadLocale;
  810. if DefaultCustomLocaleID <> 0 then
  811. begin
  812. { Locale Identifiers
  813. +-------------+---------+-------------------------+
  814. | Reserved | Sort ID | Language ID |
  815. +-------------+---------+-------------------------+
  816. 31 20 19 16 15 0 bit }
  817. DefaultCustomLanguageID := DefaultCustomLocaleID and $FFFF; // 2^16
  818. if DefaultCustomLanguageID <> 0 then
  819. begin
  820. SysLocale.DefaultLCID := DefaultCustomLocaleID;
  821. { Language Identifiers
  822. +-------------------------+-------------------------+
  823. | SubLanguage ID | Primary Language ID |
  824. +-------------------------+-------------------------+
  825. 15 10 9 0 bit }
  826. SysLocale.PriLangID := DefaultCustomLanguageID and $3ff; // 2^10
  827. SysLocale.SubLangID := DefaultCustomLanguageID shr 10;
  828. end;
  829. end;
  830. Set8087CW(old8087CW);
  831. GetFormatSettings;
  832. if SysLocale.FarEast then GetEraNamesAndYearOffsets;
  833. end;
  834. {****************************************************************************
  835. Target Dependent
  836. ****************************************************************************}
  837. function SysErrorMessage(ErrorCode: Integer): String;
  838. const
  839. MaxMsgSize = Format_Message_Max_Width_Mask;
  840. var
  841. MsgBuffer: unicodestring;
  842. len: longint;
  843. begin
  844. SetLength(MsgBuffer, MaxMsgSize);
  845. len := FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
  846. nil,
  847. ErrorCode,
  848. MakeLangId(LANG_NEUTRAL, SUBLANG_DEFAULT),
  849. PUnicodeChar(MsgBuffer),
  850. MaxMsgSize,
  851. nil);
  852. // Remove trailing #13#10
  853. if (len > 1) and (MsgBuffer[len - 1] = #13) and (MsgBuffer[len] = #10) then
  854. Dec(len, 2);
  855. SetLength(MsgBuffer, len);
  856. Result := MsgBuffer;
  857. end;
  858. {****************************************************************************
  859. Initialization code
  860. ****************************************************************************}
  861. {$push}
  862. { GetEnvironmentStrings cannot be checked by CheckPointer function }
  863. {$checkpointer off}
  864. Function GetEnvironmentVariable(Const EnvVar : String) : String;
  865. var
  866. oemenvvar, oemstr : RawByteString;
  867. i, hplen : longint;
  868. hp,p : pchar;
  869. begin
  870. oemenvvar:=uppercase(envvar);
  871. SetCodePage(oemenvvar,CP_OEMCP);
  872. Result:='';
  873. p:=GetEnvironmentStringsA;
  874. hp:=p;
  875. while hp^<>#0 do
  876. begin
  877. oemstr:=hp;
  878. { cache length, may change after uppercasing depending on code page }
  879. hplen:=length(oemstr);
  880. { all environment variables are encoded in the oem code page }
  881. SetCodePage(oemstr,CP_OEMCP,false);
  882. i:=pos('=',oemstr);
  883. if uppercase(copy(oemstr,1,i-1))=oemenvvar then
  884. begin
  885. Result:=copy(oemstr,i+1,length(oemstr)-i);
  886. break;
  887. end;
  888. { next string entry}
  889. hp:=hp+hplen+1;
  890. end;
  891. FreeEnvironmentStringsA(p);
  892. end;
  893. Function GetEnvironmentVariable(Const EnvVar : UnicodeString) : UnicodeString;
  894. var
  895. s, upperenv : Unicodestring;
  896. i : longint;
  897. hp,p : pwidechar;
  898. begin
  899. Result:='';
  900. p:=GetEnvironmentStringsW;
  901. hp:=p;
  902. upperenv:=uppercase(envvar);
  903. while hp^<>#0 do
  904. begin
  905. s:=hp;
  906. i:=pos('=',s);
  907. if uppercase(copy(s,1,i-1))=upperenv then
  908. begin
  909. Result:=copy(s,i+1,length(s)-i);
  910. break;
  911. end;
  912. { next string entry}
  913. hp:=hp+strlen(hp)+1;
  914. end;
  915. FreeEnvironmentStringsW(p);
  916. end;
  917. Function GetEnvironmentVariableCount : Integer;
  918. var
  919. hp,p : pchar;
  920. begin
  921. Result:=0;
  922. p:=GetEnvironmentStringsA;
  923. hp:=p;
  924. If (Hp<>Nil) then
  925. while hp^<>#0 do
  926. begin
  927. Inc(Result);
  928. hp:=hp+strlen(hp)+1;
  929. end;
  930. FreeEnvironmentStringsA(p);
  931. end;
  932. Function GetEnvironmentString(Index : Integer) : {$ifdef FPC_RTL_UNICODE}UnicodeString{$else}AnsiString{$endif};
  933. var
  934. hp,p : pchar;
  935. {$ifdef FPC_RTL_UNICODE}
  936. tmpstr : RawByteString;
  937. {$endif}
  938. begin
  939. Result:='';
  940. p:=GetEnvironmentStringsA;
  941. hp:=p;
  942. If (Hp<>Nil) then
  943. begin
  944. while (hp^<>#0) and (Index>1) do
  945. begin
  946. Dec(Index);
  947. hp:=hp+strlen(hp)+1;
  948. end;
  949. If (hp^<>#0) then
  950. begin
  951. {$ifdef FPC_RTL_UNICODE}
  952. tmpstr:=hp;
  953. SetCodePage(tmpstr,CP_OEMCP,false);
  954. Result:=tmpstr;
  955. {$else}
  956. Result:=hp;
  957. SetCodePage(RawByteString(Result),CP_OEMCP,false);
  958. {$endif}
  959. end;
  960. end;
  961. FreeEnvironmentStringsA(p);
  962. end;
  963. {$pop}
  964. function ExecuteProcess(Const Path: AnsiString; Const ComLine: AnsiString;Flags:TExecuteFlags=[]):integer;
  965. // win specific function
  966. var
  967. SI: TStartupInfo;
  968. PI: TProcessInformation;
  969. Proc : THandle;
  970. l : DWord;
  971. CommandLine : ansistring;
  972. e : EOSError;
  973. ExecInherits : longbool;
  974. begin
  975. FillChar(SI, SizeOf(SI), 0);
  976. SI.cb:=SizeOf(SI);
  977. SI.wShowWindow:=1;
  978. { always surround the name of the application by quotes
  979. so that long filenames will always be accepted. But don't
  980. do it if there are already double quotes, since Win32 does not
  981. like double quotes which are duplicated!
  982. }
  983. if pos('"',path)=0 then
  984. CommandLine:='"'+path+'"'
  985. else
  986. CommandLine:=path;
  987. if ComLine <> '' then
  988. CommandLine:=Commandline+' '+ComLine+#0
  989. else
  990. CommandLine := CommandLine + #0;
  991. ExecInherits:=ExecInheritsHandles in Flags;
  992. if not CreateProcessA(nil, pchar(CommandLine),
  993. Nil, Nil, ExecInherits,$20, Nil, Nil, SI, PI) then
  994. begin
  995. e:=EOSError.CreateFmt(SExecuteProcessFailed,[CommandLine,GetLastError]);
  996. e.ErrorCode:=GetLastError;
  997. raise e;
  998. end;
  999. Proc:=PI.hProcess;
  1000. if WaitForSingleObject(Proc, dword($ffffffff)) <> $ffffffff then
  1001. begin
  1002. GetExitCodeProcess(Proc,l);
  1003. CloseHandle(Proc);
  1004. CloseHandle(PI.hThread);
  1005. result:=l;
  1006. end
  1007. else
  1008. begin
  1009. e:=EOSError.CreateFmt(SExecuteProcessFailed,[CommandLine,GetLastError]);
  1010. e.ErrorCode:=GetLastError;
  1011. CloseHandle(Proc);
  1012. CloseHandle(PI.hThread);
  1013. raise e;
  1014. end;
  1015. end;
  1016. function ExecuteProcess(Const Path: AnsiString; Const ComLine: Array of AnsiString;Flags:TExecuteFlags=[]):integer;
  1017. var
  1018. CommandLine: AnsiString;
  1019. I: integer;
  1020. begin
  1021. Commandline := '';
  1022. for I := 0 to High (ComLine) do
  1023. if Pos (' ', ComLine [I]) <> 0 then
  1024. CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
  1025. else
  1026. CommandLine := CommandLine + ' ' + Comline [I];
  1027. ExecuteProcess := ExecuteProcess (Path, CommandLine,Flags);
  1028. end;
  1029. Procedure Sleep(Milliseconds : Cardinal);
  1030. begin
  1031. Windows.Sleep(MilliSeconds)
  1032. end;
  1033. Function GetLastOSError : Integer;
  1034. begin
  1035. Result:=GetLastError;
  1036. end;
  1037. {****************************************************************************
  1038. Initialization code
  1039. ****************************************************************************}
  1040. var
  1041. kernel32dll : THandle;
  1042. Procedure LoadVersionInfo;
  1043. // and getfreespaceex
  1044. Var
  1045. versioninfo : TOSVERSIONINFO;
  1046. begin
  1047. GetDiskFreeSpaceEx:=nil;
  1048. versioninfo.dwOSVersionInfoSize:=sizeof(versioninfo);
  1049. GetVersionEx(versioninfo);
  1050. Win32Platform:=versionInfo.dwPlatformId;
  1051. Win32MajorVersion:=versionInfo.dwMajorVersion;
  1052. Win32MinorVersion:=versionInfo.dwMinorVersion;
  1053. Win32BuildNumber:=versionInfo.dwBuildNumber;
  1054. Move (versioninfo.szCSDVersion ,Win32CSDVersion[1],128);
  1055. win32CSDVersion[0]:=chr(strlen(pchar(@versioninfo.szCSDVersion)));
  1056. kernel32dll:=GetModuleHandle('kernel32');
  1057. if kernel32dll<>0 then
  1058. GetDiskFreeSpaceEx:=TGetDiskFreeSpaceEx(GetProcAddress(kernel32dll,'GetDiskFreeSpaceExA'));
  1059. end;
  1060. Function GetAppConfigDir(Global : Boolean) : String;
  1061. begin
  1062. If Global then
  1063. Result:=GetWindowsSpecialDir(CSIDL_COMMON_APPDATA)
  1064. else
  1065. Result:=GetWindowsSpecialDir(CSIDL_LOCAL_APPDATA);
  1066. If (Result<>'') then
  1067. begin
  1068. if VendorName<>'' then
  1069. Result:=IncludeTrailingPathDelimiter(Result+VendorName);
  1070. Result:=IncludeTrailingPathDelimiter(Result+ApplicationName);
  1071. end
  1072. else
  1073. Result:=IncludeTrailingPathDelimiter(DGetAppConfigDir(Global));
  1074. end;
  1075. Function GetAppConfigFile(Global : Boolean; SubDir : Boolean) : String;
  1076. begin
  1077. result:=DGetAppConfigFile(Global,SubDir);
  1078. end;
  1079. Function GetUserDir : String;
  1080. begin
  1081. Result:=GetWindowsSpecialDir(CSIDL_PROFILE);
  1082. end;
  1083. Procedure InitSysConfigDir;
  1084. begin
  1085. SetLength(SysConfigDir, MAX_PATH);
  1086. SetLength(SysConfigDir, GetWindowsDirectoryA(PChar(SysConfigDir), MAX_PATH));
  1087. end;
  1088. {****************************************************************************
  1089. Target Dependent WideString stuff
  1090. ****************************************************************************}
  1091. { This is the case of Win9x. Limited to current locale of course, but it's better
  1092. than not working at all. }
  1093. function DoCompareStringA(P1, P2: PWideChar; L1, L2: PtrUInt; Flags: DWORD): PtrInt;
  1094. var
  1095. a1, a2: AnsiString;
  1096. begin
  1097. if L1>0 then
  1098. widestringmanager.Wide2AnsiMoveProc(P1,a1,DefaultSystemCodePage,L1);
  1099. if L2>0 then
  1100. widestringmanager.Wide2AnsiMoveProc(P2,a2,DefaultSystemCodePage,L2);
  1101. SetLastError(0);
  1102. Result:=CompareStringA(LOCALE_USER_DEFAULT,Flags,pchar(a1),
  1103. length(a1),pchar(a2),length(a2))-2;
  1104. end;
  1105. function DoCompareStringW(P1, P2: PWideChar; L1, L2: PtrUInt; Flags: DWORD): PtrInt;
  1106. begin
  1107. SetLastError(0);
  1108. Result:=CompareStringW(LOCALE_USER_DEFAULT,Flags,P1,L1,P2,L2)-2;
  1109. if GetLastError=0 then
  1110. Exit;
  1111. if GetLastError=ERROR_CALL_NOT_IMPLEMENTED then // Win9x case
  1112. Result:=DoCompareStringA(P1, P2, L1, L2, Flags);
  1113. if GetLastError<>0 then
  1114. RaiseLastOSError;
  1115. end;
  1116. const
  1117. WinAPICompareFlags : array [TCompareOption] of LongWord
  1118. = (LINGUISTIC_IGNORECASE, LINGUISTIC_IGNOREDIACRITIC, NORM_IGNORECASE,
  1119. NORM_IGNOREKANATYPE, NORM_IGNORENONSPACE, NORM_IGNORESYMBOLS, NORM_IGNOREWIDTH,
  1120. NORM_LINGUISTIC_CASING, SORT_DIGITSASNUMBERS, SORT_STRINGSORT);
  1121. function Win32CompareWideString(const s1, s2 : WideString; Options : TCompareOptions) : PtrInt;
  1122. Var
  1123. O : LongWord;
  1124. CO : TCompareOption;
  1125. begin
  1126. O:=0;
  1127. for CO in TCompareOption do
  1128. if CO in Options then
  1129. O:=O or WinAPICompareFlags[CO];
  1130. Result:=DoCompareStringW(PWideChar(s1), PWideChar(s2), Length(s1), Length(s2), O);
  1131. end;
  1132. function Win32CompareTextWideString(const s1, s2 : WideString) : PtrInt;
  1133. begin
  1134. Result:=DoCompareStringW(PWideChar(s1), PWideChar(s2), Length(s1), Length(s2), NORM_IGNORECASE);
  1135. end;
  1136. function Win32AnsiUpperCase(const s: string): string;
  1137. begin
  1138. if length(s)>0 then
  1139. begin
  1140. result:=s;
  1141. UniqueString(result);
  1142. CharUpperBuffA(pchar(result),length(result));
  1143. end
  1144. else
  1145. result:='';
  1146. end;
  1147. function Win32AnsiLowerCase(const s: string): string;
  1148. begin
  1149. if length(s)>0 then
  1150. begin
  1151. result:=s;
  1152. UniqueString(result);
  1153. CharLowerBuffA(pchar(result),length(result));
  1154. end
  1155. else
  1156. result:='';
  1157. end;
  1158. function Win32AnsiCompareStr(const S1, S2: string): PtrInt;
  1159. begin
  1160. result:=CompareStringA(LOCALE_USER_DEFAULT,0,pchar(s1),length(s1),
  1161. pchar(s2),length(s2))-2;
  1162. end;
  1163. function Win32AnsiCompareText(const S1, S2: string): PtrInt;
  1164. begin
  1165. result:=CompareStringA(LOCALE_USER_DEFAULT,NORM_IGNORECASE,pchar(s1),length(s1),
  1166. pchar(s2),length(s2))-2;
  1167. end;
  1168. function Win32AnsiStrComp(S1, S2: PChar): PtrInt;
  1169. begin
  1170. result:=CompareStringA(LOCALE_USER_DEFAULT,0,s1,-1,s2,-1)-2;
  1171. end;
  1172. function Win32AnsiStrIComp(S1, S2: PChar): PtrInt;
  1173. begin
  1174. result:=CompareStringA(LOCALE_USER_DEFAULT,NORM_IGNORECASE,s1,-1,s2,-1)-2;
  1175. end;
  1176. function Win32AnsiStrLComp(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
  1177. begin
  1178. result:=CompareStringA(LOCALE_USER_DEFAULT,0,s1,maxlen,s2,maxlen)-2;
  1179. end;
  1180. function Win32AnsiStrLIComp(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
  1181. begin
  1182. result:=CompareStringA(LOCALE_USER_DEFAULT,NORM_IGNORECASE,s1,maxlen,s2,maxlen)-2;
  1183. end;
  1184. function Win32AnsiStrLower(Str: PChar): PChar;
  1185. begin
  1186. CharLowerA(str);
  1187. result:=str;
  1188. end;
  1189. function Win32AnsiStrUpper(Str: PChar): PChar;
  1190. begin
  1191. CharUpperA(str);
  1192. result:=str;
  1193. end;
  1194. function Win32CompareUnicodeString(const s1, s2 : UnicodeString; Options : TCompareOptions) : PtrInt;
  1195. Var
  1196. O : LongWord;
  1197. CO : TCompareOption;
  1198. begin
  1199. O:=0;
  1200. for CO in TCompareOption do
  1201. if CO in Options then
  1202. O:=O or WinAPICompareFlags[CO];
  1203. Result:=DoCompareStringW(PWideChar(s1), PWideChar(s2), Length(s1), Length(s2), O);
  1204. end;
  1205. function Win32CompareTextUnicodeString(const s1, s2 : UnicodeString) : PtrInt;
  1206. begin
  1207. Result:=DoCompareStringW(PWideChar(s1), PWideChar(s2), Length(s1), Length(s2), NORM_IGNORECASE);
  1208. end;
  1209. { there is a similiar procedure in the system unit which inits the fields which
  1210. are relevant already for the system unit }
  1211. procedure InitWin32Widestrings;
  1212. begin
  1213. { return value: number of code points in the string. Whenever an invalid
  1214. code point is encountered, all characters part of this invalid code point
  1215. are considered to form one "character" and the next character is
  1216. considered to be the start of a new (possibly also invalid) code point }
  1217. //!!! CharLengthPCharProc : function(const Str: PChar): PtrInt;
  1218. { return value:
  1219. -1 if incomplete or invalid code point
  1220. 0 if NULL character,
  1221. > 0 if that's the length in bytes of the code point }
  1222. //!!!! CodePointLengthProc : function(const Str: PChar; MaxLookAead: PtrInt): Ptrint;
  1223. widestringmanager.CompareWideStringProc:=@Win32CompareWideString;
  1224. widestringmanager.UpperAnsiStringProc:=@Win32AnsiUpperCase;
  1225. widestringmanager.LowerAnsiStringProc:=@Win32AnsiLowerCase;
  1226. widestringmanager.CompareStrAnsiStringProc:=@Win32AnsiCompareStr;
  1227. widestringmanager.CompareTextAnsiStringProc:=@Win32AnsiCompareText;
  1228. widestringmanager.StrCompAnsiStringProc:=@Win32AnsiStrComp;
  1229. widestringmanager.StrICompAnsiStringProc:=@Win32AnsiStrIComp;
  1230. widestringmanager.StrLCompAnsiStringProc:=@Win32AnsiStrLComp;
  1231. widestringmanager.StrLICompAnsiStringProc:=@Win32AnsiStrLIComp;
  1232. widestringmanager.StrLowerAnsiStringProc:=@Win32AnsiStrLower;
  1233. widestringmanager.StrUpperAnsiStringProc:=@Win32AnsiStrUpper;
  1234. widestringmanager.CompareUnicodeStringProc:=@Win32CompareUnicodeString;
  1235. end;
  1236. { Platform-specific exception support }
  1237. function WinExceptionObject(code: Longint; const rec: TExceptionRecord): Exception;
  1238. var
  1239. entry: PExceptMapEntry;
  1240. begin
  1241. entry := FindExceptMapEntry(code);
  1242. if assigned(entry) then
  1243. result:=entry^.cls.CreateRes(entry^.msg)
  1244. else
  1245. result:=EExternalException.CreateResFmt(@SExternalException,[rec.ExceptionCode]);
  1246. if result is EExternal then
  1247. EExternal(result).FExceptionRecord:=rec;
  1248. end;
  1249. function WinExceptionClass(code: longint): ExceptClass;
  1250. var
  1251. entry: PExceptMapEntry;
  1252. begin
  1253. entry := FindExceptMapEntry(code);
  1254. if assigned(entry) then
  1255. result:=entry^.cls
  1256. else
  1257. result:=EExternalException;
  1258. end;
  1259. Initialization
  1260. InitWin32Widestrings;
  1261. InitExceptions; { Initialize exceptions. OS independent }
  1262. {$ifdef mswindows} { Keeps exe size down for systems that do not use SEH }
  1263. ExceptObjProc:=@WinExceptionObject;
  1264. ExceptClsProc:=@WinExceptionClass;
  1265. {$endif mswindows}
  1266. InitInternational; { Initialize internationalization settings }
  1267. LoadVersionInfo;
  1268. InitSysConfigDir;
  1269. OnBeep:=@SysBeep;
  1270. Finalization
  1271. DoneExceptions;
  1272. end.