sysutils.pp 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936
  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 Go32v2
  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. {$MODE objfpc}
  16. { force ansistrings }
  17. {$H+}
  18. uses
  19. go32,dos;
  20. {$DEFINE HAS_SLEEP}
  21. { Include platform independent interface part }
  22. {$i sysutilh.inc}
  23. implementation
  24. uses
  25. sysconst;
  26. { Include platform independent implementation part }
  27. {$i sysutils.inc}
  28. {****************************************************************************
  29. File Functions
  30. ****************************************************************************}
  31. { some internal constants }
  32. const
  33. ofRead = $0000; { Open for reading }
  34. ofWrite = $0001; { Open for writing }
  35. ofReadWrite = $0002; { Open for reading/writing }
  36. faFail = $0000; { Fail if file does not exist }
  37. faCreate = $0010; { Create if file does not exist }
  38. faOpen = $0001; { Open if file exists }
  39. faOpenReplace = $0002; { Clear if file exists }
  40. Type
  41. PSearchrec = ^Searchrec;
  42. { converts S to a pchar and copies it to the transfer-buffer. }
  43. procedure StringToTB(const S: string);
  44. var
  45. P: pchar;
  46. Len: integer;
  47. begin
  48. Len := Length(S) + 1;
  49. P := StrPCopy(StrAlloc(Len), S);
  50. SysCopyToDos(longint(P), Len);
  51. StrDispose(P);
  52. end ;
  53. { Native OpenFile function.
  54. if return value <> 0 call failed. }
  55. function OpenFile(const FileName: string; var Handle: longint; Mode, Action: word): longint;
  56. var
  57. Regs: registers;
  58. begin
  59. result := 0;
  60. Handle := 0;
  61. StringToTB(FileName);
  62. if LFNSupport then
  63. Regs.Eax := $716c { Use LFN Open/Create API }
  64. else { Check if Extended Open/Create API is safe to use }
  65. if lo(dosversion) < 7 then
  66. Regs.Eax := $3d00 + (Mode and $ff) { For now, map to Open API }
  67. else
  68. Regs.Eax := $6c00; { Use Extended Open/Create API }
  69. if Regs.Ah = $3d then
  70. begin
  71. if (Action and $00f0) <> 0 then
  72. Regs.Eax := $3c00; { Map to Create/Replace API }
  73. Regs.Ds := tb_segment;
  74. Regs.Edx := tb_offset;
  75. end
  76. else { LFN or Extended Open/Create API }
  77. begin
  78. Regs.Edx := Action; { Action if file exists/not exists }
  79. Regs.Ds := tb_segment;
  80. Regs.Esi := tb_offset;
  81. Regs.Ebx := $2000 + (Mode and $ff); { file open mode }
  82. end;
  83. Regs.Ecx := $20; { Attributes }
  84. RealIntr($21, Regs);
  85. if (Regs.Flags and CarryFlag) <> 0 then
  86. result := Regs.Ax
  87. else
  88. Handle := Regs.Ax;
  89. end;
  90. Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
  91. var
  92. e: integer;
  93. Begin
  94. e := OpenFile(FileName, result, Mode, faOpen);
  95. if e <> 0 then
  96. result := -1;
  97. end;
  98. Function FileCreate (Const FileName : String) : Longint;
  99. var
  100. e: integer;
  101. begin
  102. e := OpenFile(FileName, result, ofReadWrite, faCreate or faOpenReplace);
  103. if e <> 0 then
  104. result := -1;
  105. end;
  106. Function FileCreate (Const FileName : String; Mode:longint) : Longint;
  107. begin
  108. FileCreate:=FileCreate(FileName);
  109. end;
  110. Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
  111. var
  112. regs : registers;
  113. size,
  114. readsize : longint;
  115. begin
  116. readsize:=0;
  117. while Count > 0 do
  118. begin
  119. if Count>tb_size then
  120. size:=tb_size
  121. else
  122. size:=Count;
  123. regs.realecx:=size;
  124. regs.realedx:=tb_offset;
  125. regs.realds:=tb_segment;
  126. regs.realebx:=Handle;
  127. regs.realeax:=$3f00;
  128. RealIntr($21,regs);
  129. if (regs.realflags and carryflag) <> 0 then
  130. begin
  131. Result:=-1;
  132. exit;
  133. end;
  134. syscopyfromdos(Longint(@Buffer)+readsize,lo(regs.realeax));
  135. inc(readsize,lo(regs.realeax));
  136. dec(Count,lo(regs.realeax));
  137. { stop when not the specified size is read }
  138. if lo(regs.realeax)<size then
  139. break;
  140. end;
  141. Result:=readsize;
  142. end;
  143. Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
  144. var
  145. regs : registers;
  146. size,
  147. writesize : longint;
  148. begin
  149. writesize:=0;
  150. while Count > 0 do
  151. begin
  152. if Count>tb_size then
  153. size:=tb_size
  154. else
  155. size:=Count;
  156. syscopytodos(Longint(@Buffer)+writesize,size);
  157. regs.realecx:=size;
  158. regs.realedx:=tb_offset;
  159. regs.realds:=tb_segment;
  160. regs.realebx:=Handle;
  161. regs.realeax:=$4000;
  162. RealIntr($21,regs);
  163. if (regs.realflags and carryflag) <> 0 then
  164. begin
  165. Result:=-1;
  166. exit;
  167. end;
  168. inc(writesize,lo(regs.realeax));
  169. dec(Count,lo(regs.realeax));
  170. { stop when not the specified size is written }
  171. if lo(regs.realeax)<size then
  172. break;
  173. end;
  174. Result:=WriteSize;
  175. end;
  176. Function FileSeek (Handle, FOffset, Origin : Longint) : Longint;
  177. var
  178. Regs: registers;
  179. begin
  180. Regs.Eax := $4200;
  181. Regs.Al := Origin;
  182. Regs.Edx := Lo(FOffset);
  183. Regs.Ecx := Hi(FOffset);
  184. Regs.Ebx := Handle;
  185. RealIntr($21, Regs);
  186. if Regs.Flags and CarryFlag <> 0 then
  187. result := -1
  188. else begin
  189. LongRec(result).Lo := Regs.Ax;
  190. LongRec(result).Hi := Regs.Dx;
  191. end ;
  192. end;
  193. Function FileSeek (Handle : Longint; FOffset,Origin : Int64) : Int64;
  194. begin
  195. {$warning need to add 64bit call }
  196. FileSeek:=FileSeek(Handle,Longint(FOffset),Longint(Origin));
  197. end;
  198. Procedure FileClose (Handle : Longint);
  199. var
  200. Regs: registers;
  201. begin
  202. if Handle<=4 then
  203. exit;
  204. Regs.Eax := $3e00;
  205. Regs.Ebx := Handle;
  206. RealIntr($21, Regs);
  207. end;
  208. Function FileTruncate (Handle,Size: Longint) : boolean;
  209. var
  210. regs : trealregs;
  211. begin
  212. FileSeek(Handle,Size,0);
  213. Regs.realecx := 0;
  214. Regs.realedx := tb_offset;
  215. Regs.ds := tb_segment;
  216. Regs.ebx := Handle;
  217. Regs.eax:=$4000;
  218. RealIntr($21, Regs);
  219. FileTruncate:=(regs.realflags and carryflag)=0;
  220. end;
  221. Function FileAge (Const FileName : String): Longint;
  222. var Handle: longint;
  223. begin
  224. Handle := FileOpen(FileName, 0);
  225. if Handle <> -1 then
  226. begin
  227. result := FileGetDate(Handle);
  228. FileClose(Handle);
  229. end
  230. else
  231. result := -1;
  232. end;
  233. Function FileExists (Const FileName : String) : Boolean;
  234. Var
  235. Sr : Searchrec;
  236. begin
  237. DOS.FindFirst(FileName,$3f,sr);
  238. if DosError = 0 then
  239. begin
  240. { No volumeid,directory }
  241. Result:=(sr.attr and $18)=0;
  242. Dos.FindClose(sr);
  243. end
  244. else
  245. Result:=false;
  246. end;
  247. Function DirectoryExists (Const Directory : String) : Boolean;
  248. Var
  249. Sr : Searchrec;
  250. begin
  251. DOS.FindFirst(Directory,$3f,sr);
  252. if DosError = 0 then
  253. begin
  254. Result:=(sr.attr and $10)=$10;
  255. Dos.FindClose(sr);
  256. end
  257. else
  258. Result:=false;
  259. end;
  260. Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
  261. Var Sr : PSearchrec;
  262. begin
  263. //!! Sr := New(PSearchRec);
  264. getmem(sr,sizeof(searchrec));
  265. Rslt.FindHandle := longint(Sr);
  266. DOS.FindFirst(Path, Attr, Sr^);
  267. result := -DosError;
  268. if result = 0 then
  269. begin
  270. Rslt.Time := Sr^.Time;
  271. Rslt.Size := Sr^.Size;
  272. Rslt.Attr := Sr^.Attr;
  273. Rslt.ExcludeAttr := 0;
  274. Rslt.Name := Sr^.Name;
  275. end ;
  276. end;
  277. Function FindNext (Var Rslt : TSearchRec) : Longint;
  278. var
  279. Sr: PSearchRec;
  280. begin
  281. Sr := PSearchRec(Rslt.FindHandle);
  282. if Sr <> nil then
  283. begin
  284. DOS.FindNext(Sr^);
  285. result := -DosError;
  286. if result = 0 then
  287. begin
  288. Rslt.Time := Sr^.Time;
  289. Rslt.Size := Sr^.Size;
  290. Rslt.Attr := Sr^.Attr;
  291. Rslt.ExcludeAttr := 0;
  292. Rslt.Name := Sr^.Name;
  293. end;
  294. end;
  295. end;
  296. Procedure FindClose (Var F : TSearchrec);
  297. var
  298. Sr: PSearchRec;
  299. begin
  300. Sr := PSearchRec(F.FindHandle);
  301. if Sr <> nil then
  302. begin
  303. //!! Dispose(Sr);
  304. // This call is non dummy if LFNSupport is true PM
  305. DOS.FindClose(SR^);
  306. freemem(sr,sizeof(searchrec));
  307. end;
  308. F.FindHandle := 0;
  309. end;
  310. Function FileGetDate (Handle : Longint) : Longint;
  311. var
  312. Regs: registers;
  313. begin
  314. //!! for win95 an alternative function is available.
  315. Regs.Ebx := Handle;
  316. Regs.Eax := $5700;
  317. RealIntr($21, Regs);
  318. if Regs.Flags and CarryFlag <> 0 then
  319. result := -1
  320. else
  321. begin
  322. LongRec(result).Lo := Regs.cx;
  323. LongRec(result).Hi := Regs.dx;
  324. end ;
  325. end;
  326. Function FileSetDate (Handle, Age : Longint) : Longint;
  327. var
  328. Regs: registers;
  329. begin
  330. Regs.Ebx := Handle;
  331. Regs.Eax := $5701;
  332. Regs.Ecx := Lo(Age);
  333. Regs.Edx := Hi(Age);
  334. RealIntr($21, Regs);
  335. if Regs.Flags and CarryFlag <> 0 then
  336. result := -Regs.Ax
  337. else
  338. result := 0;
  339. end;
  340. Function FileGetAttr (Const FileName : String) : Longint;
  341. var
  342. Regs: registers;
  343. begin
  344. StringToTB(FileName);
  345. Regs.Edx := tb_offset;
  346. Regs.Ds := tb_segment;
  347. if LFNSupport then
  348. begin
  349. Regs.Ax := $7143;
  350. Regs.Bx := 0;
  351. end
  352. else
  353. Regs.Ax := $4300;
  354. RealIntr($21, Regs);
  355. if Regs.Flags and CarryFlag <> 0 then
  356. result := -1
  357. else
  358. result := Regs.Cx;
  359. end;
  360. Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
  361. var
  362. Regs: registers;
  363. begin
  364. StringToTB(FileName);
  365. Regs.Edx := tb_offset;
  366. Regs.Ds := tb_segment;
  367. if LFNSupport then
  368. begin
  369. Regs.Ax := $7143;
  370. Regs.Bx := 1;
  371. end
  372. else
  373. Regs.Ax := $4301;
  374. Regs.Cx := Attr;
  375. RealIntr($21, Regs);
  376. if Regs.Flags and CarryFlag <> 0 then
  377. result := -Regs.Ax
  378. else
  379. result := 0;
  380. end;
  381. Function DeleteFile (Const FileName : String) : Boolean;
  382. var
  383. Regs: registers;
  384. begin
  385. StringToTB(FileName);
  386. Regs.Edx := tb_offset;
  387. Regs.Ds := tb_segment;
  388. if LFNSupport then
  389. Regs.Eax := $7141
  390. else
  391. Regs.Eax := $4100;
  392. Regs.Esi := 0;
  393. Regs.Ecx := 0;
  394. RealIntr($21, Regs);
  395. result := (Regs.Flags and CarryFlag = 0);
  396. end;
  397. Function RenameFile (Const OldName, NewName : String) : Boolean;
  398. var
  399. Regs: registers;
  400. begin
  401. StringToTB(OldName + #0 + NewName);
  402. Regs.Edx := tb_offset;
  403. Regs.Ds := tb_segment;
  404. Regs.Edi := tb_offset + Length(OldName) + 1;
  405. Regs.Es := tb_segment;
  406. if LFNSupport then
  407. Regs.Eax := $7156
  408. else
  409. Regs.Eax := $5600;
  410. Regs.Ecx := $ff;
  411. RealIntr($21, Regs);
  412. result := (Regs.Flags and CarryFlag = 0);
  413. end;
  414. {****************************************************************************
  415. Disk Functions
  416. ****************************************************************************}
  417. TYPE ExtendedFat32FreeSpaceRec=packed Record
  418. RetSize : WORD; { (ret) size of returned structure}
  419. Strucversion : WORD; {(call) structure version (0000h)
  420. (ret) actual structure version (0000h)}
  421. SecPerClus, {number of sectors per cluster}
  422. BytePerSec, {number of bytes per sector}
  423. AvailClusters, {number of available clusters}
  424. TotalClusters, {total number of clusters on the drive}
  425. AvailPhysSect, {physical sectors available on the drive}
  426. TotalPhysSect, {total physical sectors on the drive}
  427. AvailAllocUnits, {Available allocation units}
  428. TotalAllocUnits : DWORD; {Total allocation units}
  429. Dummy,Dummy2 : DWORD; {8 bytes reserved}
  430. END;
  431. function do_diskdata(drive : byte; Free : BOOLEAN) : Int64;
  432. VAR S : String;
  433. Rec : ExtendedFat32FreeSpaceRec;
  434. regs : registers;
  435. BEGIN
  436. if (swap(dosversion)>=$070A) AND LFNSupport then
  437. begin
  438. DosError:=0;
  439. S:='C:\'#0;
  440. if Drive=0 then
  441. begin
  442. GetDir(Drive,S);
  443. Setlength(S,4);
  444. S[4]:=#0;
  445. end
  446. else
  447. S[1]:=chr(Drive+64);
  448. Rec.Strucversion:=0;
  449. dosmemput(tb_segment,tb_offset,Rec,SIZEOF(ExtendedFat32FreeSpaceRec));
  450. dosmemput(tb_segment,tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1,S[1],4);
  451. regs.dx:=tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1;
  452. regs.ds:=tb_segment;
  453. regs.di:=tb_offset;
  454. regs.es:=tb_segment;
  455. regs.cx:=Sizeof(ExtendedFat32FreeSpaceRec);
  456. regs.ax:=$7303;
  457. msdos(regs);
  458. if regs.ax<>$ffff then
  459. begin
  460. copyfromdos(rec,Sizeof(ExtendedFat32FreeSpaceRec));
  461. if Free then
  462. Do_DiskData:=int64(rec.AvailAllocUnits)*rec.SecPerClus*rec.BytePerSec
  463. else
  464. Do_DiskData:=int64(rec.TotalAllocUnits)*rec.SecPerClus*rec.BytePerSec;
  465. end
  466. else
  467. Do_DiskData:=-1;
  468. end
  469. else
  470. begin
  471. DosError:=0;
  472. regs.dl:=drive;
  473. regs.ah:=$36;
  474. msdos(regs);
  475. if regs.ax<>$FFFF then
  476. begin
  477. if Free then
  478. Do_DiskData:=int64(regs.ax)*regs.bx*regs.cx
  479. else
  480. Do_DiskData:=int64(regs.ax)*regs.cx*regs.dx;
  481. end
  482. else
  483. do_diskdata:=-1;
  484. end;
  485. end;
  486. function diskfree(drive : byte) : int64;
  487. begin
  488. diskfree:=Do_DiskData(drive,TRUE);
  489. end;
  490. function disksize(drive : byte) : int64;
  491. begin
  492. disksize:=Do_DiskData(drive,false);
  493. end;
  494. Function GetCurrentDir : String;
  495. begin
  496. GetDir(0, result);
  497. end;
  498. Function SetCurrentDir (Const NewDir : String) : Boolean;
  499. begin
  500. {$I-}
  501. ChDir(NewDir);
  502. {$I+}
  503. result := (IOResult = 0);
  504. end;
  505. Function CreateDir (Const NewDir : String) : Boolean;
  506. begin
  507. {$I-}
  508. MkDir(NewDir);
  509. {$I+}
  510. result := (IOResult = 0);
  511. end;
  512. Function RemoveDir (Const Dir : String) : Boolean;
  513. begin
  514. {$I-}
  515. RmDir(Dir);
  516. {$I+}
  517. result := (IOResult = 0);
  518. end;
  519. {****************************************************************************
  520. Time Functions
  521. ****************************************************************************}
  522. Procedure GetLocalTime(var SystemTime: TSystemTime);
  523. var
  524. Regs: Registers;
  525. begin
  526. Regs.ah := $2C;
  527. RealIntr($21, Regs);
  528. SystemTime.Hour := Regs.Ch;
  529. SystemTime.Minute := Regs.Cl;
  530. SystemTime.Second := Regs.Dh;
  531. SystemTime.MilliSecond := Regs.Dl*10;
  532. Regs.ah := $2A;
  533. RealIntr($21, Regs);
  534. SystemTime.Year := Regs.Cx;
  535. SystemTime.Month := Regs.Dh;
  536. SystemTime.Day := Regs.Dl;
  537. end ;
  538. {****************************************************************************
  539. Misc Functions
  540. ****************************************************************************}
  541. procedure Beep;
  542. begin
  543. end;
  544. {****************************************************************************
  545. Locale Functions
  546. ****************************************************************************}
  547. { Codepage constants }
  548. const
  549. CP_US = 437;
  550. CP_MultiLingual = 850;
  551. CP_SlavicLatin2 = 852;
  552. CP_Turkish = 857;
  553. CP_Portugal = 860;
  554. CP_IceLand = 861;
  555. CP_Canada = 863;
  556. CP_NorwayDenmark = 865;
  557. { CountryInfo }
  558. type
  559. TCountryInfo = packed record
  560. InfoId: byte;
  561. case integer of
  562. 1: ( Size: word;
  563. CountryId: word;
  564. CodePage: word;
  565. CountryInfo: array[0..33] of byte );
  566. 2: ( UpperCaseTable: longint );
  567. 4: ( FilenameUpperCaseTable: longint );
  568. 5: ( FilecharacterTable: longint );
  569. 6: ( CollatingTable: longint );
  570. 7: ( DBCSLeadByteTable: longint );
  571. end ;
  572. procedure GetExtendedCountryInfo(InfoId: integer; CodePage, CountryId: word; var CountryInfo: TCountryInfo);
  573. Var Regs: Registers;
  574. begin
  575. Regs.AH := $65;
  576. Regs.AL := InfoId;
  577. Regs.BX := CodePage;
  578. Regs.DX := CountryId;
  579. Regs.ES := transfer_buffer div 16;
  580. Regs.DI := transfer_buffer and 15;
  581. Regs.CX := SizeOf(TCountryInfo);
  582. RealIntr($21, Regs);
  583. DosMemGet(transfer_buffer div 16,
  584. transfer_buffer and 15,
  585. CountryInfo, Regs.CX );
  586. end;
  587. procedure InitAnsi;
  588. var
  589. CountryInfo: TCountryInfo; i: integer;
  590. begin
  591. { Fill table entries 0 to 127 }
  592. for i := 0 to 96 do
  593. UpperCaseTable[i] := chr(i);
  594. for i := 97 to 122 do
  595. UpperCaseTable[i] := chr(i - 32);
  596. for i := 123 to 127 do
  597. UpperCaseTable[i] := chr(i);
  598. for i := 0 to 64 do
  599. LowerCaseTable[i] := chr(i);
  600. for i := 65 to 90 do
  601. LowerCaseTable[i] := chr(i + 32);
  602. for i := 91 to 255 do
  603. LowerCaseTable[i] := chr(i);
  604. { Get country and codepage info }
  605. GetExtendedCountryInfo(1, $FFFF, $FFFF, CountryInfo);
  606. if CountryInfo.CodePage = 850 then
  607. begin
  608. { Special, known case }
  609. Move(CP850UCT, UpperCaseTable[128], 128);
  610. Move(CP850LCT, LowerCaseTable[128], 128);
  611. end
  612. else
  613. begin
  614. { this needs to be checked !!
  615. this is correct only if UpperCaseTable is
  616. and Offset:Segment word record (PM) }
  617. { get the uppercase table from dosmemory }
  618. GetExtendedCountryInfo(2, $FFFF, $FFFF, CountryInfo);
  619. DosMemGet(CountryInfo.UpperCaseTable shr 16, 2 + CountryInfo.UpperCaseTable and 65535, UpperCaseTable[128], 128);
  620. for i := 128 to 255 do
  621. begin
  622. if UpperCaseTable[i] <> chr(i) then
  623. LowerCaseTable[ord(UpperCaseTable[i])] := chr(i);
  624. end;
  625. end;
  626. end;
  627. Procedure InitInternational;
  628. begin
  629. InitAnsi;
  630. end;
  631. function SysErrorMessage(ErrorCode: Integer): String;
  632. begin
  633. Result:=Format(SUnknownErrorCode,[ErrorCode]);
  634. end;
  635. {****************************************************************************
  636. Os utils
  637. ****************************************************************************}
  638. Function GetEnvironmentVariable(Const EnvVar : String) : String;
  639. var
  640. hp : ppchar;
  641. lenvvar,hs : string;
  642. eqpos : longint;
  643. begin
  644. lenvvar:=upcase(envvar);
  645. hp:=envp;
  646. Result:='';
  647. while assigned(hp^) do
  648. begin
  649. hs:=strpas(hp^);
  650. eqpos:=pos('=',hs);
  651. if upcase(copy(hs,1,eqpos-1))=lenvvar then
  652. begin
  653. Result:=copy(hs,eqpos+1,length(hs)-eqpos);
  654. exit;
  655. end;
  656. inc(hp);
  657. end;
  658. end;
  659. function ExecuteProcess(Const Path: AnsiString; Const ComLine: AnsiString):integer;
  660. var
  661. e : EOSError;
  662. CommandLine: AnsiString;
  663. begin
  664. dos.exec(path,comline);
  665. if (Dos.DosError <> 0) then
  666. begin
  667. if ComLine <> '' then
  668. CommandLine := Path + ' ' + ComLine
  669. else
  670. CommandLine := Path;
  671. e:=EOSError.CreateFmt('Failed to execute %s : %d',[CommandLine,Dos.DosError]);
  672. e.ErrorCode:=Dos.DosError;
  673. raise e;
  674. end;
  675. Result := DosExitCode;
  676. end;
  677. function ExecuteProcess (const Path: AnsiString;
  678. const ComLine: array of AnsiString): integer;
  679. var
  680. CommandLine: AnsiString;
  681. I: integer;
  682. begin
  683. Commandline := '';
  684. for I := 0 to High (ComLine) do
  685. if Pos (' ', ComLine [I]) <> 0 then
  686. CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
  687. else
  688. CommandLine := CommandLine + ' ' + Comline [I];
  689. ExecuteProcess := ExecuteProcess (Path, CommandLine);
  690. end;
  691. {*************************************************************************
  692. Sleep (copied from crt.Delay)
  693. *************************************************************************}
  694. var
  695. DelayCnt : Longint;
  696. procedure Delayloop;assembler;
  697. asm
  698. .LDelayLoop1:
  699. subl $1,%eax
  700. jc .LDelayLoop2
  701. cmpl %fs:(%edi),%ebx
  702. je .LDelayLoop1
  703. .LDelayLoop2:
  704. end;
  705. procedure initdelay;assembler;
  706. asm
  707. pushl %ebx
  708. pushl %edi
  709. { for some reason, using int $31/ax=$901 doesn't work here }
  710. { and interrupts are always disabled at this point when }
  711. { running a program inside gdb(pas). Web bug 1345 (JM) }
  712. sti
  713. movl $0x46c,%edi
  714. movl $-28,%edx
  715. movl %fs:(%edi),%ebx
  716. .LInitDel1:
  717. cmpl %fs:(%edi),%ebx
  718. je .LInitDel1
  719. movl %fs:(%edi),%ebx
  720. movl %edx,%eax
  721. call DelayLoop
  722. notl %eax
  723. xorl %edx,%edx
  724. movl $55,%ecx
  725. divl %ecx
  726. movl %eax,DelayCnt
  727. popl %edi
  728. popl %ebx
  729. end;
  730. procedure Sleep(MilliSeconds: Cardinal);assembler;
  731. asm
  732. pushl %ebx
  733. pushl %edi
  734. movl MilliSeconds,%ecx
  735. jecxz .LDelay2
  736. movl $0x400,%edi
  737. movl DelayCnt,%edx
  738. movl %fs:(%edi),%ebx
  739. .LDelay1:
  740. movl %edx,%eax
  741. call DelayLoop
  742. loop .LDelay1
  743. .LDelay2:
  744. popl %edi
  745. popl %ebx
  746. end;
  747. {****************************************************************************
  748. Initialization code
  749. ****************************************************************************}
  750. Initialization
  751. InitExceptions; { Initialize exceptions. OS independent }
  752. InitInternational; { Initialize internationalization settings }
  753. InitDelay;
  754. Finalization
  755. DoneExceptions;
  756. end.
  757. {
  758. $Log$
  759. Revision 1.24 2004-02-15 21:34:06 hajny
  760. * overloaded ExecuteProcess added, EnvStr param changed to longint
  761. Revision 1.23 2004/01/25 13:05:08 jonas
  762. * fixed compilation errors
  763. Revision 1.22 2004/01/20 23:09:14 hajny
  764. * ExecuteProcess fixes, ProcessID and ThreadID added
  765. Revision 1.21 2004/01/10 20:25:14 michael
  766. + Added rtlconst dependency to classes.ppu and implemented sysutils.sleep
  767. Revision 1.20 2004/01/10 10:49:24 jonas
  768. * fixed compilation
  769. Revision 1.19 2003/11/26 20:00:19 florian
  770. * error handling for Variants improved
  771. Revision 1.18 2003/11/05 11:42:27 florian
  772. * applied patch from Joe da Silva to fix OpenFile on older DOS versions
  773. Revision 1.17 2003/10/25 23:42:35 hajny
  774. * THandle in sysutils common using System.THandle
  775. Revision 1.16 2003/06/03 07:54:27 michael
  776. + Patch from Peter for millisecond timing
  777. Revision 1.15 2003/04/02 15:18:28 peter
  778. * fix argument names
  779. Revision 1.14 2003/04/01 15:57:41 peter
  780. * made THandle platform dependent and unique type
  781. Revision 1.13 2003/03/29 18:21:42 hajny
  782. * DirectoryExists declaration changed to that one from fixes branch
  783. Revision 1.12 2003/03/28 19:06:59 peter
  784. * directoryexists added
  785. Revision 1.11 2003/01/03 20:41:04 peter
  786. * FileCreate(string,mode) overload added
  787. Revision 1.10 2002/09/07 16:01:19 peter
  788. * old logs removed and tabs fixed
  789. Revision 1.9 2002/05/09 08:42:24 carl
  790. * Merges from Fixes branch
  791. Revision 1.8 2002/01/25 16:23:03 peter
  792. * merged filesearch() fix
  793. Revision 1.7 2002/01/19 11:57:55 peter
  794. * merged fixes
  795. }