dos.pas 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044
  1. {****************************************************************************
  2. $Id$
  3. Free Pascal Runtime-Library
  4. DOS unit for OS/2
  5. Copyright (c) 1997,1998 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):longint;
  105. function disksize(drive:byte):longint;
  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. {No wildcards allowed in these things:}
  148. if (pos('?',path)<>0) or (pos('*',path)<>0) then
  149. fsearch:=''
  150. else
  151. begin
  152. { allow slash as backslash }
  153. for i:=1 to length(dirlist) do
  154. if dirlist[i]='/' then dirlist[i]:='\';
  155. repeat
  156. p1:=pos(';',dirlist);
  157. if p1<>0 then
  158. begin
  159. newdir:=copy(dirlist,1,p1-1);
  160. delete(dirlist,1,p1);
  161. end
  162. else
  163. begin
  164. newdir:=dirlist;
  165. dirlist:='';
  166. end;
  167. if (newdir<>'') and
  168. not (newdir[length(newdir)] in ['\',':']) then
  169. newdir:=newdir+'\';
  170. if OS_Mode = osOS2 then
  171. begin
  172. New (FStat);
  173. ND := NewDir + Path;
  174. Handle := $FFFFFFFF;
  175. Count := 1;
  176. RC := DosFindFirst (ND, Handle, $37, FStat, SizeOf (FStat^),
  177. Count, ilStandard);
  178. DosFindClose (Handle);
  179. Dispose (FStat);
  180. end else
  181. begin
  182. findfirst(newdir+path,anyfile,s);
  183. RC := DosError;
  184. end;
  185. if RC = 0 then
  186. newdir:=newdir+path
  187. else
  188. newdir:='';
  189. until (dirlist='') or (newdir<>'');
  190. fsearch:=newdir;
  191. end;
  192. end;
  193. procedure getftime(var f;var time:longint);
  194. begin
  195. asm
  196. {Load handle}
  197. movl f,%ebx
  198. movw (%ebx),%bx
  199. {Get date}
  200. movw $0x5700,%ax
  201. call syscall
  202. shll $16,%edx
  203. movw %cx,%dx
  204. movl time,%ebx
  205. movl %edx,(%ebx)
  206. xorb %ah,%ah
  207. movw %ax,doserror
  208. end;
  209. end;
  210. procedure setftime(var f;time : longint);
  211. begin
  212. asm
  213. {Load handle}
  214. movl f,%ebx
  215. movw (%ebx),%bx
  216. movl time,%ecx
  217. shldl $16,%ecx,%edx
  218. {Set date}
  219. movw $0x5701,%ax
  220. call syscall
  221. xorb %ah,%ah
  222. movw %ax,doserror
  223. end;
  224. end;
  225. procedure msdos(var regs:registers);
  226. {Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
  227. begin
  228. intr($21,regs);
  229. end;
  230. {$ASMMODE DIRECT}
  231. procedure intr(intno:byte;var regs:registers);
  232. {Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
  233. begin
  234. asm
  235. .data
  236. int86:
  237. .byte 0xcd
  238. int86_vec:
  239. .byte 0x03
  240. jmp int86_retjmp
  241. .text
  242. movl 8(%ebp),%eax
  243. movb %al,int86_vec
  244. movl 10(%ebp),%eax
  245. {Do not use first int}
  246. incl %eax
  247. incl %eax
  248. movl 4(%eax),%ebx
  249. movl 8(%eax),%ecx
  250. movl 12(%eax),%edx
  251. movl 16(%eax),%ebp
  252. movl 20(%eax),%esi
  253. movl 24(%eax),%edi
  254. movl (%eax),%eax
  255. jmp int86
  256. int86_retjmp:
  257. pushf
  258. pushl %ebp
  259. pushl %eax
  260. movl %esp,%ebp
  261. {Calc EBP new}
  262. addl $12,%ebp
  263. movl 10(%ebp),%eax
  264. {Do not use first int}
  265. incl %eax
  266. incl %eax
  267. popl (%eax)
  268. movl %ebx,4(%eax)
  269. movl %ecx,8(%eax)
  270. movl %edx,12(%eax)
  271. {Restore EBP}
  272. popl %edx
  273. movl %edx,16(%eax)
  274. movl %esi,20(%eax)
  275. movl %edi,24(%eax)
  276. {Ignore ES and DS}
  277. popl %ebx {Flags.}
  278. movl %ebx,32(%eax)
  279. {FS and GS too}
  280. end;
  281. end;
  282. {$ASMMODE ATT}
  283. procedure exec(const path:pathstr;const comline:comstr);
  284. {Execute a program.}
  285. begin
  286. dosexitcode:=exec(path,efwait,efdefault,comline);
  287. end;
  288. function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags;
  289. const comline:comstr):longint;
  290. {Execute a program. More suitable for OS/2 than the exec above.}
  291. {512 bytes should be enough to contain the command-line.}
  292. type bytearray=array[0..8191] of byte;
  293. Pbytearray=^bytearray;
  294. execstruc=record
  295. argofs,envofs,nameofs:pointer;
  296. argseg,envseg,nameseg:word;
  297. numarg,sizearg,
  298. numenv,sizeenv:word;
  299. mode1,mode2:byte;
  300. end;
  301. var args:Pbytearray;
  302. env:Pbytearray;
  303. i,j:word;
  304. es:execstruc;
  305. esadr:pointer;
  306. d:dirstr;
  307. n:namestr;
  308. e:extstr;
  309. begin
  310. getmem(args,512);
  311. getmem(env,8192);
  312. j:=1;
  313. {Now setup the arguments. The first argument should be the program
  314. name without directory and extension.}
  315. fsplit(path,d,n,e);
  316. es.numarg:=1;
  317. args^[0]:=$80;
  318. for i:=1 to length(n) do
  319. begin
  320. args^[j]:=byte(n[i]);
  321. inc(j);
  322. end;
  323. args^[j]:=0;
  324. inc(j);
  325. {Now do the real arguments.}
  326. i:=1;
  327. while i<=length(comline) do
  328. begin
  329. if comline[i]<>' ' then
  330. begin
  331. {Commandline argument found. Copy it.}
  332. inc(es.numarg);
  333. args^[j]:=$80;
  334. inc(j);
  335. while (i<=length(comline)) and (comline[i]<>' ') do
  336. begin
  337. args^[j]:=byte(comline[i]);
  338. inc(j);
  339. inc(i);
  340. end;
  341. args^[j]:=0;
  342. inc(j);
  343. end;
  344. inc(i);
  345. end;
  346. args^[j]:=0;
  347. inc(j);
  348. {Commandline ready, now build the environment.
  349. Oh boy, I always had the opinion that executing a program under Dos
  350. was a hard job!}
  351. {$ASMMODE DIRECT}
  352. asm
  353. movl env,%edi {Setup destination pointer.}
  354. movl _envc,%ecx {Load number of arguments in edx.}
  355. movl _environ,%esi {Load env. strings.}
  356. xorl %edx,%edx {Count environment size.}
  357. exa1:
  358. lodsl {Load a Pchar.}
  359. xchgl %eax,%ebx
  360. exa2:
  361. movb (%ebx),%al {Load a byte.}
  362. incl %ebx {Point to next byte.}
  363. stosb {Store it.}
  364. incl %edx {Increase counter.}
  365. cmpb $0,%al {Ready ?.}
  366. jne exa2
  367. loop exa1 {Next argument.}
  368. stosb {Store an extra 0 to finish. (AL is now 0).}
  369. incl %edx
  370. movl %edx,(24)es {Store environment size.}
  371. end;
  372. {$ASMMODE ATT}
  373. {Environtment ready, now set-up exec structure.}
  374. es.argofs:=args;
  375. es.envofs:=env;
  376. asm
  377. leal path,%esi
  378. lodsb
  379. movzbl %al,%eax
  380. addl %eax,%esi
  381. movb $0,(%esi)
  382. end;
  383. es.nameofs:=pointer(longint(@path)+1);
  384. asm
  385. movw %ss,es.argseg
  386. movw %ss,es.envseg
  387. movw %ss,es.nameseg
  388. end;
  389. es.sizearg:=j;
  390. es.numenv:=0;
  391. {Typecasting of sets in FPK is a bit hard.}
  392. es.mode1:=byte(runflags);
  393. es.mode2:=byte(winflags);
  394. {Now exec the program.}
  395. asm
  396. leal es,%edx
  397. mov $0x7f06,%ax
  398. call syscall
  399. xorl %edi,%edi
  400. jnc .Lexprg1
  401. xchgl %eax,%edi
  402. xorl %eax,%eax
  403. decl %eax
  404. .Lexprg1:
  405. movw %di,doserror
  406. movl %eax,__RESULT
  407. end;
  408. freemem(args,512);
  409. freemem(env,8192);
  410. {Phew! That's it. This was the most sophisticated procedure to call
  411. a system function I ever wrote!}
  412. end;
  413. function dosversion:word;assembler;
  414. {Returns DOS version in DOS and OS/2 version in OS/2}
  415. asm
  416. movb $0x30,%ah
  417. call syscall
  418. end;
  419. procedure getdate(var year,month,day,dayofweek:word);
  420. begin
  421. asm
  422. movb $0x2a,%ah
  423. call syscall
  424. xorb %ah,%ah
  425. movl 20(%ebp),%edi
  426. stosw
  427. movl 16(%ebp),%edi
  428. movb %dl,%al
  429. stosw
  430. movl 12(%ebp),%edi
  431. movb %dh,%al
  432. stosw
  433. movl 8(%ebp),%edi
  434. xchgw %ecx,%eax
  435. stosw
  436. end;
  437. end;
  438. procedure setdate(year,month,day : word);
  439. begin
  440. {DOS only! You cannot change the system date in OS/2!}
  441. asm
  442. movw 8(%ebp),%cx
  443. movb 10(%ebp),%dh
  444. movb 12(%ebp),%dl
  445. movb $0x2b,%ah
  446. call syscall
  447. xorb %ah,%ah
  448. movw %ax,doserror
  449. end;
  450. end;
  451. procedure gettime(var hour,minute,second,sec100:word);
  452. begin
  453. asm
  454. movb $0x2c,%ah
  455. call syscall
  456. xorb %ah,%ah
  457. movl 20(%ebp),%edi
  458. movb %dl,%al
  459. stosw
  460. movl 16(%ebp),%edi
  461. movb %dh,%al
  462. stosw
  463. movl 12(%ebp),%edi
  464. movb %cl,%al
  465. stosw
  466. movl 8(%ebp),%edi
  467. movb %ch,%al
  468. stosw
  469. end;
  470. end;
  471. procedure settime(hour,minute,second,sec100:word);
  472. begin
  473. asm
  474. movb 8(%ebp),%ch
  475. movb 10(%ebp),%cl
  476. movb 12(%ebp),%dh
  477. movb 14(%ebp),%dl
  478. movb $0x2d,%ah
  479. call syscall
  480. xorb %ah,%ah
  481. movw %ax,doserror
  482. end;
  483. end;
  484. procedure getcbreak(var breakvalue:boolean);
  485. begin
  486. {! Do not use in OS/2. Also not recommended in DOS. Use
  487. signal handling instead.}
  488. asm
  489. movw $0x3300,%ax
  490. call syscall
  491. movl 8(%ebp),%eax
  492. movb %dl,(%eax)
  493. end;
  494. end;
  495. procedure setcbreak(breakvalue:boolean);
  496. begin
  497. {! Do not use in OS/2. Also not recommended in DOS. Use
  498. signal handling instead.}
  499. asm
  500. movb 8(%ebp),%dl
  501. movw $0x3301,%ax
  502. call syscall
  503. end;
  504. end;
  505. procedure getverify(var verify:boolean);
  506. begin
  507. {! Do not use in OS/2.}
  508. asm
  509. movb $0x54,%ah
  510. call syscall
  511. movl 8(%ebp),%edi
  512. stosb
  513. end;
  514. end;
  515. procedure setverify(verify:boolean);
  516. begin
  517. {! Do not use in OS/2.}
  518. asm
  519. movb 8(%ebp),%al
  520. movb $0x2e,%ah
  521. call syscall
  522. end;
  523. end;
  524. function diskfree(drive:byte):longint;
  525. var fi:TFSinfo;
  526. begin
  527. if os_mode=osDOS then
  528. {Function 36 is not supported in OS/2.}
  529. asm
  530. movb 8(%ebp),%dl
  531. movb $0x36,%ah
  532. call syscall
  533. cmpw $-1,%ax
  534. je .LDISKFREE1
  535. mulw %cx
  536. mulw %bx
  537. shll $16,%edx
  538. movw %ax,%dx
  539. xchgl %edx,%eax
  540. leave
  541. ret
  542. .LDISKFREE1:
  543. cltd
  544. leave
  545. ret
  546. end
  547. else
  548. {In OS/2, we use the filesystem information.}
  549. begin
  550. doserror:=dosqueryFSinfo(drive,1,FI,sizeof(FI));
  551. if doserror=0 then
  552. diskfree:=FI.free_clusters*FI.sectors_per_cluster*
  553. FI.bytes_per_sector
  554. else
  555. diskfree:=-1;
  556. end;
  557. end;
  558. function disksize(drive:byte):longint;
  559. var fi:TFSinfo;
  560. begin
  561. if os_mode=osDOS then
  562. {Function 36 is not supported in OS/2.}
  563. asm
  564. movb 8(%ebp),%dl
  565. movb $0x36,%ah
  566. call syscall
  567. movw %dx,%bx
  568. cmpw $-1,%ax
  569. je .LDISKSIZE1
  570. mulw %cx
  571. mulw %bx
  572. shll $16,%edx
  573. movw %ax,%dx
  574. xchgl %edx,%eax
  575. leave
  576. ret
  577. .LDISKSIZE1:
  578. cltd
  579. leave
  580. ret
  581. end
  582. else
  583. {In OS/2, we use the filesystem information.}
  584. begin
  585. doserror:=dosqueryFSinfo(drive,1,FI,sizeof(FI));
  586. if doserror=0 then
  587. disksize:=FI.total_clusters*FI.sectors_per_cluster*
  588. FI.bytes_per_sector
  589. else
  590. disksize:=-1;
  591. end;
  592. end;
  593. procedure searchrec2dossearchrec(var f:searchrec);
  594. const namesize=255;
  595. var l,i:longint;
  596. begin
  597. l:=length(f.name);
  598. for i:=1 to namesize do
  599. f.name[i-1]:=f.name[i];
  600. f.name[l]:=#0;
  601. end;
  602. procedure dossearchrec2searchrec(var f : searchrec);
  603. const namesize=255;
  604. var l,i : longint;
  605. begin
  606. for i:=0 to namesize do
  607. if f.name[i]=#0 then
  608. begin
  609. l:=i;
  610. break;
  611. end;
  612. for i:=namesize-1 downto 0 do
  613. f.name[i+1]:=f.name[i];
  614. f.name[0]:=char(l);
  615. end;
  616. procedure findfirst(const path:pathstr;attr:word;var f:searchRec);
  617. procedure _findfirst(path:pchar;attr:word;var f:searchrec);
  618. begin
  619. asm
  620. movl 12(%esp),%edx
  621. movw 16(%esp),%cx
  622. {No need to set DTA in EMX. Just give a pointer in ESI.}
  623. movl 18(%ebp),%esi
  624. movb $0x4e,%ah
  625. call syscall
  626. jnc .LFF
  627. movw %ax,doserror
  628. .LFF:
  629. end;
  630. end;
  631. var path0:array[0..255] of char;
  632. begin
  633. {No error.}
  634. doserror:=0;
  635. strPcopy(path0,path);
  636. _findfirst(path0,attr,f);
  637. dossearchrec2searchrec(f);
  638. end;
  639. procedure findnext(var f:searchRec);
  640. procedure _findnext(var f : searchrec);
  641. begin
  642. asm
  643. movl 12(%ebp),%esi
  644. movb $0x4f,%ah
  645. call syscall
  646. jnc .LFN
  647. movw %ax,doserror
  648. .LFN:
  649. end;
  650. end;
  651. begin
  652. {No error}
  653. doserror:=0;
  654. searchrec2dossearchrec(f);
  655. _findnext(f);
  656. dossearchrec2searchrec(f);
  657. end;
  658. procedure findclose(var f:searchRec);
  659. begin
  660. end;
  661. procedure swapvectors;
  662. {For TP compatibility, this exists.}
  663. begin
  664. end;
  665. type PPchar=^Pchar;
  666. {$ASMMODE DIRECT}
  667. function envs:PPchar;assembler;
  668. asm
  669. movl _environ,%eax
  670. end ['EAX'];
  671. function envcount:longint;assembler;
  672. var hp : ppchar;
  673. asm
  674. movl _envc,%eax
  675. end ['EAX'];
  676. {$ASMMODE ATT}
  677. function envstr(index : longint) : string;
  678. var hp:PPchar;
  679. begin
  680. if (index<=0) or (index>envcount) then
  681. begin
  682. envstr:='';
  683. exit;
  684. end;
  685. hp:=PPchar(cardinal(envs)+4*(index-1));
  686. envstr:=strpas(hp^);
  687. end;
  688. function getenv(const envvar : string) : string;
  689. var hs,_envvar : string;
  690. eqpos,i : longint;
  691. begin
  692. _envvar:=upcase(envvar);
  693. getenv:='';
  694. for i:=1 to envcount do
  695. begin
  696. hs:=envstr(i);
  697. eqpos:=pos('=',hs);
  698. if copy(hs,1,eqpos-1)=_envvar then
  699. begin
  700. getenv:=copy(hs,eqpos+1,length(hs)-eqpos);
  701. exit;
  702. end;
  703. end;
  704. end;
  705. procedure fsplit(path:pathstr;var dir:dirstr;var name:namestr;
  706. var ext:extstr);
  707. var p1,i : longint;
  708. begin
  709. {Get drive name}
  710. p1:=pos(':',path);
  711. if p1>0 then
  712. begin
  713. dir:=path[1]+':';
  714. delete(path,1,p1);
  715. end
  716. else
  717. dir:='';
  718. { split the path and the name, there are no more path informtions }
  719. { if path contains no backslashes }
  720. while true do
  721. begin
  722. p1:=pos('\',path);
  723. if p1=0 then
  724. p1:=pos('/',path);
  725. if p1=0 then
  726. break;
  727. dir:=dir+copy(path,1,p1);
  728. delete(path,1,p1);
  729. end;
  730. {Try to find an extension.}
  731. ext:='';
  732. for i:=length(path) downto 1 do
  733. if path[i]='.' then
  734. begin
  735. ext:=copy(path,i,high(extstr));
  736. delete(path,i,length(path)-i+1);
  737. break;
  738. end;
  739. name:=path;
  740. end;
  741. function fexpand(const path:pathstr):pathstr;
  742. function get_current_drive:byte;assembler;
  743. asm
  744. movb $0x19,%ah
  745. call syscall
  746. end;
  747. var s,pa:string;
  748. i,j:longint;
  749. begin
  750. getdir(0,s);
  751. pa:=upcase(path);
  752. {Allow slash as backslash}
  753. for i:=1 to length(pa) do
  754. if pa[i]='/' then
  755. pa[i]:='\';
  756. if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then
  757. begin
  758. {We must get the right directory}
  759. getdir(byte(pa[1])-byte('A')+1,s);
  760. if (byte(pa[0])>2) and (pa[3]<>'\') then
  761. if pa[1]=s[1] then
  762. pa:=s+'\'+copy (pa,3,length(pa))
  763. else
  764. pa:=pa[1]+':\'+copy (pa,3,length(pa))
  765. end
  766. else
  767. if pa[1]='\' then
  768. pa:=s[1]+':'+pa
  769. else if s[0]=#3 then
  770. pa:=s+pa
  771. else
  772. pa:=s+'\'+pa;
  773. {First remove all references to '\.\'}
  774. i:=pos('\.\',pa);
  775. while i<>0 do
  776. begin
  777. delete(pa,i,2);
  778. i:=pos('\.\',pa);
  779. end;
  780. {Now remove also all references to '\..\' + of course previous dirs..}
  781. repeat
  782. i:=pos('\..\',pa);
  783. if i<>0 then
  784. begin
  785. j:=i-1;
  786. while (j>1) and (pa[j]<>'\') do
  787. dec(j);
  788. delete (pa,j,i-j+3);
  789. end;
  790. until i=0;
  791. {Remove End . and \}
  792. if (length(pa)>0) and (pa[length(pa)]='.') then
  793. dec(byte(pa[0]));
  794. if (length(pa)>0) and (pa[length(pa)]='\') then
  795. dec(byte(pa[0]));
  796. fexpand:=pa;
  797. end;
  798. procedure packtime(var d:datetime;var time:longint);
  799. var zs:longint;
  800. begin
  801. time:=-1980;
  802. time:=time+d.year and 127;
  803. time:=time shl 4;
  804. time:=time+d.month;
  805. time:=time shl 5;
  806. time:=time+d.day;
  807. time:=time shl 16;
  808. zs:=d.hour;
  809. zs:=zs shl 6;
  810. zs:=zs+d.min;
  811. zs:=zs shl 5;
  812. zs:=zs+d.sec div 2;
  813. time:=time+(zs and $ffff);
  814. end;
  815. procedure unpacktime (time:longint;var d:datetime);
  816. begin
  817. d.sec:=(time and 31) * 2;
  818. time:=time shr 5;
  819. d.min:=time and 63;
  820. time:=time shr 6;
  821. d.hour:=time and 31;
  822. time:=time shr 5;
  823. d.day:=time and 31;
  824. time:=time shr 5;
  825. d.month:=time and 15;
  826. time:=time shr 4;
  827. d.year:=time+1980;
  828. end;
  829. procedure getfattr(var f;var attr : word);assembler;
  830. asm
  831. movw $0x4300,%ax
  832. movl f,%edx
  833. {addl $filerec.name,%edx Doesn't work!!}
  834. addl $60,%edx
  835. call syscall
  836. movl attr,%ebx
  837. movw %cx,(%ebx)
  838. end;
  839. procedure setfattr(var f;attr : word);assembler;
  840. asm
  841. movw $0x4301,%ax
  842. movl f,%edx
  843. {addl $filerec.name,%edx Doesn't work!!}
  844. addl $60,%edx
  845. movw attr,%cx
  846. call syscall
  847. end;
  848. end.
  849. {
  850. $Log$
  851. Revision 1.17 1999-10-13 12:21:56 daniel
  852. * OS/2 compiler works again.
  853. Revision 1.16 1999/09/13 18:21:02 hajny
  854. * again didn't manage to read docu for DosFindFirst properly :-(
  855. Revision 1.15 1999/09/13 17:56:26 hajny
  856. * another correction to FSearch fix - mistyping
  857. Revision 1.14 1999/09/13 17:35:15 hajny
  858. * little addition/correction to FSearch fix
  859. Revision 1.13 1999/09/09 09:20:43 hajny
  860. * FSearch under OS/2 fixed
  861. Revision 1.12 1999/01/22 16:25:58 pierre
  862. + findclose added
  863. Revision 1.11 1999/01/18 16:22:51 jonas
  864. - removed "noattcdq" define
  865. Revision 1.10 1998/12/10 16:05:39 daniel
  866. * Fsearch bug fixed
  867. Revision 1.9 1998/12/07 18:55:41 jonas
  868. * fixed bug reported in the mailing list by Frank McCormick (fsearch: changed
  869. "if p1 = 0" to "if p1 <> 0"
  870. Revision 1.8 1998/10/16 14:18:02 daniel
  871. * Updates
  872. Revision 1.7 1998/07/08 14:44:11 daniel
  873. + Added moucalls and viocalls written by Tomas Hajny.
  874. + Final routines in doscalls implemented.
  875. * Fixed bugs in dos.pas.
  876. * Changed some old $ifdef FPK into $ifdef FPC.
  877. - Removed go32 stuff from dos.pas.
  878. - Removed '/' to '\' translation from system unit - EMX does this
  879. automatically.
  880. }