dos.pas 24 KB

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