dos.pas 24 KB

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