dos.pp 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by the Free Pascal development team.
  5. Dos unit for BP7 compatible RTL (novell 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 dos;
  13. interface
  14. Type
  15. searchrec = packed record
  16. DirP : POINTER; { used for opendir }
  17. EntryP: POINTER; { and readdir }
  18. Magic : WORD;
  19. fill : array[1..11] of byte;
  20. attr : byte;
  21. time : longint;
  22. { reserved : word; not in DJGPP V2 }
  23. size : longint;
  24. name : string[255]; { NW uses only [12] but more can't hurt }
  25. end;
  26. {$i dosh.inc}
  27. implementation
  28. uses
  29. strings, nwserv;
  30. {$DEFINE HAS_GETMSCOUNT}
  31. {$DEFINE HAS_GETCBREAK}
  32. {$DEFINE HAS_SETCBREAK}
  33. {$DEFINE HAS_KEEP}
  34. {$define FPC_FEXPAND_DRIVES}
  35. {$define FPC_FEXPAND_VOLUMES}
  36. {$define FPC_FEXPAND_NO_DEFAULT_PATHS}
  37. {$I dos.inc}
  38. {$ASMMODE ATT}
  39. {$I nwsys.inc }
  40. {*****************************************************************************
  41. --- Info / Date / Time ---
  42. ******************************************************************************}
  43. {$PACKRECORDS 4}
  44. function dosversion : word;
  45. VAR F : FILE_SERV_INFO;
  46. begin
  47. IF GetServerInformation(SIZEOF(F),@F) = 0 THEN
  48. dosversion := WORD (F.netwareVersion) SHL 8 + F.netwareSubVersion;
  49. end;
  50. procedure getdate(var year,month,mday,wday : word);
  51. VAR N : NWdateAndTime;
  52. begin
  53. GetFileServerDateAndTime (N);
  54. wday:=N.DayOfWeek;
  55. year:=1900 + N.Year;
  56. month:=N.Month;
  57. mday:=N.Day;
  58. end;
  59. procedure setdate(year,month,day : word);
  60. VAR N : NWdateAndTime;
  61. begin
  62. GetFileServerDateAndTime (N);
  63. SetFileServerDateAndTime(year,month,day,N.Hour,N.Minute,N.Second);
  64. end;
  65. procedure gettime(var hour,minute,second,sec100 : word);
  66. VAR N : NWdateAndTime;
  67. begin
  68. GetFileServerDateAndTime (N);
  69. hour := N.Hour;
  70. Minute:= N.Minute;
  71. Second := N.Second;
  72. sec100 := 0;
  73. end;
  74. procedure settime(hour,minute,second,sec100 : word);
  75. VAR N : NWdateAndTime;
  76. begin
  77. GetFileServerDateAndTime (N);
  78. SetFileServerDateAndTime(N.year,N.month,N.day,hour,minute,second);
  79. end;
  80. function GetMsCount: int64;
  81. begin
  82. GetMsCount := Nwserv.GetCurrentTicks * 55;
  83. end;
  84. {******************************************************************************
  85. --- Exec ---
  86. ******************************************************************************}
  87. const maxargs=256;
  88. procedure exec(const path : pathstr;const comline : comstr);
  89. var c : comstr;
  90. i : integer;
  91. args : array[0..maxargs] of pchar;
  92. arg0 : pathstr;
  93. numargs : integer;
  94. begin
  95. //writeln ('dos.exec (',path,',',comline,')');
  96. arg0 := fexpand (path)+#0;
  97. args[0] := @arg0[1];
  98. numargs := 0;
  99. c:=comline;
  100. i:=1;
  101. while i<=length(c) do
  102. begin
  103. if c[i]<>' ' then
  104. begin
  105. {Commandline argument found. append #0 and set pointer in args }
  106. inc(numargs);
  107. args[numargs]:=@c[i];
  108. while (i<=length(c)) and (c[i]<>' ') do
  109. inc(i);
  110. c[i] := #0;
  111. end;
  112. inc(i);
  113. end;
  114. args[numargs+1] := nil;
  115. i := spawnvp (P_WAIT,args[0],@args);
  116. if i >= 0 then
  117. begin
  118. doserror := 0;
  119. lastdosexitcode := i;
  120. end else
  121. begin
  122. doserror := 8; // for now, what about errno ?
  123. end;
  124. end;
  125. procedure getcbreak(var breakvalue : boolean);
  126. begin
  127. breakvalue := _SetCtrlCharCheckMode (false); { get current setting }
  128. if breakvalue then
  129. _SetCtrlCharCheckMode (breakvalue); { and restore old setting }
  130. end;
  131. procedure setcbreak(breakvalue : boolean);
  132. begin
  133. _SetCtrlCharCheckMode (breakvalue);
  134. end;
  135. {******************************************************************************
  136. --- Disk ---
  137. ******************************************************************************}
  138. function getvolnum (drive : byte) : longint;
  139. var dir : STRING[255];
  140. P,PS,
  141. V : LONGINT;
  142. begin
  143. if drive = 0 then
  144. begin // get volume name from current directory (i.e. SERVER-NAME/VOL2:TEST)
  145. getdir (0,dir);
  146. p := pos (':', dir);
  147. if p = 0 then
  148. begin
  149. getvolnum := -1;
  150. exit;
  151. end;
  152. byte (dir[0]) := p-1;
  153. dir[p] := #0;
  154. PS := pos ('/', dir);
  155. INC (PS);
  156. if _GetVolumeNumber (@dir[PS], V) <> 0 then
  157. getvolnum := -1
  158. else
  159. getvolnum := V;
  160. end else
  161. getvolnum := drive-1;
  162. end;
  163. function diskfree(drive : byte) : int64;
  164. VAR Buf : ARRAY [0..255] OF CHAR;
  165. TotalBlocks : WORD;
  166. SectorsPerBlock : WORD;
  167. availableBlocks : WORD;
  168. totalDirectorySlots : WORD;
  169. availableDirSlots : WORD;
  170. volumeisRemovable : WORD;
  171. volumeNumber : LONGINT;
  172. begin
  173. volumeNumber := getvolnum (drive);
  174. if volumeNumber >= 0 then
  175. begin
  176. {i think thats not the right function but for others i need a connection handle}
  177. if _GetVolumeInfoWithNumber (byte(volumeNumber),@Buf,
  178. TotalBlocks,
  179. SectorsPerBlock,
  180. availableBlocks,
  181. totalDirectorySlots,
  182. availableDirSlots,
  183. volumeisRemovable) = 0 THEN
  184. begin
  185. diskfree := int64 (availableBlocks) * int64 (SectorsPerBlock) * 512;
  186. end else
  187. diskfree := 0;
  188. end else
  189. diskfree := 0;
  190. end;
  191. function disksize(drive : byte) : int64;
  192. VAR Buf : ARRAY [0..255] OF CHAR;
  193. TotalBlocks : WORD;
  194. SectorsPerBlock : WORD;
  195. availableBlocks : WORD;
  196. totalDirectorySlots : WORD;
  197. availableDirSlots : WORD;
  198. volumeisRemovable : WORD;
  199. volumeNumber : LONGINT;
  200. begin
  201. volumeNumber := getvolnum (drive);
  202. if volumeNumber >= 0 then
  203. begin
  204. {i think thats not the right function but for others i need a connection handle}
  205. if _GetVolumeInfoWithNumber (byte(volumeNumber),@Buf,
  206. TotalBlocks,
  207. SectorsPerBlock,
  208. availableBlocks,
  209. totalDirectorySlots,
  210. availableDirSlots,
  211. volumeisRemovable) = 0 THEN
  212. begin
  213. disksize := int64 (TotalBlocks) * int64 (SectorsPerBlock) * 512;
  214. end else
  215. disksize := 0;
  216. end else
  217. disksize := 0;
  218. end;
  219. {******************************************************************************
  220. --- Findfirst FindNext ---
  221. ******************************************************************************}
  222. PROCEDURE find_setfields (VAR f : searchRec);
  223. BEGIN
  224. WITH F DO
  225. BEGIN
  226. IF Magic = $AD01 THEN
  227. BEGIN
  228. attr := WORD (PNWDirEnt(EntryP)^.d_attr); // lowest 16 bit -> same as dos
  229. time := PNWDirEnt(EntryP)^.d_time + (LONGINT (PNWDirEnt(EntryP)^.d_date) SHL 16);
  230. size := PNWDirEnt(EntryP)^.d_size;
  231. name := strpas (PNWDirEnt(EntryP)^.d_name);
  232. if name = '' then
  233. name := strpas (PNWDirEnt(EntryP)^.d_nameDOS);
  234. doserror := 0;
  235. END ELSE
  236. BEGIN
  237. FillChar (f,SIZEOF(f),0);
  238. doserror := 18;
  239. END;
  240. END;
  241. END;
  242. procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  243. var
  244. path0 : array[0..256] of char;
  245. begin
  246. IF path = '' then
  247. begin
  248. doserror := 18;
  249. exit;
  250. end;
  251. strpcopy(path0,path);
  252. PNWDirEnt(f.DirP) := _opendir (path0);
  253. IF f.DirP = NIL THEN
  254. doserror := 18
  255. ELSE
  256. BEGIN
  257. IF attr <> anyfile THEN
  258. _SetReaddirAttribute (PNWDirEnt(f.DirP), attr);
  259. F.Magic := $AD01;
  260. PNWDirEnt(f.EntryP) := _readdir (PNWDirEnt(f.DirP));
  261. IF F.EntryP = NIL THEN
  262. BEGIN
  263. _closedir (PNWDirEnt(f.DirP));
  264. f.Magic := 0;
  265. doserror := 18;
  266. END ELSE
  267. find_setfields (f);
  268. END;
  269. end;
  270. procedure findnext(var f : searchRec);
  271. begin
  272. IF F.Magic <> $AD01 THEN
  273. BEGIN
  274. doserror := 18;
  275. EXIT;
  276. END;
  277. doserror:=0;
  278. PNWDirEnt(f.EntryP) := _readdir (PNWDirEnt(f.DirP));
  279. IF F.EntryP = NIL THEN
  280. doserror := 18
  281. ELSE
  282. find_setfields (f);
  283. end;
  284. Procedure FindClose(Var f: SearchRec);
  285. begin
  286. IF F.Magic <> $AD01 THEN
  287. BEGIN
  288. doserror := 18;
  289. EXIT;
  290. END;
  291. doserror:=0;
  292. _closedir (PNWDirEnt(f.DirP));
  293. f.Magic := 0;
  294. f.DirP := NIL;
  295. f.EntryP := NIL;
  296. end;
  297. {******************************************************************************
  298. --- File ---
  299. ******************************************************************************}
  300. Function FSearch(path: pathstr; dirlist: string): pathstr;
  301. var
  302. i,p1 : longint;
  303. s : searchrec;
  304. newdir : pathstr;
  305. begin
  306. write ('FSearch ("',path,'","',dirlist,'"');
  307. { check if the file specified exists }
  308. findfirst(path,anyfile,s);
  309. if doserror=0 then
  310. begin
  311. findclose(s);
  312. fsearch:=path;
  313. exit;
  314. end;
  315. { No wildcards allowed in these things }
  316. if (pos('?',path)<>0) or (pos('*',path)<>0) then
  317. fsearch:=''
  318. else
  319. begin
  320. { allow backslash as slash }
  321. for i:=1 to length(dirlist) do
  322. if dirlist[i]='\' then dirlist[i]:='/';
  323. repeat
  324. p1:=pos(';',dirlist);
  325. if p1<>0 then
  326. begin
  327. newdir:=copy(dirlist,1,p1-1);
  328. delete(dirlist,1,p1);
  329. end
  330. else
  331. begin
  332. newdir:=dirlist;
  333. dirlist:='';
  334. end;
  335. if (newdir<>'') and (not (newdir[length(newdir)] in ['/',':'])) then
  336. newdir:=newdir+'/';
  337. findfirst(newdir+path,anyfile,s);
  338. if doserror=0 then
  339. newdir:=newdir+path
  340. else
  341. newdir:='';
  342. until (dirlist='') or (newdir<>'');
  343. fsearch:=newdir;
  344. end;
  345. findclose(s);
  346. end;
  347. {******************************************************************************
  348. --- Get/Set File Time,Attr ---
  349. ******************************************************************************}
  350. procedure getftime(var f;var time : longint);
  351. VAR StatBuf : NWStatBufT;
  352. T : DateTime;
  353. DosDate,
  354. DosTime : WORD;
  355. begin
  356. IF _fstat (FileRec (f).Handle, StatBuf) = 0 THEN
  357. BEGIN
  358. _ConvertTimeToDos (StatBuf.st_mtime, DosDate, DosTime);
  359. time := DosTime + (LONGINT (DosDate) SHL 16);
  360. END ELSE
  361. time := 0;
  362. end;
  363. procedure setftime(var f;time : longint);
  364. begin
  365. {is there a netware function to do that ?????}
  366. ConsolePrintf ('warning: fpc dos.setftime not implemented'#13#10);
  367. end;
  368. procedure getfattr(var f;var attr : word);
  369. VAR StatBuf : NWStatBufT;
  370. begin
  371. IF _fstat (FileRec (f).Handle, StatBuf) = 0 THEN
  372. BEGIN
  373. attr := word (StatBuf.st_attr);
  374. END ELSE
  375. attr := 0;
  376. end;
  377. procedure setfattr(var f;attr : word);
  378. begin
  379. {is there a netware function to do that ?????}
  380. ConsolePrintf ('warning: fpc dos.setfattr not implemented'#13#10);
  381. end;
  382. {******************************************************************************
  383. --- Environment ---
  384. ******************************************************************************}
  385. function envcount : longint;
  386. begin
  387. envcount := 0; {is there a netware function to do that ?????}
  388. ConsolePrintf ('warning: fpc dos.envcount not implemented'#13#10);
  389. end;
  390. function envstr (index: longint) : string;
  391. begin
  392. envstr := ''; {is there a netware function to do that ?????}
  393. ConsolePrintf ('warning: fpc dos.envstr not implemented'#13#10);
  394. end;
  395. { works fine (at least with netware 6.5) }
  396. Function GetEnv(envvar: string): string;
  397. var envvar0 : array[0..512] of char;
  398. p : pchar;
  399. i,isDosPath,res : longint;
  400. begin
  401. if upcase(envvar) = 'PATH' then
  402. begin // netware does not have search paths in the environment var PATH
  403. // return it here (needed for the compiler)
  404. GetEnv := '';
  405. i := 1;
  406. res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]);
  407. while res = 0 do
  408. begin
  409. if GetEnv <> '' then GetEnv := GetEnv + ';';
  410. GetEnv := GetEnv + strpas(envvar0);
  411. inc (i);
  412. res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]);
  413. end;
  414. for i := 1 to length(GetEnv) do
  415. if GetEnv[i] = '\' then
  416. GetEnv[i] := '/';
  417. end else
  418. begin
  419. strpcopy(envvar0,envvar);
  420. p := _getenv (envvar0);
  421. if p = NIL then
  422. GetEnv := ''
  423. else
  424. GetEnv := strpas (p);
  425. end;
  426. end;
  427. {******************************************************************************
  428. --- Not Supported ---
  429. ******************************************************************************}
  430. Procedure keep(exitcode : word);
  431. Begin
  432. { simply wait until nlm will be unloaded }
  433. while true do _delay (60000);
  434. End;
  435. end.
  436. {
  437. $Log$
  438. Revision 1.14 2005-01-11 11:32:33 armin
  439. * fixed compile error in getenv
  440. Revision 1.13 2004/12/07 11:03:44 armin
  441. * fixed typo's
  442. Revision 1.12 2004/12/05 16:44:43 hajny
  443. * GetMsCount added, platform independent routines moved to single include file
  444. Revision 1.11 2004/08/01 20:02:48 armin
  445. * changed dir separator from \ to /
  446. * long namespace by default
  447. * dos.exec implemented
  448. * getenv ('PATH') is now supported
  449. * changed FExpand to global version
  450. * fixed heaplist growth error
  451. * support SysOSFree
  452. * stackcheck was without saveregisters
  453. * fpc can compile itself on netware
  454. Revision 1.10 2004/02/17 17:37:26 daniel
  455. * Enable threadvars again
  456. Revision 1.9 2004/02/16 22:16:59 hajny
  457. * LastDosExitCode changed back from threadvar temporarily
  458. Revision 1.8 2004/02/15 21:34:06 hajny
  459. * overloaded ExecuteProcess added, EnvStr param changed to longint
  460. Revision 1.7 2004/02/09 12:03:16 michael
  461. + Switched to single interface in dosh.inc
  462. Revision 1.6 2003/03/25 18:17:54 armin
  463. * support for fcl, support for linking without debug info
  464. * renamed winsock2 to winsock for win32 compatinility
  465. * new sockets unit for netware
  466. * changes for compiler warnings
  467. Revision 1.5 2002/09/07 16:01:20 peter
  468. * old logs removed and tabs fixed
  469. }