sysutils.pp 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495
  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. 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. { Include platform independent implementation part }
  52. {$i sysutils.inc}
  53. {****************************************************************************
  54. File Functions
  55. ****************************************************************************}
  56. Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
  57. VAR NWOpenFlags : longint;
  58. BEGIN
  59. NWOpenFlags:=0;
  60. Case (Mode and 3) of
  61. 0 : NWOpenFlags:=NWOpenFlags or O_RDONLY;
  62. 1 : NWOpenFlags:=NWOpenFlags or O_WRONLY;
  63. 2 : NWOpenFlags:=NWOpenFlags or O_RDWR;
  64. end;
  65. FileOpen := _open (pchar(FileName),NWOpenFlags,0);
  66. //!! We need to set locking based on Mode !!
  67. end;
  68. Function FileCreate (Const FileName : String) : Longint;
  69. begin
  70. FileCreate:=_open(Pchar(FileName),O_RdWr or O_Creat or O_Trunc,0);
  71. end;
  72. Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
  73. begin
  74. FileRead:=_read (Handle,@Buffer,Count);
  75. end;
  76. Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
  77. begin
  78. FileWrite:=_write (Handle,@Buffer,Count);
  79. end;
  80. Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
  81. begin
  82. FileSeek:=_lseek (Handle,FOffset,Origin);
  83. end;
  84. Function FileSeek (Handle : Longint; FOffset,Origin : Int64) : Int64;
  85. begin
  86. {$warning need to add 64bit FileSeek }
  87. FileSeek:=FileSeek(Handle,Longint(FOffset),Longint(Origin));
  88. end;
  89. Procedure FileClose (Handle : Longint);
  90. begin
  91. _close(Handle);
  92. end;
  93. Function FileTruncate (Handle,Size: Longint) : boolean;
  94. begin
  95. FileTruncate:=(_chsize(Handle,Size) = 0);
  96. end;
  97. Function FileAge (Const FileName : String): Longint;
  98. VAR Info : NWStatBufT;
  99. PTM : PNWTM;
  100. begin
  101. If _stat (pchar(FileName),Info) <> 0 then
  102. exit(-1)
  103. else
  104. begin
  105. PTM := _localtime (Info.st_mtime);
  106. IF PTM = NIL THEN
  107. exit(-1)
  108. else
  109. WITH PTM^ DO
  110. Result:=DateTimeToFileDate(EncodeDate(tm_year+1900,tm_mon+1,tm_mday)+EncodeTime(tm_hour,tm_min,tm_sec,0));
  111. end;
  112. end;
  113. Function FileExists (Const FileName : String) : Boolean;
  114. VAR Info : NWStatBufT;
  115. begin
  116. FileExists:=(_stat(pchar(filename),Info) = 0);
  117. end;
  118. PROCEDURE find_setfields (VAR f : TsearchRec);
  119. VAR T : Dos.DateTime;
  120. BEGIN
  121. WITH F DO
  122. BEGIN
  123. IF FindData.Magic = $AD01 THEN
  124. BEGIN
  125. {attr := FindData.EntryP^.d_attr AND $FF;} // lowest 8 bit -> same as dos
  126. attr := FindData.EntryP^.d_attr; { return complete netware attributes }
  127. UnpackTime(FindData.EntryP^.d_time + (LONGINT (FindData.EntryP^.d_date) SHL 16), T);
  128. time := DateTimeToFileDate(EncodeDate(T.Year,T.Month,T.day)+EncodeTime(T.Hour,T.Min,T.Sec,0));
  129. size := FindData.EntryP^.d_size;
  130. name := strpas (FindData.EntryP^.d_nameDOS);
  131. END ELSE
  132. BEGIN
  133. FillChar (f,SIZEOF(f),0);
  134. END;
  135. END;
  136. END;
  137. Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
  138. begin
  139. IF path = '' then
  140. exit (18);
  141. Rslt.FindData.DirP := _opendir (pchar(Path));
  142. IF Rslt.FindData.DirP = NIL THEN
  143. exit (18);
  144. IF attr <> faAnyFile THEN
  145. _SetReaddirAttribute (Rslt.FindData.DirP, attr);
  146. Rslt.FindData.Magic := $AD01;
  147. Rslt.FindData.EntryP := _readdir (Rslt.FindData.DirP);
  148. if Rslt.FindData.EntryP = nil then
  149. begin
  150. _closedir (Rslt.FindData.DirP);
  151. Rslt.FindData.DirP := NIL;
  152. result := 18;
  153. end else
  154. begin
  155. find_setfields (Rslt);
  156. result := 0;
  157. end;
  158. end;
  159. Function FindNext (Var Rslt : TSearchRec) : Longint;
  160. begin
  161. IF Rslt.FindData.Magic <> $AD01 THEN
  162. exit (18);
  163. Rslt.FindData.EntryP := _readdir (Rslt.FindData.DirP);
  164. IF Rslt.FindData.EntryP = NIL THEN
  165. exit (18);
  166. find_setfields (Rslt);
  167. result := 0;
  168. end;
  169. Procedure FindClose (Var F : TSearchrec);
  170. begin
  171. IF F.FindData.Magic = $AD01 THEN
  172. BEGIN
  173. IF F.FindData.DirP <> NIL THEN
  174. _closedir (F.FindData.DirP);
  175. F.FindData.Magic := 0;
  176. F.FindData.DirP := NIL;
  177. F.FindData.EntryP := NIL;
  178. END;
  179. end;
  180. Function FileGetDate (Handle : Longint) : Longint;
  181. Var Info : NWStatBufT;
  182. PTM : PNWTM;
  183. begin
  184. If _fstat(Handle,Info) <> 0 then
  185. Result:=-1
  186. else
  187. begin
  188. PTM := _localtime (Info.st_mtime);
  189. IF PTM = NIL THEN
  190. exit(-1)
  191. else
  192. WITH PTM^ DO
  193. Result:=DateTimeToFileDate(EncodeDate(tm_year+1900,tm_mon+1,tm_mday)+EncodeTime(tm_hour,tm_min,tm_sec,0));
  194. end;
  195. end;
  196. Function FileSetDate (Handle,Age : Longint) : Longint;
  197. begin
  198. { i think its impossible under netware from FileHandle. I dident found a way to get the
  199. complete pathname of a filehandle, that would be needed for ChangeDirectoryEntry }
  200. FileSetDate:=-1;
  201. ConsolePrintf ('warning: fpc sysutils.FileSetDate not implemented'#13#10,0);
  202. {$warning FileSetDate not implemented (i think is impossible) }
  203. end;
  204. Function FileGetAttr (Const FileName : String) : Longint;
  205. Var Info : NWStatBufT;
  206. begin
  207. If _stat (pchar(FileName),Info) <> 0 then
  208. Result:=-1
  209. Else
  210. Result := Info.st_attr AND $FFFF;
  211. end;
  212. Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
  213. VAR MS : NWModifyStructure;
  214. begin
  215. FillChar (MS, SIZEOF (MS), 0);
  216. if _ChangeDirectoryEntry (PChar (Filename), MS, MFileAtrributesBit, 0) <> 0 then
  217. result := -1
  218. else
  219. result := 0;
  220. end;
  221. Function DeleteFile (Const FileName : String) : Boolean;
  222. begin
  223. Result:= (_UnLink (pchar(FileName)) = 0);
  224. end;
  225. Function RenameFile (Const OldName, NewName : String) : Boolean;
  226. begin
  227. RenameFile:=(_rename(pchar(OldName),pchar(NewName)) = 0);
  228. end;
  229. {****************************************************************************
  230. Disk Functions
  231. ****************************************************************************}
  232. {
  233. The Diskfree and Disksize functions need a file on the specified drive, since this
  234. is required for the statfs system call.
  235. These filenames are set in drivestr[0..26], and have been preset to :
  236. 0 - '.' (default drive - hence current dir is ok.)
  237. 1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
  238. 2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
  239. 3 - '/' (C: equivalent of dos is the root partition)
  240. 4..26 (can be set by you're own applications)
  241. ! Use AddDisk() to Add new drives !
  242. They both return -1 when a failure occurs.
  243. }
  244. Const
  245. FixDriveStr : array[0..3] of pchar=(
  246. '.',
  247. 'a:.',
  248. 'b:.',
  249. 'sys:/'
  250. );
  251. var
  252. Drives : byte;
  253. DriveStr : array[4..26] of pchar;
  254. Procedure AddDisk(const path:string);
  255. begin
  256. if not (DriveStr[Drives]=nil) then
  257. FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
  258. GetMem(DriveStr[Drives],length(Path)+1);
  259. StrPCopy(DriveStr[Drives],path);
  260. inc(Drives);
  261. if Drives>26 then
  262. Drives:=4;
  263. end;
  264. Function DiskFree(Drive: Byte): int64;
  265. //var fs : statfs;
  266. Begin
  267. { if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or
  268. ((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
  269. Diskfree:=int64(fs.bavail)*int64(fs.bsize)
  270. else
  271. Diskfree:=-1;}
  272. DiskFree := -1;
  273. ConsolePrintf ('warning: fpc sysutils.diskfree not implemented'#13#10,0);
  274. {$warning DiskFree not implemented (does it make sense ?) }
  275. End;
  276. Function DiskSize(Drive: Byte): int64;
  277. //var fs : statfs;
  278. Begin
  279. { if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or
  280. ((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
  281. DiskSize:=int64(fs.blocks)*int64(fs.bsize)
  282. else
  283. DiskSize:=-1;}
  284. DiskSize := -1;
  285. ConsolePrintf ('warning: fpc sysutils.disksize not implemented'#13#10,0);
  286. {$warning DiskSize not implemented (does it make sense ?) }
  287. End;
  288. Function GetCurrentDir : String;
  289. begin
  290. GetDir (0,Result);
  291. end;
  292. Function SetCurrentDir (Const NewDir : String) : Boolean;
  293. begin
  294. {$I-}
  295. ChDir(NewDir);
  296. {$I+}
  297. result := (IOResult = 0);
  298. end;
  299. Function CreateDir (Const NewDir : String) : Boolean;
  300. begin
  301. {$I-}
  302. MkDir(NewDir);
  303. {$I+}
  304. result := (IOResult = 0);
  305. end;
  306. Function RemoveDir (Const Dir : String) : Boolean;
  307. begin
  308. {$I-}
  309. RmDir(Dir);
  310. {$I+}
  311. result := (IOResult = 0);
  312. end;
  313. {****************************************************************************
  314. Misc Functions
  315. ****************************************************************************}
  316. procedure Beep;
  317. begin
  318. _RingTheBell;
  319. end;
  320. {****************************************************************************
  321. Locale Functions
  322. ****************************************************************************}
  323. Procedure GetLocalTime(var SystemTime: TSystemTime);
  324. var xx : word;
  325. begin
  326. Dos.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second, xx);
  327. Dos.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day, xx);
  328. SystemTime.MilliSecond := 0;
  329. end;
  330. Procedure InitAnsi;
  331. Var i : longint;
  332. begin
  333. { Fill table entries 0 to 127 }
  334. for i := 0 to 96 do
  335. UpperCaseTable[i] := chr(i);
  336. for i := 97 to 122 do
  337. UpperCaseTable[i] := chr(i - 32);
  338. for i := 123 to 191 do
  339. UpperCaseTable[i] := chr(i);
  340. Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
  341. for i := 0 to 64 do
  342. LowerCaseTable[i] := chr(i);
  343. for i := 65 to 90 do
  344. LowerCaseTable[i] := chr(i + 32);
  345. for i := 91 to 191 do
  346. LowerCaseTable[i] := chr(i);
  347. Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
  348. end;
  349. Procedure InitInternational;
  350. begin
  351. InitAnsi;
  352. end;
  353. function SysErrorMessage(ErrorCode: Integer): String;
  354. begin
  355. Result:=''; // StrError(ErrorCode);
  356. end;
  357. {****************************************************************************
  358. OS utility functions
  359. ****************************************************************************}
  360. Function GetEnvironmentVariable(Const EnvVar : String) : String;
  361. begin
  362. Result:=StrPas(_getenv(PChar(EnvVar)));
  363. end;
  364. {****************************************************************************
  365. Initialization code
  366. ****************************************************************************}
  367. Initialization
  368. InitExceptions; { Initialize exceptions. OS independent }
  369. InitInternational; { Initialize internationalization settings }
  370. Finalization
  371. DoneExceptions;
  372. end.
  373. {
  374. $Log$
  375. Revision 1.7 2002-09-07 16:01:21 peter
  376. * old logs removed and tabs fixed
  377. Revision 1.6 2002/04/01 10:47:31 armin
  378. makefile.fpc for netware
  379. stderr to netware console
  380. free all memory (threadvars and heap) to avoid error message while unloading nlm
  381. Revision 1.5 2002/03/08 19:10:14 armin
  382. * added 64 bit fileseek (currently only 32 bit supported)
  383. }