dos.pp 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2004 by the Free Pascal development team.
  4. Dos unit for BP7 compatible RTL
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. unit dos;
  12. interface
  13. uses windows;
  14. Const
  15. Max_Path = MaxPathLen;
  16. Type
  17. Searchrec = Packed Record
  18. FindHandle : THandle;
  19. W32FindData : TWin32FindData;
  20. ExcludeAttr : longint;
  21. time : longint;
  22. size : longint;
  23. attr : longint;
  24. name : string;
  25. end;
  26. {$i dosh.inc}
  27. Function WinToDosTime (Const Wtime : TFileTime; var DTime:longint):longbool;
  28. Function DosToWinTime (DTime:longint; var Wtime : TFileTime):longbool;
  29. implementation
  30. {$DEFINE HAS_GETMSCOUNT}
  31. {$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
  32. {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
  33. {$I dos.inc}
  34. {******************************************************************************
  35. --- Conversion ---
  36. ******************************************************************************}
  37. function GetMsCount: int64;
  38. begin
  39. GetMsCount := cardinal (GetTickCount);
  40. end;
  41. function Last2DosError(d:dword):integer;
  42. begin
  43. case d of
  44. 87 : { Parameter invalid -> Data invalid }
  45. Last2DosError:=13;
  46. else
  47. Last2DosError:=integer(d);
  48. end;
  49. end;
  50. Function DosToWinAttr (Const Attr : Longint) : longint;
  51. begin
  52. DosToWinAttr:=Attr;
  53. end;
  54. Function WinToDosAttr (Const Attr : Longint) : longint;
  55. begin
  56. WinToDosAttr:=Attr;
  57. end;
  58. type
  59. Longrec=packed record
  60. lo,hi : word;
  61. end;
  62. Function DosToWinTime (DTime:longint; var Wtime : TFileTime):longbool;
  63. var
  64. FatDate, FatTime: WORD;
  65. lft: TFileTime;
  66. st: SYSTEMTIME;
  67. begin
  68. FatDate:=Longrec(Dtime).Hi;
  69. FatTime:=Longrec(Dtime).Lo;
  70. with st do
  71. begin
  72. wDay:=FatDate and $1F;
  73. wMonth:=(FatDate shr 5) and $F;
  74. wYear:=(FatDate shr 9) + 1980;
  75. wSecond:=(FatTime and $1F)*2;
  76. wMinute:=(FatTime shr 5) and $1F;
  77. wHour:=FatTime shr 11;
  78. wMilliseconds:=0;
  79. wDayOfWeek:=0;
  80. end;
  81. DosToWinTime:=SystemTimeToFileTime(@st, @lft) and LocalFileTimeToFileTime(@lft, @Wtime);
  82. end;
  83. Function WinToDosTime (Const Wtime : TFileTime; var DTime:longint):longbool;
  84. var
  85. FatDate, FatTime: WORD;
  86. lft: TFileTime;
  87. st: SYSTEMTIME;
  88. res: longbool;
  89. begin
  90. res:=FileTimeToLocalFileTime(@WTime, @lft) and FileTimeToSystemTime(@lft, @st);
  91. if res then
  92. begin
  93. FatDate:=st.wDay or (st.wMonth shl 5) or ((st.wYear - 1980) shl 9);
  94. FatTime:=(st.wSecond div 2) or (st.wMinute shl 5) or (st.wHour shl 11);
  95. Longrec(Dtime).Hi:=FatDate;
  96. Longrec(Dtime).Lo:=FatTime;
  97. end;
  98. WinToDosTime:=res;
  99. end;
  100. {******************************************************************************
  101. --- Info / Date / Time ---
  102. ******************************************************************************}
  103. function dosversion : word;
  104. var
  105. versioninfo : OSVERSIONINFO;
  106. begin
  107. versioninfo.dwOSVersionInfoSize:=sizeof(versioninfo);
  108. GetVersionEx(versioninfo);
  109. dosversion:=versioninfo.dwMajorVersion and $FF or versioninfo.dwMinorVersion and $FF shl 8;
  110. end;
  111. procedure getdate(var year,month,mday,wday : word);
  112. var
  113. t : TSystemTime;
  114. begin
  115. GetLocalTime(t);
  116. year:=t.wYear;
  117. month:=t.wMonth;
  118. mday:=t.wDay;
  119. wday:=t.wDayOfWeek;
  120. end;
  121. procedure setdate(year,month,day : word);
  122. var
  123. t : TSystemTime;
  124. begin
  125. GetLocalTime(t);
  126. t.wYear:=year;
  127. t.wMonth:=month;
  128. t.wDay:=day;
  129. { only a quite good solution, we can loose some ms }
  130. SetLocalTime(t);
  131. end;
  132. procedure gettime(var hour,minute,second,sec100 : word);
  133. var
  134. t : TSystemTime;
  135. begin
  136. GetLocalTime(t);
  137. hour:=t.wHour;
  138. minute:=t.wMinute;
  139. second:=t.wSecond;
  140. sec100:=t.wMilliSeconds div 10;
  141. end;
  142. procedure settime(hour,minute,second,sec100 : word);
  143. var
  144. t : TSystemTime;
  145. begin
  146. GetLocalTime(t);
  147. t.wHour:=hour;
  148. t.wMinute:=minute;
  149. t.wSecond:=second;
  150. t.wMilliSeconds:=sec100*10;
  151. SetLocalTime(t);
  152. end;
  153. {******************************************************************************
  154. --- Exec ---
  155. ******************************************************************************}
  156. procedure exec(const path : pathstr;const comline : comstr);
  157. var
  158. PI: TProcessInformation;
  159. Proc : THandle;
  160. l : LongInt;
  161. PathW : array[0..FileNameLen] of WideChar;
  162. CmdLineW : array[0..FileNameLen] of WideChar;
  163. begin
  164. DosError := 0;
  165. AnsiToWideBuf(@path[1], Length(path), PathW, SizeOf(PathW));
  166. AnsiToWideBuf(@comline[1], Length(comline), CmdLineW, SizeOf(CmdLineW));
  167. if not CreateProcess(PathW, CmdLineW,
  168. nil, nil, FALSE, 0, nil, nil, nil, PI) then
  169. begin
  170. DosError:=Last2DosError(GetLastError);
  171. exit;
  172. end;
  173. Proc:=PI.hProcess;
  174. CloseHandle(PI.hThread);
  175. if WaitForSingleObject(Proc, dword($ffffffff)) <> $ffffffff then
  176. GetExitCodeProcess(Proc, @l)
  177. else
  178. l:=-1;
  179. CloseHandle(Proc);
  180. LastDosExitCode:=l;
  181. end;
  182. {******************************************************************************
  183. --- Disk ---
  184. ******************************************************************************}
  185. var
  186. DriveNames: array[1..24] of PWideChar;
  187. function GetDriveName(drive: byte): PWideChar;
  188. const
  189. dev_attr = FILE_ATTRIBUTE_TEMPORARY or FILE_ATTRIBUTE_DIRECTORY;
  190. var
  191. h: THandle;
  192. fd: TWin32FindData;
  193. i, len: LongInt;
  194. begin
  195. GetDriveName:=nil;
  196. // Current drive is C: drive always
  197. if drive = 0 then
  198. drive:=2;
  199. if (drive < 3) or (drive > 26) then
  200. exit;
  201. if DriveNames[1] = nil then
  202. begin
  203. // Drive C: is filesystem root always
  204. GetMem(DriveNames[1], 2*SizeOf(WideChar));
  205. DriveNames[1][0]:='\';
  206. DriveNames[1][1]:=#0;
  207. // Other drives are found dinamically
  208. h:=FindFirstFile('\*', @fd);
  209. if h <> 0 then
  210. begin
  211. i:=2;
  212. repeat
  213. if fd.dwFileAttributes and dev_attr = dev_attr then begin
  214. len:=0;
  215. while fd.cFileName[len] <> 0 do
  216. Inc(len);
  217. len:=(len + 2)*SizeOf(WideChar);
  218. GetMem(DriveNames[i], len);
  219. DriveNames[i]^:='\';
  220. Move(fd.cFileName, DriveNames[i][1], len - SizeOf(WideChar));
  221. Inc(i);
  222. end;
  223. until (i > 24) or not FindNextFile(h, fd);
  224. Windows.FindClose(h);
  225. end;
  226. end;
  227. GetDriveName:=DriveNames[drive - 2];
  228. end;
  229. function diskfree(drive : byte) : int64;
  230. var
  231. disk: PWideChar;
  232. qwtotal,qwfree,qwcaller : int64;
  233. begin
  234. disk:=GetDriveName(drive);
  235. if (disk <> nil) and GetDiskFreeSpaceEx(disk, @qwcaller, @qwtotal, @qwfree) then
  236. diskfree:=qwfree
  237. else
  238. diskfree:=-1;
  239. end;
  240. function disksize(drive : byte) : int64;
  241. var
  242. disk : PWideChar;
  243. qwtotal,qwfree,qwcaller : int64;
  244. begin
  245. disk:=GetDriveName(drive);
  246. if (disk <> nil) and GetDiskFreeSpaceEx(disk, @qwcaller, @qwtotal, @qwfree) then
  247. disksize:=qwtotal
  248. else
  249. disksize:=-1;
  250. end;
  251. {******************************************************************************
  252. --- Findfirst FindNext ---
  253. ******************************************************************************}
  254. Procedure StringToPchar (Var S : String);
  255. Var L : Longint;
  256. begin
  257. L:=ord(S[0]);
  258. Move (S[1],S[0],L);
  259. S[L]:=#0;
  260. end;
  261. Procedure PCharToString (Var S : String);
  262. Var L : Longint;
  263. begin
  264. L:=strlen(pchar(@S[0]));
  265. Move (S[0],S[1],L);
  266. S[0]:=char(l);
  267. end;
  268. procedure FindMatch(var f:searchrec);
  269. var
  270. buf: array[0..MaxPathLen] of char;
  271. begin
  272. { Find file with correct attribute }
  273. While (F.W32FindData.dwFileAttributes and cardinal(F.ExcludeAttr))<>0 do
  274. begin
  275. if not FindNextFile (F.FindHandle, F.W32FindData) then
  276. begin
  277. DosError:=Last2DosError(GetLastError);
  278. if DosError=2 then
  279. DosError:=18;
  280. exit;
  281. end;
  282. end;
  283. { Convert some attributes back }
  284. f.size:=F.W32FindData.NFileSizeLow;
  285. f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes);
  286. WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time);
  287. WideToAnsiBuf(@F.W32FindData.cFileName, -1, buf, SizeOf(buf));
  288. f.Name:=StrPas(@buf);
  289. end;
  290. procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  291. var
  292. buf: array[0..MaxPathLen] of WideChar;
  293. begin
  294. fillchar(f,sizeof(f),0);
  295. { no error }
  296. doserror:=0;
  297. F.Name:=Path;
  298. F.Attr:=attr;
  299. F.ExcludeAttr:=(not Attr) and ($1e); {hidden,sys,dir,volume}
  300. StringToPchar(f.name);
  301. { FindFirstFile is a WinCE Call }
  302. F.W32FindData.dwFileAttributes:=DosToWinAttr(f.attr);
  303. AnsiToWideBuf(@f.Name, -1, buf, SizeOf(buf));
  304. F.FindHandle:=FindFirstFile (buf, F.W32FindData);
  305. If F.FindHandle = Invalid_Handle_value then
  306. begin
  307. DosError:=Last2DosError(GetLastError);
  308. if DosError=2 then
  309. DosError:=18;
  310. exit;
  311. end;
  312. { Find file with correct attribute }
  313. FindMatch(f);
  314. end;
  315. procedure findnext(var f : searchRec);
  316. begin
  317. { no error }
  318. doserror:=0;
  319. if not FindNextFile (F.FindHandle, F.W32FindData) then
  320. begin
  321. DosError:=Last2DosError(GetLastError);
  322. if DosError=2 then
  323. DosError:=18;
  324. exit;
  325. end;
  326. { Find file with correct attribute }
  327. FindMatch(f);
  328. end;
  329. Procedure FindClose(Var f: SearchRec);
  330. begin
  331. If F.FindHandle <> Invalid_Handle_value then
  332. Windows.FindClose(F.FindHandle);
  333. end;
  334. {******************************************************************************
  335. --- File ---
  336. ******************************************************************************}
  337. Function FSearch(path: pathstr; dirlist: string): pathstr;
  338. var
  339. i,p1 : longint;
  340. s : searchrec;
  341. newdir : pathstr;
  342. begin
  343. { check if the file specified exists }
  344. findfirst(path,anyfile and not(directory),s);
  345. if doserror=0 then
  346. begin
  347. findclose(s);
  348. fsearch:=path;
  349. exit;
  350. end;
  351. { No wildcards allowed in these things }
  352. if (pos('?',path)<>0) or (pos('*',path)<>0) then
  353. fsearch:=''
  354. else
  355. begin
  356. { allow slash as backslash }
  357. for i:=1 to length(dirlist) do
  358. if dirlist[i]='/' then dirlist[i]:='\';
  359. repeat
  360. p1:=pos(';',dirlist);
  361. if p1<>0 then
  362. begin
  363. newdir:=copy(dirlist,1,p1-1);
  364. delete(dirlist,1,p1);
  365. end
  366. else
  367. begin
  368. newdir:=dirlist;
  369. dirlist:='';
  370. end;
  371. if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
  372. newdir:=newdir+'\';
  373. findfirst(newdir+path,anyfile and not(directory),s);
  374. if doserror=0 then
  375. newdir:=newdir+path
  376. else
  377. newdir:='';
  378. until (dirlist='') or (newdir<>'');
  379. fsearch:=newdir;
  380. end;
  381. findclose(s);
  382. end;
  383. { </immobilizer> }
  384. procedure getftime(var f;var time : longint);
  385. var
  386. ft : TFileTime;
  387. begin
  388. doserror:=0;
  389. if GetFileTime(filerec(f).Handle,nil,nil,@ft) and
  390. WinToDosTime(ft,time) then
  391. exit
  392. else
  393. begin
  394. DosError:=Last2DosError(GetLastError);
  395. time:=0;
  396. end;
  397. end;
  398. procedure setftime(var f;time : longint);
  399. var
  400. ft : TFileTime;
  401. begin
  402. doserror:=0;
  403. if DosToWinTime(time,ft) and
  404. SetFileTime(filerec(f).Handle,nil,nil,@ft) then
  405. exit
  406. else
  407. DosError:=Last2DosError(GetLastError);
  408. end;
  409. procedure getfattr(var f;var attr : word);
  410. var
  411. l : longint;
  412. buf: array[0..MaxPathLen] of WideChar;
  413. begin
  414. doserror:=0;
  415. AnsiToWideBuf(@filerec(f).name, -1, buf, SizeOf(buf));
  416. l:=GetFileAttributes(buf);
  417. if l=longint($ffffffff) then
  418. begin
  419. doserror:=Last2DosError(GetLastError);
  420. attr:=0;
  421. end
  422. else
  423. attr:=l and $ffff;
  424. end;
  425. procedure setfattr(var f;attr : word);
  426. var
  427. buf: array[0..MaxPathLen] of WideChar;
  428. begin
  429. { Fail for setting VolumeId }
  430. if (attr and VolumeID)<>0 then
  431. doserror:=5
  432. else
  433. AnsiToWideBuf(@filerec(f).name, -1, buf, SizeOf(buf));
  434. if SetFileAttributes(buf,attr) then
  435. doserror:=0
  436. else
  437. doserror:=Last2DosError(GetLastError);
  438. end;
  439. {******************************************************************************
  440. --- Environment ---
  441. ******************************************************************************}
  442. // WinCE does not have environment. It can be emulated via registry or file. (YS)
  443. function envcount : longint;
  444. begin
  445. envcount:=0;
  446. end;
  447. Function EnvStr (Index: longint): string;
  448. begin
  449. EnvStr:='';
  450. end;
  451. Function GetEnv(envvar: string): string;
  452. begin
  453. GetEnv:='';
  454. end;
  455. var
  456. oldexitproc : pointer;
  457. procedure dosexitproc;
  458. var
  459. i: LongInt;
  460. begin
  461. exitproc:=oldexitproc;
  462. if DriveNames[1] <> nil then
  463. for i:=1 to 24 do
  464. if DriveNames[i] <> nil then
  465. FreeMem(DriveNames[i])
  466. else
  467. break;
  468. end;
  469. begin
  470. oldexitproc:=exitproc;
  471. exitproc:=@dosexitproc;
  472. end.