sysutils.pp 15 KB

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