sysutils.pp 15 KB

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