dos.pas 34 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342
  1. {****************************************************************************
  2. FPKPascal Runtime-Library
  3. Copyright (c) 1994,97 by
  4. Florian Klaempfl and Michael Spiegel
  5. OS/2 port by Dani‰l Mantione
  6. ****************************************************************************}
  7. {
  8. History:
  9. 2.7.1994: Version 0.2
  10. Datenstrukturen sind deklariert sowie
  11. 50 % der Unterprogramme sind implementiert
  12. 12.8.1994: exec implemented
  13. 14.8.1994: findfirst and findnext implemented
  14. 24.8.1994: Version 0.3
  15. 28.2.1995: Version 0.31
  16. some parameter lists with const optimized
  17. 3.7.1996: bug in fsplit removed (dir and ext were not intializised)
  18. 7.7.1996: packtime and unpacktime implemented
  19. 20.9.1996: Version 0.5
  20. setftime and getftime implemented
  21. some optimizations done (integer -> longint)
  22. procedure fsearch from the LINUX version ported
  23. msdos call implemented
  24. 26th november 1996:
  25. better fexpand
  26. 29th january 1997:
  27. bug in getftime and setftime removed
  28. setfattr and getfattr added
  29. 2th february 1997: Version 0.9
  30. bug of searchrec corrected
  31. 2 june 1997:
  32. OS/2 support added.
  33. 12 june 1997:
  34. OS/2 port done.
  35. 12 November 1997:
  36. Adapted to new DLL stuff.
  37. }
  38. unit dos;
  39. {$I os.inc}
  40. interface
  41. uses
  42. strings;
  43. const
  44. { bit masks for CPU flags}
  45. fcarry = $0001;
  46. fparity = $0004;
  47. fauxiliary = $0010;
  48. fzero = $0040;
  49. fsign = $0080;
  50. foverflow = $0800;
  51. { Bitmasken fuer Dateiattribute }
  52. readonly = $01;
  53. hidden = $02;
  54. sysfile = $04;
  55. volumeid = $08;
  56. directory = $10;
  57. archive = $20;
  58. anyfile = $3F;
  59. fmclosed = $D7B0;
  60. fminput = $D7B1;
  61. fmoutput = $D7B2;
  62. fminout = $D7B3;
  63. type
  64. { some string types }
  65. {$IFDEF OS2}
  66. comstr=string; {Filenames can be long in OS/2.}
  67. pathstr=string;
  68. {$ELSE}
  69. comstr = string[127]; { Kommandozeilenstring }
  70. pathstr = string[79]; { String fuer einen Pfadnamen }
  71. {$ENDIF}
  72. dirstr = string[67]; { String fuer kompletten Pfad }
  73. namestr = string[8]; { Dateinamenstring }
  74. extstr = string[4]; { String fuer Dateinamensuffix }
  75. { search record which is used by findfirst and findnext }
  76. {$PACKRECORDS 1}
  77. searchrec = record
  78. fill : array[1..21] of byte;
  79. attr : byte;
  80. time : longint;
  81. {$IFNDEF OS2} { A DJGPP strange thing.}
  82. reserved : word; { requires the DOS extender (DJ GNU-C) }
  83. {$ENDIF}
  84. size : longint;
  85. {$IFNDEF OS2}
  86. name : string[15]; { the same size as declared by (DJ GNU C) }
  87. {$ELSE}
  88. name:string; {Filenames can be very long in OS/2!}
  89. {$ENDIF}
  90. end;
  91. {$PACKRECORDS 2}
  92. { file record for untyped files }
  93. filerec = record
  94. handle : word;
  95. mode : word;
  96. recsize : word;
  97. _private : array[1..26] of byte;
  98. userdata: array[1..16] of byte;
  99. name: array[0..79] of char;
  100. end;
  101. { file record for text files }
  102. textbuf = array[0..127] of char;
  103. textrec = record
  104. handle : word;
  105. mode : word;
  106. bufSize : word;
  107. _private : word;
  108. bufpos : word;
  109. bufend : word;
  110. bufptr : ^textbuf;
  111. openfunc : pointer;
  112. inoutfunc : pointer;
  113. flushfunc : pointer;
  114. closefunc : pointer;
  115. userdata : array[1..16] of byte;
  116. name : array[0..79] of char;
  117. buffer : textbuf;
  118. end;
  119. { data structure for the registers needed by msdos and intr }
  120. registers = record
  121. case i : integer of
  122. 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
  123. 1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
  124. 2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
  125. end;
  126. { record for date and time }
  127. datetime = record
  128. year,month,day,hour,min,sec : word;
  129. end;
  130. {Flags for the exec procedure:
  131. Starting the program:
  132. efwait: Wait until program terminates, otherwise the program
  133. continues execution.
  134. efno_wait: ? Function unknown. Not implemented in EMX.
  135. efoverlay: Terminate this program, then execute the requested
  136. program. WARNING: Exit-procedures are not called!
  137. efdebug: Debug program. Details are unknown.
  138. efsession: Do not execute as child of this program. Use a seperate
  139. session instead.
  140. efdetach: Detached. Function unknown. Info wanted!
  141. efpm: Run as presentation manager program.
  142. Determining the window state of the program:
  143. efdefault: Run the pm program in it's default situation.
  144. efminimize: Run the pm program minimized.
  145. efmaximize: Run the pm program maximized.
  146. effullscreen: Run the non-pm program fullscreen.
  147. efwindowed: Run the non-pm program in a window.
  148. Other options are not implemented defined because lack of
  149. knowledge abou what they do.}
  150. type execrunflags=(efwait,efno_wait,efoverlay,efdebug,efsession,
  151. efdetach,efpm);
  152. execwinflags=(efdefault,efminimize,efmaximize,effullscreen,
  153. efwindowed);
  154. execset=set of execrunflags;
  155. var
  156. { error variable }
  157. doserror : integer;
  158. procedure getdate(var year,month,day,dayofweek : word);
  159. procedure gettime(var hour,minute,second,sec100 : word);
  160. function dosversion : word;
  161. procedure setdate(year,month,day : word);
  162. procedure settime(hour,minute,second,sec100 : word);
  163. procedure getcbreak(var breakvalue : boolean);
  164. procedure setcbreak(breakvalue : boolean);
  165. procedure getverify(var verify : boolean);
  166. procedure setverify(verify : boolean);
  167. function diskfree(drive : byte) : longint;
  168. function disksize(drive : byte) : longint;
  169. procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  170. procedure findnext(var f : searchRec);
  171. { is a dummy }
  172. procedure swapvectors;
  173. { not supported:
  174. procedure getintvec(intno : byte;var vector : pointer);
  175. procedure setintvec(intno : byte;vector : pointer);
  176. procedure keep(exitcode : word);
  177. }
  178. procedure msdos(var regs : registers);
  179. procedure intr(intno : byte;var regs : registers);
  180. procedure getfattr(var f;var attr : word);
  181. procedure setfattr(var f;attr : word);
  182. function fsearch(const path : pathstr;dirlist : string) : pathstr;
  183. procedure getftime(var f;var time : longint);
  184. procedure setftime(var f;time : longint);
  185. procedure packtime (var d: datetime; var time: longint);
  186. procedure unpacktime (time: longint; var d: datetime);
  187. function fexpand(const path : pathstr) : pathstr;
  188. procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
  189. var ext : extstr);
  190. procedure exec(const path : pathstr;const comline : comstr);
  191. {$IFDEF OS2}
  192. function exec(path:pathstr;runflags:execset;winflags:execwinflags;
  193. const comline:comstr):longint;
  194. {$ENDIF}
  195. function dosexitcode : word;
  196. function envcount : longint;
  197. function envstr(index : longint) : string;
  198. function getenv(const envvar : string): string;
  199. implementation
  200. {$ifdef OS2}
  201. type OS2FSAllocate=record
  202. idfilesystem,
  203. csectorunit,
  204. cunit,
  205. cunitavail:longint;
  206. cbsector:word;
  207. end;
  208. function dosqueryFSinfo(driveno:word;infolevel:word;
  209. var info;infolen:word):word;
  210. external 'DOSCALLS' index 278;
  211. {$endif OS2}
  212. { this was first written for the LINUX version, }
  213. { by Michael Van Canneyt but it works also }
  214. { for the DOS version (I hope so) }
  215. function fsearch(const path : pathstr;dirlist : string) : pathstr;
  216. var
  217. newdir : pathstr;
  218. p1 : byte;
  219. s : searchrec;
  220. begin
  221. if (pos('?',path)<>0) or (pos('*',path)<>0) then
  222. { No wildcards allowed in these things }
  223. fsearch:=''
  224. else
  225. begin
  226. repeat
  227. { get first path }
  228. p1:=pos(';',dirlist);
  229. if p1>0 then
  230. begin
  231. newdir:=copy(dirlist,1,p1-1);
  232. delete(dirlist,1,p1)
  233. end
  234. else
  235. begin
  236. newdir:=dirlist;
  237. dirlist:=''
  238. end;
  239. findfirst(newdir+'\'+path,anyfile,s);
  240. if doserror=0 then
  241. begin
  242. newdir:=newdir+'\'+s.name;
  243. { this was for LINUX:
  244. if pos('.\',newdir)=1 then
  245. delete(newdir, 1, 2)
  246. { DOS strips off an initial .\ }
  247. }
  248. end
  249. else newdir:='';
  250. until(dirlist='') or (length(newdir)>0);
  251. fsearch:=newdir;
  252. end;
  253. end;
  254. procedure getftime(var f;var time : longint);
  255. begin
  256. {$IFNDEF OS2}
  257. asm
  258. { load handle }
  259. movl f,%ebx
  260. movw (%ebx),%bx
  261. { get date }
  262. movw $0x5700,%ax
  263. int $0x21
  264. shll $16,%edx
  265. movw %cx,%dx
  266. movl time,%ebx
  267. movl %edx,(%ebx)
  268. xorb %ah,%ah
  269. movw %ax,U_DOS_DOSERROR
  270. end;
  271. {$ELSE}
  272. asm
  273. { load handle }
  274. movl f,%ebx
  275. movw (%ebx),%bx
  276. { get date }
  277. movw $0x5700,%ax
  278. call ___syscall
  279. shll $16,%edx
  280. movw %cx,%dx
  281. movl time,%ebx
  282. movl %edx,(%ebx)
  283. xorb %ah,%ah
  284. movw %ax,U_DOS_DOSERROR
  285. end;
  286. {$ENDIF}
  287. end;
  288. procedure setftime(var f;time : longint);
  289. begin
  290. {$IFNDEF OS2}
  291. asm
  292. { load handle }
  293. movl f,%ebx
  294. movw (%ebx),%bx
  295. movl time,%ecx
  296. shldl $16,%ecx,%edx
  297. { set date }
  298. movw $0x5701,%ax
  299. int $0x21
  300. xorb %ah,%ah
  301. movw %ax,U_DOS_DOSERROR
  302. end;
  303. {$ELSE}
  304. asm
  305. { load handle }
  306. movl f,%ebx
  307. movw (%ebx),%bx
  308. movl time,%ecx
  309. shldl $16,%ecx,%edx
  310. { set date }
  311. movw $0x5701,%ax
  312. call ___syscall
  313. xorb %ah,%ah
  314. movw %ax,U_DOS_DOSERROR
  315. end;
  316. {$ENDIF}
  317. end;
  318. procedure msdos(var regs : registers);
  319. { Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
  320. begin
  321. intr($21,regs);
  322. end;
  323. procedure intr(intno : byte;var regs : registers);
  324. { Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
  325. begin
  326. asm
  327. .data
  328. int86:
  329. .byte 0xcd
  330. int86_vec:
  331. .byte 0x03
  332. jmp int86_retjmp
  333. .text
  334. movl 8(%ebp),%eax
  335. movb %al,int86_vec
  336. movl 10(%ebp),%eax
  337. ; do not use first int
  338. addl $2,%eax
  339. movl 4(%eax),%ebx
  340. movl 8(%eax),%ecx
  341. movl 12(%eax),%edx
  342. movl 16(%eax),%ebp
  343. movl 20(%eax),%esi
  344. movl 24(%eax),%edi
  345. movl (%eax),%eax
  346. jmp int86
  347. int86_retjmp:
  348. pushf
  349. pushl %ebp
  350. pushl %eax
  351. movl %esp,%ebp
  352. ; calc EBP new
  353. addl $12,%ebp
  354. movl 10(%ebp),%eax
  355. ; do not use first int
  356. addl $2,%eax
  357. popl (%eax)
  358. movl %ebx,4(%eax)
  359. movl %ecx,8(%eax)
  360. movl %edx,12(%eax)
  361. ; restore EBP
  362. popl %edx
  363. movl %edx,16(%eax)
  364. movl %esi,20(%eax)
  365. movl %edi,24(%eax)
  366. ; ignore ES and DS
  367. popl %ebx /* flags */
  368. movl %ebx,32(%eax)
  369. ; FS and GS too
  370. end;
  371. end;
  372. var
  373. lastdosexitcode : word;
  374. {$IFNDEF OS2}
  375. procedure exec(const path : pathstr;const comline : comstr);
  376. procedure do_system(p : pchar);
  377. begin
  378. asm
  379. movl 12(%ebp),%ebx
  380. movw $0xff07,%ax
  381. int $0x21
  382. movw %ax,_LASTDOSEXITCODE
  383. end;
  384. end;
  385. var
  386. execute : string;
  387. b : array[0..255] of char;
  388. begin
  389. execute:=path+' '+comline;
  390. move(execute[1],b,length(execute));
  391. b[length(execute)]:=#0;
  392. do_system(b);
  393. end;
  394. {$ELSE}
  395. procedure exec(const path:pathstr;const comline:comstr);
  396. {Execute a program.}
  397. begin
  398. exec(path,[efwait],efdefault,comline);
  399. end;
  400. function exec(path:pathstr;runflags:execset;winflags:execwinflags;
  401. const comline:comstr):longint;
  402. {Execute a program. More suitable for OS/2 than the exec above.}
  403. {512 bytes should be enough to contain the command-line.}
  404. type bytearray=array[0..8191] of byte;
  405. Pbytearray=^bytearray;
  406. setarray=array[0..3] of byte;
  407. execstruc=record
  408. argofs,envofs,nameofs:pointer;
  409. argseg,envseg,nameseg:word;
  410. numarg,sizearg,
  411. numenv,sizeenv:word;
  412. mode1,mode2:byte;
  413. end;
  414. var args:Pbytearray;
  415. env:Pbytearray;
  416. i,j:word;
  417. es:execstruc;
  418. esadr:pointer;
  419. begin
  420. getmem(args,512);
  421. getmem(env,8192);
  422. i:=1;
  423. j:=0;
  424. es.numarg:=0;
  425. while i<=length(comline) do
  426. begin
  427. if comline[i]<>' ' then
  428. begin
  429. {Commandline argument found. Copy it.}
  430. inc(es.numarg);
  431. args^[j]:=$80;
  432. inc(j);
  433. while (i<=length(comline)) and (comline[i]<>' ') do
  434. begin
  435. args^[j]:=byte(comline[i]);
  436. inc(j);
  437. inc(i);
  438. end;
  439. args^[j]:=0;
  440. inc(j);
  441. end;
  442. inc(i);
  443. end;
  444. args^[j]:=0;
  445. inc(j);
  446. {Commandline ready, now build the environment.
  447. Oh boy, I always had the opinion that executing a program under Dos
  448. was a hard job!}
  449. asm
  450. movl env,%edi {Setup destination pointer.}
  451. movl _envc,%ecx {Load number of arguments in edx.}
  452. movl _environ,%esi {Load env. strings.}
  453. xorl %edx,%edx {Count environment size.}
  454. exa1:
  455. lodsl {Load a Pchar.}
  456. xchgl %eax,%ebx
  457. exa2:
  458. movb (%ebx),%al {Load a byte.}
  459. incl %ebx {Point to next byte.}
  460. stosb {Store it.}
  461. incl %edx {Increase counter.}
  462. cmpb $0,%al {Ready ?.}
  463. jne exa2
  464. loop exa1 {Next argument.}
  465. stosb {Store an extra 0 to finish. (AL is now 0).}
  466. incl %edx
  467. movl %edx,(24)es {Store environment size.}
  468. end;
  469. {Environtment ready, now set-up exec structure.}
  470. es.argofs:=args;
  471. es.envofs:=env;
  472. asm
  473. leal path,%esi
  474. lodsb
  475. movzbl %al,%eax
  476. incl %eax
  477. addl %eax,%esi
  478. movb $0,(%esi)
  479. end;
  480. es.nameofs:=pointer(longint(@path)+1);
  481. asm
  482. movw %ss,(12)es {Compiler doesn't like record elems in asm.}
  483. movw %ss,(14)es
  484. movw %ss,(16)es
  485. end;
  486. es.sizearg:=j;
  487. es.numenv:=0;
  488. {Typecasting of sets in FPK is a bit hard.}
  489. es.mode1:=setarray(runflags)[0];
  490. es.mode2:=byte(winflags);
  491. {Now exec the program.}
  492. esadr:=@es;
  493. asm
  494. movl esadr,%edx
  495. mov $0x7f06,%ax
  496. call ___syscall
  497. jnc exprg1
  498. movl %eax,U_DOS_DOSERROR
  499. xorl %eax,%eax
  500. decl %eax
  501. exprg1:
  502. movl %eax,__RESULT
  503. end;
  504. freemem(args,512);
  505. freemem(env,8192);
  506. {Phew! That's it. This was the most sophisticated procedure to call
  507. a system function I ever wrote!}
  508. end;
  509. {$ENDIF}
  510. function dosexitcode : word;
  511. begin
  512. dosexitcode:=lastdosexitcode;
  513. end;
  514. function dosversion : word;
  515. begin
  516. {$IFNDEF OS2}
  517. asm
  518. movb $0x30,%ah
  519. pushl %ebp
  520. int $0x21
  521. popl %ebp
  522. leave
  523. ret
  524. end;
  525. {$ELSE}
  526. {Returns DOS version in DOS and OS/2 version in OS/2}
  527. asm
  528. movb $0x30,%ah
  529. call ___syscall
  530. leave
  531. ret
  532. end;
  533. {$ENDIF}
  534. end;
  535. procedure getdate(var year,month,day,dayofweek : word);
  536. begin
  537. {$IFNDEF OS/2}
  538. asm
  539. movb $0x2a,%ah
  540. pushl %ebp
  541. int $0x21
  542. popl %ebp
  543. xorb %ah,%ah
  544. movl 20(%ebp),%edi
  545. stosw
  546. movl 16(%ebp),%edi
  547. movb %dl,%al
  548. stosw
  549. movl 12(%ebp),%edi
  550. movb %dh,%al
  551. stosw
  552. movl 8(%ebp),%edi
  553. movw %cx,%ax
  554. stosw
  555. end;
  556. {$ELSE}
  557. asm
  558. movb $0x2a,%ah
  559. call ___syscall
  560. xorb %ah,%ah
  561. movl 20(%ebp),%edi
  562. stosw
  563. movl 16(%ebp),%edi
  564. movb %dl,%al
  565. stosw
  566. movl 12(%ebp),%edi
  567. movb %dh,%al
  568. stosw
  569. movl 8(%ebp),%edi
  570. xchgw %ecx,%eax
  571. stosw
  572. end;
  573. {$ENDIF}
  574. end;
  575. procedure setdate(year,month,day : word);
  576. begin
  577. {$IFNDEF OS2}
  578. asm
  579. movw 8(%ebp),%cx
  580. movb 10(%ebp),%dh
  581. movb 12(%ebp),%dl
  582. movb $0x2b,%ah
  583. pushl %ebp
  584. int $0x21
  585. popl %ebp
  586. xorb %ah,%ah
  587. movw %ax,U_DOS_DOSERROR
  588. end;
  589. {$ELSE}
  590. {DOS only! You cannot change the system date in OS/2!}
  591. asm
  592. movw 8(%ebp),%cx
  593. movb 10(%ebp),%dh
  594. movb 12(%ebp),%dl
  595. movb $0x2b,%ah
  596. call ___syscall
  597. xorb %ah,%ah
  598. movw %ax,U_DOS_DOSERROR
  599. end;
  600. {$ENDIF}
  601. end;
  602. procedure gettime(var hour,minute,second,sec100 : word);
  603. begin
  604. {$IFNDEF OS2}
  605. asm
  606. movb $0x2c,%ah
  607. pushl %ebp
  608. int $0x21
  609. popl %ebp
  610. xorb %ah,%ah
  611. movl 20(%ebp),%edi
  612. movb %dl,%al
  613. stosw
  614. movl 16(%ebp),%edi
  615. movb %dh,%al
  616. stosw
  617. movl 12(%ebp),%edi
  618. movb %cl,%al
  619. stosw
  620. movl 8(%ebp),%edi
  621. movb %ch,%al
  622. stosw
  623. end;
  624. {$ELSE}
  625. asm
  626. movb $0x2c,%ah
  627. call ___syscall
  628. xorb %ah,%ah
  629. movl 20(%ebp),%edi
  630. movb %dl,%al
  631. stosw
  632. movl 16(%ebp),%edi
  633. movb %dh,%al
  634. stosw
  635. movl 12(%ebp),%edi
  636. movb %cl,%al
  637. stosw
  638. movl 8(%ebp),%edi
  639. movb %ch,%al
  640. stosw
  641. end;
  642. {$ENDIF}
  643. end;
  644. procedure settime(hour,minute,second,sec100 : word);
  645. begin
  646. {$IFNDEF OS2}
  647. asm
  648. movb 8(%ebp),%ch
  649. movb 10(%ebp),%cl
  650. movb 12(%ebp),%dh
  651. movb 14(%ebp),%dl
  652. movb $0x2d,%ah
  653. pushl %ebp
  654. int $0x21
  655. popl %ebp
  656. xorb %ah,%ah
  657. movw %ax,U_DOS_DOSERROR
  658. end;
  659. {$ELSE}
  660. asm
  661. movb 8(%ebp),%ch
  662. movb 10(%ebp),%cl
  663. movb 12(%ebp),%dh
  664. movb 14(%ebp),%dl
  665. movb $0x2d,%ah
  666. call ___syscall
  667. xorb %ah,%ah
  668. movw %ax,U_DOS_DOSERROR
  669. end;
  670. {$ENDIF}
  671. end;
  672. procedure getcbreak(var breakvalue : boolean);
  673. begin
  674. {$IFNDEF OS2}
  675. asm
  676. movw $0x3300,%ax
  677. pushl %ebp
  678. int $0x21
  679. popl %ebp
  680. movl 8(%ebp),%eax
  681. movb %dl,(%eax)
  682. end;
  683. {$ELSE}
  684. {! Do not use in OS/2. Also not recommended in DOS. Use
  685. signal handling instead.}
  686. asm
  687. movw $0x3300,%ax
  688. call ___syscall
  689. movl 8(%ebp),%eax
  690. movb %dl,(%eax)
  691. end;
  692. {$ENDIF}
  693. end;
  694. procedure setcbreak(breakvalue : boolean);
  695. begin
  696. {$IFNDEF OS2}
  697. asm
  698. movb 8(%ebp),%dl
  699. movl $0x3301,%ax
  700. pushl %ebp
  701. int $0x21
  702. popl %ebp
  703. end;
  704. {$ELSE}
  705. {! Do not use in OS/2. Also not recommended in DOS. Use
  706. signal handling instead.}
  707. asm
  708. movb 8(%ebp),%dl
  709. movl $0x3301,%ax
  710. call ___syscall
  711. end;
  712. {$ENDIF}
  713. end;
  714. procedure getverify(var verify : boolean);
  715. begin
  716. {$IFNDEF OS2}
  717. asm
  718. movb $0x54,%ah
  719. pushl %ebp
  720. int $0x21
  721. popl %ebp
  722. movl 8(%ebp),%edi
  723. stosb
  724. end;
  725. {$ELSE}
  726. {! Do not use in OS/2.}
  727. asm
  728. movb $0x54,%ah
  729. call ___syscall
  730. movl 8(%ebp),%edi
  731. stosb
  732. end;
  733. {$ENDIF}
  734. end;
  735. procedure setverify(verify : boolean);
  736. begin
  737. {$IFNDEF OS2}
  738. asm
  739. movb 8(%ebp),%al
  740. movl $0x2e,%ah
  741. pushl %ebp
  742. int $0x21
  743. popl %ebp
  744. end;
  745. {$ELSE}
  746. {! Do not use in OS/2.}
  747. asm
  748. movb 8(%ebp),%al
  749. movl $0x2e,%ah
  750. call ___syscall
  751. end;
  752. {$ENDIF}
  753. end;
  754. function diskfree(drive : byte) : longint;
  755. var fi:OS2FSallocate;
  756. begin
  757. {$IFNDEF OS2}
  758. asm
  759. movb 8(%ebp),%dl
  760. movb $0x36,%ah
  761. pushl %ebp
  762. int $0x21
  763. popl %ebp
  764. cmpw $-1,%ax
  765. je LDISKFREE1
  766. mulw %cx
  767. mulw %bx
  768. shll $16,%edx
  769. movw %ax,%dx
  770. movl %edx,%eax
  771. leave
  772. ret
  773. LDISKFREE1:
  774. cwde
  775. leave
  776. ret
  777. end;
  778. {$ELSE}
  779. if os_mode=osDOS then
  780. {Function 36 is not supported in OS/2.}
  781. asm
  782. movb 8(%ebp),%dl
  783. movb $0x36,%ah
  784. call ___syscall
  785. cmpw $-1,%ax
  786. je LDISKFREE1
  787. mulw %cx
  788. mulw %bx
  789. shll $16,%edx
  790. movw %ax,%dx
  791. xchgl %edx,%eax
  792. leave
  793. ret
  794. LDISKFREE1:
  795. cwde
  796. leave
  797. ret
  798. end
  799. else
  800. {In OS/2, we use the filesystem information.}
  801. begin
  802. doserror:=dosqueryFSinfo(drive,1,FI,sizeof(FI));
  803. if doserror=0 then
  804. diskfree:=FI.cunitavail*FI.csectorunit*FI.cbsector
  805. else
  806. diskfree:=-1;
  807. end;
  808. {$ENDIF}
  809. end;
  810. function disksize(drive : byte) : longint;
  811. begin
  812. {$IFNDEF OS/2}
  813. asm
  814. movb 8(%ebp),%dl
  815. movb $0x36,%ah
  816. pushl %ebp
  817. int $0x21
  818. popl %ebp
  819. movw %dx,%bx
  820. cmpw $-1,%ax
  821. je LDISKSIZE1
  822. mulw %cx
  823. mulw %bx
  824. shll $16,%edx
  825. movw %ax,%dx
  826. movl %edx,%eax
  827. leave
  828. ret
  829. LDISKSIZE1:
  830. movl $-1,%eax
  831. leave
  832. ret
  833. end;
  834. {$ELSE}
  835. if os_mode=osDOS then
  836. {Function 36 is not supported in OS/2.}
  837. asm
  838. movb 8(%ebp),%dl
  839. movb $0x36,%ah
  840. call ___syscall
  841. movw %dx,%bx
  842. cmpw $-1,%ax
  843. je LDISKSIZE1
  844. mulw %cx
  845. mulw %bx
  846. shll $16,%edx
  847. movw %ax,%dx
  848. xchgl %edx,%eax
  849. leave
  850. ret
  851. LDISKSIZE1:
  852. cwde
  853. leave
  854. ret
  855. end;
  856. else
  857. {In OS/2, we use the filesystem information.}
  858. begin
  859. doserror:=dosQFSinfo(drive,1,FI,sizeof(FI));
  860. if doserror=0 then
  861. diskfree:=FI.cunit*FI.csectorunit*FI.cbsector
  862. else
  863. diskfree:=-1;
  864. end;
  865. {$ENDIF}
  866. end;
  867. procedure searchrec2dossearchrec(var f : searchrec);
  868. var
  869. l,i : longint;
  870. {$IFDEF OS2}
  871. const namesize=255;
  872. {$ELSE}
  873. const namesize=12;
  874. {$ENDIF}
  875. begin
  876. l:=length(f.name);
  877. for i:=1 to namesize do
  878. f.name[i-1]:=f.name[i];
  879. f.name[l]:=#0;
  880. end;
  881. procedure dossearchrec2searchrec(var f : searchrec);
  882. var
  883. l,i : longint;
  884. {$IFDEF OS2}
  885. const namesize=255;
  886. {$ELSE}
  887. const namesize=12;
  888. {$ENDIF}
  889. begin
  890. for i:=0 to namesize do
  891. if f.name[i]=#0 then
  892. begin
  893. l:=i;
  894. break;
  895. end;
  896. for i:=namesize-1 downto 0 do
  897. f.name[i+1]:=f.name[i];
  898. f.name[0]:=chr(l);
  899. end;
  900. procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  901. procedure _findfirst(path : pchar;attr : word;var f : searchrec);
  902. begin
  903. {$IFNDEF OS2}
  904. asm
  905. movl 18(%ebp),%edx
  906. movb $0x1a,%ah
  907. int $0x21
  908. movl 12(%esp),%edx
  909. movzwl 16(%esp),%ecx
  910. movb $0x4e,%ah
  911. int $0x21
  912. jnc LFF
  913. movw %ax,U_DOS_DOSERROR
  914. LFF:
  915. end;
  916. {$ELSE}
  917. asm
  918. movl 12(%esp),%edx
  919. movw 16(%esp),%cx
  920. {No need to set DTA in EMX. Just give a pointer in ESI.}
  921. movl 18(%ebp),%esi
  922. movb $0x4e,%ah
  923. call ___syscall
  924. jnc LFF
  925. movw %ax,U_DOS_DOSERROR
  926. LFF:
  927. end;
  928. {$ENDIF}
  929. end;
  930. var
  931. path0 : array[0..80] of char;
  932. begin
  933. { no error }
  934. doserror:=0;
  935. strpcopy(path0,path);
  936. _findfirst(path0,attr,f);
  937. dossearchrec2searchrec(f);
  938. end;
  939. procedure findnext(var f : searchRec);
  940. procedure _findnext(var f : searchrec);
  941. begin
  942. {$IFNDEF OS2}
  943. asm
  944. movl 12(%ebp),%edx
  945. movb $0x1a,%ah
  946. int $0x21
  947. movb $0x4f,%ah
  948. int $0x21
  949. jnc LFN
  950. movw %ax,U_DOS_DOSERROR
  951. LFN:
  952. end;
  953. {$ELSE}
  954. asm
  955. movl 12(%ebp),%esi
  956. movb $0x4f,%ah
  957. call ___syscall
  958. jnc LFN
  959. movw %ax,U_DOS_DOSERROR
  960. LFN:
  961. end;
  962. {$ENDIF}
  963. end;
  964. begin
  965. { no error }
  966. doserror:=0;
  967. searchrec2dossearchrec(f);
  968. _findnext(f);
  969. dossearchrec2searchrec(f);
  970. end;
  971. procedure swapvectors;
  972. begin
  973. { tut nichts, DOS-Extender �bernimmt das N”tige }
  974. { normalerweise selber }
  975. { nur aus Kompatibilit„tsgr�nden implementiert }
  976. end;
  977. type
  978. ppchar = ^pchar;
  979. function envs : ppchar;
  980. begin
  981. asm
  982. movl _environ,%eax
  983. leave
  984. ret
  985. end ['EAX'];
  986. end;
  987. function envcount : longint;
  988. var
  989. hp : ppchar;
  990. begin
  991. {$IFNDEF OS2}
  992. hp:=envs;
  993. envcount:=0;
  994. while assigned(hp^) do
  995. begin
  996. { not the best solution, but quite understandable }
  997. inc(envcount);
  998. hp:=hp+4;
  999. end;
  1000. {$ELSE}
  1001. asm
  1002. movl _envc,%eax
  1003. leave
  1004. ret
  1005. end ['EAX'];
  1006. {$ENDIF}
  1007. end;
  1008. function envstr(index : longint) : string;
  1009. var
  1010. hp : ppchar;
  1011. begin
  1012. if (index<=0) or (index>envcount) then
  1013. begin
  1014. envstr:='';
  1015. exit;
  1016. end;
  1017. hp:=envs+4*(index-1);
  1018. envstr:=strpas(hp^);
  1019. end;
  1020. function getenv(const envvar : string) : string;
  1021. var
  1022. hs,_envvar : string;
  1023. eqpos,i : longint;
  1024. begin
  1025. _envvar:=upcase(envvar);
  1026. getenv:='';
  1027. for i:=1 to envcount do
  1028. begin
  1029. hs:=envstr(i);
  1030. eqpos:=pos('=',hs);
  1031. if copy(hs,1,eqpos-1)=_envvar then
  1032. begin
  1033. getenv:=copy(hs,eqpos+1,length(hs)-eqpos);
  1034. exit;
  1035. end;
  1036. end;
  1037. end;
  1038. procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
  1039. var ext : extstr);
  1040. var
  1041. p1 : byte;
  1042. begin
  1043. { try to find out a extension }
  1044. p1:=pos('.',path);
  1045. if p1>0 then
  1046. begin
  1047. ext:=copy(path,p1,4);
  1048. delete(path,p1,length(path)-p1+1);
  1049. end
  1050. else
  1051. ext:='';
  1052. { get drive name }
  1053. p1:=pos(':',path);
  1054. if p1>0 then
  1055. begin
  1056. dir:=path[1]+':';
  1057. delete(path,1,p1);
  1058. end
  1059. else
  1060. dir:='';
  1061. { split the path and the name, there are no more path informtions }
  1062. { if path contains no backslashes }
  1063. while true do
  1064. begin
  1065. p1:=pos('\',path);
  1066. if p1=0 then
  1067. break;
  1068. dir:=dir+copy(path,1,p1);
  1069. delete(path,1,p1);
  1070. end;
  1071. name:=path;
  1072. end;
  1073. function fexpand(const path : pathstr) : pathstr;
  1074. function get_current_drive : byte;
  1075. var
  1076. r : registers;
  1077. begin
  1078. r.ah:=$19;
  1079. msdos(r);
  1080. get_current_drive:=r.al;
  1081. end;
  1082. var
  1083. {$IFDEF DOS}
  1084. s,pa : string[79];
  1085. {$ELSE}
  1086. s,pa:string;
  1087. {$ENDIF}
  1088. begin
  1089. { There are differences between FPKPascal and Turbo Pascal
  1090. e.g. for the string 'D:\DEMO\..\HELLO' which isn't handled }
  1091. getdir(0,s);
  1092. pa:=upcase(path);
  1093. if (byte(pa[0])>1) and ((pa[1] in ['A'..'Z']) and (pa[2]=':')) then
  1094. begin
  1095. if (byte(pa[0])>2) and (pa[3]<>'\') then
  1096. if pa[1]=s[1] then
  1097. pa:=s+'\'+copy (pa,3,length(pa))
  1098. else
  1099. pa:=pa[1]+':\'+copy (pa,3,length(pa))
  1100. end
  1101. else
  1102. if pa[1]='\' then
  1103. pa:=s[1]+':'+pa
  1104. else if s[0]=#3 then
  1105. pa:=s+pa
  1106. else
  1107. pa:=s+'\'+pa;
  1108. fexpand:=pa;
  1109. end;
  1110. procedure packtime(var d : datetime;var time : longint);
  1111. var
  1112. zs : longint;
  1113. begin
  1114. time:=-1980;
  1115. time:=time+d.year and 127;
  1116. time:=time shl 4;
  1117. time:=time+d.month;
  1118. time:=time shl 5;
  1119. time:=time+d.day;
  1120. time:=time shl 16;
  1121. zs:=d.hour;
  1122. zs:=zs shl 6;
  1123. zs:=zs+d.min;
  1124. zs:=zs shl 5;
  1125. zs:=zs+d.sec div 2;
  1126. time:=time+(zs and $ffff);
  1127. end;
  1128. procedure unpacktime (time: longint; var d: datetime);
  1129. begin
  1130. d.sec:=(time and 31) * 2;
  1131. time:=time shr 5;
  1132. d.min:=time and 63;
  1133. time:=time shr 6;
  1134. d.hour:=time and 31;
  1135. time:=time shr 5;
  1136. d.day:=time and 31;
  1137. time:=time shr 5;
  1138. d.month:=time and 15;
  1139. time:=time shr 4;
  1140. d.year:=time + 1980;
  1141. end;
  1142. procedure getfattr(var f;var attr : word);
  1143. var
  1144. { to avoid problems }
  1145. n : array[0..255] of char;
  1146. {$IFNDEF OS2}
  1147. r : registers;
  1148. {$ENDIF}
  1149. begin
  1150. strpcopy(n,filerec(f).name);
  1151. {$IFNDEF OS2}
  1152. r.ax:=$4300;
  1153. r.edx:=longint(@n);
  1154. msdos(r);
  1155. attr:=r.cx;
  1156. {$ELSE}
  1157. {Alas, msdos(r) doesn't work when we are running in OS/2.}
  1158. asm
  1159. movw $0x4300,%ax
  1160. leal n,%edx
  1161. call ___syscall
  1162. movl attr,%ebx
  1163. movw %cx,(%ebx)
  1164. end;
  1165. {$ENDIF}
  1166. end;
  1167. procedure setfattr(var f;attr : word);
  1168. var
  1169. { to avoid problems }
  1170. n : array[0..255] of char;
  1171. {$IFNDEF OS2}
  1172. r : registers;
  1173. {$ENDIF}
  1174. begin
  1175. strpcopy(n,filerec(f).name);
  1176. {$IFNDEF OS2}
  1177. r.ax:=$4301;
  1178. r.edx:=longint(@n);
  1179. r.cx:=attr;
  1180. msdos(r);
  1181. {$ELSE}
  1182. {Alas, msdos(r) doesn't work when we are running in OS/2.}
  1183. asm
  1184. movw $0x4301,%ax
  1185. leal n,%edx
  1186. movw attr,%cx
  1187. call ___syscall
  1188. end;
  1189. {$ENDIF}
  1190. end;
  1191. end.