dos.pp 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974
  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
  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. Uses
  15. Go32;
  16. Const
  17. FileNameLen = 255;
  18. Type
  19. searchrec = packed record
  20. fill : array[1..21] of byte;
  21. attr : byte;
  22. time : longint;
  23. { reserved : word; not in DJGPP V2 }
  24. size : longint;
  25. name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) }
  26. end;
  27. Registers = Go32.Registers;
  28. {$i dosh.inc}
  29. implementation
  30. uses
  31. strings;
  32. {******************************************************************************
  33. --- Dos Interrupt ---
  34. ******************************************************************************}
  35. var
  36. dosregs : registers;
  37. procedure LoadDosError;
  38. var
  39. r : registers;
  40. SimpleDosError : word;
  41. begin
  42. if (dosregs.flags and fcarry) <> 0 then
  43. begin
  44. { I got a extended error = 0
  45. while CarryFlag was set from Exec function }
  46. SimpleDosError:=dosregs.ax;
  47. r.eax:=$5900;
  48. r.ebx:=$0;
  49. realintr($21,r);
  50. { conversion from word to integer !!
  51. gave a Bound check error if ax is $FFFF !! PM }
  52. doserror:=integer(r.ax);
  53. case doserror of
  54. 0 : DosError:=integer(SimpleDosError);
  55. 19 : DosError:=150;
  56. 21 : DosError:=152;
  57. end;
  58. end
  59. else
  60. doserror:=0;
  61. end;
  62. procedure intr(intno : byte;var regs : registers);
  63. begin
  64. realintr(intno,regs);
  65. end;
  66. procedure msdos(var regs : registers);
  67. begin
  68. intr($21,regs);
  69. end;
  70. {******************************************************************************
  71. --- Info / Date / Time ---
  72. ******************************************************************************}
  73. function dosversion : word;
  74. begin
  75. dosregs.ax:=$3000;
  76. msdos(dosregs);
  77. dosversion:=dosregs.ax;
  78. end;
  79. procedure getdate(var year,month,mday,wday : word);
  80. begin
  81. dosregs.ax:=$2a00;
  82. msdos(dosregs);
  83. wday:=dosregs.al;
  84. year:=dosregs.cx;
  85. month:=dosregs.dh;
  86. mday:=dosregs.dl;
  87. end;
  88. procedure setdate(year,month,day : word);
  89. begin
  90. dosregs.cx:=year;
  91. dosregs.dh:=month;
  92. dosregs.dl:=day;
  93. dosregs.ah:=$2b;
  94. msdos(dosregs);
  95. end;
  96. procedure gettime(var hour,minute,second,sec100 : word);
  97. begin
  98. dosregs.ah:=$2c;
  99. msdos(dosregs);
  100. hour:=dosregs.ch;
  101. minute:=dosregs.cl;
  102. second:=dosregs.dh;
  103. sec100:=dosregs.dl;
  104. end;
  105. procedure settime(hour,minute,second,sec100 : word);
  106. begin
  107. dosregs.ch:=hour;
  108. dosregs.cl:=minute;
  109. dosregs.dh:=second;
  110. dosregs.dl:=sec100;
  111. dosregs.ah:=$2d;
  112. msdos(dosregs);
  113. end;
  114. Procedure packtime(var t : datetime;var p : longint);
  115. Begin
  116. p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
  117. End;
  118. Procedure unpacktime(p : longint;var t : datetime);
  119. Begin
  120. with t do
  121. begin
  122. sec:=(p and 31) shl 1;
  123. min:=(p shr 5) and 63;
  124. hour:=(p shr 11) and 31;
  125. day:=(p shr 16) and 31;
  126. month:=(p shr 21) and 15;
  127. year:=(p shr 25)+1980;
  128. end;
  129. End;
  130. {******************************************************************************
  131. --- Exec ---
  132. ******************************************************************************}
  133. {$ifdef HASTHREADVAR}
  134. threadvar
  135. {$else HASTHREADVAR}
  136. var
  137. {$endif HASTHREADVAR}
  138. lastdosexitcode : word;
  139. procedure exec(const path : pathstr;const comline : comstr);
  140. type
  141. realptr = packed record
  142. ofs,seg : word;
  143. end;
  144. texecblock = packed record
  145. envseg : word;
  146. comtail : realptr;
  147. firstFCB : realptr;
  148. secondFCB : realptr;
  149. iniStack : realptr;
  150. iniCSIP : realptr;
  151. end;
  152. var
  153. current_dos_buffer_pos,
  154. arg_ofs,
  155. i,la_env,
  156. la_p,la_c,la_e,
  157. fcb1_la,fcb2_la : longint;
  158. execblock : texecblock;
  159. c,p : string;
  160. function paste_to_dos(src : string) : boolean;
  161. var
  162. c : array[0..255] of char;
  163. begin
  164. paste_to_dos:=false;
  165. if current_dos_buffer_pos+length(src)+1>transfer_buffer+tb_size then
  166. RunError(217);
  167. move(src[1],c[0],length(src));
  168. c[length(src)]:=#0;
  169. seg_move(get_ds,longint(@c),dosmemselector,current_dos_buffer_pos,length(src)+1);
  170. current_dos_buffer_pos:=current_dos_buffer_pos+length(src)+1;
  171. paste_to_dos:=true;
  172. end;
  173. begin
  174. { create command line }
  175. move(comline[0],c[1],length(comline)+1);
  176. c[length(comline)+2]:=#13;
  177. c[0]:=char(length(comline)+2);
  178. { create path }
  179. p:=path;
  180. for i:=1 to length(p) do
  181. if p[i]='/' then
  182. p[i]:='\';
  183. if LFNSupport then
  184. GetShortName(p);
  185. { create buffer }
  186. la_env:=transfer_buffer;
  187. while (la_env and 15)<>0 do
  188. inc(la_env);
  189. current_dos_buffer_pos:=la_env;
  190. { copy environment }
  191. for i:=1 to envcount do
  192. paste_to_dos(envstr(i));
  193. paste_to_dos(''); { adds a double zero at the end }
  194. { allow slash as backslash }
  195. la_p:=current_dos_buffer_pos;
  196. paste_to_dos(p);
  197. la_c:=current_dos_buffer_pos;
  198. paste_to_dos(c);
  199. la_e:=current_dos_buffer_pos;
  200. fcb1_la:=la_e;
  201. la_e:=la_e+16;
  202. fcb2_la:=la_e;
  203. la_e:=la_e+16;
  204. { allocate FCB see dosexec code }
  205. arg_ofs:=1;
  206. while (c[arg_ofs] in [' ',#9]) do
  207. inc(arg_ofs);
  208. dosregs.ax:=$2901;
  209. dosregs.ds:=(la_c+arg_ofs) shr 4;
  210. dosregs.esi:=(la_c+arg_ofs) and 15;
  211. dosregs.es:=fcb1_la shr 4;
  212. dosregs.edi:=fcb1_la and 15;
  213. msdos(dosregs);
  214. { allocate second FCB see dosexec code }
  215. repeat
  216. inc(arg_ofs);
  217. until (c[arg_ofs] in [' ',#9,#13]);
  218. if c[arg_ofs]<>#13 then
  219. begin
  220. repeat
  221. inc(arg_ofs);
  222. until not (c[arg_ofs] in [' ',#9]);
  223. end;
  224. dosregs.ax:=$2901;
  225. dosregs.ds:=(la_c+arg_ofs) shr 4;
  226. dosregs.si:=(la_c+arg_ofs) and 15;
  227. dosregs.es:=fcb2_la shr 4;
  228. dosregs.di:=fcb2_la and 15;
  229. msdos(dosregs);
  230. with execblock do
  231. begin
  232. envseg:=la_env shr 4;
  233. comtail.seg:=la_c shr 4;
  234. comtail.ofs:=la_c and 15;
  235. firstFCB.seg:=fcb1_la shr 4;
  236. firstFCB.ofs:=fcb1_la and 15;
  237. secondFCB.seg:=fcb2_la shr 4;
  238. secondFCB.ofs:=fcb2_la and 15;
  239. end;
  240. seg_move(get_ds,longint(@execblock),dosmemselector,la_e,sizeof(texecblock));
  241. dosregs.edx:=la_p and 15;
  242. dosregs.ds:=la_p shr 4;
  243. dosregs.ebx:=la_e and 15;
  244. dosregs.es:=la_e shr 4;
  245. dosregs.ax:=$4b00;
  246. msdos(dosregs);
  247. LoadDosError;
  248. if DosError=0 then
  249. begin
  250. dosregs.ax:=$4d00;
  251. msdos(dosregs);
  252. LastDosExitCode:=DosRegs.al
  253. end
  254. else
  255. LastDosExitCode:=0;
  256. end;
  257. function dosexitcode : word;
  258. begin
  259. dosexitcode:=lastdosexitcode;
  260. end;
  261. procedure getcbreak(var breakvalue : boolean);
  262. begin
  263. dosregs.ax:=$3300;
  264. msdos(dosregs);
  265. breakvalue:=dosregs.dl<>0;
  266. end;
  267. procedure setcbreak(breakvalue : boolean);
  268. begin
  269. dosregs.ax:=$3301;
  270. dosregs.dl:=ord(breakvalue);
  271. msdos(dosregs);
  272. end;
  273. procedure getverify(var verify : boolean);
  274. begin
  275. dosregs.ah:=$54;
  276. msdos(dosregs);
  277. verify:=dosregs.al<>0;
  278. end;
  279. procedure setverify(verify : boolean);
  280. begin
  281. dosregs.ah:=$2e;
  282. dosregs.al:=ord(verify);
  283. msdos(dosregs);
  284. end;
  285. {******************************************************************************
  286. --- Disk ---
  287. ******************************************************************************}
  288. TYPE ExtendedFat32FreeSpaceRec=packed Record
  289. RetSize : WORD; { (ret) size of returned structure}
  290. Strucversion : WORD; {(call) structure version (0000h)
  291. (ret) actual structure version (0000h)}
  292. SecPerClus, {number of sectors per cluster}
  293. BytePerSec, {number of bytes per sector}
  294. AvailClusters, {number of available clusters}
  295. TotalClusters, {total number of clusters on the drive}
  296. AvailPhysSect, {physical sectors available on the drive}
  297. TotalPhysSect, {total physical sectors on the drive}
  298. AvailAllocUnits, {Available allocation units}
  299. TotalAllocUnits : DWORD; {Total allocation units}
  300. Dummy,Dummy2 : DWORD; {8 bytes reserved}
  301. END;
  302. function do_diskdata(drive : byte; Free : BOOLEAN) : Int64;
  303. VAR
  304. S : String;
  305. Rec : ExtendedFat32FreeSpaceRec;
  306. BEGIN
  307. if (swap(dosversion)>=$070A) AND LFNSupport then
  308. begin
  309. S:='C:\'#0;
  310. if Drive=0 then
  311. begin
  312. GetDir(Drive,S);
  313. Setlength(S,4);
  314. S[4]:=#0;
  315. end
  316. else
  317. S[1]:=chr(Drive+64);
  318. Rec.Strucversion:=0;
  319. dosmemput(tb_segment,tb_offset,Rec,SIZEOF(ExtendedFat32FreeSpaceRec));
  320. dosmemput(tb_segment,tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1,S[1],4);
  321. dosregs.dx:=tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1;
  322. dosregs.ds:=tb_segment;
  323. dosregs.di:=tb_offset;
  324. dosregs.es:=tb_segment;
  325. dosregs.cx:=Sizeof(ExtendedFat32FreeSpaceRec);
  326. dosregs.ax:=$7303;
  327. msdos(dosregs);
  328. if (dosregs.flags and fcarry) = 0 then {No error clausule in int except cf}
  329. begin
  330. copyfromdos(rec,Sizeof(ExtendedFat32FreeSpaceRec));
  331. if Free then
  332. Do_DiskData:=int64(rec.AvailAllocUnits)*rec.SecPerClus*rec.BytePerSec
  333. else
  334. Do_DiskData:=int64(rec.TotalAllocUnits)*rec.SecPerClus*rec.BytePerSec;
  335. end
  336. else
  337. Do_DiskData:=-1;
  338. end
  339. else
  340. begin
  341. dosregs.dl:=drive;
  342. dosregs.ah:=$36;
  343. msdos(dosregs);
  344. if dosregs.ax<>$FFFF then
  345. begin
  346. if Free then
  347. Do_DiskData:=int64(dosregs.ax)*dosregs.bx*dosregs.cx
  348. else
  349. Do_DiskData:=int64(dosregs.ax)*dosregs.cx*dosregs.dx;
  350. end
  351. else
  352. do_diskdata:=-1;
  353. end;
  354. end;
  355. function diskfree(drive : byte) : int64;
  356. begin
  357. diskfree:=Do_DiskData(drive,TRUE);
  358. end;
  359. function disksize(drive : byte) : int64;
  360. begin
  361. disksize:=Do_DiskData(drive,false);
  362. end;
  363. {******************************************************************************
  364. --- LFNFindfirst LFNFindNext ---
  365. ******************************************************************************}
  366. type
  367. LFNSearchRec=packed record
  368. attr,
  369. crtime,
  370. crtimehi,
  371. actime,
  372. actimehi,
  373. lmtime,
  374. lmtimehi,
  375. sizehi,
  376. size : longint;
  377. reserved : array[0..7] of byte;
  378. name : array[0..259] of byte;
  379. shortname : array[0..13] of byte;
  380. end;
  381. procedure LFNSearchRec2Dos(const w:LFNSearchRec;hdl:longint;var d:Searchrec;from_findfirst : boolean);
  382. var
  383. Len : longint;
  384. begin
  385. With w do
  386. begin
  387. FillChar(d,sizeof(SearchRec),0);
  388. if DosError=0 then
  389. len:=StrLen(@Name)
  390. else
  391. len:=0;
  392. d.Name[0]:=chr(len);
  393. Move(Name[0],d.Name[1],Len);
  394. d.Time:=lmTime;
  395. d.Size:=Size;
  396. d.Attr:=Attr and $FF;
  397. if (DosError<>0) and from_findfirst then
  398. hdl:=-1;
  399. Move(hdl,d.Fill,4);
  400. end;
  401. end;
  402. procedure LFNFindFirst(path:pchar;attr:longint;var s:searchrec);
  403. var
  404. i : longint;
  405. w : LFNSearchRec;
  406. begin
  407. { allow slash as backslash }
  408. for i:=0 to strlen(path) do
  409. if path[i]='/' then path[i]:='\';
  410. dosregs.si:=1; { use ms-dos time }
  411. { don't include the label if not asked for it, needed for network drives }
  412. if attr=$8 then
  413. dosregs.ecx:=8
  414. else
  415. dosregs.ecx:=attr and (not 8);
  416. dosregs.edx:=tb_offset+Sizeof(LFNSearchrec)+1;
  417. dosmemput(tb_segment,tb_offset+Sizeof(LFNSearchrec)+1,path^,strlen(path)+1);
  418. dosregs.ds:=tb_segment;
  419. dosregs.edi:=tb_offset;
  420. dosregs.es:=tb_segment;
  421. dosregs.ax:=$714e;
  422. msdos(dosregs);
  423. LoadDosError;
  424. copyfromdos(w,sizeof(LFNSearchRec));
  425. LFNSearchRec2Dos(w,dosregs.ax,s,true);
  426. end;
  427. procedure LFNFindNext(var s:searchrec);
  428. var
  429. hdl : longint;
  430. w : LFNSearchRec;
  431. begin
  432. Move(s.Fill,hdl,4);
  433. dosregs.si:=1; { use ms-dos time }
  434. dosregs.edi:=tb_offset;
  435. dosregs.es:=tb_segment;
  436. dosregs.ebx:=hdl;
  437. dosregs.ax:=$714f;
  438. msdos(dosregs);
  439. LoadDosError;
  440. copyfromdos(w,sizeof(LFNSearchRec));
  441. LFNSearchRec2Dos(w,hdl,s,false);
  442. end;
  443. procedure LFNFindClose(var s:searchrec);
  444. var
  445. hdl : longint;
  446. begin
  447. Move(s.Fill,hdl,4);
  448. { Do not call MsDos if FindFirst returned with an error }
  449. if hdl=-1 then
  450. begin
  451. DosError:=0;
  452. exit;
  453. end;
  454. dosregs.ebx:=hdl;
  455. dosregs.ax:=$71a1;
  456. msdos(dosregs);
  457. LoadDosError;
  458. end;
  459. {******************************************************************************
  460. --- DosFindfirst DosFindNext ---
  461. ******************************************************************************}
  462. procedure dossearchrec2searchrec(var f : searchrec);
  463. var
  464. len : longint;
  465. begin
  466. { Check is necessary!! OS/2's VDM doesn't clear the name with #0 if the }
  467. { file doesn't exist! (JM) }
  468. if dosError = 0 then
  469. len:=StrLen(@f.Name)
  470. else len := 0;
  471. Move(f.Name[0],f.Name[1],Len);
  472. f.Name[0]:=chr(len);
  473. end;
  474. procedure DosFindfirst(path : pchar;attr : word;var f : searchrec);
  475. var
  476. i : longint;
  477. begin
  478. { allow slash as backslash }
  479. for i:=0 to strlen(path) do
  480. if path[i]='/' then path[i]:='\';
  481. copytodos(f,sizeof(searchrec));
  482. dosregs.edx:=tb_offset;
  483. dosregs.ds:=tb_segment;
  484. dosregs.ah:=$1a;
  485. msdos(dosregs);
  486. dosregs.ecx:=attr;
  487. dosregs.edx:=tb_offset+Sizeof(searchrec)+1;
  488. dosmemput(tb_segment,tb_offset+Sizeof(searchrec)+1,path^,strlen(path)+1);
  489. dosregs.ds:=tb_segment;
  490. dosregs.ah:=$4e;
  491. msdos(dosregs);
  492. copyfromdos(f,sizeof(searchrec));
  493. LoadDosError;
  494. dossearchrec2searchrec(f);
  495. end;
  496. procedure Dosfindnext(var f : searchrec);
  497. begin
  498. copytodos(f,sizeof(searchrec));
  499. dosregs.edx:=tb_offset;
  500. dosregs.ds:=tb_segment;
  501. dosregs.ah:=$1a;
  502. msdos(dosregs);
  503. dosregs.ah:=$4f;
  504. msdos(dosregs);
  505. copyfromdos(f,sizeof(searchrec));
  506. LoadDosError;
  507. dossearchrec2searchrec(f);
  508. end;
  509. {******************************************************************************
  510. --- Findfirst FindNext ---
  511. ******************************************************************************}
  512. procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  513. var
  514. path0 : array[0..256] of char;
  515. begin
  516. doserror:=0;
  517. strpcopy(path0,path);
  518. if LFNSupport then
  519. LFNFindFirst(path0,attr,f)
  520. else
  521. Dosfindfirst(path0,attr,f);
  522. end;
  523. procedure findnext(var f : searchRec);
  524. begin
  525. doserror:=0;
  526. if LFNSupport then
  527. LFNFindnext(f)
  528. else
  529. Dosfindnext(f);
  530. end;
  531. Procedure FindClose(Var f: SearchRec);
  532. begin
  533. DosError:=0;
  534. if LFNSupport then
  535. LFNFindClose(f);
  536. end;
  537. type swap_proc = procedure;
  538. var
  539. _swap_in : swap_proc;external name '_swap_in';
  540. _swap_out : swap_proc;external name '_swap_out';
  541. _exception_exit : pointer;external name '_exception_exit';
  542. _v2prt0_exceptions_on : longbool;external name '_v2prt0_exceptions_on';
  543. procedure swapvectors;
  544. begin
  545. if _exception_exit<>nil then
  546. if _v2prt0_exceptions_on then
  547. _swap_out()
  548. else
  549. _swap_in();
  550. end;
  551. {******************************************************************************
  552. --- File ---
  553. ******************************************************************************}
  554. procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
  555. var
  556. dotpos,p1,i : longint;
  557. begin
  558. { allow slash as backslash }
  559. for i:=1 to length(path) do
  560. if path[i]='/' then path[i]:='\';
  561. { get drive name }
  562. p1:=pos(':',path);
  563. if p1>0 then
  564. begin
  565. dir:=path[1]+':';
  566. delete(path,1,p1);
  567. end
  568. else
  569. dir:='';
  570. { split the path and the name, there are no more path informtions }
  571. { if path contains no backslashes }
  572. while true do
  573. begin
  574. p1:=pos('\',path);
  575. if p1=0 then
  576. break;
  577. dir:=dir+copy(path,1,p1);
  578. delete(path,1,p1);
  579. end;
  580. { try to find out a extension }
  581. if LFNSupport then
  582. begin
  583. Ext:='';
  584. i:=Length(Path);
  585. DotPos:=256;
  586. While (i>0) Do
  587. Begin
  588. If (Path[i]='.') Then
  589. begin
  590. DotPos:=i;
  591. break;
  592. end;
  593. Dec(i);
  594. end;
  595. Ext:=Copy(Path,DotPos,255);
  596. Name:=Copy(Path,1,DotPos - 1);
  597. end
  598. else
  599. begin
  600. p1:=pos('.',path);
  601. if p1>0 then
  602. begin
  603. ext:=copy(path,p1,4);
  604. delete(path,p1,length(path)-p1+1);
  605. end
  606. else
  607. ext:='';
  608. name:=path;
  609. end;
  610. end;
  611. (*
  612. function FExpand (const Path: PathStr): PathStr;
  613. - declared in fexpand.inc
  614. *)
  615. {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
  616. {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
  617. {$I fexpand.inc}
  618. {$UNDEF FPC_FEXPAND_DRIVES}
  619. {$UNDEF FPC_FEXPAND_UNC}
  620. Function FSearch(path: pathstr; dirlist: string): pathstr;
  621. var
  622. i,p1 : longint;
  623. s : searchrec;
  624. newdir : pathstr;
  625. begin
  626. { check if the file specified exists }
  627. findfirst(path,anyfile and not(directory),s);
  628. if doserror=0 then
  629. begin
  630. findclose(s);
  631. fsearch:=path;
  632. exit;
  633. end;
  634. { No wildcards allowed in these things }
  635. if (pos('?',path)<>0) or (pos('*',path)<>0) then
  636. fsearch:=''
  637. else
  638. begin
  639. { allow slash as backslash }
  640. for i:=1 to length(dirlist) do
  641. if dirlist[i]='/' then dirlist[i]:='\';
  642. repeat
  643. p1:=pos(';',dirlist);
  644. if p1<>0 then
  645. begin
  646. newdir:=copy(dirlist,1,p1-1);
  647. delete(dirlist,1,p1);
  648. end
  649. else
  650. begin
  651. newdir:=dirlist;
  652. dirlist:='';
  653. end;
  654. if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
  655. newdir:=newdir+'\';
  656. findfirst(newdir+path,anyfile and not(directory),s);
  657. if doserror=0 then
  658. newdir:=newdir+path
  659. else
  660. newdir:='';
  661. until (dirlist='') or (newdir<>'');
  662. fsearch:=newdir;
  663. end;
  664. findclose(s);
  665. end;
  666. { change to short filename if successful DOS call PM }
  667. function GetShortName(var p : String) : boolean;
  668. var
  669. c : array[0..255] of char;
  670. begin
  671. move(p[1],c[0],length(p));
  672. c[length(p)]:=#0;
  673. copytodos(c,length(p)+1);
  674. dosregs.ax:=$7160;
  675. dosregs.cx:=1;
  676. dosregs.ds:=tb_segment;
  677. dosregs.si:=tb_offset;
  678. dosregs.es:=tb_segment;
  679. dosregs.di:=tb_offset;
  680. msdos(dosregs);
  681. LoadDosError;
  682. if DosError=0 then
  683. begin
  684. copyfromdos(c,255);
  685. move(c[0],p[1],strlen(c));
  686. p[0]:=char(strlen(c));
  687. GetShortName:=true;
  688. end
  689. else
  690. GetShortName:=false;
  691. end;
  692. { change to long filename if successful DOS call PM }
  693. function GetLongName(var p : String) : boolean;
  694. var
  695. c : array[0..255] of char;
  696. begin
  697. move(p[1],c[0],length(p));
  698. c[length(p)]:=#0;
  699. copytodos(c,length(p)+1);
  700. dosregs.ax:=$7160;
  701. dosregs.cx:=2;
  702. dosregs.ds:=tb_segment;
  703. dosregs.si:=tb_offset;
  704. dosregs.es:=tb_segment;
  705. dosregs.di:=tb_offset;
  706. msdos(dosregs);
  707. LoadDosError;
  708. if DosError=0 then
  709. begin
  710. copyfromdos(c,255);
  711. move(c[0],p[1],strlen(c));
  712. p[0]:=char(strlen(c));
  713. GetLongName:=true;
  714. end
  715. else
  716. GetLongName:=false;
  717. end;
  718. {******************************************************************************
  719. --- Get/Set File Time,Attr ---
  720. ******************************************************************************}
  721. procedure getftime(var f;var time : longint);
  722. begin
  723. dosregs.bx:=textrec(f).handle;
  724. dosregs.ax:=$5700;
  725. msdos(dosregs);
  726. loaddoserror;
  727. time:=(dosregs.dx shl 16)+dosregs.cx;
  728. end;
  729. procedure setftime(var f;time : longint);
  730. begin
  731. dosregs.bx:=textrec(f).handle;
  732. dosregs.cx:=time and $ffff;
  733. dosregs.dx:=time shr 16;
  734. dosregs.ax:=$5701;
  735. msdos(dosregs);
  736. loaddoserror;
  737. end;
  738. procedure getfattr(var f;var attr : word);
  739. begin
  740. copytodos(filerec(f).name,strlen(filerec(f).name)+1);
  741. dosregs.edx:=tb_offset;
  742. dosregs.ds:=tb_segment;
  743. if LFNSupport then
  744. begin
  745. dosregs.ax:=$7143;
  746. dosregs.bx:=0;
  747. end
  748. else
  749. dosregs.ax:=$4300;
  750. msdos(dosregs);
  751. LoadDosError;
  752. Attr:=dosregs.cx;
  753. end;
  754. procedure setfattr(var f;attr : word);
  755. begin
  756. copytodos(filerec(f).name,strlen(filerec(f).name)+1);
  757. dosregs.edx:=tb_offset;
  758. dosregs.ds:=tb_segment;
  759. if LFNSupport then
  760. begin
  761. dosregs.ax:=$7143;
  762. dosregs.bx:=1;
  763. end
  764. else
  765. dosregs.ax:=$4301;
  766. dosregs.cx:=attr;
  767. msdos(dosregs);
  768. LoadDosError;
  769. end;
  770. {******************************************************************************
  771. --- Environment ---
  772. ******************************************************************************}
  773. function envcount : longint;
  774. var
  775. hp : ppchar;
  776. begin
  777. hp:=envp;
  778. envcount:=0;
  779. while assigned(hp^) do
  780. begin
  781. inc(envcount);
  782. inc(hp);
  783. end;
  784. end;
  785. function envstr (Index: longint): string;
  786. begin
  787. if (index<=0) or (index>envcount) then
  788. begin
  789. envstr:='';
  790. exit;
  791. end;
  792. envstr:=strpas(ppchar(pointer(envp)+4*(index-1))^);
  793. end;
  794. Function GetEnv(envvar: string): string;
  795. var
  796. hp : ppchar;
  797. hs : string;
  798. eqpos : longint;
  799. begin
  800. envvar:=upcase(envvar);
  801. hp:=envp;
  802. getenv:='';
  803. while assigned(hp^) do
  804. begin
  805. hs:=strpas(hp^);
  806. eqpos:=pos('=',hs);
  807. if upcase(copy(hs,1,eqpos-1))=envvar then
  808. begin
  809. getenv:=copy(hs,eqpos+1,255);
  810. exit;
  811. end;
  812. inc(hp);
  813. end;
  814. end;
  815. {******************************************************************************
  816. --- Not Supported ---
  817. ******************************************************************************}
  818. Procedure keep(exitcode : word);
  819. Begin
  820. End;
  821. Procedure getintvec(intno : byte;var vector : pointer);
  822. Begin
  823. End;
  824. Procedure setintvec(intno : byte;vector : pointer);
  825. Begin
  826. End;
  827. end.
  828. {
  829. $Log$
  830. Revision 1.21 2004-02-17 17:37:26 daniel
  831. * Enable threadvars again
  832. Revision 1.20 2004/02/16 22:16:59 hajny
  833. * LastDosExitCode changed back from threadvar temporarily
  834. Revision 1.19 2004/02/15 21:34:06 hajny
  835. * overloaded ExecuteProcess added, EnvStr param changed to longint
  836. Revision 1.18 2004/02/09 12:03:16 michael
  837. + Switched to single interface in dosh.inc
  838. Revision 1.17 2004/01/06 00:58:35 florian
  839. * fixed fsearch
  840. Revision 1.16 2003/10/03 21:46:25 peter
  841. * stdcall fixes
  842. Revision 1.15 2002/09/07 16:01:18 peter
  843. * old logs removed and tabs fixed
  844. }