sysutils.pp 35 KB

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