paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-07-30 16:46:11 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Prepared for native target (emx code replaced)

Browse Source
This commit is contained in:
yuri 2003-09-24 08:59:16 +00:00
parent ea10418935
commit 7fa443b61f
1 changed files with 139 additions and 655 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

694
rtl/os2/dos.pas
View File

@ -109,6 +109,8 @@ type {Some string types:}
efdetach: Detached. Function unknown. Info wanted! efdetach: Detached. Function unknown. Info wanted!
efpm: Run as presentation manager program. efpm: Run as presentation manager program.
Not found info about execwinflags
Determining the window state of the program: Determining the window state of the program:
efdefault: Run the pm program in it's default situation. efdefault: Run the pm program in it's default situation.
efminimize: Run the pm program minimized. efminimize: Run the pm program minimized.
@ -116,9 +118,7 @@ type {Some string types:}
effullscreen: Run the non-pm program fullscreen. effullscreen: Run the non-pm program fullscreen.
efwindowed: Run the non-pm program in a window. efwindowed: Run the non-pm program in a window.
Other options are not implemented defined because lack of }
knowledge about what they do.}
type execrunflags=(efwait,efno_wait,efoverlay,efdebug,efsession, type execrunflags=(efwait,efno_wait,efoverlay,efdebug,efsession,
efdetach,efpm); efdetach,efpm);
execwinflags=(efdefault,efminimize,efmaximize,effullscreen, execwinflags=(efdefault,efminimize,efmaximize,effullscreen,
@ -155,9 +155,9 @@ procedure swapvectors;
procedure getintvec(intno:byte;var vector:pointer); procedure getintvec(intno:byte;var vector:pointer);
procedure setintvec(intno:byte;vector:pointer); procedure setintvec(intno:byte;vector:pointer);
procedure keep(exitcode:word); procedure keep(exitcode:word);
}
procedure msdos(var regs:registers); procedure msdos(var regs:registers);
procedure intr(intno : byte;var regs:registers); procedure intr(intno : byte;var regs:registers);
}
procedure getfattr(var f;var attr:word); procedure getfattr(var f;var attr:word);
procedure setfattr(var f;attr:word); procedure setfattr(var f;attr:word);
@ -181,8 +181,6 @@ function getenv(const envvar:string): string;
implementation implementation
var LastSR: SearchRec; var LastSR: SearchRec;
EnvC: longint; external name '_envc';
EnvP: ppchar; external name '_environ';
type TBA = array [1..SizeOf (SearchRec)] of byte; type TBA = array [1..SizeOf (SearchRec)] of byte;
PBA = ^TBA; PBA = ^TBA;
@ -191,98 +189,32 @@ const FindResvdMask = $00003737; {Allowed bits in attribute
specification for DosFindFirst call.} specification for DosFindFirst call.}
{Import syscall to call it nicely from assembler procedures.}
procedure syscall;external name '___SYSCALL';
function fsearch(path:pathstr;dirlist:string):pathstr; function fsearch(path:pathstr;dirlist:string):pathstr;
Var
var i,p1:longint; R: PChar;
newdir:pathstr; D, P: AnsiString;
{$ASMMODE INTEL}
function CheckFile (FN: ShortString):boolean; assembler;
asm
mov ax, 4300h
mov edx, FN { get pointer to string }
inc edx { avoid length byte }
call syscall
mov ax, 0
jc @LCFstop
test cx, 18h
jnz @LCFstop
inc ax
@LCFstop:
end;
{$ASMMODE ATT}
begin begin
{ check if the file specified exists } P:=Path;
if CheckFile (Path + #0) then D:=DirList;
FSearch := Path DosError:=DosSearchPath(0, PChar(D), PChar(P), R, 255);
else fsearch:=R;
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+'\';
if CheckFile (NewDir + Path + #0) then
NewDir := NewDir + Path
else
NewDir := '';
until (DirList = '') or (NewDir <> '');
FSearch := NewDir;
end;
end;
end; end;
procedure getftime(var f;var time:longint); procedure getftime(var f;var time:longint);
var
FStat: PFileStatus3;
begin begin
asm DosError:=DosQueryFileInfo(FileRec(F).Handle, 1, FStat, SizeOf(FStat^));
{Load handle} If DosError=0 then
movl f,%ebx Time:=FStat^.timelastwrite+FStat^.DateLastWrite*256
movl (%ebx),%ebx else
{Get date} Time:=0;
movw $0x5700,%ax
call syscall
shll $16,%edx
movw %cx,%dx
movl time,%ebx
movl %edx,(%ebx)
xorb %ah,%ah
movw %ax,doserror
end;
end; end;
procedure SetFTime (var F; Time: longint); procedure SetFTime (var F; Time: longint);
var FStat: PFileStatus3; var FStat: PFileStatus3;
RC: longint; RC: longint;
begin begin
if os_mode = osOS2 then
begin
New (FStat); New (FStat);
RC := DosQueryFileInfo (FileRec (F).Handle, ilStandard, FStat, RC := DosQueryFileInfo (FileRec (F).Handle, ilStandard, FStat,
SizeOf (FStat^)); SizeOf (FStat^));
@ -294,155 +226,41 @@ begin
FStat^.TimeLastWrite := Lo (Time); FStat^.TimeLastWrite := Lo (Time);
RC := DosSetFileInfo (FileRec (F).Handle, ilStandard, RC := DosSetFileInfo (FileRec (F).Handle, ilStandard,
FStat, SizeOf (FStat^)); FStat, SizeOf (FStat^));
end; end;
DosError := integer(RC); DosError := integer(RC);
Dispose (FStat); Dispose (FStat);
end
else
asm
{Load handle}
movl f,%ebx
movl (%ebx),%ebx
movl time,%ecx
shldl $16,%ecx,%edx
{Set date}
movw $0x5701,%ax
call syscall
xorb %ah,%ah
movw %ax,doserror
end;
end;
procedure msdos(var regs:registers);
{Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
begin
if os_mode in [osDPMI,osDOS] then
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
if os_mode = osos2 then exit;
asm
jmp .Lstart
{ .data}
.Lint86:
.byte 0xcd
.Lint86_vec:
.byte 0x03
jmp .Lint86_retjmp
{ .text}
.Lstart:
movb intno,%al
movb %al,.Lint86_vec
{
movl 10(%ebp),%eax
incl %eax
incl %eax
}
movl regs,%eax
{Do not use first int}
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 .Lint86
.Lint86_retjmp:
pushf
pushl %ebp
pushl %eax
movl %esp,%ebp
{Calc EBP new}
addl $12,%ebp
{
movl 10(%ebp),%eax
incl %eax
incl %eax
}
{Do not use first int}
movl regs,%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; end;
procedure exec(const path:pathstr;const comline:comstr); procedure exec(const path:pathstr;const comline:comstr);
{Execute a program.} {Execute a program.}
begin begin
dosexitcode:=word(exec(path,execrunflags(ExecFlags),efdefault,comline)); dosexitcode:=word(exec(path,execrunflags(ExecFlags),efdefault,comline));
end; end;
function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags; function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags;
const comline:comstr):longint; const comline:comstr):longint;
{Execute a program. More suitable for OS/2 than the exec above.} {Execute a program. More suitable for OS/2 than the exec above.}
type bytearray=array[0..8191] of byte;
Pbytearray=^bytearray;
execstruc=packed record
argofs : pointer; { pointer to arguments (offset) }
envofs : pointer; { pointer to environment (offset) }
nameofs: pointer; { pointer to file name (offset) }
argseg : word; { pointer to arguments (selector) }
envseg : word; { pointer to environment (selector}
nameseg: word; { pointer to file name (selector) }
numarg : word; { number of arguments }
sizearg : word; { size of arguments }
numenv : word; { number of env strings }
sizeenv:word; { size of environment }
mode1,mode2:byte; { mode byte }
end;
var args:Pbytearray; var args:Pbytearray;
env:Pbytearray; env:Pbytearray;
i,argsize:word; i,argsize:word;
es:execstruc;
esadr:pointer; esadr:pointer;
d:dirstr; d:dirstr;
n:namestr; n:namestr;
e:extstr; e:extstr;
p : ppchar; p : ppchar;
j : integer; j : integer;
res: TResultCodes;
ObjName: String;
const const
ArgsSize = 2048; (* Amount of memory reserved for arguments in bytes. *) ArgsSize = 2048; (* Amount of memory reserved for arguments in bytes. *)
begin begin
getmem(args,ArgsSize); getmem(args,ArgsSize);
GetMem(env, envc*sizeof(pchar)+16384); GetMem(env, envc*sizeof(pchar)+16384);
{Now setup the arguments. The first argument should be the program {Now setup the arguments. The first argument should be the program
name without directory and extension.} name without directory and extension.}
fsplit(path,d,n,e); fsplit(path,d,n,e);
es.numarg:=1; // args^[0]:=$80;
args^[0]:=$80; argsize:=0;
argsize:=1;
for i:=1 to length(n) do for i:=1 to length(n) do
begin begin
args^[argsize]:=byte(n[i]); args^[argsize]:=byte(n[i]);
@ -457,16 +275,15 @@ begin
if comline[i]<>' ' then if comline[i]<>' ' then
begin begin
{Commandline argument found. Copy it.} {Commandline argument found. Copy it.}
inc(es.numarg); // args^[argsize]:=$80;
args^[argsize]:=$80; // inc(argsize);
inc(argsize);
while (i<=length(comline)) and (comline[i]<>' ') do while (i<=length(comline)) and (comline[i]<>' ') do
begin begin
args^[argsize]:=byte(comline[i]); args^[argsize]:=byte(comline[i]);
inc(argsize); inc(argsize);
inc(i); inc(i);
end; end;
args^[argsize]:=0; args^[argsize]:=32;//0;
inc(argsize); inc(argsize);
end; end;
inc(i); inc(i);
@ -497,47 +314,11 @@ begin
loop .Lexa1 {Next argument.} loop .Lexa1 {Next argument.}
stosb {Store an extra 0 to finish. (AL is now 0).} stosb {Store an extra 0 to finish. (AL is now 0).}
incl %edx incl %edx
movw %dx,ES.SizeEnv {Store environment size.} // movw %dx,ES.SizeEnv {Store environment size.}
end; end;
{Environment ready, now set-up exec structure.} //Not clear how to use
es.argofs:=args; exec:=DosExecPgm(ObjName, Longint(runflags), Args, Env, Res, Path);
es.envofs:=env;
es.numenv:=envc;
{ set an error - path is too long }
{ since we must add a zero to the }
{ end. }
if length(path) > 254 then
begin
exec := 8;
exit;
end;
path[length(path)+1] := #0;
es.nameofs:=pointer(longint(@path)+1);
asm
movw %ss,es.argseg
movw %ss,es.envseg
movw %ss,es.nameseg
end;
es.sizearg:=argsize;
{Typecasting of sets in FPC is a bit hard.}
es.mode1:=byte(runflags);
es.mode2:=byte(winflags);
{Now exec the program.}
asm
leal es,%edx
movw $0x7f06,%ax
call syscall
movl $0,%edi
jnc .Lexprg1
xchgl %eax,%edi
xorl %eax,%eax
decl %eax
.Lexprg1:
movw %di,doserror
movl %eax,__RESULT
end;
freemem(args,ArgsSize); freemem(args,ArgsSize);
FreeMem(env, envc*sizeof(pchar)+16384); FreeMem(env, envc*sizeof(pchar)+16384);
@ -545,304 +326,130 @@ begin
a system function I ever wrote!} a system function I ever wrote!}
end; end;
function dosversion:word;assembler; function dosversion:word;
{Returns OS/2 version}
{Returns DOS version in DOS and OS/2 version in OS/2} var
asm Minor, Major: Cardinal;
movb $0x30,%ah begin
call syscall DosQuerySysInfo(svMajorVersion, svMajorVersion, Major, 4);
DosQuerySysInfo(svMinorVersion, svMinorVersion, Minor, 4);
DosVersion:=Major or Minor shl 8;
end; end;
procedure GetDate (var Year, Month, Day, DayOfWeek: word); procedure GetDate (var Year, Month, Day, DayOfWeek: word);
Var
dt: TDateTime;
begin begin
asm DosGetDateTime(dt);
movb $0x2a, %ah Year:=dt.year;
call syscall Month:=dt.month;
xorb %ah, %ah Day:=dt.Day;
movl DayOfWeek, %edi DayofWeek:=dt.Weekday;
stosw
movl Day, %edi
movb %dl, %al
stosw
movl Month, %edi
movb %dh, %al
stosw
movl Year, %edi
xchgw %ecx, %eax
stosw
end;
end; end;
{$asmmode intel}
procedure SetDate (Year, Month, Day: word); procedure SetDate (Year, Month, Day: word);
var DT: TDateTime; var
DT: TDateTime;
begin begin
if os_mode = osOS2 then
begin
DosGetDateTime (DT); DosGetDateTime (DT);
DT.Year := Year; DT.Year := Year;
DT.Month := byte (Month); DT.Month := byte (Month);
DT.Day := byte (Day); DT.Day := byte (Day);
DosSetDateTime (DT); DosSetDateTime (DT);
end
else
asm
mov cx, Year
mov dh, byte ptr Month
mov dl, byte ptr Day
mov ah, 2Bh
call syscall
end;
end; end;
{$asmmode att} procedure GetTime (var Hour, Minute, Second, Sec100: word);
var
procedure GetTime (var Hour, Minute, Second, Sec100: word); assembler; dt: TDateTime;
asm begin
movb $0x2c, %ah DosGetDateTime(dt);
call syscall Hour:=dt.Hour;
xorb %ah, %ah Minute:=dt.Minute;
movl Sec100, %edi Second:=dt.Second;
movb %dl, %al Sec100:=dt.Hundredths;
stosw end;
movl Second, %edi
movb %dh,%al procedure SetTime (Hour, Minute, Second, Sec100: word);
stosw var
movl Minute, %edi DT: TDateTime;
movb %cl,%al
stosw
movl Hour, %edi
movb %ch,%al
stosw
end;
{$asmmode intel}
procedure SetTime (Hour, Minute, Second, Sec100: word);
var DT: TDateTime;
begin begin
if os_mode = osOS2 then
begin
DosGetDateTime (DT); DosGetDateTime (DT);
DT.Hour := byte (Hour); DT.Hour := byte (Hour);
DT.Minute := byte (Minute); DT.Minute := byte (Minute);
DT.Second := byte (Second); DT.Second := byte (Second);
DT.Sec100 := byte (Sec100); DT.Sec100 := byte (Sec100);
DosSetDateTime (DT); DosSetDateTime (DT);
end
else
asm
mov ch, byte ptr Hour
mov cl, byte ptr Minute
mov dh, byte ptr Second
mov dl, byte ptr Sec100
mov ah, 2Dh
call syscall
end;
end; end;
{$asmmode att}
procedure getcbreak(var breakvalue:boolean); procedure getcbreak(var breakvalue:boolean);
begin begin
breakvalue := True; breakvalue := True;
end; end;
procedure setcbreak(breakvalue:boolean); procedure setcbreak(breakvalue:boolean);
begin begin
{! Do not use in OS/2. Also not recommended in DOS. Use
signal handling instead.
asm
movb 8(%ebp),%dl
movw $0x3301,%ax
call syscall
end;
}
end; end;
procedure getverify(var verify:boolean); procedure getverify(var verify:boolean);
begin begin
{! Do not use in OS/2.}
if os_mode in [osDOS,osDPMI] then
asm
movb $0x54,%ah
call syscall
movl verify,%edi
stosb
end
else
verify := true; verify := true;
end; end;
procedure setverify(verify:boolean); procedure setverify(verify:boolean);
begin begin
{! Do not use in OS/2!} end;
if os_mode in [osDOS,osDPMI] then
asm
movb verify,%al
movb $0x2e,%ah
call syscall
end;
end;
function DiskFree (Drive: byte): int64; function DiskFree (Drive: byte): int64;
var FI: TFSinfo; var FI: TFSinfo;
RC: longint; RC: longint;
begin begin
if (os_mode = osDOS) or (os_mode = osDPMI) then
{Function 36 is not supported in OS/2.}
asm
movb Drive,%dl
movb $0x36,%ah
call syscall
cmpw $-1,%ax
je .LDISKFREE1
mulw %cx
mulw %bx
shll $16,%edx
movw %ax,%dx
movl $0,%eax
xchgl %edx,%eax
leave
ret
.LDISKFREE1:
cltd
leave
ret
end
else
{In OS/2, we use the filesystem information.} {In OS/2, we use the filesystem information.}
begin
RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI)); RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then if RC = 0 then
DiskFree := int64 (FI.Free_Clusters) * DiskFree := int64 (FI.Free_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector) int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else else
DiskFree := -1; DiskFree := -1;
end;
end; end;
function DiskSize (Drive: byte): int64; function DiskSize (Drive: byte): int64;
var FI: TFSinfo; var FI: TFSinfo;
RC: longint; RC: longint;
begin begin
if (os_mode = osDOS) or (os_mode = osDPMI) then
{Function 36 is not supported in OS/2.}
asm
movb Drive,%dl
movb $0x36,%ah
call syscall
movw %dx,%bx
cmpw $-1,%ax
je .LDISKSIZE1
mulw %cx
mulw %bx
shll $16,%edx
movw %ax,%dx
movl $0,%eax
xchgl %edx,%eax
leave
ret
.LDISKSIZE1:
cltd
leave
ret
end
else
{In OS/2, we use the filesystem information.}
begin
RC := DosQueryFSinfo (Drive, 1, FI, SizeOf (FI)); RC := DosQueryFSinfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then if RC = 0 then
DiskSize := int64 (FI.Total_Clusters) * DiskSize := int64 (FI.Total_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector) int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else else
DiskSize := -1; DiskSize := -1;
end;
end; end;
procedure SearchRec2DosSearchRec (var F: SearchRec); procedure SearchRec2DosSearchRec (var F: SearchRec);
const NameSize = 255;
var L, I: longint;
begin begin
if os_mode <> osOS2 then
begin
I := 1;
while (I <= SizeOf (LastSR))
and (PBA (@F)^ [I] = PBA (@LastSR)^ [I]) do Inc (I);
{ Raise "Invalid file handle" RTE if nested FindFirst calls were used. }
if I <= SizeOf (LastSR) then RunError (6);
l:=length(f.name);
for i:=1 to namesize do
f.name[i-1]:=f.name[i];
f.name[l]:=#0;
end;
end; end;
procedure DosSearchRec2SearchRec (var F: SearchRec); procedure DosSearchRec2SearchRec (var F: SearchRec);
const
const NameSize=255; NameSize=255;
var
var L, I: longint; L, I: longint;
type
type TRec = record TRec = record
T, D: word; T, D: word;
end; end;
begin begin
if os_mode = osOS2 then with F do with F do
begin begin
Name := FStat^.Name; Name := FStat^.Name;
Size := FStat^.FileSize; Size := FStat^.FileSize;
Attr := byte(FStat^.AttrFile and $FF); Attr := byte(FStat^.AttrFile and $FF);
TRec (Time).T := FStat^.TimeLastWrite; TRec (Time).T := FStat^.TimeLastWrite;
TRec (Time).D := FStat^.DateLastWrite; TRec (Time).D := FStat^.DateLastWrite;
end else
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);
Move (F, LastSR, SizeOf (LastSR));
end; end;
end; end;
procedure _findfirst(path:pchar;attr:word;var f:searchrec);
begin
asm
movl path,%edx
movw attr,%cx
{No need to set DTA in EMX. Just give a pointer in ESI.}
movl f,%esi
movb $0x4e,%ah
call syscall
jnc .LFF
movw %ax,doserror
.LFF:
end;
end;
procedure FindFirst (const Path: PathStr; Attr: word; var F: SearchRec); procedure FindFirst (const Path: PathStr; Attr: word; var F: SearchRec);
@ -852,8 +459,6 @@ var path0: array[0..255] of char;
begin begin
{No error.} {No error.}
DosError := 0; DosError := 0;
if os_mode = osOS2 then
begin
New (F.FStat); New (F.FStat);
F.Handle := longint ($FFFFFFFF); F.Handle := longint ($FFFFFFFF);
Count := 1; Count := 1;
@ -861,53 +466,27 @@ begin
Attr and FindResvdMask, F.FStat, SizeOf (F.FStat^), Attr and FindResvdMask, F.FStat, SizeOf (F.FStat^),
Count, ilStandard)); Count, ilStandard));
if (DosError = 0) and (Count = 0) then DosError := 18; if (DosError = 0) and (Count = 0) then DosError := 18;
end else
begin
strPcopy(path0,path);
_findfirst(path0,attr,f);
end;
DosSearchRec2SearchRec (F); DosSearchRec2SearchRec (F);
end; end;
procedure _findnext(var f : searchrec);
begin
asm
movl f,%esi
movb $0x4f,%ah
call syscall
jnc .LFN
movw %ax,doserror
.LFN:
end;
end;
procedure FindNext (var F: SearchRec); procedure FindNext (var F: SearchRec);
var Count: cardinal; var
Count: cardinal;
begin begin
{No error} {No error}
DosError := 0; DosError := 0;
SearchRec2DosSearchRec (F); SearchRec2DosSearchRec (F);
if os_mode = osOS2 then
begin
Count := 1; Count := 1;
DosError := integer (DosFindNext (F.Handle, F.FStat, SizeOf (F.FStat^), DosError := integer (DosFindNext (F.Handle, F.FStat, SizeOf (F.FStat^),
Count)); Count));
if (DosError = 0) and (Count = 0) then DosError := 18; if (DosError = 0) and (Count = 0) then DosError := 18;
end else _findnext (F);
DosSearchRec2SearchRec (F); DosSearchRec2SearchRec (F);
end; end;
procedure FindClose (var F: SearchRec); procedure FindClose (var F: SearchRec);
begin begin
if os_mode = osOS2 then
begin
if F.Handle <> $FFFFFFFF then DosError := DosFindClose (F.Handle); if F.Handle <> $FFFFFFFF then DosError := DosFindClose (F.Handle);
Dispose (F.FStat); Dispose (F.FStat);
end;
end; end;
procedure swapvectors; procedure swapvectors;
@ -915,10 +494,10 @@ procedure swapvectors;
begin begin
end; end;
function envcount:longint;assembler; function envcount:longint;
asm begin
movl envc,%eax envcount:=envc;
end ['EAX']; end;
function envstr(index : longint) : string; function envstr(index : longint) : string;
@ -1099,130 +678,35 @@ begin
end; end;
procedure getfattr(var f;var attr : word); procedure getfattr(var f;var attr : word);
{ Under EMX, this routine requires }
{ the expanded path specification }
{ otherwise it will not function }
{ properly (CEC) }
var var
path: pathstr; PathInfo: PFileStatus3;
buffer:array[0..255] of char;
begin begin
DosError := 0; Attr:=0;
path:=''; DosError:=DosQueryPathInfo(FileRec(F).Name, ilStandard, PathInfo, SizeOf(PathInfo^));
path := StrPas(filerec(f).Name); if DosError=0 then
{ Takes care of slash and backslash support } Attr := PathInfo^.attrFile;
path:=FExpand(path);
move(path[1],buffer,length(path));
buffer[length(path)]:=#0;
asm
movw $0x4300,%ax
leal buffer,%edx
call syscall
jnc .Lnoerror { is there an error ? }
movw %ax,doserror
.Lnoerror:
movl attr,%ebx
movw %cx,(%ebx)
end;
end; end;
procedure setfattr(var f;attr : word); procedure setfattr(var f;attr : word);
{ Under EMX, this routine requires }
{ the expanded path specification }
{ otherwise it will not function }
{ properly (CEC) }
var var
path: pathstr; PathInfo: PFileStatus3;
buffer:array[0..255] of char;
begin begin
path:=''; DosError:=DosQueryPathInfo(FileRec(F).Name, ilStandard, PathInfo, SizeOf(PathInfo^));
DosError := 0; if DosError=0 then
path := StrPas(filerec(f).Name); begin
{ Takes care of slash and backslash support } PathInfo^.attrFile:=Attr;
path:=FExPand(path); DosError:=DosSetPathInfo(FileRec(F).Name, ilStandard, PathInfo, SizeOf(PathInfo^), doWriteThru);
move(path[1],buffer,length(path));
buffer[length(path)]:=#0;
asm
movw $0x4301,%ax
leal buffer,%edx
movw attr,%cx
call syscall
jnc .Lnoerror
movw %ax,doserror
.Lnoerror:
end; end;
end; end;
procedure InitEnvironment;
var
cnt : integer;
ptr : pchar;
base : pchar;
i: integer;
PIB: PProcessInfoBlock;
TIB: PThreadInfoBlock;
begin begin
{ We need to setup the environment }
{ only in the case of OS/2 }
{ otherwise everything is in the stack }
if os_Mode in [OsDOS,osDPMI] then
exit;
cnt := 0;
{ count number of environment pointers }
DosGetInfoBlocks (PPThreadInfoBlock (@TIB), PPProcessInfoBlock (@PIB));
ptr := pchar(PIB^.env);
{ stringz,stringz...,#0 }
i := 0;
repeat
repeat
(inc(i));
until (ptr[i] = #0);
inc(i);
{ here, it may be a double null, end of environment }
if ptr[i] <> #0 then
inc(cnt);
until (ptr[i] = #0);
{ save environment count }
envc := cnt;
{ got count of environment strings }
GetMem(envp, cnt*sizeof(pchar)+16384);
cnt := 0;
ptr := pchar(PIB^.env);
i:=0;
repeat
envp[cnt] := ptr;
Inc(cnt);
{ go to next string ... }
repeat
inc(ptr);
until (ptr^ = #0);
inc(ptr);
until ptr^ = #0;
envp[cnt] := #0;
end;
procedure DoneEnvironment;
begin
{ it is allocated on the stack for DOS/DPMI }
if os_mode = osOs2 then
FreeMem(envp, envc*sizeof(pchar)+16384);
end;
var
oldexit : pointer;
begin
oldexit:=exitproc;
exitproc:=@doneenvironment;
InitEnvironment;
end. end.
{ {
$Log$ $Log$
Revision 1.25 2003-02-20 17:37:00 hajny Revision 1.26 2003-09-24 08:59:16 yuri
* Prepared for native target (emx code replaced)
Revision 1.25 2003/02/20 17:37:00 hajny
* correction for previous mistyping * correction for previous mistyping
Revision 1.24 2003/02/20 17:09:49 hajny Revision 1.24 2003/02/20 17:09:49 hajny