sysutils.pp 34 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251
  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. { force ansistrings }
  16. {$H+}
  17. uses
  18. windows;
  19. {$DEFINE HAS_SLEEP}
  20. {$DEFINE HAS_OSERROR}
  21. {$DEFINE HAS_OSCONFIG}
  22. {$DEFINE HAS_OSUSERDIR}
  23. {$DEFINE HAS_CREATEGUID}
  24. { Include platform independent interface part }
  25. {$i sysutilh.inc}
  26. type
  27. TSystemTime = Windows.TSystemTime;
  28. EWin32Error = class(Exception)
  29. public
  30. ErrorCode : DWORD;
  31. end;
  32. Var
  33. Win32Platform : Longint;
  34. Win32MajorVersion,
  35. Win32MinorVersion,
  36. Win32BuildNumber : dword;
  37. Win32CSDVersion : ShortString; // CSD record is 128 bytes only?
  38. Const
  39. { it can be discussed whether fmShareDenyNone means read and write or read, write and delete, see
  40. also http://bugs.freepascal.org/view.php?id=8898, this allows users to configure the used
  41. value
  42. }
  43. fmShareDenyNoneFlags : DWord = 3;
  44. { Compatibility with Delphi }
  45. function Win32Check(res:boolean):boolean;inline;
  46. function WinCheck(res:boolean):boolean;
  47. function CheckWin32Version(Major,Minor : Integer ): Boolean;
  48. function CheckWin32Version(Major : Integer): Boolean;
  49. Procedure RaiseLastWin32Error;
  50. function GetFileVersion(const AFileName: string): Cardinal;
  51. procedure GetFormatSettings;
  52. implementation
  53. uses
  54. sysconst;
  55. function WinCheck(res:boolean):boolean;
  56. begin
  57. if not res then
  58. RaiseLastOSError;
  59. result:=res;
  60. end;
  61. function Win32Check(res:boolean):boolean;inline;
  62. begin
  63. result:=WinCheck(res);
  64. end;
  65. procedure RaiseLastWin32Error;
  66. begin
  67. RaiseLastOSError;
  68. end;
  69. function CheckWin32Version(Major : Integer): Boolean;
  70. begin
  71. Result:=CheckWin32Version(Major,0)
  72. end;
  73. function CheckWin32Version(Major,Minor: Integer): Boolean;
  74. begin
  75. Result:=(Win32MajorVersion>dword(Major)) or
  76. ((Win32MajorVersion=dword(Major)) and (Win32MinorVersion>=dword(Minor)));
  77. end;
  78. function GetFileVersion(const AFileName:string):Cardinal;
  79. var
  80. { usefull only as long as we don't need to touch different stack pages }
  81. buf : array[0..3071] of byte;
  82. bufp : pointer;
  83. fn : string;
  84. valsize,
  85. size : DWORD;
  86. h : DWORD;
  87. valrec : PVSFixedFileInfo;
  88. begin
  89. result:=$fffffff;
  90. fn:=AFileName;
  91. UniqueString(fn);
  92. size:=GetFileVersionInfoSize(pchar(fn),@h);
  93. if size>sizeof(buf) then
  94. begin
  95. getmem(bufp,size);
  96. try
  97. if GetFileVersionInfo(pchar(fn),h,size,bufp) then
  98. if VerQueryValue(bufp,'\',valrec,valsize) then
  99. result:=valrec^.dwFileVersionMS;
  100. finally
  101. freemem(bufp);
  102. end;
  103. end
  104. else
  105. begin
  106. if GetFileVersionInfo(pchar(fn),h,size,@buf) then
  107. if VerQueryValue(@buf,'\',valrec,valsize) then
  108. result:=valrec^.dwFileVersionMS;
  109. end;
  110. end;
  111. {$define HASCREATEGUID}
  112. {$define HASEXPANDUNCFILENAME}
  113. {$DEFINE FPC_NOGENERICANSIROUTINES}
  114. {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
  115. {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
  116. { Include platform independent implementation part }
  117. {$i sysutils.inc}
  118. function SysGetTempFileName(lpPathName:LPCSTR;
  119. lpPrefixString:LPCSTR;
  120. uUnique:UINT;
  121. lpTempFileName:LPSTR):UINT;stdcall;external 'kernel32' name 'GetTempFileNameA';
  122. function GetTempFileName(Dir,Prefix: PChar; uUnique: DWORD; TempFileName: PChar):DWORD;
  123. begin
  124. Result:=SysGetTempFileName(Dir,Prefix,uUnique,TempFileName);
  125. end;
  126. { UUID generation. }
  127. function CoCreateGuid(out guid: TGUID): HResult; stdcall; external 'ole32.dll' name 'CoCreateGuid';
  128. function SysCreateGUID(out Guid: TGUID): Integer;
  129. begin
  130. Result := Integer(CoCreateGuid(Guid));
  131. end;
  132. function ExpandUNCFileName (const filename:string) : string;
  133. { returns empty string on errors }
  134. var
  135. s : ansistring;
  136. size : dword;
  137. rc : dword;
  138. buf : pchar;
  139. begin
  140. s := ExpandFileName (filename);
  141. s := s + #0;
  142. size := max_path;
  143. getmem(buf,size);
  144. try
  145. rc := WNetGetUniversalName (pchar(s), UNIVERSAL_NAME_INFO_LEVEL, buf, @size);
  146. if rc=ERROR_MORE_DATA then
  147. begin
  148. buf:=reallocmem(buf,size);
  149. rc := WNetGetUniversalName (pchar(s), UNIVERSAL_NAME_INFO_LEVEL, buf, @size);
  150. end;
  151. if rc = NO_ERROR then
  152. Result := PRemoteNameInfo(buf)^.lpUniversalName
  153. else if rc = ERROR_NOT_CONNECTED then
  154. Result := filename
  155. else
  156. Result := '';
  157. finally
  158. freemem(buf);
  159. end;
  160. end;
  161. {****************************************************************************
  162. File Functions
  163. ****************************************************************************}
  164. var
  165. SetFilePointerEx : function(hFile : THandle;
  166. liDistanceToMove : int64;lpNewFilePointer : pint64;
  167. dwMoveMethod : DWord) : ByteBool;stdcall;
  168. Function FileOpen (Const FileName : string; Mode : Integer) : THandle;
  169. const
  170. AccessMode: array[0..2] of Cardinal = (
  171. GENERIC_READ,
  172. GENERIC_WRITE,
  173. GENERIC_READ or GENERIC_WRITE);
  174. ShareMode: array[0..4] of Integer = (
  175. 0,
  176. 0,
  177. FILE_SHARE_READ,
  178. FILE_SHARE_WRITE,
  179. FILE_SHARE_READ or FILE_SHARE_WRITE);
  180. Var
  181. FN : string;
  182. begin
  183. FN:=FileName+#0;
  184. result := CreateFile(@FN[1], dword(AccessMode[Mode and 3]),
  185. dword(ShareMode[(Mode and $F0) shr 4]), nil, OPEN_EXISTING,
  186. FILE_ATTRIBUTE_NORMAL, 0);
  187. //if fail api return feInvalidHandle (INVALIDE_HANDLE=feInvalidHandle=-1)
  188. end;
  189. Function FileCreate (Const FileName : String) : THandle;
  190. Var
  191. FN : string;
  192. begin
  193. FN:=FileName+#0;
  194. Result := CreateFile(@FN[1], GENERIC_READ or GENERIC_WRITE,
  195. 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
  196. end;
  197. Function FileCreate (Const FileName : String; Mode:longint) : THandle;
  198. begin
  199. FileCreate:=FileCreate(FileName);
  200. end;
  201. Function FileRead (Handle : THandle; Var Buffer; Count : longint) : Longint;
  202. Var
  203. res : dword;
  204. begin
  205. if ReadFile(Handle, Buffer, Count, res, nil) then
  206. FileRead:=Res
  207. else
  208. FileRead:=-1;
  209. end;
  210. Function FileWrite (Handle : THandle; const Buffer; Count : Longint) : Longint;
  211. Var
  212. Res : dword;
  213. begin
  214. if WriteFile(Handle, Buffer, Count, Res, nil) then
  215. FileWrite:=Res
  216. else
  217. FileWrite:=-1;
  218. end;
  219. Function FileSeek (Handle : THandle;FOffset,Origin : Longint) : Longint;
  220. begin
  221. Result := longint(SetFilePointer(Handle, FOffset, nil, Origin));
  222. end;
  223. Function FileSeek (Handle : THandle; FOffset: Int64; Origin: Longint) : Int64;
  224. begin
  225. if assigned(SetFilePointerEx) then
  226. begin
  227. if not(SetFilePointerEx(Handle, FOffset, @result, Origin)) then
  228. Result:=-1;
  229. end
  230. else
  231. Result:=longint(SetFilePointer(Handle, FOffset, nil, Origin));
  232. end;
  233. Procedure FileClose (Handle : THandle);
  234. begin
  235. if Handle<=4 then
  236. exit;
  237. CloseHandle(Handle);
  238. end;
  239. Function FileTruncate (Handle : THandle;Size: Int64) : boolean;
  240. begin
  241. {
  242. Result:=longint(SetFilePointer(handle,Size,nil,FILE_BEGIN))<>-1;
  243. }
  244. if FileSeek (Handle, Size, FILE_BEGIN) = Size then
  245. Result:=SetEndOfFile(handle)
  246. else
  247. Result := false;
  248. end;
  249. Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):longbool;
  250. var
  251. lft : TFileTime;
  252. begin
  253. DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,@lft) and
  254. LocalFileTimeToFileTime(lft,Wtime);
  255. end;
  256. Function WinToDosTime (Var Wtime : TFileTime;var DTime:longint):longbool;
  257. var
  258. lft : TFileTime;
  259. begin
  260. WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
  261. FileTimeToDosDateTime(lft,Longrec(Dtime).Hi,LongRec(DTIME).lo);
  262. end;
  263. Function FileAge (Const FileName : String): Longint;
  264. var
  265. Handle: THandle;
  266. FindData: TWin32FindData;
  267. begin
  268. Handle := FindFirstFile(Pchar(FileName), FindData);
  269. if Handle <> INVALID_HANDLE_VALUE then
  270. begin
  271. Windows.FindClose(Handle);
  272. if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
  273. If WinToDosTime(FindData.ftLastWriteTime,Result) then
  274. exit;
  275. end;
  276. Result := -1;
  277. end;
  278. Function FileExists (Const FileName : String) : Boolean;
  279. var
  280. Attr:Dword;
  281. begin
  282. Attr:=GetFileAttributes(PChar(FileName));
  283. if Attr <> $ffffffff then
  284. Result:= (Attr and FILE_ATTRIBUTE_DIRECTORY) = 0
  285. else
  286. Result:=False;
  287. end;
  288. Function DirectoryExists (Const Directory : String) : Boolean;
  289. var
  290. Attr:Dword;
  291. begin
  292. Attr:=GetFileAttributes(PChar(Directory));
  293. if Attr <> $ffffffff then
  294. Result:= (Attr and FILE_ATTRIBUTE_DIRECTORY) > 0
  295. else
  296. Result:=False;
  297. end;
  298. Function FindMatch(var f: TSearchRec) : Longint;
  299. begin
  300. { Find file with correct attribute }
  301. While (F.FindData.dwFileAttributes and cardinal(F.ExcludeAttr))<>0 do
  302. begin
  303. if not FindNextFile (F.FindHandle,F.FindData) then
  304. begin
  305. Result:=GetLastError;
  306. exit;
  307. end;
  308. end;
  309. { Convert some attributes back }
  310. WinToDosTime(F.FindData.ftLastWriteTime,F.Time);
  311. f.size:=F.FindData.NFileSizeLow+(qword(maxdword)+1)*F.FindData.NFileSizeHigh;
  312. f.attr:=F.FindData.dwFileAttributes;
  313. f.Name:=StrPas(@F.FindData.cFileName[0]);
  314. Result:=0;
  315. end;
  316. Function FindFirst (Const Path : String; Attr : Longint; out Rslt : TSearchRec) : Longint;
  317. begin
  318. Rslt.Name:=Path;
  319. Rslt.Attr:=attr;
  320. Rslt.ExcludeAttr:=(not Attr) and ($1e);
  321. { $1e = faHidden or faSysFile or faVolumeID or faDirectory }
  322. { FindFirstFile is a Win32 Call }
  323. Rslt.FindHandle:=FindFirstFile (PChar(Path),Rslt.FindData);
  324. If Rslt.FindHandle=Invalid_Handle_value then
  325. begin
  326. Result:=GetLastError;
  327. exit;
  328. end;
  329. { Find file with correct attribute }
  330. Result:=FindMatch(Rslt);
  331. end;
  332. Function FindNext (Var Rslt : TSearchRec) : Longint;
  333. begin
  334. if FindNextFile(Rslt.FindHandle, Rslt.FindData) then
  335. Result := FindMatch(Rslt)
  336. else
  337. Result := GetLastError;
  338. end;
  339. Procedure FindClose (Var F : TSearchrec);
  340. begin
  341. if F.FindHandle <> INVALID_HANDLE_VALUE then
  342. Windows.FindClose(F.FindHandle);
  343. end;
  344. Function FileGetDate (Handle : THandle) : Longint;
  345. Var
  346. FT : TFileTime;
  347. begin
  348. If GetFileTime(Handle,nil,nil,@ft) and
  349. WinToDosTime(FT,Result) then
  350. exit;
  351. Result:=-1;
  352. end;
  353. Function FileSetDate (Handle : THandle;Age : Longint) : Longint;
  354. Var
  355. FT: TFileTime;
  356. begin
  357. Result := 0;
  358. if DosToWinTime(Age,FT) and
  359. SetFileTime(Handle, nil, nil, @FT) then
  360. Exit;
  361. Result := GetLastError;
  362. end;
  363. Function FileGetAttr (Const FileName : String) : Longint;
  364. begin
  365. Result:=GetFileAttributes(PChar(FileName));
  366. end;
  367. Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
  368. begin
  369. if SetFileAttributes(PChar(FileName), Attr) then
  370. Result:=0
  371. else
  372. Result := GetLastError;
  373. end;
  374. Function DeleteFile (Const FileName : String) : Boolean;
  375. begin
  376. Result:=Windows.DeleteFile(Pchar(FileName));
  377. end;
  378. Function RenameFile (Const OldName, NewName : String) : Boolean;
  379. begin
  380. Result := MoveFile(PChar(OldName), PChar(NewName));
  381. end;
  382. {****************************************************************************
  383. Disk Functions
  384. ****************************************************************************}
  385. function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
  386. freeclusters,totalclusters:longint):longbool;
  387. stdcall;external 'kernel32' name 'GetDiskFreeSpaceA';
  388. type
  389. TGetDiskFreeSpaceEx = function(drive:pchar;var availableforcaller,total,free):longbool;stdcall;
  390. var
  391. GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
  392. function diskfree(drive : byte) : int64;
  393. var
  394. disk : array[1..4] of char;
  395. secs,bytes,
  396. free,total : longint;
  397. qwtotal,qwfree,qwcaller : int64;
  398. begin
  399. if drive=0 then
  400. begin
  401. disk[1]:='\';
  402. disk[2]:=#0;
  403. end
  404. else
  405. begin
  406. disk[1]:=chr(drive+64);
  407. disk[2]:=':';
  408. disk[3]:='\';
  409. disk[4]:=#0;
  410. end;
  411. if assigned(GetDiskFreeSpaceEx) then
  412. begin
  413. if GetDiskFreeSpaceEx(@disk[1],qwcaller,qwtotal,qwfree) then
  414. diskfree:=qwfree
  415. else
  416. diskfree:=-1;
  417. end
  418. else
  419. begin
  420. if GetDiskFreeSpace(@disk[1],secs,bytes,free,total) then
  421. diskfree:=int64(free)*secs*bytes
  422. else
  423. diskfree:=-1;
  424. end;
  425. end;
  426. function disksize(drive : byte) : int64;
  427. var
  428. disk : array[1..4] of char;
  429. secs,bytes,
  430. free,total : longint;
  431. qwtotal,qwfree,qwcaller : int64;
  432. begin
  433. if drive=0 then
  434. begin
  435. disk[1]:='\';
  436. disk[2]:=#0;
  437. end
  438. else
  439. begin
  440. disk[1]:=chr(drive+64);
  441. disk[2]:=':';
  442. disk[3]:='\';
  443. disk[4]:=#0;
  444. end;
  445. if assigned(GetDiskFreeSpaceEx) then
  446. begin
  447. if GetDiskFreeSpaceEx(@disk[1],qwcaller,qwtotal,qwfree) then
  448. disksize:=qwtotal
  449. else
  450. disksize:=-1;
  451. end
  452. else
  453. begin
  454. if GetDiskFreeSpace(@disk[1],secs,bytes,free,total) then
  455. disksize:=int64(total)*secs*bytes
  456. else
  457. disksize:=-1;
  458. end;
  459. end;
  460. Function GetCurrentDir : String;
  461. begin
  462. GetDir(0, result);
  463. end;
  464. Function SetCurrentDir (Const NewDir : String) : Boolean;
  465. begin
  466. Result:=SetCurrentDirectory(PChar(NewDir));
  467. end;
  468. Function CreateDir (Const NewDir : String) : Boolean;
  469. begin
  470. Result:=CreateDirectory(PChar(NewDir),nil);
  471. end;
  472. Function RemoveDir (Const Dir : String) : Boolean;
  473. begin
  474. Result:=RemoveDirectory(PChar(Dir));
  475. end;
  476. {****************************************************************************
  477. Time Functions
  478. ****************************************************************************}
  479. Procedure GetLocalTime(var SystemTime: TSystemTime);
  480. Var
  481. Syst : Windows.TSystemtime;
  482. begin
  483. windows.Getlocaltime(@syst);
  484. SystemTime.year:=syst.wYear;
  485. SystemTime.month:=syst.wMonth;
  486. SystemTime.day:=syst.wDay;
  487. SystemTime.hour:=syst.wHour;
  488. SystemTime.minute:=syst.wMinute;
  489. SystemTime.second:=syst.wSecond;
  490. SystemTime.millisecond:=syst.wMilliSeconds;
  491. end;
  492. {****************************************************************************
  493. Misc Functions
  494. ****************************************************************************}
  495. procedure Beep;
  496. begin
  497. MessageBeep(0);
  498. end;
  499. {****************************************************************************
  500. Locale Functions
  501. ****************************************************************************}
  502. function GetLocaleStr(LID, LT: Longint; const Def: string): ShortString;
  503. var
  504. L: Integer;
  505. Buf: array[0..255] of Char;
  506. begin
  507. L := GetLocaleInfo(LID, LT, Buf, SizeOf(Buf));
  508. if L > 0 then
  509. SetString(Result, @Buf[0], L - 1)
  510. else
  511. Result := Def;
  512. end;
  513. function GetLocaleChar(LID, LT: Longint; Def: Char): Char;
  514. var
  515. Buf: array[0..1] of Char;
  516. begin
  517. if GetLocaleInfo(LID, LT, Buf, 2) > 0 then
  518. Result := Buf[0]
  519. else
  520. Result := Def;
  521. end;
  522. Function GetLocaleInt(LID,TP,Def: LongInt): LongInt;
  523. Var
  524. S: String;
  525. C: Integer;
  526. Begin
  527. S:=GetLocaleStr(LID,TP,'0');
  528. Val(S,Result,C);
  529. If C<>0 Then
  530. Result:=Def;
  531. End;
  532. procedure GetFormatSettings;
  533. var
  534. HF : Shortstring;
  535. LID : LCID;
  536. I,Day : longint;
  537. begin
  538. LID := GetThreadLocale;
  539. { Date stuff }
  540. for I := 1 to 12 do
  541. begin
  542. ShortMonthNames[I]:=GetLocaleStr(LID,LOCALE_SABBREVMONTHNAME1+I-1,ShortMonthNames[i]);
  543. LongMonthNames[I]:=GetLocaleStr(LID,LOCALE_SMONTHNAME1+I-1,LongMonthNames[i]);
  544. end;
  545. for I := 1 to 7 do
  546. begin
  547. Day := (I + 5) mod 7;
  548. ShortDayNames[I]:=GetLocaleStr(LID,LOCALE_SABBREVDAYNAME1+Day,ShortDayNames[i]);
  549. LongDayNames[I]:=GetLocaleStr(LID,LOCALE_SDAYNAME1+Day,LongDayNames[i]);
  550. end;
  551. DateSeparator := GetLocaleChar(LID, LOCALE_SDATE, '/');
  552. ShortDateFormat := GetLocaleStr(LID, LOCALE_SSHORTDATE, 'm/d/yy');
  553. LongDateFormat := GetLocaleStr(LID, LOCALE_SLONGDATE, 'mmmm d, yyyy');
  554. { Time stuff }
  555. TimeSeparator := GetLocaleChar(LID, LOCALE_STIME, ':');
  556. TimeAMString := GetLocaleStr(LID, LOCALE_S1159, 'AM');
  557. TimePMString := GetLocaleStr(LID, LOCALE_S2359, 'PM');
  558. if StrToIntDef(GetLocaleStr(LID, LOCALE_ITLZERO, '0'), 0) = 0 then
  559. HF:='h'
  560. else
  561. HF:='hh';
  562. // No support for 12 hour stuff at the moment...
  563. ShortTimeFormat := HF+':nn';
  564. LongTimeFormat := HF + ':nn:ss';
  565. { Currency stuff }
  566. CurrencyString:=GetLocaleStr(LID, LOCALE_SCURRENCY, '');
  567. CurrencyFormat:=StrToIntDef(GetLocaleStr(LID, LOCALE_ICURRENCY, '0'), 0);
  568. NegCurrFormat:=StrToIntDef(GetLocaleStr(LID, LOCALE_INEGCURR, '0'), 0);
  569. { Number stuff }
  570. ThousandSeparator:=GetLocaleChar(LID, LOCALE_STHOUSAND, ',');
  571. DecimalSeparator:=GetLocaleChar(LID, LOCALE_SDECIMAL, '.');
  572. CurrencyDecimals:=StrToIntDef(GetLocaleStr(LID, LOCALE_ICURRDIGITS, '0'), 0);
  573. end;
  574. Procedure InitInternational;
  575. var
  576. { A call to GetSystemMetrics changes the value of the 8087 Control Word on
  577. Pentium4 with WinXP SP2 }
  578. old8087CW: word;
  579. begin
  580. InitInternationalGeneric;
  581. old8087CW:=Get8087CW;
  582. SysLocale.MBCS:=GetSystemMetrics(SM_DBCSENABLED)<>0;
  583. SysLocale.RightToLeft:=GetSystemMetrics(SM_MIDEASTENABLED)<>0;
  584. SysLocale.DefaultLCID := $0409;
  585. SysLocale.PriLangID := LANG_ENGLISH;
  586. SysLocale.SubLangID := SUBLANG_ENGLISH_US;
  587. // probably needs update with getthreadlocale. post 2.0.2
  588. Set8087CW(old8087CW);
  589. GetFormatSettings;
  590. end;
  591. {****************************************************************************
  592. Target Dependent
  593. ****************************************************************************}
  594. function FormatMessageA(dwFlags : DWORD;
  595. lpSource : Pointer;
  596. dwMessageId : DWORD;
  597. dwLanguageId: DWORD;
  598. lpBuffer : PCHAR;
  599. nSize : DWORD;
  600. Arguments : Pointer): DWORD; stdcall;external 'kernel32' name 'FormatMessageA';
  601. function SysErrorMessage(ErrorCode: Integer): String;
  602. const
  603. MaxMsgSize = Format_Message_Max_Width_Mask;
  604. var
  605. MsgBuffer: pChar;
  606. begin
  607. GetMem(MsgBuffer, MaxMsgSize);
  608. FillChar(MsgBuffer^, MaxMsgSize, #0);
  609. FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
  610. nil,
  611. ErrorCode,
  612. MakeLangId(LANG_NEUTRAL, SUBLANG_DEFAULT),
  613. MsgBuffer, { This function allocs the memory }
  614. MaxMsgSize, { Maximum message size }
  615. nil);
  616. SysErrorMessage := StrPas(MsgBuffer);
  617. FreeMem(MsgBuffer, MaxMsgSize);
  618. end;
  619. {****************************************************************************
  620. Initialization code
  621. ****************************************************************************}
  622. Function GetEnvironmentVariable(Const EnvVar : String) : String;
  623. var
  624. s : string;
  625. i : longint;
  626. hp,p : pchar;
  627. begin
  628. Result:='';
  629. p:=GetEnvironmentStrings;
  630. hp:=p;
  631. while hp^<>#0 do
  632. begin
  633. s:=strpas(hp);
  634. i:=pos('=',s);
  635. if uppercase(copy(s,1,i-1))=upcase(envvar) then
  636. begin
  637. Result:=copy(s,i+1,length(s)-i);
  638. break;
  639. end;
  640. { next string entry}
  641. hp:=hp+strlen(hp)+1;
  642. end;
  643. FreeEnvironmentStrings(p);
  644. end;
  645. Function GetEnvironmentVariableCount : Integer;
  646. var
  647. hp,p : pchar;
  648. begin
  649. Result:=0;
  650. p:=GetEnvironmentStrings;
  651. hp:=p;
  652. If (Hp<>Nil) then
  653. while hp^<>#0 do
  654. begin
  655. Inc(Result);
  656. hp:=hp+strlen(hp)+1;
  657. end;
  658. FreeEnvironmentStrings(p);
  659. end;
  660. Function GetEnvironmentString(Index : Integer) : String;
  661. var
  662. hp,p : pchar;
  663. begin
  664. Result:='';
  665. p:=GetEnvironmentStrings;
  666. hp:=p;
  667. If (Hp<>Nil) then
  668. begin
  669. while (hp^<>#0) and (Index>1) do
  670. begin
  671. Dec(Index);
  672. hp:=hp+strlen(hp)+1;
  673. end;
  674. If (hp^<>#0) then
  675. Result:=StrPas(HP);
  676. end;
  677. FreeEnvironmentStrings(p);
  678. end;
  679. function ExecuteProcess(Const Path: AnsiString; Const ComLine: AnsiString):integer;
  680. var
  681. SI: TStartupInfo;
  682. PI: TProcessInformation;
  683. Proc : THandle;
  684. l : DWord;
  685. CommandLine : ansistring;
  686. e : EOSError;
  687. begin
  688. FillChar(SI, SizeOf(SI), 0);
  689. SI.cb:=SizeOf(SI);
  690. SI.wShowWindow:=1;
  691. { always surround the name of the application by quotes
  692. so that long filenames will always be accepted. But don't
  693. do it if there are already double quotes, since Win32 does not
  694. like double quotes which are duplicated!
  695. }
  696. if pos('"',path)=0 then
  697. CommandLine:='"'+path+'"'
  698. else
  699. CommandLine:=path;
  700. if ComLine <> '' then
  701. CommandLine:=Commandline+' '+ComLine+#0
  702. else
  703. CommandLine := CommandLine + #0;
  704. if not CreateProcess(nil, pchar(CommandLine),
  705. Nil, Nil, False,$20, Nil, Nil, SI, PI) then
  706. begin
  707. e:=EOSError.CreateFmt(SExecuteProcessFailed,[CommandLine,GetLastError]);
  708. e.ErrorCode:=GetLastError;
  709. raise e;
  710. end;
  711. Proc:=PI.hProcess;
  712. if WaitForSingleObject(Proc, dword($ffffffff)) <> $ffffffff then
  713. begin
  714. GetExitCodeProcess(Proc,l);
  715. CloseHandle(Proc);
  716. CloseHandle(PI.hThread);
  717. result:=l;
  718. end
  719. else
  720. begin
  721. e:=EOSError.CreateFmt(SExecuteProcessFailed,[CommandLine,GetLastError]);
  722. e.ErrorCode:=GetLastError;
  723. CloseHandle(Proc);
  724. CloseHandle(PI.hThread);
  725. raise e;
  726. end;
  727. end;
  728. function ExecuteProcess(Const Path: AnsiString; Const ComLine: Array of AnsiString):integer;
  729. var
  730. CommandLine: AnsiString;
  731. I: integer;
  732. begin
  733. Commandline := '';
  734. for I := 0 to High (ComLine) do
  735. if Pos (' ', ComLine [I]) <> 0 then
  736. CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
  737. else
  738. CommandLine := CommandLine + ' ' + Comline [I];
  739. ExecuteProcess := ExecuteProcess (Path, CommandLine);
  740. end;
  741. Procedure Sleep(Milliseconds : Cardinal);
  742. begin
  743. Windows.Sleep(MilliSeconds)
  744. end;
  745. Function GetLastOSError : Integer;
  746. begin
  747. Result:=GetLastError;
  748. end;
  749. {****************************************************************************
  750. Initialization code
  751. ****************************************************************************}
  752. var
  753. kernel32dll : THandle;
  754. Procedure LoadVersionInfo;
  755. // and getfreespaceex
  756. Var
  757. versioninfo : TOSVERSIONINFO;
  758. begin
  759. kernel32dll:=0;
  760. GetDiskFreeSpaceEx:=nil;
  761. versioninfo.dwOSVersionInfoSize:=sizeof(versioninfo);
  762. GetVersionEx(versioninfo);
  763. Win32Platform:=versionInfo.dwPlatformId;
  764. Win32MajorVersion:=versionInfo.dwMajorVersion;
  765. Win32MinorVersion:=versionInfo.dwMinorVersion;
  766. Win32BuildNumber:=versionInfo.dwBuildNumber;
  767. Move (versioninfo.szCSDVersion ,Win32CSDVersion[1],128);
  768. win32CSDVersion[0]:=chr(strlen(pchar(@versioninfo.szCSDVersion)));
  769. if ((versioninfo.dwPlatformId=VER_PLATFORM_WIN32_WINDOWS) and
  770. (versioninfo.dwBuildNUmber>=1000)) or
  771. (versioninfo.dwPlatformId=VER_PLATFORM_WIN32_NT) then
  772. begin
  773. kernel32dll:=LoadLibrary('kernel32');
  774. if kernel32dll<>0 then
  775. GetDiskFreeSpaceEx:=TGetDiskFreeSpaceEx(GetProcAddress(kernel32dll,'GetDiskFreeSpaceExA'));
  776. end;
  777. end;
  778. function FreeLibrary(hLibModule : THANDLE) : longbool;
  779. stdcall;external 'kernel32' name 'FreeLibrary';
  780. function GetVersionEx(var VersionInformation:TOSVERSIONINFO) : longbool;
  781. stdcall;external 'kernel32' name 'GetVersionExA';
  782. function LoadLibrary(lpLibFileName : pchar):THandle;
  783. stdcall;external 'kernel32' name 'LoadLibraryA';
  784. function GetProcAddress(hModule : THandle;lpProcName : pchar) : pointer;
  785. stdcall;external 'kernel32' name 'GetProcAddress';
  786. Const
  787. CSIDL_PROGRAMS = $0002; { %SYSTEMDRIVE%\Program Files }
  788. CSIDL_PERSONAL = $0005; { %USERPROFILE%\My Documents }
  789. CSIDL_FAVORITES = $0006; { %USERPROFILE%\Favorites }
  790. CSIDL_STARTUP = $0007; { %USERPROFILE%\Start menu\Programs\Startup }
  791. CSIDL_RECENT = $0008; { %USERPROFILE%\Recent }
  792. CSIDL_SENDTO = $0009; { %USERPROFILE%\Sendto }
  793. CSIDL_STARTMENU = $000B; { %USERPROFILE%\Start menu }
  794. CSIDL_MYMUSIC = $000D; { %USERPROFILE%\Documents\My Music }
  795. CSIDL_MYVIDEO = $000E; { %USERPROFILE%\Documents\My Videos }
  796. CSIDL_DESKTOPDIRECTORY = $0010; { %USERPROFILE%\Desktop }
  797. CSIDL_NETHOOD = $0013; { %USERPROFILE%\NetHood }
  798. CSIDL_TEMPLATES = $0015; { %USERPROFILE%\Templates }
  799. CSIDL_COMMON_STARTMENU = $0016; { %PROFILEPATH%\All users\Start menu }
  800. CSIDL_COMMON_PROGRAMS = $0017; { %PROFILEPATH%\All users\Start menu\Programs }
  801. CSIDL_COMMON_STARTUP = $0018; { %PROFILEPATH%\All users\Start menu\Programs\Startup }
  802. CSIDL_COMMON_DESKTOPDIRECTORY = $0019; { %PROFILEPATH%\All users\Desktop }
  803. CSIDL_APPDATA = $001A; { %USERPROFILE%\Application Data (roaming) }
  804. CSIDL_PRINTHOOD = $001B; { %USERPROFILE%\Printhood }
  805. CSIDL_LOCAL_APPDATA = $001C; { %USERPROFILE%\Local Settings\Application Data (non roaming) }
  806. CSIDL_COMMON_FAVORITES = $001F; { %PROFILEPATH%\All users\Favorites }
  807. CSIDL_INTERNET_CACHE = $0020; { %USERPROFILE%\Local Settings\Temporary Internet Files }
  808. CSIDL_COOKIES = $0021; { %USERPROFILE%\Cookies }
  809. CSIDL_HISTORY = $0022; { %USERPROFILE%\Local settings\History }
  810. CSIDL_COMMON_APPDATA = $0023; { %PROFILESPATH%\All Users\Application Data }
  811. CSIDL_WINDOWS = $0024; { %SYSTEMROOT% }
  812. CSIDL_SYSTEM = $0025; { %SYSTEMROOT%\SYSTEM32 (may be system on 95/98/ME) }
  813. CSIDL_PROGRAM_FILES = $0026; { %SYSTEMDRIVE%\Program Files }
  814. CSIDL_MYPICTURES = $0027; { %USERPROFILE%\My Documents\My Pictures }
  815. CSIDL_PROFILE = $0028; { %USERPROFILE% }
  816. CSIDL_PROGRAM_FILES_COMMON = $002B; { %SYSTEMDRIVE%\Program Files\Common }
  817. CSIDL_COMMON_TEMPLATES = $002D; { %PROFILEPATH%\All Users\Templates }
  818. CSIDL_COMMON_DOCUMENTS = $002E; { %PROFILEPATH%\All Users\Documents }
  819. CSIDL_COMMON_ADMINTOOLS = $002F; { %PROFILEPATH%\All Users\Start Menu\Programs\Administrative Tools }
  820. CSIDL_ADMINTOOLS = $0030; { %USERPROFILE%\Start Menu\Programs\Administrative Tools }
  821. CSIDL_COMMON_MUSIC = $0035; { %PROFILEPATH%\All Users\Documents\my music }
  822. CSIDL_COMMON_PICTURES = $0036; { %PROFILEPATH%\All Users\Documents\my pictures }
  823. CSIDL_COMMON_VIDEO = $0037; { %PROFILEPATH%\All Users\Documents\my videos }
  824. CSIDL_CDBURN_AREA = $003B; { %USERPROFILE%\Local Settings\Application Data\Microsoft\CD Burning }
  825. CSIDL_PROFILES = $003E; { %PROFILEPATH% }
  826. CSIDL_FLAG_CREATE = $8000; { (force creation of requested folder if it doesn't exist yet) }
  827. Type
  828. PFNSHGetFolderPath = Function(Ahwnd: HWND; Csidl: Integer; Token: THandle; Flags: DWord; Path: PChar): HRESULT; stdcall;
  829. var
  830. SHGetFolderPath : PFNSHGetFolderPath = Nil;
  831. CFGDLLHandle : THandle = 0;
  832. Procedure InitDLL;
  833. Var
  834. P : Pointer;
  835. begin
  836. CFGDLLHandle:=LoadLibrary('shell32.dll');
  837. if (CFGDLLHandle<>0) then
  838. begin
  839. P:=GetProcAddress(CFGDLLHandle,'SHGetFolderPathA');
  840. If (P=Nil) then
  841. begin
  842. FreeLibrary(CFGDLLHandle);
  843. CFGDllHandle:=0;
  844. end
  845. else
  846. SHGetFolderPath:=PFNSHGetFolderPath(P);
  847. end;
  848. If (P=Nil) then
  849. begin
  850. CFGDLLHandle:=LoadLibrary('shfolder.dll');
  851. if (CFGDLLHandle<>0) then
  852. begin
  853. P:=GetProcAddress(CFGDLLHandle,'SHGetFolderPathA');
  854. If (P=Nil) then
  855. begin
  856. FreeLibrary(CFGDLLHandle);
  857. CFGDllHandle:=0;
  858. end
  859. else
  860. ShGetFolderPath:=PFNSHGetFolderPath(P);
  861. end;
  862. end;
  863. If (@ShGetFolderPath=Nil) then
  864. Raise Exception.Create('Could not determine SHGetFolderPath Function');
  865. end;
  866. Function GetSpecialDir(ID : Integer) : String;
  867. Var
  868. APath : Array[0..MAX_PATH] of char;
  869. begin
  870. Result:='';
  871. if (CFGDLLHandle=0) then
  872. InitDLL;
  873. If (SHGetFolderPath<>Nil) then
  874. begin
  875. if SHGetFolderPath(0,ID or CSIDL_FLAG_CREATE,0,0,@APATH[0])=S_OK then
  876. Result:=IncludeTrailingPathDelimiter(StrPas(@APath[0]));
  877. end;
  878. end;
  879. Function GetAppConfigDir(Global : Boolean) : String;
  880. begin
  881. If Global then
  882. Result:=GetSpecialDir(CSIDL_COMMON_APPDATA)
  883. else
  884. Result:=GetSpecialDir(CSIDL_LOCAL_APPDATA);
  885. If (Result<>'') then
  886. begin
  887. if VendorName<>'' then
  888. Result:=IncludeTrailingPathDelimiter(Result+VendorName);
  889. Result:=IncludeTrailingPathDelimiter(Result+ApplicationName);
  890. end
  891. else
  892. Result:=IncludeTrailingPathDelimiter(DGetAppConfigDir(Global));
  893. end;
  894. Function GetAppConfigFile(Global : Boolean; SubDir : Boolean) : String;
  895. begin
  896. result:=DGetAppConfigFile(Global,SubDir);
  897. end;
  898. Function GetUserDir : String;
  899. begin
  900. Result:=GetSpecialDir(CSIDL_PROFILE);
  901. end;
  902. Procedure InitSysConfigDir;
  903. begin
  904. SetLength(SysConfigDir, MAX_PATH);
  905. SetLength(SysConfigDir, GetWindowsDirectory(PChar(SysConfigDir), MAX_PATH));
  906. end;
  907. {****************************************************************************
  908. Target Dependent WideString stuff
  909. ****************************************************************************}
  910. { This is the case of Win9x. Limited to current locale of course, but it's better
  911. than not working at all. }
  912. function DoCompareStringA(const s1, s2: WideString; Flags: DWORD): PtrInt;
  913. var
  914. a1, a2: AnsiString;
  915. begin
  916. a1:=s1;
  917. a2:=s2;
  918. SetLastError(0);
  919. Result:=CompareStringA(LOCALE_USER_DEFAULT,Flags,pchar(a1),
  920. length(a1),pchar(a2),length(a2))-2;
  921. end;
  922. function DoCompareStringW(const s1, s2: WideString; Flags: DWORD): PtrInt;
  923. begin
  924. SetLastError(0);
  925. Result:=CompareStringW(LOCALE_USER_DEFAULT,Flags,pwidechar(s1),
  926. length(s1),pwidechar(s2),length(s2))-2;
  927. if GetLastError=0 then
  928. Exit;
  929. if GetLastError=ERROR_CALL_NOT_IMPLEMENTED then // Win9x case
  930. Result:=DoCompareStringA(s1, s2, Flags);
  931. if GetLastError<>0 then
  932. RaiseLastOSError;
  933. end;
  934. function Win32CompareWideString(const s1, s2 : WideString) : PtrInt;
  935. begin
  936. Result:=DoCompareStringW(s1, s2, 0);
  937. end;
  938. function Win32CompareTextWideString(const s1, s2 : WideString) : PtrInt;
  939. begin
  940. Result:=DoCompareStringW(s1, s2, NORM_IGNORECASE);
  941. end;
  942. function Win32AnsiUpperCase(const s: string): string;
  943. begin
  944. if length(s)>0 then
  945. begin
  946. result:=s;
  947. UniqueString(result);
  948. CharUpperBuff(pchar(result),length(result));
  949. end
  950. else
  951. result:='';
  952. end;
  953. function Win32AnsiLowerCase(const s: string): string;
  954. begin
  955. if length(s)>0 then
  956. begin
  957. result:=s;
  958. UniqueString(result);
  959. CharLowerBuff(pchar(result),length(result));
  960. end
  961. else
  962. result:='';
  963. end;
  964. function Win32AnsiCompareStr(const S1, S2: string): PtrInt;
  965. begin
  966. result:=CompareString(LOCALE_USER_DEFAULT,0,pchar(s1),length(s1),
  967. pchar(s2),length(s2))-2;
  968. end;
  969. function Win32AnsiCompareText(const S1, S2: string): PtrInt;
  970. begin
  971. result:=CompareString(LOCALE_USER_DEFAULT,NORM_IGNORECASE,pchar(s1),length(s1),
  972. pchar(s2),length(s2))-2;
  973. end;
  974. function Win32AnsiStrComp(S1, S2: PChar): PtrInt;
  975. begin
  976. result:=CompareString(LOCALE_USER_DEFAULT,0,s1,-1,s2,-1)-2;
  977. end;
  978. function Win32AnsiStrIComp(S1, S2: PChar): PtrInt;
  979. begin
  980. result:=CompareString(LOCALE_USER_DEFAULT,NORM_IGNORECASE,s1,-1,s2,-1)-2;
  981. end;
  982. function Win32AnsiStrLComp(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
  983. begin
  984. result:=CompareString(LOCALE_USER_DEFAULT,0,s1,maxlen,s2,maxlen)-2;
  985. end;
  986. function Win32AnsiStrLIComp(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
  987. begin
  988. result:=CompareString(LOCALE_USER_DEFAULT,NORM_IGNORECASE,s1,maxlen,s2,maxlen)-2;
  989. end;
  990. function Win32AnsiStrLower(Str: PChar): PChar;
  991. begin
  992. CharLower(str);
  993. result:=str;
  994. end;
  995. function Win32AnsiStrUpper(Str: PChar): PChar;
  996. begin
  997. CharUpper(str);
  998. result:=str;
  999. end;
  1000. { there is a similiar procedure in the system unit which inits the fields which
  1001. are relevant already for the system unit }
  1002. procedure InitWin32Widestrings;
  1003. begin
  1004. //!!! CharLengthPCharProc : function(const Str: PChar): PtrInt;
  1005. widestringmanager.CompareWideStringProc:=@Win32CompareWideString;
  1006. widestringmanager.CompareTextWideStringProc:=@Win32CompareTextWideString;
  1007. widestringmanager.UpperAnsiStringProc:=@Win32AnsiUpperCase;
  1008. widestringmanager.LowerAnsiStringProc:=@Win32AnsiLowerCase;
  1009. widestringmanager.CompareStrAnsiStringProc:=@Win32AnsiCompareStr;
  1010. widestringmanager.CompareTextAnsiStringProc:=@Win32AnsiCompareText;
  1011. widestringmanager.StrCompAnsiStringProc:=@Win32AnsiStrComp;
  1012. widestringmanager.StrICompAnsiStringProc:=@Win32AnsiStrIComp;
  1013. widestringmanager.StrLCompAnsiStringProc:=@Win32AnsiStrLComp;
  1014. widestringmanager.StrLICompAnsiStringProc:=@Win32AnsiStrLIComp;
  1015. widestringmanager.StrLowerAnsiStringProc:=@Win32AnsiStrLower;
  1016. widestringmanager.StrUpperAnsiStringProc:=@Win32AnsiStrUpper;
  1017. end;
  1018. procedure SetupProcVars;
  1019. var
  1020. hinstLib : THandle;
  1021. begin
  1022. SetFilePointerEx:=nil;
  1023. hinstLib:=LoadLibrary(KernelDLL);
  1024. if hinstLib<>0 then
  1025. begin
  1026. pointer(SetFilePointerEx):=GetProcAddress(hinstLib,'SetFilePointerEx');
  1027. FreeLibrary(hinstLib);
  1028. end;
  1029. end;
  1030. Initialization
  1031. InitWin32Widestrings;
  1032. InitExceptions; { Initialize exceptions. OS independent }
  1033. InitInternational; { Initialize internationalization settings }
  1034. LoadVersionInfo;
  1035. InitSysConfigDir;
  1036. SetupProcVars;
  1037. Finalization
  1038. DoneExceptions;
  1039. if kernel32dll<>0 then
  1040. FreeLibrary(kernel32dll);
  1041. if CFGDLLHandle<>0 then
  1042. FreeLibrary(CFGDllHandle);
  1043. end.