mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-01 21:30:35 +02:00
* Prepared for native target (emx code replaced)
This commit is contained in:
yuri
parent
ea10418935
commit
7fa443b61f
694
rtl/os2/dos.pas
694
rtl/os2/dos.pas
@ -109,6 +109,8 @@ type {Some string types:}
|
||||
efdetach: Detached. Function unknown. Info wanted!
|
||||
efpm: Run as presentation manager program.
|
||||
|
||||
Not found info about execwinflags
|
||||
|
||||
Determining the window state of the program:
|
||||
efdefault: Run the pm program in it's default situation.
|
||||
efminimize: Run the pm program minimized.
|
||||
@ -116,9 +118,7 @@ type {Some string types:}
|
||||
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 about what they do.}
|
||||
|
||||
}
|
||||
type execrunflags=(efwait,efno_wait,efoverlay,efdebug,efsession,
|
||||
efdetach,efpm);
|
||||
execwinflags=(efdefault,efminimize,efmaximize,effullscreen,
|
||||
@ -155,9 +155,9 @@ procedure swapvectors;
|
||||
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);
|
||||
@ -181,8 +181,6 @@ function getenv(const envvar:string): string;
|
||||
implementation
|
||||
|
||||
var LastSR: SearchRec;
|
||||
EnvC: longint; external name '_envc';
|
||||
EnvP: ppchar; external name '_environ';
|
||||
|
||||
type TBA = array [1..SizeOf (SearchRec)] of byte;
|
||||
PBA = ^TBA;
|
||||
@ -191,98 +189,32 @@ const FindResvdMask = $00003737; {Allowed bits in attribute
|
||||
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;
|
||||
|
||||
var i,p1:longint;
|
||||
newdir:pathstr;
|
||||
|
||||
{$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}
|
||||
|
||||
Var
|
||||
R: PChar;
|
||||
D, P: AnsiString;
|
||||
begin
|
||||
{ check if the file specified exists }
|
||||
if CheckFile (Path + #0) then
|
||||
FSearch := Path
|
||||
else
|
||||
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;
|
||||
P:=Path;
|
||||
D:=DirList;
|
||||
DosError:=DosSearchPath(0, PChar(D), PChar(P), R, 255);
|
||||
fsearch:=R;
|
||||
end;
|
||||
|
||||
procedure getftime(var f;var time:longint);
|
||||
|
||||
var
|
||||
FStat: PFileStatus3;
|
||||
begin
|
||||
asm
|
||||
{Load handle}
|
||||
movl f,%ebx
|
||||
movl (%ebx),%ebx
|
||||
{Get date}
|
||||
movw $0x5700,%ax
|
||||
call syscall
|
||||
shll $16,%edx
|
||||
movw %cx,%dx
|
||||
movl time,%ebx
|
||||
movl %edx,(%ebx)
|
||||
xorb %ah,%ah
|
||||
movw %ax,doserror
|
||||
end;
|
||||
DosError:=DosQueryFileInfo(FileRec(F).Handle, 1, FStat, SizeOf(FStat^));
|
||||
If DosError=0 then
|
||||
Time:=FStat^.timelastwrite+FStat^.DateLastWrite*256
|
||||
else
|
||||
Time:=0;
|
||||
end;
|
||||
|
||||
procedure SetFTime (var F; Time: longint);
|
||||
|
||||
var FStat: PFileStatus3;
|
||||
RC: longint;
|
||||
|
||||
begin
|
||||
if os_mode = osOS2 then
|
||||
begin
|
||||
New (FStat);
|
||||
RC := DosQueryFileInfo (FileRec (F).Handle, ilStandard, FStat,
|
||||
SizeOf (FStat^));
|
||||
@ -294,155 +226,41 @@ begin
|
||||
FStat^.TimeLastWrite := Lo (Time);
|
||||
RC := DosSetFileInfo (FileRec (F).Handle, ilStandard,
|
||||
FStat, SizeOf (FStat^));
|
||||
|
||||
|
||||
end;
|
||||
DosError := integer(RC);
|
||||
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;
|
||||
|
||||
procedure exec(const path:pathstr;const comline:comstr);
|
||||
|
||||
{Execute a program.}
|
||||
|
||||
begin
|
||||
dosexitcode:=word(exec(path,execrunflags(ExecFlags),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.}
|
||||
|
||||
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;
|
||||
env:Pbytearray;
|
||||
i,argsize:word;
|
||||
es:execstruc;
|
||||
esadr:pointer;
|
||||
d:dirstr;
|
||||
n:namestr;
|
||||
e:extstr;
|
||||
p : ppchar;
|
||||
j : integer;
|
||||
res: TResultCodes;
|
||||
ObjName: String;
|
||||
const
|
||||
ArgsSize = 2048; (* Amount of memory reserved for arguments in bytes. *)
|
||||
|
||||
begin
|
||||
getmem(args,ArgsSize);
|
||||
GetMem(env, envc*sizeof(pchar)+16384);
|
||||
{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;
|
||||
argsize:=1;
|
||||
// args^[0]:=$80;
|
||||
argsize:=0;
|
||||
for i:=1 to length(n) do
|
||||
begin
|
||||
args^[argsize]:=byte(n[i]);
|
||||
@ -457,16 +275,15 @@ begin
|
||||
if comline[i]<>' ' then
|
||||
begin
|
||||
{Commandline argument found. Copy it.}
|
||||
inc(es.numarg);
|
||||
args^[argsize]:=$80;
|
||||
inc(argsize);
|
||||
// args^[argsize]:=$80;
|
||||
// inc(argsize);
|
||||
while (i<=length(comline)) and (comline[i]<>' ') do
|
||||
begin
|
||||
args^[argsize]:=byte(comline[i]);
|
||||
inc(argsize);
|
||||
inc(i);
|
||||
end;
|
||||
args^[argsize]:=0;
|
||||
args^[argsize]:=32;//0;
|
||||
inc(argsize);
|
||||
end;
|
||||
inc(i);
|
||||
@ -497,47 +314,11 @@ begin
|
||||
loop .Lexa1 {Next argument.}
|
||||
stosb {Store an extra 0 to finish. (AL is now 0).}
|
||||
incl %edx
|
||||
movw %dx,ES.SizeEnv {Store environment size.}
|
||||
// movw %dx,ES.SizeEnv {Store environment size.}
|
||||
end;
|
||||
|
||||
{Environment ready, now set-up exec structure.}
|
||||
es.argofs:=args;
|
||||
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;
|
||||
//Not clear how to use
|
||||
exec:=DosExecPgm(ObjName, Longint(runflags), Args, Env, Res, Path);
|
||||
|
||||
freemem(args,ArgsSize);
|
||||
FreeMem(env, envc*sizeof(pchar)+16384);
|
||||
@ -545,304 +326,130 @@ begin
|
||||
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
|
||||
function dosversion:word;
|
||||
{Returns OS/2 version}
|
||||
var
|
||||
Minor, Major: Cardinal;
|
||||
begin
|
||||
DosQuerySysInfo(svMajorVersion, svMajorVersion, Major, 4);
|
||||
DosQuerySysInfo(svMinorVersion, svMinorVersion, Minor, 4);
|
||||
DosVersion:=Major or Minor shl 8;
|
||||
end;
|
||||
|
||||
procedure GetDate (var Year, Month, Day, DayOfWeek: word);
|
||||
|
||||
Var
|
||||
dt: TDateTime;
|
||||
begin
|
||||
asm
|
||||
movb $0x2a, %ah
|
||||
call syscall
|
||||
xorb %ah, %ah
|
||||
movl DayOfWeek, %edi
|
||||
stosw
|
||||
movl Day, %edi
|
||||
movb %dl, %al
|
||||
stosw
|
||||
movl Month, %edi
|
||||
movb %dh, %al
|
||||
stosw
|
||||
movl Year, %edi
|
||||
xchgw %ecx, %eax
|
||||
stosw
|
||||
end;
|
||||
DosGetDateTime(dt);
|
||||
Year:=dt.year;
|
||||
Month:=dt.month;
|
||||
Day:=dt.Day;
|
||||
DayofWeek:=dt.Weekday;
|
||||
end;
|
||||
|
||||
{$asmmode intel}
|
||||
|
||||
procedure SetDate (Year, Month, Day: word);
|
||||
var DT: TDateTime;
|
||||
var
|
||||
DT: TDateTime;
|
||||
begin
|
||||
if os_mode = osOS2 then
|
||||
begin
|
||||
DosGetDateTime (DT);
|
||||
DT.Year := Year;
|
||||
DT.Month := byte (Month);
|
||||
DT.Day := byte (Day);
|
||||
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;
|
||||
|
||||
{$asmmode att}
|
||||
|
||||
procedure GetTime (var Hour, Minute, Second, Sec100: word); assembler;
|
||||
asm
|
||||
movb $0x2c, %ah
|
||||
call syscall
|
||||
xorb %ah, %ah
|
||||
movl Sec100, %edi
|
||||
movb %dl, %al
|
||||
stosw
|
||||
movl Second, %edi
|
||||
movb %dh,%al
|
||||
stosw
|
||||
movl Minute, %edi
|
||||
movb %cl,%al
|
||||
stosw
|
||||
movl Hour, %edi
|
||||
movb %ch,%al
|
||||
stosw
|
||||
end;
|
||||
|
||||
{$asmmode intel}
|
||||
procedure SetTime (Hour, Minute, Second, Sec100: word);
|
||||
var DT: TDateTime;
|
||||
procedure GetTime (var Hour, Minute, Second, Sec100: word);
|
||||
var
|
||||
dt: TDateTime;
|
||||
begin
|
||||
DosGetDateTime(dt);
|
||||
Hour:=dt.Hour;
|
||||
Minute:=dt.Minute;
|
||||
Second:=dt.Second;
|
||||
Sec100:=dt.Hundredths;
|
||||
end;
|
||||
|
||||
procedure SetTime (Hour, Minute, Second, Sec100: word);
|
||||
var
|
||||
DT: TDateTime;
|
||||
begin
|
||||
if os_mode = osOS2 then
|
||||
begin
|
||||
DosGetDateTime (DT);
|
||||
DT.Hour := byte (Hour);
|
||||
DT.Minute := byte (Minute);
|
||||
DT.Second := byte (Second);
|
||||
DT.Sec100 := byte (Sec100);
|
||||
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;
|
||||
|
||||
{$asmmode att}
|
||||
|
||||
procedure getcbreak(var breakvalue:boolean);
|
||||
|
||||
begin
|
||||
breakvalue := True;
|
||||
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
|
||||
movw $0x3301,%ax
|
||||
call syscall
|
||||
end;
|
||||
}
|
||||
end;
|
||||
|
||||
procedure getverify(var verify:boolean);
|
||||
|
||||
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;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure setverify(verify:boolean);
|
||||
|
||||
begin
|
||||
{! Do not use in OS/2!}
|
||||
if os_mode in [osDOS,osDPMI] then
|
||||
asm
|
||||
movb verify,%al
|
||||
movb $0x2e,%ah
|
||||
call syscall
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function DiskFree (Drive: byte): int64;
|
||||
|
||||
var FI: TFSinfo;
|
||||
RC: longint;
|
||||
|
||||
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.}
|
||||
begin
|
||||
RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI));
|
||||
if RC = 0 then
|
||||
DiskFree := int64 (FI.Free_Clusters) *
|
||||
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
|
||||
else
|
||||
DiskFree := -1;
|
||||
end;
|
||||
end;
|
||||
|
||||
function DiskSize (Drive: byte): int64;
|
||||
|
||||
var FI: TFSinfo;
|
||||
RC: longint;
|
||||
|
||||
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));
|
||||
if RC = 0 then
|
||||
DiskSize := int64 (FI.Total_Clusters) *
|
||||
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
|
||||
else
|
||||
DiskSize := -1;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure SearchRec2DosSearchRec (var F: SearchRec);
|
||||
|
||||
const NameSize = 255;
|
||||
|
||||
var L, I: longint;
|
||||
|
||||
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;
|
||||
|
||||
procedure DosSearchRec2SearchRec (var F: SearchRec);
|
||||
|
||||
const NameSize=255;
|
||||
|
||||
var L, I: longint;
|
||||
|
||||
type TRec = record
|
||||
const
|
||||
NameSize=255;
|
||||
var
|
||||
L, I: longint;
|
||||
type
|
||||
TRec = record
|
||||
T, D: word;
|
||||
end;
|
||||
|
||||
begin
|
||||
if os_mode = osOS2 then with F do
|
||||
with F do
|
||||
begin
|
||||
Name := FStat^.Name;
|
||||
Size := FStat^.FileSize;
|
||||
Attr := byte(FStat^.AttrFile and $FF);
|
||||
TRec (Time).T := FStat^.TimeLastWrite;
|
||||
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;
|
||||
|
||||
|
||||
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);
|
||||
|
||||
|
||||
@ -852,8 +459,6 @@ var path0: array[0..255] of char;
|
||||
begin
|
||||
{No error.}
|
||||
DosError := 0;
|
||||
if os_mode = osOS2 then
|
||||
begin
|
||||
New (F.FStat);
|
||||
F.Handle := longint ($FFFFFFFF);
|
||||
Count := 1;
|
||||
@ -861,53 +466,27 @@ begin
|
||||
Attr and FindResvdMask, F.FStat, SizeOf (F.FStat^),
|
||||
Count, ilStandard));
|
||||
if (DosError = 0) and (Count = 0) then DosError := 18;
|
||||
end else
|
||||
begin
|
||||
strPcopy(path0,path);
|
||||
_findfirst(path0,attr,f);
|
||||
end;
|
||||
DosSearchRec2SearchRec (F);
|
||||
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);
|
||||
var Count: cardinal;
|
||||
|
||||
|
||||
var
|
||||
Count: cardinal;
|
||||
begin
|
||||
{No error}
|
||||
DosError := 0;
|
||||
SearchRec2DosSearchRec (F);
|
||||
if os_mode = osOS2 then
|
||||
begin
|
||||
Count := 1;
|
||||
DosError := integer (DosFindNext (F.Handle, F.FStat, SizeOf (F.FStat^),
|
||||
Count));
|
||||
if (DosError = 0) and (Count = 0) then DosError := 18;
|
||||
end else _findnext (F);
|
||||
DosSearchRec2SearchRec (F);
|
||||
end;
|
||||
|
||||
procedure FindClose (var F: SearchRec);
|
||||
begin
|
||||
if os_mode = osOS2 then
|
||||
begin
|
||||
if F.Handle <> $FFFFFFFF then DosError := DosFindClose (F.Handle);
|
||||
Dispose (F.FStat);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure swapvectors;
|
||||
@ -915,10 +494,10 @@ procedure swapvectors;
|
||||
begin
|
||||
end;
|
||||
|
||||
function envcount:longint;assembler;
|
||||
asm
|
||||
movl envc,%eax
|
||||
end ['EAX'];
|
||||
function envcount:longint;
|
||||
begin
|
||||
envcount:=envc;
|
||||
end;
|
||||
|
||||
function envstr(index : longint) : string;
|
||||
|
||||
@ -1099,130 +678,35 @@ begin
|
||||
end;
|
||||
|
||||
procedure getfattr(var f;var attr : word);
|
||||
{ Under EMX, this routine requires }
|
||||
{ the expanded path specification }
|
||||
{ otherwise it will not function }
|
||||
{ properly (CEC) }
|
||||
var
|
||||
path: pathstr;
|
||||
buffer:array[0..255] of char;
|
||||
PathInfo: PFileStatus3;
|
||||
begin
|
||||
DosError := 0;
|
||||
path:='';
|
||||
path := StrPas(filerec(f).Name);
|
||||
{ Takes care of slash and backslash support }
|
||||
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;
|
||||
Attr:=0;
|
||||
DosError:=DosQueryPathInfo(FileRec(F).Name, ilStandard, PathInfo, SizeOf(PathInfo^));
|
||||
if DosError=0 then
|
||||
Attr := PathInfo^.attrFile;
|
||||
end;
|
||||
|
||||
procedure setfattr(var f;attr : word);
|
||||
{ Under EMX, this routine requires }
|
||||
{ the expanded path specification }
|
||||
{ otherwise it will not function }
|
||||
{ properly (CEC) }
|
||||
var
|
||||
path: pathstr;
|
||||
buffer:array[0..255] of char;
|
||||
PathInfo: PFileStatus3;
|
||||
begin
|
||||
path:='';
|
||||
DosError := 0;
|
||||
path := StrPas(filerec(f).Name);
|
||||
{ Takes care of slash and backslash support }
|
||||
path:=FExPand(path);
|
||||
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:
|
||||
DosError:=DosQueryPathInfo(FileRec(F).Name, ilStandard, PathInfo, SizeOf(PathInfo^));
|
||||
if DosError=0 then
|
||||
begin
|
||||
PathInfo^.attrFile:=Attr;
|
||||
DosError:=DosSetPathInfo(FileRec(F).Name, ilStandard, PathInfo, SizeOf(PathInfo^), doWriteThru);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure InitEnvironment;
|
||||
var
|
||||
cnt : integer;
|
||||
ptr : pchar;
|
||||
base : pchar;
|
||||
i: integer;
|
||||
PIB: PProcessInfoBlock;
|
||||
TIB: PThreadInfoBlock;
|
||||
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.
|
||||
{
|
||||
$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
|
||||
|
||||
Revision 1.24 2003/02/20 17:09:49 hajny
|
||||
|
||||
Loading…
Reference in New Issue
Block a user