dos.pas 26 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061
  1. {****************************************************************************
  2. $Id$
  3. Free Pascal Runtime-Library
  4. DOS unit for OS/2
  5. Copyright (c) 1997,1999-2000 by Daniel Mantione,
  6. member of the Free Pascal development team
  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 dos;
  14. {$ASMMODE ATT}
  15. {***************************************************************************}
  16. interface
  17. {***************************************************************************}
  18. {$PACKRECORDS 1}
  19. uses strings;
  20. const {Bit masks for CPU flags.}
  21. fcarry = $0001;
  22. fparity = $0004;
  23. fauxiliary = $0010;
  24. fzero = $0040;
  25. fsign = $0080;
  26. foverflow = $0800;
  27. {Bit masks for file attributes.}
  28. readonly = $01;
  29. hidden = $02;
  30. sysfile = $04;
  31. volumeid = $08;
  32. directory = $10;
  33. archive = $20;
  34. anyfile = $3F;
  35. fmclosed = $D7B0;
  36. fminput = $D7B1;
  37. fmoutput = $D7B2;
  38. fminout = $D7B3;
  39. type {Some string types:}
  40. comstr=string; {Filenames can be long in OS/2.}
  41. pathstr=string; {String for pathnames.}
  42. dirstr=string; {String for a directory}
  43. namestr=string; {String for a filename.}
  44. extstr=string[40]; {String for an extension. Can be 253
  45. characters long, in theory, but let's
  46. say fourty will be enough.}
  47. {Search record which is used by findfirst and findnext:}
  48. searchrec=record
  49. fill:array[1..21] of byte;
  50. attr:byte;
  51. time:longint;
  52. size:longint;
  53. name:string; {Filenames can be long in OS/2!}
  54. end;
  55. {$i filerec.inc}
  56. {$i textrec.inc}
  57. {Data structure for the registers needed by msdos and intr:}
  58. registers=record
  59. case i:integer of
  60. 0:(ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,
  61. f8,flags,fs,gs:word);
  62. 1:(al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh:byte);
  63. 2:(eax,ebx,ecx,edx,ebp,esi,edi:longint);
  64. end;
  65. {Record for date and time:}
  66. datetime=record
  67. year,month,day,hour,min,sec:word;
  68. end;
  69. {Flags for the exec procedure:
  70. Starting the program:
  71. efwait: Wait until program terminates.
  72. efno_wait: Don't wait until the program terminates. Does not work
  73. in dos, as DOS cannot multitask.
  74. efoverlay: Terminate this program, then execute the requested
  75. program. WARNING: Exit-procedures are not called!
  76. efdebug: Debug program. Details are unknown.
  77. efsession: Do not execute as child of this program. Use a seperate
  78. session instead.
  79. efdetach: Detached. Function unknown. Info wanted!
  80. efpm: Run as presentation manager program.
  81. Determining the window state of the program:
  82. efdefault: Run the pm program in it's default situation.
  83. efminimize: Run the pm program minimized.
  84. efmaximize: Run the pm program maximized.
  85. effullscreen: Run the non-pm program fullscreen.
  86. efwindowed: Run the non-pm program in a window.
  87. Other options are not implemented defined because lack of
  88. knowledge abou what they do.}
  89. type execrunflags=(efwait,efno_wait,efoverlay,efdebug,efsession,
  90. efdetach,efpm);
  91. execwinflags=(efdefault,efminimize,efmaximize,effullscreen,
  92. efwindowed);
  93. var doserror:integer;
  94. dosexitcode:word;
  95. procedure getdate(var year,month,day,dayofweek:word);
  96. procedure gettime(var hour,minute,second,sec100:word);
  97. function dosversion:word;
  98. procedure setdate(year,month,day:word);
  99. procedure settime(hour,minute,second,sec100:word);
  100. procedure getcbreak(var breakvalue:boolean);
  101. procedure setcbreak(breakvalue:boolean);
  102. procedure getverify(var verify:boolean);
  103. procedure setverify(verify : boolean);
  104. function diskfree(drive:byte):int64;
  105. function disksize(drive:byte):int64;
  106. procedure findfirst(const path:pathstr;attr:word;var f:searchRec);
  107. procedure findnext(var f:searchRec);
  108. procedure findclose(var f:searchRec);
  109. {Is a dummy:}
  110. procedure swapvectors;
  111. {Not supported:
  112. procedure getintvec(intno:byte;var vector:pointer);
  113. procedure setintvec(intno:byte;vector:pointer);
  114. procedure keep(exitcode:word);
  115. }
  116. procedure msdos(var regs:registers);
  117. procedure intr(intno : byte;var regs:registers);
  118. procedure getfattr(var f;var attr:word);
  119. procedure setfattr(var f;attr:word);
  120. function fsearch(path:pathstr;dirlist:string):pathstr;
  121. procedure getftime(var f;var time:longint);
  122. procedure setftime(var f;time:longint);
  123. procedure packtime (var d:datetime; var time:longint);
  124. procedure unpacktime (time:longint; var d:datetime);
  125. function fexpand(const path:pathstr):pathstr;
  126. procedure fsplit(path:pathstr;var dir:dirstr;var name:namestr;
  127. var ext:extstr);
  128. procedure exec(const path:pathstr;const comline:comstr);
  129. function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags;
  130. const comline:comstr):longint;
  131. function envcount:longint;
  132. function envstr(index:longint) : string;
  133. function getenv(const envvar:string): string;
  134. implementation
  135. uses doscalls;
  136. {Import syscall to call it nicely from assembler procedures.}
  137. procedure syscall;external name '___SYSCALL';
  138. function fsearch(path:pathstr;dirlist:string):pathstr;
  139. var i,p1:longint;
  140. s:searchrec;
  141. newdir:pathstr;
  142. Handle: cardinal;
  143. RC, Count: longint;
  144. FStat: PFileFindBuf3;
  145. ND: PathStr;
  146. begin
  147. { check if the file specified exists }
  148. if OS_Mode = osOS2 then
  149. begin
  150. New (FStat);
  151. ND := NewDir + Path;
  152. Handle := $FFFFFFFF;
  153. Count := 1;
  154. RC := DosFindFirst (ND, Handle, $37, FStat, SizeOf (FStat^),
  155. Count, ilStandard);
  156. DosFindClose (Handle);
  157. Dispose (FStat);
  158. end
  159. else
  160. begin
  161. FindFirst (path,anyfile,s);
  162. FindClose (s);
  163. RC := DosError;
  164. end;
  165. if RC = 0 then
  166. FSearch := Path
  167. else
  168. begin
  169. {No wildcards allowed in these things:}
  170. if (pos('?',path)<>0) or (pos('*',path)<>0) then
  171. fsearch:=''
  172. else
  173. begin
  174. { allow slash as backslash }
  175. for i:=1 to length(dirlist) do
  176. if dirlist[i]='/' then dirlist[i]:='\';
  177. repeat
  178. p1:=pos(';',dirlist);
  179. if p1<>0 then
  180. begin
  181. newdir:=copy(dirlist,1,p1-1);
  182. delete(dirlist,1,p1);
  183. end
  184. else
  185. begin
  186. newdir:=dirlist;
  187. dirlist:='';
  188. end;
  189. if (newdir<>'') and
  190. not (newdir[length(newdir)] in ['\',':']) then
  191. newdir:=newdir+'\';
  192. if OS_Mode = osOS2 then
  193. begin
  194. New (FStat);
  195. ND := NewDir + Path;
  196. Handle := $FFFFFFFF;
  197. Count := 1;
  198. RC := DosFindFirst (ND, Handle, $37, FStat,
  199. SizeOf (FStat^), Count, ilStandard);
  200. DosFindClose (Handle);
  201. Dispose (FStat);
  202. end else
  203. begin
  204. FindFirst (newdir+path,anyfile,s);
  205. RC := DosError;
  206. FindClose (S);
  207. end;
  208. if RC = 0 then
  209. newdir:=newdir+path
  210. else
  211. newdir:='';
  212. until (dirlist='') or (newdir<>'');
  213. fsearch:=newdir;
  214. end;
  215. end;
  216. end;
  217. procedure getftime(var f;var time:longint);
  218. begin
  219. asm
  220. {Load handle}
  221. movl f,%ebx
  222. movw (%ebx),%bx
  223. {Get date}
  224. movw $0x5700,%ax
  225. call syscall
  226. shll $16,%edx
  227. movw %cx,%dx
  228. movl time,%ebx
  229. movl %edx,(%ebx)
  230. xorb %ah,%ah
  231. movw %ax,doserror
  232. end;
  233. end;
  234. procedure setftime(var f;time : longint);
  235. begin
  236. asm
  237. {Load handle}
  238. movl f,%ebx
  239. movw (%ebx),%bx
  240. movl time,%ecx
  241. shldl $16,%ecx,%edx
  242. {Set date}
  243. movw $0x5701,%ax
  244. call syscall
  245. xorb %ah,%ah
  246. movw %ax,doserror
  247. end;
  248. end;
  249. procedure msdos(var regs:registers);
  250. {Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
  251. begin
  252. intr($21,regs);
  253. end;
  254. {$ASMMODE DIRECT}
  255. procedure intr(intno:byte;var regs:registers);
  256. {Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
  257. begin
  258. asm
  259. .data
  260. int86:
  261. .byte 0xcd
  262. int86_vec:
  263. .byte 0x03
  264. jmp int86_retjmp
  265. .text
  266. movl 8(%ebp),%eax
  267. movb %al,int86_vec
  268. movl 10(%ebp),%eax
  269. {Do not use first int}
  270. incl %eax
  271. incl %eax
  272. movl 4(%eax),%ebx
  273. movl 8(%eax),%ecx
  274. movl 12(%eax),%edx
  275. movl 16(%eax),%ebp
  276. movl 20(%eax),%esi
  277. movl 24(%eax),%edi
  278. movl (%eax),%eax
  279. jmp int86
  280. int86_retjmp:
  281. pushf
  282. pushl %ebp
  283. pushl %eax
  284. movl %esp,%ebp
  285. {Calc EBP new}
  286. addl $12,%ebp
  287. movl 10(%ebp),%eax
  288. {Do not use first int}
  289. incl %eax
  290. incl %eax
  291. popl (%eax)
  292. movl %ebx,4(%eax)
  293. movl %ecx,8(%eax)
  294. movl %edx,12(%eax)
  295. {Restore EBP}
  296. popl %edx
  297. movl %edx,16(%eax)
  298. movl %esi,20(%eax)
  299. movl %edi,24(%eax)
  300. {Ignore ES and DS}
  301. popl %ebx {Flags.}
  302. movl %ebx,32(%eax)
  303. {FS and GS too}
  304. end;
  305. end;
  306. {$ASMMODE ATT}
  307. procedure exec(const path:pathstr;const comline:comstr);
  308. {Execute a program.}
  309. begin
  310. dosexitcode:=exec(path,efwait,efdefault,comline);
  311. end;
  312. function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags;
  313. const comline:comstr):longint;
  314. {Execute a program. More suitable for OS/2 than the exec above.}
  315. {512 bytes should be enough to contain the command-line.}
  316. type bytearray=array[0..8191] of byte;
  317. Pbytearray=^bytearray;
  318. execstruc=record
  319. argofs,envofs,nameofs:pointer;
  320. argseg,envseg,nameseg:word;
  321. numarg,sizearg,
  322. numenv,sizeenv:word;
  323. mode1,mode2:byte;
  324. end;
  325. var args:Pbytearray;
  326. env:Pbytearray;
  327. i,j:word;
  328. es:execstruc;
  329. esadr:pointer;
  330. d:dirstr;
  331. n:namestr;
  332. e:extstr;
  333. begin
  334. getmem(args,512);
  335. getmem(env,8192);
  336. j:=1;
  337. {Now setup the arguments. The first argument should be the program
  338. name without directory and extension.}
  339. fsplit(path,d,n,e);
  340. es.numarg:=1;
  341. args^[0]:=$80;
  342. for i:=1 to length(n) do
  343. begin
  344. args^[j]:=byte(n[i]);
  345. inc(j);
  346. end;
  347. args^[j]:=0;
  348. inc(j);
  349. {Now do the real arguments.}
  350. i:=1;
  351. while i<=length(comline) do
  352. begin
  353. if comline[i]<>' ' then
  354. begin
  355. {Commandline argument found. Copy it.}
  356. inc(es.numarg);
  357. args^[j]:=$80;
  358. inc(j);
  359. while (i<=length(comline)) and (comline[i]<>' ') do
  360. begin
  361. args^[j]:=byte(comline[i]);
  362. inc(j);
  363. inc(i);
  364. end;
  365. args^[j]:=0;
  366. inc(j);
  367. end;
  368. inc(i);
  369. end;
  370. args^[j]:=0;
  371. inc(j);
  372. {Commandline ready, now build the environment.
  373. Oh boy, I always had the opinion that executing a program under Dos
  374. was a hard job!}
  375. {$ASMMODE DIRECT}
  376. asm
  377. movl env,%edi {Setup destination pointer.}
  378. movl _envc,%ecx {Load number of arguments in edx.}
  379. movl _environ,%esi {Load env. strings.}
  380. xorl %edx,%edx {Count environment size.}
  381. exa1:
  382. lodsl {Load a Pchar.}
  383. xchgl %eax,%ebx
  384. exa2:
  385. movb (%ebx),%al {Load a byte.}
  386. incl %ebx {Point to next byte.}
  387. stosb {Store it.}
  388. incl %edx {Increase counter.}
  389. cmpb $0,%al {Ready ?.}
  390. jne exa2
  391. loop exa1 {Next argument.}
  392. stosb {Store an extra 0 to finish. (AL is now 0).}
  393. incl %edx
  394. movl %edx,(24)es {Store environment size.}
  395. end;
  396. {$ASMMODE ATT}
  397. {Environtment ready, now set-up exec structure.}
  398. es.argofs:=args;
  399. es.envofs:=env;
  400. asm
  401. leal path,%esi
  402. lodsb
  403. movzbl %al,%eax
  404. addl %eax,%esi
  405. movb $0,(%esi)
  406. end;
  407. es.nameofs:=pointer(longint(@path)+1);
  408. asm
  409. movw %ss,es.argseg
  410. movw %ss,es.envseg
  411. movw %ss,es.nameseg
  412. end;
  413. es.sizearg:=j;
  414. es.numenv:=0;
  415. {Typecasting of sets in FPC is a bit hard.}
  416. es.mode1:=byte(runflags);
  417. es.mode2:=byte(winflags);
  418. {Now exec the program.}
  419. asm
  420. leal es,%edx
  421. mov $0x7f06,%ax
  422. call syscall
  423. xorl %edi,%edi
  424. jnc .Lexprg1
  425. xchgl %eax,%edi
  426. xorl %eax,%eax
  427. decl %eax
  428. .Lexprg1:
  429. movw %di,doserror
  430. movl %eax,__RESULT
  431. end;
  432. freemem(args,512);
  433. freemem(env,8192);
  434. {Phew! That's it. This was the most sophisticated procedure to call
  435. a system function I ever wrote!}
  436. end;
  437. function dosversion:word;assembler;
  438. {Returns DOS version in DOS and OS/2 version in OS/2}
  439. asm
  440. movb $0x30,%ah
  441. call syscall
  442. end;
  443. procedure getdate(var year,month,day,dayofweek:word);
  444. begin
  445. asm
  446. movb $0x2a,%ah
  447. call syscall
  448. xorb %ah,%ah
  449. movl 20(%ebp),%edi
  450. stosw
  451. movl 16(%ebp),%edi
  452. movb %dl,%al
  453. stosw
  454. movl 12(%ebp),%edi
  455. movb %dh,%al
  456. stosw
  457. movl 8(%ebp),%edi
  458. xchgw %ecx,%eax
  459. stosw
  460. end;
  461. end;
  462. procedure setdate(year,month,day : word);
  463. begin
  464. {DOS only! You cannot change the system date in OS/2!}
  465. asm
  466. movw 8(%ebp),%cx
  467. movb 10(%ebp),%dh
  468. movb 12(%ebp),%dl
  469. movb $0x2b,%ah
  470. call syscall
  471. xorb %ah,%ah
  472. movw %ax,doserror
  473. end;
  474. end;
  475. procedure gettime(var hour,minute,second,sec100:word);
  476. begin
  477. asm
  478. movb $0x2c,%ah
  479. call syscall
  480. xorb %ah,%ah
  481. movl 20(%ebp),%edi
  482. movb %dl,%al
  483. stosw
  484. movl 16(%ebp),%edi
  485. movb %dh,%al
  486. stosw
  487. movl 12(%ebp),%edi
  488. movb %cl,%al
  489. stosw
  490. movl 8(%ebp),%edi
  491. movb %ch,%al
  492. stosw
  493. end;
  494. end;
  495. procedure settime(hour,minute,second,sec100:word);
  496. begin
  497. asm
  498. movb 8(%ebp),%ch
  499. movb 10(%ebp),%cl
  500. movb 12(%ebp),%dh
  501. movb 14(%ebp),%dl
  502. movb $0x2d,%ah
  503. call syscall
  504. xorb %ah,%ah
  505. movw %ax,doserror
  506. end;
  507. end;
  508. procedure getcbreak(var breakvalue:boolean);
  509. begin
  510. {! Do not use in OS/2. Also not recommended in DOS. Use
  511. signal handling instead.}
  512. asm
  513. movw $0x3300,%ax
  514. call syscall
  515. movl 8(%ebp),%eax
  516. movb %dl,(%eax)
  517. end;
  518. end;
  519. procedure setcbreak(breakvalue:boolean);
  520. begin
  521. {! Do not use in OS/2. Also not recommended in DOS. Use
  522. signal handling instead.}
  523. asm
  524. movb 8(%ebp),%dl
  525. movw $0x3301,%ax
  526. call syscall
  527. end;
  528. end;
  529. procedure getverify(var verify:boolean);
  530. begin
  531. {! Do not use in OS/2.}
  532. asm
  533. movb $0x54,%ah
  534. call syscall
  535. movl 8(%ebp),%edi
  536. stosb
  537. end;
  538. end;
  539. procedure setverify(verify:boolean);
  540. begin
  541. {! Do not use in OS/2.}
  542. asm
  543. movb 8(%ebp),%al
  544. movb $0x2e,%ah
  545. call syscall
  546. end;
  547. end;
  548. function diskfree(drive:byte):int64;
  549. var fi:TFSinfo;
  550. begin
  551. if (os_mode=osDOS) or (os_mode = osDPMI) then
  552. {Function 36 is not supported in OS/2.}
  553. asm
  554. movb 8(%ebp),%dl
  555. movb $0x36,%ah
  556. call syscall
  557. cmpw $-1,%ax
  558. je .LDISKFREE1
  559. mulw %cx
  560. mulw %bx
  561. shll $16,%edx
  562. movw %ax,%dx
  563. xchgl %edx,%eax
  564. leave
  565. ret
  566. .LDISKFREE1:
  567. cltd
  568. leave
  569. ret
  570. end
  571. else
  572. {In OS/2, we use the filesystem information.}
  573. begin
  574. doserror:=dosqueryFSinfo(drive,1,FI,sizeof(FI));
  575. if doserror=0 then
  576. diskfree:=FI.free_clusters*FI.sectors_per_cluster*
  577. FI.bytes_per_sector
  578. else
  579. diskfree:=-1;
  580. end;
  581. end;
  582. function disksize(drive:byte):int64;
  583. var fi:TFSinfo;
  584. begin
  585. if (os_mode=osDOS) or (os_mode = osDPMI) then
  586. {Function 36 is not supported in OS/2.}
  587. asm
  588. movb 8(%ebp),%dl
  589. movb $0x36,%ah
  590. call syscall
  591. movw %dx,%bx
  592. cmpw $-1,%ax
  593. je .LDISKSIZE1
  594. mulw %cx
  595. mulw %bx
  596. shll $16,%edx
  597. movw %ax,%dx
  598. xchgl %edx,%eax
  599. leave
  600. ret
  601. .LDISKSIZE1:
  602. cltd
  603. leave
  604. ret
  605. end
  606. else
  607. {In OS/2, we use the filesystem information.}
  608. begin
  609. doserror:=dosqueryFSinfo(drive,1,FI,sizeof(FI));
  610. if doserror=0 then
  611. disksize:=FI.total_clusters*FI.sectors_per_cluster*
  612. FI.bytes_per_sector
  613. else
  614. disksize:=-1;
  615. end;
  616. end;
  617. procedure searchrec2dossearchrec(var f:searchrec);
  618. const namesize=255;
  619. var l,i:longint;
  620. begin
  621. l:=length(f.name);
  622. for i:=1 to namesize do
  623. f.name[i-1]:=f.name[i];
  624. f.name[l]:=#0;
  625. end;
  626. procedure dossearchrec2searchrec(var f : searchrec);
  627. const namesize=255;
  628. var l,i : longint;
  629. begin
  630. for i:=0 to namesize do
  631. if f.name[i]=#0 then
  632. begin
  633. l:=i;
  634. break;
  635. end;
  636. for i:=namesize-1 downto 0 do
  637. f.name[i+1]:=f.name[i];
  638. f.name[0]:=char(l);
  639. end;
  640. procedure findfirst(const path:pathstr;attr:word;var f:searchRec);
  641. procedure _findfirst(path:pchar;attr:word;var f:searchrec);
  642. begin
  643. asm
  644. movl 12(%esp),%edx
  645. movw 16(%esp),%cx
  646. {No need to set DTA in EMX. Just give a pointer in ESI.}
  647. movl 18(%ebp),%esi
  648. movb $0x4e,%ah
  649. call syscall
  650. jnc .LFF
  651. movw %ax,doserror
  652. .LFF:
  653. end;
  654. end;
  655. var path0:array[0..255] of char;
  656. begin
  657. {No error.}
  658. doserror:=0;
  659. strPcopy(path0,path);
  660. _findfirst(path0,attr,f);
  661. dossearchrec2searchrec(f);
  662. end;
  663. procedure findnext(var f:searchRec);
  664. procedure _findnext(var f : searchrec);
  665. begin
  666. asm
  667. movl 12(%ebp),%esi
  668. movb $0x4f,%ah
  669. call syscall
  670. jnc .LFN
  671. movw %ax,doserror
  672. .LFN:
  673. end;
  674. end;
  675. begin
  676. {No error}
  677. doserror:=0;
  678. searchrec2dossearchrec(f);
  679. _findnext(f);
  680. dossearchrec2searchrec(f);
  681. end;
  682. procedure findclose(var f:searchRec);
  683. begin
  684. end;
  685. procedure swapvectors;
  686. {For TP compatibility, this exists.}
  687. begin
  688. end;
  689. type PPchar=^Pchar;
  690. {$ASMMODE DIRECT}
  691. function envs:PPchar;assembler;
  692. asm
  693. movl _environ,%eax
  694. end ['EAX'];
  695. function envcount:longint;assembler;
  696. var hp : ppchar;
  697. asm
  698. movl _envc,%eax
  699. end ['EAX'];
  700. {$ASMMODE ATT}
  701. function envstr(index : longint) : string;
  702. var hp:PPchar;
  703. begin
  704. if (index<=0) or (index>envcount) then
  705. begin
  706. envstr:='';
  707. exit;
  708. end;
  709. hp:=PPchar(cardinal(envs)+4*(index-1));
  710. envstr:=strpas(hp^);
  711. end;
  712. function getenv(const envvar : string) : string;
  713. var hs,_envvar : string;
  714. eqpos,i : longint;
  715. begin
  716. _envvar:=upcase(envvar);
  717. getenv:='';
  718. for i:=1 to envcount do
  719. begin
  720. hs:=envstr(i);
  721. eqpos:=pos('=',hs);
  722. if copy(hs,1,eqpos-1)=_envvar then
  723. begin
  724. getenv:=copy(hs,eqpos+1,length(hs)-eqpos);
  725. exit;
  726. end;
  727. end;
  728. end;
  729. procedure fsplit(path:pathstr;var dir:dirstr;var name:namestr;
  730. var ext:extstr);
  731. var p1,i : longint;
  732. begin
  733. {Get drive name}
  734. p1:=pos(':',path);
  735. if p1>0 then
  736. begin
  737. dir:=path[1]+':';
  738. delete(path,1,p1);
  739. end
  740. else
  741. dir:='';
  742. { split the path and the name, there are no more path informtions }
  743. { if path contains no backslashes }
  744. while true do
  745. begin
  746. p1:=pos('\',path);
  747. if p1=0 then
  748. p1:=pos('/',path);
  749. if p1=0 then
  750. break;
  751. dir:=dir+copy(path,1,p1);
  752. delete(path,1,p1);
  753. end;
  754. {Try to find an extension.}
  755. ext:='';
  756. for i:=length(path) downto 1 do
  757. if path[i]='.' then
  758. begin
  759. ext:=copy(path,i,high(extstr));
  760. delete(path,i,length(path)-i+1);
  761. break;
  762. end;
  763. name:=path;
  764. end;
  765. function fexpand(const path:pathstr):pathstr;
  766. function get_current_drive:byte;assembler;
  767. asm
  768. movb $0x19,%ah
  769. call syscall
  770. end;
  771. var s,pa:string;
  772. i,j:longint;
  773. begin
  774. getdir(0,s);
  775. pa:=upcase(path);
  776. {Allow slash as backslash}
  777. for i:=1 to length(pa) do
  778. if pa[i]='/' then
  779. pa[i]:='\';
  780. if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then
  781. begin
  782. {We must get the right directory}
  783. getdir(byte(pa[1])-byte('A')+1,s);
  784. if (byte(pa[0])>2) and (pa[3]<>'\') then
  785. if pa[1]=s[1] then
  786. pa:=s+'\'+copy (pa,3,length(pa))
  787. else
  788. pa:=pa[1]+':\'+copy (pa,3,length(pa))
  789. end
  790. else
  791. if pa[1]='\' then
  792. pa:=s[1]+':'+pa
  793. else if s[0]=#3 then
  794. pa:=s+pa
  795. else
  796. pa:=s+'\'+pa;
  797. {First remove all references to '\.\'}
  798. i:=pos('\.\',pa);
  799. while i<>0 do
  800. begin
  801. delete(pa,i,2);
  802. i:=pos('\.\',pa);
  803. end;
  804. {Now remove also all references to '\..\' + of course previous dirs..}
  805. repeat
  806. i:=pos('\..\',pa);
  807. if i<>0 then
  808. begin
  809. j:=i-1;
  810. while (j>1) and (pa[j]<>'\') do
  811. dec(j);
  812. delete (pa,j,i-j+3);
  813. end;
  814. until i=0;
  815. {Remove End . and \}
  816. if (length(pa)>0) and (pa[length(pa)]='.') then
  817. dec(byte(pa[0]));
  818. if (length(pa)>0) and (pa[length(pa)]='\') then
  819. dec(byte(pa[0]));
  820. fexpand:=pa;
  821. end;
  822. procedure packtime(var d:datetime;var time:longint);
  823. var zs:longint;
  824. begin
  825. time:=-1980;
  826. time:=time+d.year and 127;
  827. time:=time shl 4;
  828. time:=time+d.month;
  829. time:=time shl 5;
  830. time:=time+d.day;
  831. time:=time shl 16;
  832. zs:=d.hour;
  833. zs:=zs shl 6;
  834. zs:=zs+d.min;
  835. zs:=zs shl 5;
  836. zs:=zs+d.sec div 2;
  837. time:=time+(zs and $ffff);
  838. end;
  839. procedure unpacktime (time:longint;var d:datetime);
  840. begin
  841. d.sec:=(time and 31) * 2;
  842. time:=time shr 5;
  843. d.min:=time and 63;
  844. time:=time shr 6;
  845. d.hour:=time and 31;
  846. time:=time shr 5;
  847. d.day:=time and 31;
  848. time:=time shr 5;
  849. d.month:=time and 15;
  850. time:=time shr 4;
  851. d.year:=time+1980;
  852. end;
  853. procedure getfattr(var f;var attr : word);assembler;
  854. asm
  855. movw $0x4300,%ax
  856. movl f,%edx
  857. {addl $filerec.name,%edx Doesn't work!!}
  858. addl $60,%edx
  859. call syscall
  860. movl attr,%ebx
  861. movw %cx,(%ebx)
  862. end;
  863. procedure setfattr(var f;attr : word);assembler;
  864. asm
  865. movw $0x4301,%ax
  866. movl f,%edx
  867. {addl $filerec.name,%edx Doesn't work!!}
  868. addl $60,%edx
  869. movw attr,%cx
  870. call syscall
  871. end;
  872. end.
  873. {
  874. $Log$
  875. Revision 1.23 2000-04-18 20:30:02 hajny
  876. * FSearch with given path corrected
  877. Revision 1.22 2000/03/12 18:32:17 hajny
  878. * missing parentheses added
  879. Revision 1.21 2000/03/05 19:00:37 hajny
  880. * DiskFree, DiskSize - int64 result, fix for osDPMI mode
  881. Revision 1.20 2000/02/09 16:59:33 peter
  882. * truncated log
  883. Revision 1.19 2000/01/09 20:51:03 hajny
  884. * FPK changed to FPC
  885. Revision 1.18 2000/01/07 16:41:45 daniel
  886. * copyright 2000
  887. Revision 1.17 1999/10/13 12:21:56 daniel
  888. * OS/2 compiler works again.
  889. Revision 1.16 1999/09/13 18:21:02 hajny
  890. * again didn't manage to read docu for DosFindFirst properly :-(
  891. Revision 1.15 1999/09/13 17:56:26 hajny
  892. * another correction to FSearch fix - mistyping
  893. Revision 1.14 1999/09/13 17:35:15 hajny
  894. * little addition/correction to FSearch fix
  895. Revision 1.13 1999/09/09 09:20:43 hajny
  896. * FSearch under OS/2 fixed
  897. }