1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015 |
- {****************************************************************************
- $Id$
- Free Pascal Runtime-Library
- DOS unit for OS/2
- Copyright (c) 1997,1998 by Dani‰l Mantione,
- member of the Free Pascal development team
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- ****************************************************************************}
- unit dos;
- {$I os.inc}
- {$I386_DIRECT}
- {***************************************************************************}
- interface
- {***************************************************************************}
- {$PACKRECORDS 1}
- uses strings;
- const {Bit masks for CPU flags.}
- fcarry = $0001;
- fparity = $0004;
- fauxiliary = $0010;
- fzero = $0040;
- fsign = $0080;
- foverflow = $0800;
- {Bit masks for file attributes.}
- readonly = $01;
- hidden = $02;
- sysfile = $04;
- volumeid = $08;
- directory = $10;
- archive = $20;
- anyfile = $3F;
- fmclosed = $D7B0;
- fminput = $D7B1;
- fmoutput = $D7B2;
- fminout = $D7B3;
- type {Some string types:}
- comstr=string; {Filenames can be long in OS/2.}
- pathstr=string; {String for pathnames.}
- dirstr=string; {String for a directory}
- namestr=string; {String for a filename.}
- extstr=string[40]; {String for an extension. Can be 253
- characters long, in theory, but let's
- say fourty will be enough.}
- {Search record which is used by findfirst and findnext:}
- searchrec=record
- fill:array[1..21] of byte;
- attr:byte;
- time:longint;
- size:longint;
- name:string; {Filenames can be long in OS/2!}
- end;
- {File record for untyped files:}
- filerec = record
- handle:word;
- mode:word;
- recsize:word;
- _private:array[1..26] of byte;
- userdata:array[1..16] of byte;
- name:array[0..79] of char;
- end;
- {File record for text files:}
- textbuf=array[0..127] of char;
- textrec = record
- handle:word;
- mode:word;
- bufSize:word;
- _private:word;
- bufpos:word;
- bufend:word;
- bufptr:^textbuf;
- openfunc:pointer;
- inoutfunc:pointer;
- flushfunc:pointer;
- closefunc:pointer;
- userdata:array[1..16] of byte;
- name:array[0..79] of char;
- buffer:textbuf;
- end;
- {Data structure for the registers needed by msdos and intr:}
- registers=record
- case i:integer of
- 0:(ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,
- f8,flags,fs,gs:word);
- 1:(al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh:byte);
- 2:(eax,ebx,ecx,edx,ebp,esi,edi:longint);
- end;
- {Record for date and time:}
- datetime=record
- year,month,day,hour,min,sec:word;
- end;
- {Flags for the exec procedure:
- Starting the program:
- efwait: Wait until program terminates.
- efno_wait: Don't wait until the program terminates. Does not work
- in dos, as DOS cannot multitask.
- efoverlay: Terminate this program, then execute the requested
- program. WARNING: Exit-procedures are not called!
- efdebug: Debug program. Details are unknown.
- efsession: Do not execute as child of this program. Use a seperate
- session instead.
- efdetach: Detached. Function unknown. Info wanted!
- efpm: Run as presentation manager program.
- Determining the window state of the program:
- efdefault: Run the pm program in it's default situation.
- efminimize: Run the pm program minimized.
- efmaximize: Run the pm program maximized.
- effullscreen: Run the non-pm program fullscreen.
- efwindowed: Run the non-pm program in a window.
- Other options are not implemented defined because lack of
- knowledge abou what they do.}
- type execrunflags=(efwait,efno_wait,efoverlay,efdebug,efsession,
- efdetach,efpm);
- execwinflags=(efdefault,efminimize,efmaximize,effullscreen,
- efwindowed);
- var doserror:integer;
- dosexitcode:word;
- procedure getdate(var year,month,day,dayofweek:word);
- procedure gettime(var hour,minute,second,sec100:word);
- function dosversion:word;
- procedure setdate(year,month,day:word);
- procedure settime(hour,minute,second,sec100:word);
- procedure getcbreak(var breakvalue:boolean);
- procedure setcbreak(breakvalue:boolean);
- procedure getverify(var verify:boolean);
- procedure setverify(verify : boolean);
- function diskfree(drive:byte):longint;
- function disksize(drive:byte):longint;
- procedure findfirst(const path:pathstr;attr:word;var f:searchRec);
- procedure findnext(var f:searchRec);
- {Is a dummy:}
- procedure swapvectors;
- {Not supported:
- procedure getintvec(intno:byte;var vector:pointer);
- procedure setintvec(intno:byte;vector:pointer);
- procedure keep(exitcode:word);
- }
- procedure msdos(var regs:registers);
- procedure intr(intno : byte;var regs:registers);
- procedure getfattr(var f;var attr:word);
- procedure setfattr(var f;attr:word);
- function fsearch(path:pathstr;dirlist:string):pathstr;
- procedure getftime(var f;var time:longint);
- procedure setftime(var f;time:longint);
- procedure packtime (var d:datetime; var time:longint);
- procedure unpacktime (time:longint; var d:datetime);
- function fexpand(const path:pathstr):pathstr;
- procedure fsplit(path:pathstr;var dir:dirstr;var name:namestr;
- var ext:extstr);
- procedure exec(const path:pathstr;const comline:comstr);
- function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags;
- const comline:comstr):longint;
- function envcount:longint;
- function envstr(index:longint) : string;
- function getenv(const envvar:string): string;
- implementation
- uses doscalls;
- {Import ___SYSCALL to call it nicely from assembler procedures.
- procedure syscall;external name '___SYSCALL';}
- function fsearch(path:pathstr;dirlist:string):pathstr;
- var i,p1:longint;
- s:searchrec;
- newdir:pathstr;
- begin
- {No wildcards allowed in these things:}
- if (pos('?',path)<>0) or (pos('*',path)<>0) then
- fsearch:=''
- else
- begin
- { allow slash as backslash }
- for i:=1 to length(dirlist) do
- if dirlist[i]='/' then dirlist[i]:='\';
- repeat
- p1:=pos(';',dirlist);
- if p1=0 then
- begin
- newdir:=copy(dirlist,1,p1-1);
- delete(dirlist,1,p1);
- end
- else
- begin
- newdir:=dirlist;
- dirlist:='';
- end;
- if (newdir<>'') and
- not (newdir[length(newdir)] in ['\',':']) then
- newdir:=newdir+'\';
- findfirst(newdir+path,anyfile,s);
- if doserror=0 then
- newdir:=newdir+path
- else
- newdir:='';
- until (dirlist='') or (newdir<>'');
- fsearch:=newdir;
- end;
- end;
- procedure getftime(var f;var time:longint);
- begin
- asm
- {Load handle}
- movl f,%ebx
- movw (%ebx),%bx
- {Get date}
- movw $0x5700,%ax
- call ___SYSCALL
- shll $16,%edx
- movw %cx,%dx
- movl time,%ebx
- movl %edx,(%ebx)
- xorb %ah,%ah
- movw %ax,U_DOS_DOSERROR
- end;
- end;
- procedure setftime(var f;time : longint);
- begin
- asm
- {Load handle}
- movl f,%ebx
- movw (%ebx),%bx
- movl time,%ecx
- shldl $16,%ecx,%edx
- {Set date}
- movw $0x5701,%ax
- call ___SYSCALL
- xorb %ah,%ah
- movw %ax,U_DOS_DOSERROR
- end;
- end;
- procedure msdos(var regs:registers);
- {Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
- begin
- intr($21,regs);
- end;
- procedure intr(intno:byte;var regs:registers);
- {Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
- begin
- asm
- .data
- int86:
- .byte 0xcd
- int86_vec:
- .byte 0x03
- jmp int86_retjmp
- .text
- movl 8(%ebp),%eax
- movb %al,int86_vec
- movl 10(%ebp),%eax
- {Do not use first int}
- incl %eax
- incl %eax
- movl 4(%eax),%ebx
- movl 8(%eax),%ecx
- movl 12(%eax),%edx
- movl 16(%eax),%ebp
- movl 20(%eax),%esi
- movl 24(%eax),%edi
- movl (%eax),%eax
- jmp int86
- int86_retjmp:
- pushf
- pushl %ebp
- pushl %eax
- movl %esp,%ebp
- {Calc EBP new}
- addl $12,%ebp
- movl 10(%ebp),%eax
- {Do not use first int}
- incl %eax
- incl %eax
- popl (%eax)
- movl %ebx,4(%eax)
- movl %ecx,8(%eax)
- movl %edx,12(%eax)
- {Restore EBP}
- popl %edx
- movl %edx,16(%eax)
- movl %esi,20(%eax)
- movl %edi,24(%eax)
- {Ignore ES and DS}
- popl %ebx {Flags.}
- movl %ebx,32(%eax)
- {FS and GS too}
- end;
- end;
- procedure exec(const path:pathstr;const comline:comstr);
- {Execute a program.}
- begin
- dosexitcode:=exec(path,efwait,efdefault,comline);
- end;
- function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags;
- const comline:comstr):longint;
- {Execute a program. More suitable for OS/2 than the exec above.}
- {512 bytes should be enough to contain the command-line.}
- type bytearray=array[0..8191] of byte;
- Pbytearray=^bytearray;
- execstruc=record
- argofs,envofs,nameofs:pointer;
- argseg,envseg,nameseg:word;
- numarg,sizearg,
- numenv,sizeenv:word;
- mode1,mode2:byte;
- end;
- var args:Pbytearray;
- env:Pbytearray;
- i,j:word;
- es:execstruc;
- esadr:pointer;
- d:dirstr;
- n:namestr;
- e:extstr;
- begin
- getmem(args,512);
- getmem(env,8192);
- j:=1;
- {Now setup the arguments. The first argument should be the program
- name without directory and extension.}
- fsplit(path,d,n,e);
- es.numarg:=1;
- args^[0]:=$80;
- for i:=1 to length(n) do
- begin
- args^[j]:=byte(n[i]);
- inc(j);
- end;
- args^[j]:=0;
- inc(j);
- {Now do the real arguments.}
- i:=1;
- while i<=length(comline) do
- begin
- if comline[i]<>' ' then
- begin
- {Commandline argument found. Copy it.}
- inc(es.numarg);
- args^[j]:=$80;
- inc(j);
- while (i<=length(comline)) and (comline[i]<>' ') do
- begin
- args^[j]:=byte(comline[i]);
- inc(j);
- inc(i);
- end;
- args^[j]:=0;
- inc(j);
- end;
- inc(i);
- end;
- args^[j]:=0;
- inc(j);
- {Commandline ready, now build the environment.
- Oh boy, I always had the opinion that executing a program under Dos
- was a hard job!}
- asm
- movl env,%edi {Setup destination pointer.}
- movl _envc,%ecx {Load number of arguments in edx.}
- movl _environ,%esi {Load env. strings.}
- xorl %edx,%edx {Count environment size.}
- exa1:
- lodsl {Load a Pchar.}
- xchgl %eax,%ebx
- exa2:
- movb (%ebx),%al {Load a byte.}
- incl %ebx {Point to next byte.}
- stosb {Store it.}
- incl %edx {Increase counter.}
- cmpb $0,%al {Ready ?.}
- jne exa2
- loop exa1 {Next argument.}
- stosb {Store an extra 0 to finish. (AL is now 0).}
- incl %edx
- movl %edx,(24)es {Store environment size.}
- end;
- {Environtment ready, now set-up exec structure.}
- es.argofs:=args;
- es.envofs:=env;
- asm
- leal path,%esi
- lodsb
- movzbl %al,%eax
- addl %eax,%esi
- movb $0,(%esi)
- end;
- es.nameofs:=pointer(longint(@path)+1);
- asm
- movw %ss,(12)es {Compiler doesn't like record elems in asm.}
- movw %ss,(14)es
- movw %ss,(16)es
- end;
- es.sizearg:=j;
- es.numenv:=0;
- {Typecasting of sets in FPK is a bit hard.}
- es.mode1:=byte(runflags);
- es.mode2:=byte(winflags);
- {Now exec the program.}
- asm
- leal es,%edx
- mov $0x7f06,%ax
- call ___SYSCALL
- xorl %edi,%edi
- jnc exprg1
- xchgl %eax,%edi
- xorl %eax,%eax
- decl %eax
- exprg1:
- movl %edi,U_DOS_DOSERROR
- movl %eax,__RESULT
- end;
- freemem(args,512);
- freemem(env,8192);
- {Phew! That's it. This was the most sophisticated procedure to call
- a system function I ever wrote!}
- end;
- function dosversion:word;assembler;
- {Returns DOS version in DOS and OS/2 version in OS/2}
- asm
- movb $0x30,%ah
- call ___SYSCALL
- end;
- procedure getdate(var year,month,day,dayofweek:word);
- begin
- asm
- movb $0x2a,%ah
- call ___SYSCALL
- xorb %ah,%ah
- movl 20(%ebp),%edi
- stosw
- movl 16(%ebp),%edi
- movb %dl,%al
- stosw
- movl 12(%ebp),%edi
- movb %dh,%al
- stosw
- movl 8(%ebp),%edi
- xchgw %ecx,%eax
- stosw
- end;
- end;
- procedure setdate(year,month,day : word);
- begin
- {DOS only! You cannot change the system date in OS/2!}
- asm
- movw 8(%ebp),%cx
- movb 10(%ebp),%dh
- movb 12(%ebp),%dl
- movb $0x2b,%ah
- call ___SYSCALL
- xorb %ah,%ah
- movw %ax,U_DOS_DOSERROR
- end;
- end;
- procedure gettime(var hour,minute,second,sec100:word);
- begin
- asm
- movb $0x2c,%ah
- call ___SYSCALL
- xorb %ah,%ah
- movl 20(%ebp),%edi
- movb %dl,%al
- stosw
- movl 16(%ebp),%edi
- movb %dh,%al
- stosw
- movl 12(%ebp),%edi
- movb %cl,%al
- stosw
- movl 8(%ebp),%edi
- movb %ch,%al
- stosw
- end;
- end;
- procedure settime(hour,minute,second,sec100:word);
- begin
- asm
- movb 8(%ebp),%ch
- movb 10(%ebp),%cl
- movb 12(%ebp),%dh
- movb 14(%ebp),%dl
- movb $0x2d,%ah
- call ___SYSCALL
- xorb %ah,%ah
- movw %ax,U_DOS_DOSERROR
- end;
- end;
- procedure getcbreak(var breakvalue:boolean);
- begin
- {! Do not use in OS/2. Also not recommended in DOS. Use
- signal handling instead.}
- asm
- movw $0x3300,%ax
- call ___SYSCALL
- movl 8(%ebp),%eax
- movb %dl,(%eax)
- end;
- end;
- procedure setcbreak(breakvalue:boolean);
- begin
- {! Do not use in OS/2. Also not recommended in DOS. Use
- signal handling instead.}
- asm
- movb 8(%ebp),%dl
- movl $0x3301,%ax
- call ___SYSCALL
- end;
- end;
- procedure getverify(var verify:boolean);
- begin
- {! Do not use in OS/2.}
- asm
- movb $0x54,%ah
- call ___SYSCALL
- movl 8(%ebp),%edi
- stosb
- end;
- end;
- procedure setverify(verify:boolean);
- begin
- {! Do not use in OS/2.}
- asm
- movb 8(%ebp),%al
- movb $0x2e,%ah
- call ___SYSCALL
- end;
- end;
- function diskfree(drive:byte):longint;
- var fi:TFSinfo;
- begin
- if os_mode=osDOS then
- {Function 36 is not supported in OS/2.}
- asm
- movb 8(%ebp),%dl
- movb $0x36,%ah
- call ___SYSCALL
- cmpw $-1,%ax
- je LDISKFREE1
- mulw %cx
- mulw %bx
- shll $16,%edx
- movw %ax,%dx
- xchgl %edx,%eax
- leave
- ret
- LDISKFREE1:
- cwde
- leave
- ret
- end
- else
- {In OS/2, we use the filesystem information.}
- begin
- doserror:=dosqueryFSinfo(drive,1,FI,sizeof(FI));
- if doserror=0 then
- diskfree:=FI.free_clusters*FI.sectors_per_cluster*
- FI.bytes_per_sector
- else
- diskfree:=-1;
- end;
- end;
- function disksize(drive:byte):longint;
- var fi:TFSinfo;
- begin
- if os_mode=osDOS then
- {Function 36 is not supported in OS/2.}
- asm
- movb 8(%ebp),%dl
- movb $0x36,%ah
- call ___SYSCALL
- movw %dx,%bx
- cmpw $-1,%ax
- je LDISKSIZE1
- mulw %cx
- mulw %bx
- shll $16,%edx
- movw %ax,%dx
- xchgl %edx,%eax
- leave
- ret
- LDISKSIZE1:
- cwde
- leave
- ret
- end
- else
- {In OS/2, we use the filesystem information.}
- begin
- doserror:=dosqueryFSinfo(drive,1,FI,sizeof(FI));
- if doserror=0 then
- disksize:=FI.total_clusters*FI.sectors_per_cluster*
- FI.bytes_per_sector
- else
- disksize:=-1;
- end;
- end;
- procedure searchrec2dossearchrec(var f:searchrec);
- const namesize=255;
- var l,i:longint;
- begin
- l:=length(f.name);
- for i:=1 to namesize do
- f.name[i-1]:=f.name[i];
- f.name[l]:=#0;
- end;
- procedure dossearchrec2searchrec(var f : searchrec);
- const namesize=255;
- var l,i : longint;
- begin
- for i:=0 to namesize do
- if f.name[i]=#0 then
- begin
- l:=i;
- break;
- end;
- for i:=namesize-1 downto 0 do
- f.name[i+1]:=f.name[i];
- f.name[0]:=char(l);
- end;
- procedure findfirst(const path:pathstr;attr:word;var f:searchRec);
- procedure _findfirst(path:pchar;attr:word;var f:searchrec);
- begin
- asm
- movl 12(%esp),%edx
- movw 16(%esp),%cx
- {No need to set DTA in EMX. Just give a pointer in ESI.}
- movl 18(%ebp),%esi
- movb $0x4e,%ah
- call ___SYSCALL
- jnc LFF
- movw %ax,U_DOS_DOSERROR
- LFF:
- end;
- end;
- var path0:array[0..255] of char;
- begin
- {No error.}
- doserror:=0;
- strPcopy(path0,path);
- _findfirst(path0,attr,f);
- dossearchrec2searchrec(f);
- end;
- procedure findnext(var f:searchRec);
- procedure _findnext(var f : searchrec);
- begin
- asm
- movl 12(%ebp),%esi
- movb $0x4f,%ah
- call ___SYSCALL
- jnc LFN
- movw %ax,U_DOS_DOSERROR
- LFN:
- end;
- end;
- begin
- {No error}
- doserror:=0;
- searchrec2dossearchrec(f);
- _findnext(f);
- dossearchrec2searchrec(f);
- end;
- procedure swapvectors;
- {For TP compatibility, this exists.}
- begin
- end;
- type PPchar=^Pchar;
- function envs:PPchar;assembler;
- asm
- movl _environ,%eax
- end ['EAX'];
- function envcount:longint;assembler;
- var hp : ppchar;
- asm
- movl _envc,%eax
- end ['EAX'];
- function envstr(index : longint) : string;
- var hp:PPchar;
- begin
- if (index<=0) or (index>envcount) then
- begin
- envstr:='';
- exit;
- end;
- hp:=envs+4*(index-1);
- envstr:=strpas(hp^);
- end;
- function getenv(const envvar : string) : string;
- var hs,_envvar : string;
- eqpos,i : longint;
- begin
- _envvar:=upcase(envvar);
- getenv:='';
- for i:=1 to envcount do
- begin
- hs:=envstr(i);
- eqpos:=pos('=',hs);
- if copy(hs,1,eqpos-1)=_envvar then
- begin
- getenv:=copy(hs,eqpos+1,length(hs)-eqpos);
- exit;
- end;
- end;
- end;
- procedure fsplit(path:pathstr;var dir:dirstr;var name:namestr;
- var ext:extstr);
- var p1,i : longint;
- begin
- {Get drive name}
- p1:=pos(':',path);
- if p1>0 then
- begin
- dir:=path[1]+':';
- delete(path,1,p1);
- end
- else
- dir:='';
- { split the path and the name, there are no more path informtions }
- { if path contains no backslashes }
- while true do
- begin
- p1:=pos('\',path);
- if p1=0 then
- p1:=pos('/',path);
- if p1=0 then
- break;
- dir:=dir+copy(path,1,p1);
- delete(path,1,p1);
- end;
- {Try to find an extension.}
- ext:='';
- for i:=length(path) downto 1 do
- if path[i]='.' then
- begin
- ext:=copy(path,p1,high(extstr));
- delete(path,p1,length(path)-p1+1);
- break;
- end;
- name:=path;
- end;
- function fexpand(const path:pathstr):pathstr;
- function get_current_drive:byte;assembler;
- asm
- movb $0x19,%ah
- call ___SYSCALL
- end;
- var s,pa:string;
- i,j:longint;
- begin
- getdir(0,s);
- pa:=upcase(path);
- {Allow slash as backslash}
- for i:=1 to length(pa) do
- if pa[i]='/' then
- pa[i]:='\';
- if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then
- begin
- {We must get the right directory}
- getdir(byte(pa[1])-byte('A')+1,s);
- if (byte(pa[0])>2) and (pa[3]<>'\') then
- if pa[1]=s[1] then
- pa:=s+'\'+copy (pa,3,length(pa))
- else
- pa:=pa[1]+':\'+copy (pa,3,length(pa))
- end
- else
- if pa[1]='\' then
- pa:=s[1]+':'+pa
- else if s[0]=#3 then
- pa:=s+pa
- else
- pa:=s+'\'+pa;
- {First remove all references to '\.\'}
- i:=pos('\.\',pa);
- while i<>0 do
- begin
- delete(pa,i,2);
- i:=pos('\.\',pa);
- end;
- {Now remove also all references to '\..\' + of course previous dirs..}
- repeat
- i:=pos('\..\',pa);
- if i<>0 then
- begin
- j:=i-1;
- while (j>1) and (pa[j]<>'\') do
- dec(j);
- delete (pa,j,i-j+3);
- end;
- until i=0;
- {Remove End . and \}
- if (length(pa)>0) and (pa[length(pa)]='.') then
- dec(byte(pa[0]));
- if (length(pa)>0) and (pa[length(pa)]='\') then
- dec(byte(pa[0]));
- fexpand:=pa;
- end;
- procedure packtime(var d:datetime;var time:longint);
- var zs:longint;
- begin
- time:=-1980;
- time:=time+d.year and 127;
- time:=time shl 4;
- time:=time+d.month;
- time:=time shl 5;
- time:=time+d.day;
- time:=time shl 16;
- zs:=d.hour;
- zs:=zs shl 6;
- zs:=zs+d.min;
- zs:=zs shl 5;
- zs:=zs+d.sec div 2;
- time:=time+(zs and $ffff);
- end;
- procedure unpacktime (time:longint;var d:datetime);
- begin
- d.sec:=(time and 31) * 2;
- time:=time shr 5;
- d.min:=time and 63;
- time:=time shr 6;
- d.hour:=time and 31;
- time:=time shr 5;
- d.day:=time and 31;
- time:=time shr 5;
- d.month:=time and 15;
- time:=time shr 4;
- d.year:=time+1980;
- end;
- procedure getfattr(var f;var attr : word);
- var n:array[0..255] of char;
- begin
- strpcopy(n,filerec(f).name);
- {Alas, msdos(r) doesn't work when we are running in OS/2.}
- asm
- movw $0x4300,%ax
- leal n,%edx
- call ___SYSCALL
- movl attr,%ebx
- movw %cx,(%ebx)
- end;
- end;
- procedure setfattr(var f;attr : word);
- var n:array[0..255] of char;
- begin
- strpcopy(n,filerec(f).name);
- {Alas, msdos(r) doesn't work when we are running in OS/2.}
- asm
- movw $0x4301,%ax
- leal n,%edx
- movw attr,%cx
- call ___SYSCALL
- end;
- end;
- end.
- {
- $Log$
- Revision 1.7 1998-07-08 14:44:11 daniel
- + Added moucalls and viocalls written by Tomas Hajny.
- + Final routines in doscalls implemented.
- * Fixed bugs in dos.pas.
- * Changed some old $ifdef FPK into $ifdef FPC.
- - Removed go32 stuff from dos.pas.
- - Removed '/' to '\' translation from system unit - EMX does this
- automatically.
- }
|