sysutils.pp 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935
  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. begin
  640. Result:=FPCGetEnvVarFromP(envp,EnvVar);
  641. end;
  642. Function GetEnvironmentVariableCount : Integer;
  643. begin
  644. Result:=FPCCountEnvVar(EnvP);
  645. end;
  646. Function GetEnvironmentString(Index : Integer) : String;
  647. begin
  648. Result:=FPCGetEnvStrFromP(Envp,Index);
  649. end;
  650. function ExecuteProcess(Const Path: AnsiString; Const ComLine: AnsiString):integer;
  651. var
  652. e : EOSError;
  653. CommandLine: AnsiString;
  654. begin
  655. dos.exec(path,comline);
  656. if (Dos.DosError <> 0) then
  657. begin
  658. if ComLine <> '' then
  659. CommandLine := Path + ' ' + ComLine
  660. else
  661. CommandLine := Path;
  662. e:=EOSError.CreateFmt('Failed to execute %s : %d',[CommandLine,Dos.DosError]);
  663. e.ErrorCode:=Dos.DosError;
  664. raise e;
  665. end;
  666. Result := DosExitCode;
  667. end;
  668. function ExecuteProcess (const Path: AnsiString;
  669. const ComLine: array of AnsiString): integer;
  670. var
  671. CommandLine: AnsiString;
  672. I: integer;
  673. begin
  674. Commandline := '';
  675. for I := 0 to High (ComLine) do
  676. if Pos (' ', ComLine [I]) <> 0 then
  677. CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
  678. else
  679. CommandLine := CommandLine + ' ' + Comline [I];
  680. ExecuteProcess := ExecuteProcess (Path, CommandLine);
  681. end;
  682. {*************************************************************************
  683. Sleep (copied from crt.Delay)
  684. *************************************************************************}
  685. var
  686. DelayCnt : Longint;
  687. procedure Delayloop;assembler;
  688. asm
  689. .LDelayLoop1:
  690. subl $1,%eax
  691. jc .LDelayLoop2
  692. cmpl %fs:(%edi),%ebx
  693. je .LDelayLoop1
  694. .LDelayLoop2:
  695. end;
  696. procedure initdelay;assembler;
  697. asm
  698. pushl %ebx
  699. pushl %edi
  700. { for some reason, using int $31/ax=$901 doesn't work here }
  701. { and interrupts are always disabled at this point when }
  702. { running a program inside gdb(pas). Web bug 1345 (JM) }
  703. sti
  704. movl $0x46c,%edi
  705. movl $-28,%edx
  706. movl %fs:(%edi),%ebx
  707. .LInitDel1:
  708. cmpl %fs:(%edi),%ebx
  709. je .LInitDel1
  710. movl %fs:(%edi),%ebx
  711. movl %edx,%eax
  712. call DelayLoop
  713. notl %eax
  714. xorl %edx,%edx
  715. movl $55,%ecx
  716. divl %ecx
  717. movl %eax,DelayCnt
  718. popl %edi
  719. popl %ebx
  720. end;
  721. procedure Sleep(MilliSeconds: Cardinal);assembler;
  722. asm
  723. pushl %ebx
  724. pushl %edi
  725. movl MilliSeconds,%ecx
  726. jecxz .LDelay2
  727. movl $0x400,%edi
  728. movl DelayCnt,%edx
  729. movl %fs:(%edi),%ebx
  730. .LDelay1:
  731. movl %edx,%eax
  732. call DelayLoop
  733. loop .LDelay1
  734. .LDelay2:
  735. popl %edi
  736. popl %ebx
  737. end;
  738. {****************************************************************************
  739. Initialization code
  740. ****************************************************************************}
  741. Initialization
  742. InitExceptions; { Initialize exceptions. OS independent }
  743. InitInternational; { Initialize internationalization settings }
  744. InitDelay;
  745. Finalization
  746. DoneExceptions;
  747. end.
  748. {
  749. $Log$
  750. Revision 1.25 2004-12-11 11:32:44 michael
  751. + Added GetEnvironmentVariableCount and GetEnvironmentString calls
  752. Revision 1.24 2004/02/15 21:34:06 hajny
  753. * overloaded ExecuteProcess added, EnvStr param changed to longint
  754. Revision 1.23 2004/01/25 13:05:08 jonas
  755. * fixed compilation errors
  756. Revision 1.22 2004/01/20 23:09:14 hajny
  757. * ExecuteProcess fixes, ProcessID and ThreadID added
  758. Revision 1.21 2004/01/10 20:25:14 michael
  759. + Added rtlconst dependency to classes.ppu and implemented sysutils.sleep
  760. Revision 1.20 2004/01/10 10:49:24 jonas
  761. * fixed compilation
  762. Revision 1.19 2003/11/26 20:00:19 florian
  763. * error handling for Variants improved
  764. Revision 1.18 2003/11/05 11:42:27 florian
  765. * applied patch from Joe da Silva to fix OpenFile on older DOS versions
  766. Revision 1.17 2003/10/25 23:42:35 hajny
  767. * THandle in sysutils common using System.THandle
  768. Revision 1.16 2003/06/03 07:54:27 michael
  769. + Patch from Peter for millisecond timing
  770. Revision 1.15 2003/04/02 15:18:28 peter
  771. * fix argument names
  772. Revision 1.14 2003/04/01 15:57:41 peter
  773. * made THandle platform dependent and unique type
  774. Revision 1.13 2003/03/29 18:21:42 hajny
  775. * DirectoryExists declaration changed to that one from fixes branch
  776. Revision 1.12 2003/03/28 19:06:59 peter
  777. * directoryexists added
  778. Revision 1.11 2003/01/03 20:41:04 peter
  779. * FileCreate(string,mode) overload added
  780. Revision 1.10 2002/09/07 16:01:19 peter
  781. * old logs removed and tabs fixed
  782. Revision 1.9 2002/05/09 08:42:24 carl
  783. * Merges from Fixes branch
  784. Revision 1.8 2002/01/25 16:23:03 peter
  785. * merged filesearch() fix
  786. Revision 1.7 2002/01/19 11:57:55 peter
  787. * merged fixes
  788. }