sysutils.pp 21 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by Florian Klaempfl
  5. member of the Free Pascal development team
  6. Sysutils unit for win32
  7. See the file COPYING.FPC, included in this distribution,
  8. for details about the copyright.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12. **********************************************************************}
  13. unit sysutils;
  14. interface
  15. {$IFNDEF VIRTUALPASCAL}
  16. {$MODE objfpc}
  17. {$ENDIF}
  18. { force ansistrings }
  19. {$H+}
  20. uses
  21. {$IFDEF VIRTUALPASCAL}
  22. vpglue,
  23. strings,
  24. crt,
  25. {$ENDIF}
  26. dos,
  27. windows;
  28. {$DEFINE HAS_SLEEP}
  29. {$DEFINE HAS_OSERROR}
  30. { Include platform independent interface part }
  31. {$i sysutilh.inc}
  32. type
  33. TSystemTime = Windows.TSystemTime;
  34. EWin32Error = class(Exception)
  35. public
  36. ErrorCode : DWORD;
  37. end;
  38. Var
  39. Win32Platform : Longint;
  40. Win32MajorVersion,
  41. Win32MinorVersion,
  42. Win32BuildNumber : dword;
  43. Win32CSDVersion : ShortString; // CSD record is 128 bytes only?
  44. implementation
  45. uses
  46. sysconst;
  47. { Include platform independent implementation part }
  48. {$i sysutils.inc}
  49. {****************************************************************************
  50. File Functions
  51. ****************************************************************************}
  52. Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
  53. const
  54. AccessMode: array[0..2] of Cardinal = (
  55. GENERIC_READ,
  56. GENERIC_WRITE,
  57. GENERIC_READ or GENERIC_WRITE);
  58. ShareMode: array[0..4] of Integer = (
  59. 0,
  60. 0,
  61. FILE_SHARE_READ,
  62. FILE_SHARE_WRITE,
  63. FILE_SHARE_READ or FILE_SHARE_WRITE);
  64. Var
  65. FN : string;
  66. begin
  67. FN:=FileName+#0;
  68. result := CreateFile(@FN[1], dword(AccessMode[Mode and 3]),
  69. dword(ShareMode[(Mode and $F0) shr 4]), nil, OPEN_EXISTING,
  70. FILE_ATTRIBUTE_NORMAL, 0);
  71. end;
  72. Function FileCreate (Const FileName : String) : Longint;
  73. Var
  74. FN : string;
  75. begin
  76. FN:=FileName+#0;
  77. Result := CreateFile(@FN[1], GENERIC_READ or GENERIC_WRITE,
  78. 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
  79. end;
  80. Function FileCreate (Const FileName : String; Mode:longint) : Longint;
  81. begin
  82. FileCreate:=FileCreate(FileName);
  83. end;
  84. Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
  85. Var
  86. res : dword;
  87. begin
  88. if ReadFile(Handle, Buffer, Count, res, nil) then
  89. FileRead:=Res
  90. else
  91. FileRead:=-1;
  92. end;
  93. Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
  94. Var
  95. Res : dword;
  96. begin
  97. if WriteFile(Handle, Buffer, Count, Res, nil) then
  98. FileWrite:=Res
  99. else
  100. FileWrite:=-1;
  101. end;
  102. Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
  103. begin
  104. Result := longint(SetFilePointer(Handle, FOffset, nil, Origin));
  105. end;
  106. Function FileSeek (Handle : Longint; FOffset,Origin : Int64) : Int64;
  107. begin
  108. {$warning need to add 64bit call }
  109. Result := longint(SetFilePointer(Handle, FOffset, nil, Origin));
  110. end;
  111. Procedure FileClose (Handle : Longint);
  112. begin
  113. if Handle<=4 then
  114. exit;
  115. CloseHandle(Handle);
  116. end;
  117. Function FileTruncate (Handle,Size: Longint) : boolean;
  118. begin
  119. Result:=longint(SetFilePointer(handle,Size,nil,FILE_BEGIN))<>-1;
  120. If Result then
  121. Result:=SetEndOfFile(handle);
  122. end;
  123. Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):longbool;
  124. var
  125. lft : TFileTime;
  126. begin
  127. {$IFDEF VIRTUALPASCAL}
  128. DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
  129. LocalFileTimeToFileTime(lft,Wtime);
  130. {$ELSE}
  131. DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,@lft) and
  132. LocalFileTimeToFileTime(lft,Wtime);
  133. {$ENDIF}
  134. end;
  135. Function WinToDosTime (Var Wtime : TFileTime;var DTime:longint):longbool;
  136. var
  137. lft : TFileTime;
  138. begin
  139. WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
  140. FileTimeToDosDateTime(lft,Longrec(Dtime).Hi,LongRec(DTIME).lo);
  141. end;
  142. Function FileAge (Const FileName : String): Longint;
  143. var
  144. Handle: THandle;
  145. FindData: TWin32FindData;
  146. begin
  147. Handle := FindFirstFile(Pchar(FileName), FindData);
  148. if Handle <> INVALID_HANDLE_VALUE then
  149. begin
  150. Windows.FindClose(Handle);
  151. if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
  152. If WinToDosTime(FindData.ftLastWriteTime,Result) then
  153. exit;
  154. end;
  155. Result := -1;
  156. end;
  157. Function FileExists (Const FileName : String) : Boolean;
  158. var
  159. Handle: THandle;
  160. FindData: TWin32FindData;
  161. begin
  162. Handle := FindFirstFile(Pchar(FileName), FindData);
  163. Result:=Handle <> INVALID_HANDLE_VALUE;
  164. If Result then
  165. Windows.FindClose(Handle);
  166. end;
  167. Function DirectoryExists (Const Directory : String) : Boolean;
  168. var
  169. Handle: THandle;
  170. FindData: TWin32FindData;
  171. begin
  172. Result:=False;
  173. Handle := FindFirstFile(Pchar(Directory), FindData);
  174. If (Handle <> INVALID_HANDLE_VALUE) then
  175. begin
  176. Result:=((FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY);
  177. Windows.FindClose(Handle);
  178. end;
  179. end;
  180. Function FindMatch(var f: TSearchRec) : Longint;
  181. begin
  182. { Find file with correct attribute }
  183. While (F.FindData.dwFileAttributes and cardinal(F.ExcludeAttr))<>0 do
  184. begin
  185. if not FindNextFile (F.FindHandle,F.FindData) then
  186. begin
  187. Result:=GetLastError;
  188. exit;
  189. end;
  190. end;
  191. { Convert some attributes back }
  192. WinToDosTime(F.FindData.ftLastWriteTime,F.Time);
  193. f.size:=F.FindData.NFileSizeLow;
  194. f.attr:=F.FindData.dwFileAttributes;
  195. f.Name:=StrPas(@F.FindData.cFileName);
  196. Result:=0;
  197. end;
  198. Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
  199. begin
  200. Rslt.Name:=Path;
  201. Rslt.Attr:=attr;
  202. Rslt.ExcludeAttr:=(not Attr) and ($1e);
  203. { $1e = faHidden or faSysFile or faVolumeID or faDirectory }
  204. { FindFirstFile is a Win32 Call }
  205. Rslt.FindHandle:=FindFirstFile (PChar(Path),Rslt.FindData);
  206. If Rslt.FindHandle=Invalid_Handle_value then
  207. begin
  208. Result:=GetLastError;
  209. exit;
  210. end;
  211. { Find file with correct attribute }
  212. Result:=FindMatch(Rslt);
  213. end;
  214. Function FindNext (Var Rslt : TSearchRec) : Longint;
  215. begin
  216. if FindNextFile(Rslt.FindHandle, Rslt.FindData) then
  217. Result := FindMatch(Rslt)
  218. else
  219. Result := GetLastError;
  220. end;
  221. Procedure FindClose (Var F : TSearchrec);
  222. begin
  223. if F.FindHandle <> INVALID_HANDLE_VALUE then
  224. Windows.FindClose(F.FindHandle);
  225. end;
  226. Function FileGetDate (Handle : Longint) : Longint;
  227. Var
  228. FT : TFileTime;
  229. begin
  230. If GetFileTime(Handle,nil,nil,@ft) and
  231. WinToDosTime(FT,Result) then
  232. exit;
  233. Result:=-1;
  234. end;
  235. Function FileSetDate (Handle,Age : Longint) : Longint;
  236. Var
  237. FT: TFileTime;
  238. begin
  239. {$IFDEF VIRTUALPASCAL}
  240. Result := 0;
  241. {$ELSE}
  242. Result := 0;
  243. if DosToWinTime(Age,FT) and
  244. SetFileTime(Handle, ft, ft, FT) then
  245. Exit;
  246. Result := GetLastError;
  247. {$ENDIF}
  248. end;
  249. Function FileGetAttr (Const FileName : String) : Longint;
  250. begin
  251. Result:=GetFileAttributes(PChar(FileName));
  252. end;
  253. Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
  254. begin
  255. if not SetFileAttributes(PChar(FileName), Attr) then
  256. Result := GetLastError
  257. else
  258. Result:=0;
  259. end;
  260. Function DeleteFile (Const FileName : String) : Boolean;
  261. begin
  262. DeleteFile:=Windows.DeleteFile(Pchar(FileName));
  263. end;
  264. Function RenameFile (Const OldName, NewName : String) : Boolean;
  265. begin
  266. Result := MoveFile(PChar(OldName), PChar(NewName));
  267. end;
  268. {****************************************************************************
  269. Disk Functions
  270. ****************************************************************************}
  271. function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
  272. freeclusters,totalclusters:longint):longbool;
  273. stdcall;external 'kernel32' name 'GetDiskFreeSpaceA';
  274. type
  275. {$IFDEF VIRTUALPASCAL}
  276. {&StdCall+}
  277. TGetDiskFreeSpaceEx = function(drive:pchar;var availableforcaller,total,free):longbool;
  278. {&StdCall-}
  279. {$ELSE}
  280. TGetDiskFreeSpaceEx = function(drive:pchar;var availableforcaller,total,free):longbool;stdcall;
  281. {$ENDIF}
  282. var
  283. GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
  284. function diskfree(drive : byte) : int64;
  285. var
  286. disk : array[1..4] of char;
  287. secs,bytes,
  288. free,total : longint;
  289. qwtotal,qwfree,qwcaller : int64;
  290. begin
  291. if drive=0 then
  292. begin
  293. disk[1]:='\';
  294. disk[2]:=#0;
  295. end
  296. else
  297. begin
  298. disk[1]:=chr(drive+64);
  299. disk[2]:=':';
  300. disk[3]:='\';
  301. disk[4]:=#0;
  302. end;
  303. if assigned(GetDiskFreeSpaceEx) then
  304. begin
  305. if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
  306. diskfree:=qwfree
  307. else
  308. diskfree:=-1;
  309. end
  310. else
  311. begin
  312. if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
  313. diskfree:=int64(free)*secs*bytes
  314. else
  315. diskfree:=-1;
  316. end;
  317. end;
  318. function disksize(drive : byte) : int64;
  319. var
  320. disk : array[1..4] of char;
  321. secs,bytes,
  322. free,total : longint;
  323. qwtotal,qwfree,qwcaller : int64;
  324. begin
  325. if drive=0 then
  326. begin
  327. disk[1]:='\';
  328. disk[2]:=#0;
  329. end
  330. else
  331. begin
  332. disk[1]:=chr(drive+64);
  333. disk[2]:=':';
  334. disk[3]:='\';
  335. disk[4]:=#0;
  336. end;
  337. if assigned(GetDiskFreeSpaceEx) then
  338. begin
  339. if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
  340. disksize:=qwtotal
  341. else
  342. disksize:=-1;
  343. end
  344. else
  345. begin
  346. if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
  347. disksize:=int64(total)*secs*bytes
  348. else
  349. disksize:=-1;
  350. end;
  351. end;
  352. Function GetCurrentDir : String;
  353. begin
  354. GetDir(0, result);
  355. end;
  356. Function SetCurrentDir (Const NewDir : String) : Boolean;
  357. begin
  358. {$I-}
  359. ChDir(NewDir);
  360. {$I+}
  361. result := (IOResult = 0);
  362. end;
  363. Function CreateDir (Const NewDir : String) : Boolean;
  364. begin
  365. {$I-}
  366. MkDir(NewDir);
  367. {$I+}
  368. result := (IOResult = 0);
  369. end;
  370. Function RemoveDir (Const Dir : String) : Boolean;
  371. begin
  372. {$I-}
  373. RmDir(Dir);
  374. {$I+}
  375. result := (IOResult = 0);
  376. end;
  377. {****************************************************************************
  378. Time Functions
  379. ****************************************************************************}
  380. Procedure GetLocalTime(var SystemTime: TSystemTime);
  381. Var
  382. Syst : Windows.TSystemtime;
  383. begin
  384. windows.Getlocaltime(@syst);
  385. SystemTime.year:=syst.wYear;
  386. SystemTime.month:=syst.wMonth;
  387. SystemTime.day:=syst.wDay;
  388. SystemTime.hour:=syst.wHour;
  389. SystemTime.minute:=syst.wMinute;
  390. SystemTime.second:=syst.wSecond;
  391. SystemTime.millisecond:=syst.wMilliSeconds;
  392. end;
  393. {****************************************************************************
  394. Misc Functions
  395. ****************************************************************************}
  396. procedure Beep;
  397. begin
  398. MessageBeep(0);
  399. end;
  400. {****************************************************************************
  401. Locale Functions
  402. ****************************************************************************}
  403. Procedure InitAnsi;
  404. Var
  405. i : longint;
  406. begin
  407. { Fill table entries 0 to 127 }
  408. for i := 0 to 96 do
  409. UpperCaseTable[i] := chr(i);
  410. for i := 97 to 122 do
  411. UpperCaseTable[i] := chr(i - 32);
  412. for i := 123 to 191 do
  413. UpperCaseTable[i] := chr(i);
  414. Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
  415. for i := 0 to 64 do
  416. LowerCaseTable[i] := chr(i);
  417. for i := 65 to 90 do
  418. LowerCaseTable[i] := chr(i + 32);
  419. for i := 91 to 191 do
  420. LowerCaseTable[i] := chr(i);
  421. Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
  422. end;
  423. function GetLocaleStr(LID, LT: Longint; const Def: string): ShortString;
  424. var
  425. L: Integer;
  426. Buf: array[0..255] of Char;
  427. begin
  428. L := GetLocaleInfo(LID, LT, Buf, SizeOf(Buf));
  429. if L > 0 then
  430. SetString(Result, @Buf[0], L - 1)
  431. else
  432. Result := Def;
  433. end;
  434. function GetLocaleChar(LID, LT: Longint; Def: Char): Char;
  435. var
  436. Buf: array[0..1] of Char;
  437. begin
  438. if GetLocaleInfo(LID, LT, Buf, 2) > 0 then
  439. Result := Buf[0]
  440. else
  441. Result := Def;
  442. end;
  443. Function GetLocaleInt(LID,TP,Def: LongInt): LongInt;
  444. Var
  445. S: String;
  446. C: Integer;
  447. Begin
  448. S:=GetLocaleStr(LID,TP,'0');
  449. Val(S,Result,C);
  450. If C<>0 Then
  451. Result:=Def;
  452. End;
  453. procedure GetFormatSettings;
  454. var
  455. HF : Shortstring;
  456. LID : LCID;
  457. I,Day,DateOrder : longint;
  458. begin
  459. LID := GetThreadLocale;
  460. { Date stuff }
  461. for I := 1 to 12 do
  462. begin
  463. ShortMonthNames[I]:=GetLocaleStr(LID,LOCALE_SABBREVMONTHNAME1+I-1,ShortMonthNames[i]);
  464. LongMonthNames[I]:=GetLocaleStr(LID,LOCALE_SMONTHNAME1+I-1,LongMonthNames[i]);
  465. end;
  466. for I := 1 to 7 do
  467. begin
  468. Day := (I + 5) mod 7;
  469. ShortDayNames[I]:=GetLocaleStr(LID,LOCALE_SABBREVDAYNAME1+Day,ShortDayNames[i]);
  470. LongDayNames[I]:=GetLocaleStr(LID,LOCALE_SDAYNAME1+Day,LongDayNames[i]);
  471. end;
  472. DateSeparator := GetLocaleChar(LID, LOCALE_SDATE, '/');
  473. DateOrder := GetLocaleInt(LID, LOCALE_IDate, 0);
  474. Case DateOrder Of
  475. 1: Begin
  476. ShortDateFormat := 'dd/mm/yyyy';
  477. LongDateFormat := 'dddd, d. mmmm yyyy';
  478. End;
  479. 2: Begin
  480. ShortDateFormat := 'yyyy/mm/dd';
  481. LongDateFormat := 'dddd, yyyy mmmm d.';
  482. End;
  483. else
  484. // Default american settings...
  485. ShortDateFormat := 'mm/dd/yyyy';
  486. LongDateFormat := 'dddd, mmmm d. yyyy';
  487. End;
  488. { Time stuff }
  489. TimeSeparator := GetLocaleChar(LID, LOCALE_STIME, ':');
  490. TimeAMString := GetLocaleStr(LID, LOCALE_S1159, 'AM');
  491. TimePMString := GetLocaleStr(LID, LOCALE_S2359, 'PM');
  492. if StrToIntDef(GetLocaleStr(LID, LOCALE_ITLZERO, '0'), 0) = 0 then
  493. HF:='h'
  494. else
  495. HF:='hh';
  496. // No support for 12 hour stuff at the moment...
  497. ShortTimeFormat := HF+':nn';
  498. LongTimeFormat := HF + ':nn:ss';
  499. { Currency stuff }
  500. CurrencyString:=GetLocaleStr(LID, LOCALE_SCURRENCY, '');
  501. CurrencyFormat:=StrToIntDef(GetLocaleStr(LID, LOCALE_ICURRENCY, '0'), 0);
  502. NegCurrFormat:=StrToIntDef(GetLocaleStr(LID, LOCALE_INEGCURR, '0'), 0);
  503. { Number stuff }
  504. ThousandSeparator:=GetLocaleChar(LID, LOCALE_STHOUSAND, ',');
  505. DecimalSeparator:=GetLocaleChar(LID, LOCALE_SDECIMAL, '.');
  506. CurrencyDecimals:=StrToIntDef(GetLocaleStr(LID, LOCALE_ICURRDIGITS, '0'), 0);
  507. end;
  508. Procedure InitInternational;
  509. begin
  510. InitAnsi;
  511. GetFormatSettings;
  512. end;
  513. {****************************************************************************
  514. Target Dependent
  515. ****************************************************************************}
  516. function FormatMessageA(dwFlags : DWORD;
  517. lpSource : Pointer;
  518. dwMessageId : DWORD;
  519. dwLanguageId: DWORD;
  520. lpBuffer : PCHAR;
  521. nSize : DWORD;
  522. Arguments : Pointer): DWORD; stdcall;external 'kernel32' name 'FormatMessageA';
  523. function SysErrorMessage(ErrorCode: Integer): String;
  524. const
  525. MaxMsgSize = Format_Message_Max_Width_Mask;
  526. var
  527. MsgBuffer: pChar;
  528. begin
  529. GetMem(MsgBuffer, MaxMsgSize);
  530. FillChar(MsgBuffer^, MaxMsgSize, #0);
  531. FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
  532. nil,
  533. ErrorCode,
  534. MakeLangId(LANG_NEUTRAL, SUBLANG_DEFAULT),
  535. MsgBuffer, { This function allocs the memory }
  536. MaxMsgSize, { Maximum message size }
  537. nil);
  538. SysErrorMessage := StrPas(MsgBuffer);
  539. FreeMem(MsgBuffer, MaxMsgSize);
  540. end;
  541. {****************************************************************************
  542. Initialization code
  543. ****************************************************************************}
  544. Function GetEnvironmentVariable(Const EnvVar : String) : String;
  545. var
  546. s : string;
  547. i : longint;
  548. hp,p : pchar;
  549. begin
  550. Result:='';
  551. p:=GetEnvironmentStrings;
  552. hp:=p;
  553. while hp^<>#0 do
  554. begin
  555. s:=strpas(hp);
  556. i:=pos('=',s);
  557. if uppercase(copy(s,1,i-1))=upcase(envvar) then
  558. begin
  559. Result:=copy(s,i+1,length(s)-i);
  560. break;
  561. end;
  562. { next string entry}
  563. hp:=hp+strlen(hp)+1;
  564. end;
  565. FreeEnvironmentStrings(p);
  566. end;
  567. function ExecuteProcess(Const Path: AnsiString; Const ComLine: AnsiString):integer;
  568. var
  569. SI: TStartupInfo;
  570. PI: TProcessInformation;
  571. Proc : TWin32Handle;
  572. l : DWord;
  573. CommandLine : ansistring;
  574. e : EOSError;
  575. begin
  576. DosError := 0;
  577. FillChar(SI, SizeOf(SI), 0);
  578. SI.cb:=SizeOf(SI);
  579. SI.wShowWindow:=1;
  580. { always surround the name of the application by quotes
  581. so that long filenames will always be accepted. But don't
  582. do it if there are already double quotes, since Win32 does not
  583. like double quotes which are duplicated!
  584. }
  585. if pos('"',path)=0 then
  586. CommandLine:='"'+path+'"'
  587. else
  588. CommandLine:=path;
  589. if ComLine <> '' then
  590. CommandLine:=Commandline+' '+ComLine+#0
  591. else
  592. CommandLine := CommandLine + #0;
  593. if not CreateProcess(nil, pchar(CommandLine),
  594. Nil, Nil, ExecInheritsHandles,$20, Nil, Nil, SI, PI) then
  595. begin
  596. e:=EOSError.CreateFmt(SExecuteProcessFailed,[CommandLine,GetLastError]);
  597. e.ErrorCode:=GetLastError;
  598. raise e;
  599. end;
  600. Proc:=PI.hProcess;
  601. CloseHandle(PI.hThread);
  602. if WaitForSingleObject(Proc, dword($ffffffff)) <> $ffffffff then
  603. begin
  604. GetExitCodeProcess(Proc,l);
  605. CloseHandle(Proc);
  606. result:=l;
  607. end
  608. else
  609. begin
  610. e:=EOSError.CreateFmt(SExecuteProcessFailed,[CommandLine,GetLastError]);
  611. e.ErrorCode:=GetLastError;
  612. CloseHandle(Proc);
  613. raise e;
  614. end;
  615. end;
  616. Procedure Sleep(Milliseconds : Cardinal);
  617. begin
  618. Windows.Sleep(MilliSeconds)
  619. end;
  620. Function GetLastOSError : Integer;
  621. begin
  622. Result:=GetLastError;
  623. end;
  624. {****************************************************************************
  625. Initialization code
  626. ****************************************************************************}
  627. var
  628. kernel32dll : THandle;
  629. Procedure LoadVersionInfo;
  630. // and getfreespaceex
  631. Var
  632. versioninfo : TOSVERSIONINFO;
  633. i : Integer;
  634. begin
  635. kernel32dll:=0;
  636. GetDiskFreeSpaceEx:=nil;
  637. versioninfo.dwOSVersionInfoSize:=sizeof(versioninfo);
  638. GetVersionEx(versioninfo);
  639. Win32Platform:=versionInfo.dwPlatformId;
  640. Win32MajorVersion:=versionInfo.dwMajorVersion;
  641. Win32MinorVersion:=versionInfo.dwMinorVersion;
  642. Win32BuildNumber:=versionInfo.dwBuildNumber;
  643. Move (versioninfo.szCSDVersion ,Win32CSDVersion[1],128);
  644. win32CSDVersion[0]:=chr(strlen(pchar(@versioninfo.szCSDVersion)));
  645. if ((versioninfo.dwPlatformId=VER_PLATFORM_WIN32_WINDOWS) and
  646. (versioninfo.dwBuildNUmber>=1000)) or
  647. (versioninfo.dwPlatformId=VER_PLATFORM_WIN32_NT) then
  648. begin
  649. kernel32dll:=LoadLibrary('kernel32');
  650. if kernel32dll<>0 then
  651. {$IFDEF VIRTUALPASCAL}
  652. @GetDiskFreeSpaceEx:=GetProcAddress(0,'GetDiskFreeSpaceExA');
  653. {$ELSE}
  654. GetDiskFreeSpaceEx:=TGetDiskFreeSpaceEx(GetProcAddress(kernel32dll,'GetDiskFreeSpaceExA'));
  655. {$ENDIF}
  656. end;
  657. end;
  658. function FreeLibrary(hLibModule : THANDLE) : longbool;
  659. stdcall;external 'kernel32' name 'FreeLibrary';
  660. function GetVersionEx(var VersionInformation:TOSVERSIONINFO) : longbool;
  661. stdcall;external 'kernel32' name 'GetVersionExA';
  662. function LoadLibrary(lpLibFileName : pchar):THandle;
  663. stdcall;external 'kernel32' name 'LoadLibraryA';
  664. function GetProcAddress(hModule : THandle;lpProcName : pchar) : pointer;
  665. stdcall;external 'kernel32' name 'GetProcAddress';
  666. Initialization
  667. InitExceptions; { Initialize exceptions. OS independent }
  668. InitInternational; { Initialize internationalization settings }
  669. LoadVersionInfo;
  670. Finalization
  671. DoneExceptions;
  672. if kernel32dll<>0 then
  673. FreeLibrary(kernel32dll);
  674. end.
  675. {
  676. $Log$
  677. Revision 1.32 2004-02-08 11:00:18 michael
  678. + Implemented winsysut unit
  679. Revision 1.31 2004/01/20 23:12:49 hajny
  680. * ExecuteProcess fixes, ProcessID and ThreadID added
  681. Revision 1.30 2004/01/16 20:53:33 michael
  682. + DirectoryExists now closes findfirst handle
  683. Revision 1.29 2004/01/10 17:40:25 michael
  684. + Added Sleep() function
  685. Revision 1.28 2004/01/05 22:56:08 florian
  686. * changed sysutils.exec to ExecuteProcess
  687. Revision 1.27 2003/11/26 20:00:19 florian
  688. * error handling for Variants improved
  689. Revision 1.26 2003/11/06 22:25:10 marco
  690. * added some more of win32* delphi pseudo constants
  691. Revision 1.25 2003/10/25 23:44:33 hajny
  692. * THandle in sysutils common using System.THandle
  693. Revision 1.24 2003/09/17 15:06:36 peter
  694. * stdcall patch
  695. Revision 1.23 2003/09/06 22:23:35 marco
  696. * VP fixes.
  697. Revision 1.22 2003/04/01 15:57:41 peter
  698. * made THandle platform dependent and unique type
  699. Revision 1.21 2003/03/29 18:21:42 hajny
  700. * DirectoryExists declaration changed to that one from fixes branch
  701. Revision 1.20 2003/03/28 19:06:59 peter
  702. * directoryexists added
  703. Revision 1.19 2003/01/03 20:41:04 peter
  704. * FileCreate(string,mode) overload added
  705. Revision 1.18 2003/01/01 20:56:57 florian
  706. + added invalid instruction exception
  707. Revision 1.17 2002/12/15 20:24:17 peter
  708. * some more C style functions
  709. Revision 1.16 2002/10/02 21:17:03 florian
  710. * we've to reimport TSystemTime time from the windows unit
  711. Revision 1.15 2002/09/07 16:01:29 peter
  712. * old logs removed and tabs fixed
  713. Revision 1.14 2002/05/09 08:28:23 carl
  714. * Merges from Fixes branch
  715. Revision 1.13 2002/03/24 19:26:49 marco
  716. * Added win32platform
  717. Revision 1.12 2002/01/25 16:23:04 peter
  718. * merged filesearch() fix
  719. }