sysutils.pp 16 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639
  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 netware
  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 DOS;
  19. {$I nwsys.inc}
  20. {$I errno.inc}
  21. {$DEFINE HAS_SLEEP}
  22. TYPE
  23. TNetwareFindData =
  24. RECORD
  25. DirP : PNWDirEnt; { used for opendir }
  26. EntryP: PNWDirEnt; { and readdir }
  27. Magic : WORD; { to avoid abends with uninitialized TSearchRec }
  28. END;
  29. { Include platform independent interface part }
  30. {$i sysutilh.inc}
  31. { additional NetWare file flags}
  32. CONST
  33. faSHARE = $00000080; { Sharable file }
  34. faNO_SUBALLOC = $00000800; { Don't sub alloc. this file }
  35. faTRANS = $00001000; { Transactional file (TTS usable) }
  36. faREADAUD = $00004000; { Read audit }
  37. faWRITAUD = $00008000; { Write audit }
  38. faIMMPURG = $00010000; { Immediate purge }
  39. faNORENAM = $00020000; { Rename inhibit }
  40. faNODELET = $00040000; { Delete inhibit }
  41. faNOCOPY = $00080000; { Copy inhibit }
  42. faFILE_MIGRATED = $00400000; { File has been migrated }
  43. faDONT_MIGRATE = $00800000; { Don't migrate this file }
  44. faIMMEDIATE_COMPRESS = $02000000; { Compress this file immediately }
  45. faFILE_COMPRESSED = $04000000; { File is compressed }
  46. faDONT_COMPRESS = $08000000; { Don't compress this file }
  47. faCANT_COMPRESS = $20000000; { Can't compress this file }
  48. faATTR_ARCHIVE = $40000000; { Entry has had an EA modified, }
  49. { an ownerID changed, or trustee }
  50. { info changed, etc. }
  51. implementation
  52. uses
  53. sysconst;
  54. { Include platform independent implementation part }
  55. {$i sysutils.inc}
  56. {****************************************************************************
  57. File Functions
  58. ****************************************************************************}
  59. Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
  60. VAR NWOpenFlags : longint;
  61. BEGIN
  62. NWOpenFlags:=0;
  63. Case (Mode and 3) of
  64. 0 : NWOpenFlags:=NWOpenFlags or O_RDONLY;
  65. 1 : NWOpenFlags:=NWOpenFlags or O_WRONLY;
  66. 2 : NWOpenFlags:=NWOpenFlags or O_RDWR;
  67. end;
  68. FileOpen := _open (pchar(FileName),NWOpenFlags,0);
  69. //!! We need to set locking based on Mode !!
  70. end;
  71. Function FileCreate (Const FileName : String) : Longint;
  72. begin
  73. FileCreate:=_open(Pchar(FileName),O_RdWr or O_Creat or O_Trunc,0);
  74. end;
  75. Function FileCreate (Const FileName : String; mode:longint) : Longint;
  76. begin
  77. FileCreate:=FileCreate (FileName);
  78. end;
  79. Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
  80. begin
  81. FileRead:=_read (Handle,@Buffer,Count);
  82. end;
  83. Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
  84. begin
  85. FileWrite:=_write (Handle,@Buffer,Count);
  86. end;
  87. Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
  88. begin
  89. FileSeek:=_lseek (Handle,FOffset,Origin);
  90. end;
  91. Function FileSeek (Handle : Longint; FOffset,Origin : Int64) : Int64;
  92. begin
  93. {$warning need to add 64bit FileSeek }
  94. FileSeek:=FileSeek(Handle,Longint(FOffset),Longint(Origin));
  95. end;
  96. Procedure FileClose (Handle : Longint);
  97. begin
  98. _close(Handle);
  99. end;
  100. Function FileTruncate (Handle,Size: Longint) : boolean;
  101. begin
  102. FileTruncate:=(_chsize(Handle,Size) = 0);
  103. end;
  104. Function FileLock (Handle,FOffset,FLen : Longint) : Longint;
  105. begin
  106. FileLock := _lock (Handle,FOffset,FLen);
  107. end;
  108. Function FileLock (Handle : Longint; FOffset,FLen : Int64) : Longint;
  109. begin
  110. {$warning need to add 64bit FileLock call }
  111. FileLock := FileLock (Handle, longint(FOffset),longint(FLen));
  112. end;
  113. Function FileUnlock (Handle,FOffset,FLen : Longint) : Longint;
  114. begin
  115. FileUnlock := _unlock (Handle,FOffset,FLen);
  116. end;
  117. Function FileUnlock (Handle : Longint; FOffset,FLen : Int64) : Longint;
  118. begin
  119. {$warning need to add 64bit FileUnlock call }
  120. FileUnlock := FileUnlock (Handle, longint(FOffset),longint(FLen));
  121. end;
  122. Function FileAge (Const FileName : String): Longint;
  123. VAR Info : NWStatBufT;
  124. PTM : PNWTM;
  125. begin
  126. If _stat (pchar(FileName),Info) <> 0 then
  127. exit(-1)
  128. else
  129. begin
  130. PTM := _localtime (Info.st_mtime);
  131. IF PTM = NIL THEN
  132. exit(-1)
  133. else
  134. WITH PTM^ DO
  135. Result:=DateTimeToFileDate(EncodeDate(tm_year+1900,tm_mon+1,tm_mday)+EncodeTime(tm_hour,tm_min,tm_sec,0));
  136. end;
  137. end;
  138. Function FileExists (Const FileName : String) : Boolean;
  139. VAR Info : NWStatBufT;
  140. begin
  141. FileExists:=(_stat(pchar(filename),Info) = 0);
  142. end;
  143. PROCEDURE find_setfields (VAR f : TsearchRec);
  144. VAR T : Dos.DateTime;
  145. BEGIN
  146. WITH F DO
  147. BEGIN
  148. IF FindData.Magic = $AD01 THEN
  149. BEGIN
  150. {attr := FindData.EntryP^.d_attr AND $FF;} // lowest 8 bit -> same as dos
  151. attr := FindData.EntryP^.d_attr; { return complete netware attributes }
  152. UnpackTime(FindData.EntryP^.d_time + (LONGINT (FindData.EntryP^.d_date) SHL 16), T);
  153. time := DateTimeToFileDate(EncodeDate(T.Year,T.Month,T.day)+EncodeTime(T.Hour,T.Min,T.Sec,0));
  154. size := FindData.EntryP^.d_size;
  155. name := strpas (FindData.EntryP^.d_nameDOS);
  156. END ELSE
  157. BEGIN
  158. FillChar (f,SIZEOF(f),0);
  159. END;
  160. END;
  161. END;
  162. Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
  163. begin
  164. IF path = '' then
  165. exit (18);
  166. Rslt.FindData.DirP := _opendir (pchar(Path));
  167. IF Rslt.FindData.DirP = NIL THEN
  168. exit (18);
  169. IF attr <> faAnyFile THEN
  170. _SetReaddirAttribute (Rslt.FindData.DirP, attr);
  171. Rslt.FindData.Magic := $AD01;
  172. Rslt.FindData.EntryP := _readdir (Rslt.FindData.DirP);
  173. if Rslt.FindData.EntryP = nil then
  174. begin
  175. _closedir (Rslt.FindData.DirP);
  176. Rslt.FindData.DirP := NIL;
  177. result := 18;
  178. end else
  179. begin
  180. find_setfields (Rslt);
  181. result := 0;
  182. end;
  183. end;
  184. Function FindNext (Var Rslt : TSearchRec) : Longint;
  185. begin
  186. IF Rslt.FindData.Magic <> $AD01 THEN
  187. exit (18);
  188. Rslt.FindData.EntryP := _readdir (Rslt.FindData.DirP);
  189. IF Rslt.FindData.EntryP = NIL THEN
  190. exit (18);
  191. find_setfields (Rslt);
  192. result := 0;
  193. end;
  194. Procedure FindClose (Var F : TSearchrec);
  195. begin
  196. IF F.FindData.Magic = $AD01 THEN
  197. BEGIN
  198. IF F.FindData.DirP <> NIL THEN
  199. _closedir (F.FindData.DirP);
  200. F.FindData.Magic := 0;
  201. F.FindData.DirP := NIL;
  202. F.FindData.EntryP := NIL;
  203. END;
  204. end;
  205. Function FileGetDate (Handle : Longint) : Longint;
  206. Var Info : NWStatBufT;
  207. PTM : PNWTM;
  208. begin
  209. If _fstat(Handle,Info) <> 0 then
  210. Result:=-1
  211. else
  212. begin
  213. PTM := _localtime (Info.st_mtime);
  214. IF PTM = NIL THEN
  215. exit(-1)
  216. else
  217. WITH PTM^ DO
  218. Result:=DateTimeToFileDate(EncodeDate(tm_year+1900,tm_mon+1,tm_mday)+EncodeTime(tm_hour,tm_min,tm_sec,0));
  219. end;
  220. end;
  221. Function FileSetDate (Handle,Age : Longint) : Longint;
  222. begin
  223. { i think its impossible under netware from FileHandle. I dident found a way to get the
  224. complete pathname of a filehandle, that would be needed for ChangeDirectoryEntry }
  225. FileSetDate:=-1;
  226. ConsolePrintf ('warning: fpc sysutils.FileSetDate not implemented'#13#10,0);
  227. {$warning FileSetDate not implemented (i think is impossible) }
  228. end;
  229. Function FileGetAttr (Const FileName : String) : Longint;
  230. Var Info : NWStatBufT;
  231. begin
  232. If _stat (pchar(FileName),Info) <> 0 then
  233. Result:=-1
  234. Else
  235. Result := Info.st_attr AND $FFFF;
  236. end;
  237. Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
  238. VAR MS : NWModifyStructure;
  239. begin
  240. FillChar (MS, SIZEOF (MS), 0);
  241. if _ChangeDirectoryEntry (PChar (Filename), MS, MFileAtrributesBit, 0) <> 0 then
  242. result := -1
  243. else
  244. result := 0;
  245. end;
  246. Function DeleteFile (Const FileName : String) : Boolean;
  247. begin
  248. Result:= (_UnLink (pchar(FileName)) = 0);
  249. end;
  250. Function RenameFile (Const OldName, NewName : String) : Boolean;
  251. begin
  252. RenameFile:=(_rename(pchar(OldName),pchar(NewName)) = 0);
  253. end;
  254. {****************************************************************************
  255. Disk Functions
  256. ****************************************************************************}
  257. {
  258. The Diskfree and Disksize functions need a file on the specified drive, since this
  259. is required for the statfs system call.
  260. These filenames are set in drivestr[0..26], and have been preset to :
  261. 0 - '.' (default drive - hence current dir is ok.)
  262. 1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
  263. 2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
  264. 3 - '/' (C: equivalent of dos is the root partition)
  265. 4..26 (can be set by you're own applications)
  266. ! Use AddDisk() to Add new drives !
  267. They both return -1 when a failure occurs.
  268. }
  269. Const
  270. FixDriveStr : array[0..3] of pchar=(
  271. '.',
  272. 'a:.',
  273. 'b:.',
  274. 'sys:/'
  275. );
  276. var
  277. Drives : byte;
  278. DriveStr : array[4..26] of pchar;
  279. Procedure AddDisk(const path:string);
  280. begin
  281. if not (DriveStr[Drives]=nil) then
  282. FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
  283. GetMem(DriveStr[Drives],length(Path)+1);
  284. StrPCopy(DriveStr[Drives],path);
  285. inc(Drives);
  286. if Drives>26 then
  287. Drives:=4;
  288. end;
  289. Function DiskFree(Drive: Byte): int64;
  290. //var fs : statfs;
  291. Begin
  292. { if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or
  293. ((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
  294. Diskfree:=int64(fs.bavail)*int64(fs.bsize)
  295. else
  296. Diskfree:=-1;}
  297. DiskFree := -1;
  298. ConsolePrintf ('warning: fpc sysutils.diskfree not implemented'#13#10,0);
  299. {$warning DiskFree not implemented (does it make sense ?) }
  300. End;
  301. Function DiskSize(Drive: Byte): int64;
  302. //var fs : statfs;
  303. Begin
  304. { if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or
  305. ((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
  306. DiskSize:=int64(fs.blocks)*int64(fs.bsize)
  307. else
  308. DiskSize:=-1;}
  309. DiskSize := -1;
  310. ConsolePrintf ('warning: fpc sysutils.disksize not implemented'#13#10,0);
  311. {$warning DiskSize not implemented (does it make sense ?) }
  312. End;
  313. Function GetCurrentDir : String;
  314. begin
  315. GetDir (0,Result);
  316. end;
  317. Function SetCurrentDir (Const NewDir : String) : Boolean;
  318. begin
  319. {$I-}
  320. ChDir(NewDir);
  321. {$I+}
  322. result := (IOResult = 0);
  323. end;
  324. Function CreateDir (Const NewDir : String) : Boolean;
  325. begin
  326. {$I-}
  327. MkDir(NewDir);
  328. {$I+}
  329. result := (IOResult = 0);
  330. end;
  331. Function RemoveDir (Const Dir : String) : Boolean;
  332. begin
  333. {$I-}
  334. RmDir(Dir);
  335. {$I+}
  336. result := (IOResult = 0);
  337. end;
  338. function DirectoryExists (const Directory: string): boolean;
  339. VAR Info : NWStatBufT;
  340. begin
  341. If _stat (pchar(Directory),Info) <> 0 then
  342. exit(false)
  343. else
  344. Exit ((Info.st_attr and faDirectory) <> 0);
  345. end;
  346. {****************************************************************************
  347. Misc Functions
  348. ****************************************************************************}
  349. procedure Beep;
  350. begin
  351. _RingTheBell;
  352. end;
  353. {****************************************************************************
  354. Locale Functions
  355. ****************************************************************************}
  356. Procedure GetLocalTime(var SystemTime: TSystemTime);
  357. var xx : word;
  358. begin
  359. Dos.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second, xx);
  360. Dos.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day, xx);
  361. SystemTime.MilliSecond := 0;
  362. end;
  363. Procedure InitAnsi;
  364. Var i : longint;
  365. begin
  366. { Fill table entries 0 to 127 }
  367. for i := 0 to 96 do
  368. UpperCaseTable[i] := chr(i);
  369. for i := 97 to 122 do
  370. UpperCaseTable[i] := chr(i - 32);
  371. for i := 123 to 191 do
  372. UpperCaseTable[i] := chr(i);
  373. Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
  374. for i := 0 to 64 do
  375. LowerCaseTable[i] := chr(i);
  376. for i := 65 to 90 do
  377. LowerCaseTable[i] := chr(i + 32);
  378. for i := 91 to 191 do
  379. LowerCaseTable[i] := chr(i);
  380. Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
  381. end;
  382. Procedure InitInternational;
  383. begin
  384. InitAnsi;
  385. end;
  386. function SysErrorMessage(ErrorCode: Integer): String;
  387. begin
  388. Result:=''; // StrError(ErrorCode);
  389. end;
  390. {****************************************************************************
  391. OS utility functions
  392. ****************************************************************************}
  393. Function GetEnvironmentVariable(Const EnvVar : String) : String;
  394. begin
  395. Result:=StrPas(_getenv(PChar(EnvVar)));
  396. end;
  397. Function GetEnvironmentVariableCount : Integer;
  398. begin
  399. // Result:=FPCCountEnvVar(EnvP);
  400. Result:=0;
  401. end;
  402. Function GetEnvironmentString(Index : Integer) : String;
  403. begin
  404. // Result:=FPCGetEnvStrFromP(Envp,Index);
  405. Result:='';
  406. end;
  407. function ExecuteProcess(Const Path: AnsiString; Const ComLine: AnsiString):integer;
  408. var
  409. e : EOSError;
  410. CommandLine: AnsiString;
  411. begin
  412. dos.exec(path,comline);
  413. if (Dos.DosError <> 0) then
  414. begin
  415. if ComLine <> '' then
  416. CommandLine := Path + ' ' + ComLine
  417. else
  418. CommandLine := Path;
  419. e:=EOSError.CreateFmt(SExecuteProcessFailed,[CommandLine,Dos.DosError]);
  420. e.ErrorCode:=Dos.DosError;
  421. raise e;
  422. end;
  423. Result := DosExitCode;
  424. end;
  425. function ExecuteProcess (const Path: AnsiString;
  426. const ComLine: array of AnsiString): integer;
  427. var
  428. CommandLine: AnsiString;
  429. I: integer;
  430. begin
  431. Commandline := '';
  432. for I := 0 to High (ComLine) do
  433. if Pos (' ', ComLine [I]) <> 0 then
  434. CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
  435. else
  436. CommandLine := CommandLine + ' ' + Comline [I];
  437. ExecuteProcess := ExecuteProcess (Path, CommandLine);
  438. end;
  439. procedure Sleep(milliseconds: Cardinal);
  440. begin
  441. _delay (milliseconds);
  442. end;
  443. {****************************************************************************
  444. Initialization code
  445. ****************************************************************************}
  446. Initialization
  447. InitExceptions; { Initialize exceptions. OS independent }
  448. InitInternational; { Initialize internationalization settings }
  449. Finalization
  450. DoneExceptions;
  451. end.
  452. {
  453. $Log$
  454. Revision 1.18 2004-12-16 12:42:55 armin
  455. * added NetWare Alert
  456. * added sysutils.sleep
  457. Revision 1.17 2004/12/11 11:32:44 michael
  458. + Added GetEnvironmentVariableCount and GetEnvironmentString calls
  459. Revision 1.16 2004/08/01 20:02:48 armin
  460. * changed dir separator from \ to /
  461. * long namespace by default
  462. * dos.exec implemented
  463. * getenv ('PATH') is now supported
  464. * changed FExpand to global version
  465. * fixed heaplist growth error
  466. * support SysOSFree
  467. * stackcheck was without saveregisters
  468. * fpc can compile itself on netware
  469. Revision 1.15 2004/02/15 21:34:06 hajny
  470. * overloaded ExecuteProcess added, EnvStr param changed to longint
  471. Revision 1.14 2004/01/20 23:11:20 hajny
  472. * ExecuteProcess fixes, ProcessID and ThreadID added
  473. Revision 1.13 2003/11/26 20:00:19 florian
  474. * error handling for Variants improved
  475. Revision 1.12 2003/10/25 23:42:35 hajny
  476. * THandle in sysutils common using System.THandle
  477. Revision 1.11 2003/04/12 13:21:27 armin
  478. * added THandle
  479. Revision 1.10 2003/03/30 12:35:43 armin
  480. * removed uses netware from winsock, DirectoryExists implemented
  481. Revision 1.9 2003/03/29 15:16:26 hajny
  482. * dummy DirectoryExists added
  483. Revision 1.8 2003/02/15 19:12:54 armin
  484. * changes for new threadvar support
  485. Revision 1.7 2002/09/07 16:01:21 peter
  486. * old logs removed and tabs fixed
  487. Revision 1.6 2002/04/01 10:47:31 armin
  488. makefile.fpc for netware
  489. stderr to netware console
  490. free all memory (threadvars and heap) to avoid error message while unloading nlm
  491. Revision 1.5 2002/03/08 19:10:14 armin
  492. * added 64 bit fileseek (currently only 32 bit supported)
  493. }