paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-14 17:49:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

* merge unix updates from the 1.0 branch, mostly related to the

Browse Source 
solaris target
This commit is contained in:
peter 2001-06-02 00:31:30 +00:00
parent 8c521811f7
commit 061d89620a
14 changed files with 481 additions and 436 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
rtl/freebsd/bsdsock.inc → rtl/freebsd/unixsock.inc
View File

91
rtl/unix/bsdsysca.inc → rtl/freebsd/unixsysc.inc
View File

@ -31,14 +31,14 @@ End;
{
function clone(func:TCloneFunc;sp:pointer;flags:longint;args:pointer):longint;
{NOT IMPLEMENTED YET UNDER BSD}
begin
begin // perhaps it is better to implement the hack from solaris then this msg
HALT;
END;
if (pointer(func)=nil) or (sp=nil) then
begin
LinuxError:=Sys_EInval;
exit;
exit(-1);
end;
asm
{ Insert the argument onto the new stack. }
@ -306,12 +306,14 @@ begin
LinuxError:=Errno;
end;
{$ifndef newreaddir}
function sys_fcntl(Fd:longint;Cmd:longint;Arg:Longint):longint;
begin
sys_fcntl:=do_syscall(syscall_nr_fcntl,fd,cmd,arg);
LinuxError:=Errno;
end;
{$endif}
Function Chmod(path:pathstr;Newmode:longint):Boolean;
{
@ -591,7 +593,6 @@ begin
LinuxError:=Errno;
end;
Function NanoSleep(const req : timespec;var rem : timespec) : longint;
begin
NanoSleep:=Do_SysCall(syscall_nr_nanosleep,longint(@req),longint(@rem));
@ -599,6 +600,7 @@ begin
end;
Function IOCtl(Handle,Ndx: Longint;Data: Pointer):boolean;
{
Interface to Unix ioctl call.
@ -628,7 +630,6 @@ begin
LinuxError:=Errno;
end;
function signal(signum:longint;Handler:signalhandler):signalhandler;
var sa,osa : sigactionrec;
@ -637,8 +638,8 @@ begin
sa.handler.sh:=handler;
FillChar(sa.sa_mask,sizeof(sigset),#0);
sa.sa_flags := 0;
{ if (sigintr and signum) =0 then {restart behaviour needs libc}
sa.sa_flags :=sa.sa_flags or SA_RESTART;}
{ if (sigintr and signum) =0 then {restart behaviour needs libc}
sa.sa_flags :=sa.sa_flags or SA_RESTART; }
sigaction(signum,@sa,@osa);
if ErrNo<>0 then
signal:=NIL
@ -651,41 +652,36 @@ end;
function Clone(func:TCloneFunc;sp:pointer;flags:longint;args:pointer):longint; assembler;
asm
pushl %esi
movl 12(%ebp), %esi // get stack addr
subl $4, %esi
movl 20(%ebp), %eax // get __arg
movl %eax, (%esi)
subl $4, %esi
movl 8(%ebp), %eax // get __fn
movl %eax, (%esi)
pushl 16(%ebp)
pushl %esi
mov syscall_nr_rfork, %eax
int $0x80 // call actualsyscall
jb .L2
test %edx, %edx
jz .L1
movl %esi,%esp
popl %eax
call %eax
addl $8, %esp
call halt // Does not return
.L2:
mov %eax,ErrNo
mov $-1,%eax
jmp .L1
// jmp PIC_PLT(HIDENAME(cerror))
pushl %esi
movl 12(%ebp), %esi // get stack addr
subl $4, %esi
movl 20(%ebp), %eax // get __arg
movl %eax, (%esi)
subl $4, %esi
movl 8(%ebp), %eax // get __fn
movl %eax, (%esi)
pushl 16(%ebp)
pushl %esi
mov syscall_nr_rfork, %eax
int $0x80 // call actualsyscall
jb .L2
test %edx, %edx
jz .L1
movl %esi,%esp
popl %eax
call %eax
addl $8, %esp
call halt // Does not return
.L2:
mov %eax,ErrNo
mov $-1,%eax
jmp .L1
// jmp PIC_PLT(HIDENAME(cerror))
.L1:
addl $8, %esp
popl %esi
addl $8, %esp
popl %esi
end;
{
* Architecture specific syscalls (i386) using the SYSARCH pseudo call
}
{$packrecords C}
TYPE uint=CARDINAL;
@ -750,23 +746,10 @@ begin
LinuxError:=ErrNo;
end;
{
$Log$
Revision 1.4 2001-01-22 07:25:10 marco
* IOPERM for FreeBSD. Port routines moved from linsysca to Unix again .
Revision 1.3 2000/10/26 22:51:12 peter
* nano sleep (merged)
Revision 1.2 2000/09/18 13:14:50 marco
* Global Linux +bsd to (rtl/freebsd rtl/unix rtl/linux structure)
Revision 1.3 2000/09/11 14:05:31 marco
* FreeBSD support and removed old signalhandling
Revision 1.2 2000/07/13 11:33:47 michael
+ removed logs
Revision 1.2 2001-06-02 00:31:30 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
}

4
rtl/linux/Makefile
View File

@ -849,7 +849,7 @@ strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc\
$(SYSTEMUNIT)$(PPUEXT)
unix$(PPUEXT) : unix.pp strings$(PPUEXT) $(INC)/textrec.inc $(INC)/filerec.inc \
syscalls.inc systypes.inc sysconst.inc $(UNIXINC)/timezone.inc $(SYSTEMUNIT)$(PPUEXT) \
$(UNIXINC)/linsysca.inc
unixsysc.inc
ports$(PPUEXT) : ports.pp unix$(PPUEXT) objpas$(PPUEXT)
dl$(PPUEXT) : $(UNIXINC)/dl.pp
dynlibs$(PPUEXT) : $(INC)/dynlibs.pp $(UNIXINC)/dynlibs.inc dl$(PPUEXT) objpas$(PPUEXT)
@ -885,7 +885,7 @@ heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) -Sg $(INC)/heaptrc.pp
lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT)
sockets$(PPUEXT) : sockets.pp $(INC)/textrec.inc $(INC)/filerec.inc \
unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
unixsock.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
errors$(PPUEXT) : errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
ipc$(PPUEXT) : ipc.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
terminfo$(PPUEXT) : terminfo.pp unix$(PPUEXT)

4
rtl/linux/Makefile.fpc
View File

@ -135,7 +135,7 @@ strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc\
unix$(PPUEXT) : unix.pp strings$(PPUEXT) $(INC)/textrec.inc $(INC)/filerec.inc \
syscalls.inc systypes.inc sysconst.inc $(UNIXINC)/timezone.inc $(SYSTEMUNIT)$(PPUEXT) \
$(UNIXINC)/linsysca.inc
unixsysc.inc
ports$(PPUEXT) : ports.pp unix$(PPUEXT) objpas$(PPUEXT)
@ -213,7 +213,7 @@ lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT)
#
sockets$(PPUEXT) : sockets.pp $(INC)/textrec.inc $(INC)/filerec.inc \
unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
unixsock.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
errors$(PPUEXT) : errors.pp strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)

86
rtl/linux/syscalls.inc
View File

@ -412,41 +412,61 @@ begin
SysCall(Syscall_nr_sigaction,sr);
end;
function Sys_FTruncate(Handle,Pos:longint):longint; //moved from sysunix.inc Do_Truncate
var
sr : syscallregs;
begin
sr.reg2:=Handle;
sr.reg3:=Pos;
Sys_FTruncate:=syscall(syscall_nr_ftruncate,sr);
end;
Function Sys_mmap(adr,len,prot,flags,fdes,off:longint):longint; // moved from sysunix.inc, used in sbrk
type
tmmapargs=packed record
address : longint;
size : longint;
prot : longint;
flags : longint;
fd : longint;
offset : longint;
end;
var
t : syscallregs;
mmapargs : tmmapargs;
begin
mmapargs.address:=adr;
mmapargs.size:=len;
mmapargs.prot:=prot;
mmapargs.flags:=flags;
mmapargs.fd:=fdes;
mmapargs.offset:=off;
t.reg2:=longint(@mmapargs);
Sys_mmap:=syscall(syscall_nr_mmap,t);
end;
{
Interface to Unix ioctl call.
Performs various operations on the filedescriptor Handle.
Ndx describes the operation to perform.
Data points to data needed for the Ndx function. The structure of this
data is function-dependent.
}
Function Sys_IOCtl(Handle,Ndx: Longint;Data: Pointer):LongInt; // This was missing here, instead hardcode in Do_IsDevice
var
sr: SysCallRegs;
begin
sr.reg2:=Handle;
sr.reg3:=Ndx;
sr.reg4:=Longint(Data);
Sys_IOCtl:=SysCall(Syscall_nr_ioctl,sr);
end;
{
$Log$
Revision 1.3 2000-09-11 14:05:31 marco
* FreeBSD support and removed old signalhandling
Revision 1.2 2000/07/13 11:33:49 michael
+ removed logs
Revision 1.1 2000/07/13 06:30:54 michael
+ Initial import
Revision 1.11 2000/07/08 18:02:39 peter
* do_open checks for directory, if directory then ioerror 2
Revision 1.10 2000/02/09 16:59:32 peter
* truncated log
Revision 1.9 2000/02/08 11:47:09 peter
* paramstr(0) support
Revision 1.8 2000/01/07 16:41:41 daniel
* copyright 2000
Revision 1.7 2000/01/07 16:32:28 daniel
* copyright 2000 added
Revision 1.6 1999/07/28 17:37:06 michael
* forgot ;
Revision 1.5 1999/07/28 12:15:16 michael
* Memory leak fixed in CloseDir, by Sebastian Guenther
Revision 1.4 1999/07/28 12:14:37 michael
* Memory leak fixed in CloseDir, by Sebastian Guenther
Revision 1.4 2001-06-02 00:31:30 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
}

21
rtl/linux/sysconst.inc
View File

@ -32,9 +32,9 @@ Const
Open_NDelay = Open_NonBlock;
Open_Sync = 1 shl 12;
Open_Direct = 4 shl 12;
Open_LargeFile = 1 shl 15;
Open_Directory = 2 shl 15;
Open_NoFollow = 4 shl 15;
Open_LargeFile = 1 shl 15;
Open_Directory = 2 shl 15;
Open_NoFollow = 4 shl 15;
{ The waitpid uses the following options:}
Wait_NoHang = 1;
Wait_UnTraced = 2;
@ -82,12 +82,17 @@ Const
fs_proc = $9fa0;
fs_xia = $012FD16D;
{ Constansts for MMAP }
MAP_PRIVATE =2;
MAP_ANONYMOUS =$20;
{Constansts Termios/Ioctl (used in Do_IsDevice) }
IOCtl_TCGETS=$5401; // TCGETS is also in termios.inc, but the sysunix needs only this
{
$Log$
Revision 1.3 2000-10-26 22:55:11 peter
* merges from fixes
Revision 1.2 2000/07/13 11:33:49 michael
+ removed logs
Revision 1.4 2001-06-02 00:31:30 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
}

16
rtl/linux/systypes.inc
View File

@ -58,15 +58,17 @@ type
end;
PDir =^TDir;
dev_t = word;
Stat = packed record
dev,
dev : dev_t;
pad1 : word;
ino : longint;
mode,
nlink,
uid,
gid,
rdev,
gid : word;
rdev : dev_t;
pad2 : word;
size,
blksze,
@ -131,10 +133,8 @@ type
{
$Log$
Revision 1.3 2000-10-26 22:55:11 peter
* merges from fixes
Revision 1.2 2000/07/13 11:33:49 michael
+ removed logs
Revision 1.4 2001-06-02 00:31:30 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
}

8
rtl/unix/linsock.inc → rtl/linux/unixsock.inc
View File

@ -55,7 +55,7 @@ begin
SocketCall:=Syscall(syscall_nr_socketcall,regs);
If SocketCall<0 then
SocketError:=Errno
else
else
SocketError:=0;
{$ELSE}
SocketError:=-1;
@ -262,7 +262,11 @@ end;
{
$Log$
Revision 1.2 2000-09-18 13:14:50 marco
Revision 1.2 2001-06-02 00:31:30 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
Revision 1.2 2000/09/18 13:14:50 marco
* Global Linux +bsd to (rtl/freebsd rtl/unix rtl/linux structure)
Revision 1.2 2000/09/11 14:05:31 marco

10
rtl/unix/linsysca.inc → rtl/linux/unixsysc.inc
View File

@ -34,7 +34,7 @@ begin
if (pointer(func)=nil) or (sp=nil) then
begin
LinuxError:=Sys_EInval;
exit;
exit(-1); // give an error result
end;
asm
{ Insert the argument onto the new stack. }
@ -927,8 +927,12 @@ end;
{
$Log$
Revision 1.6 2001-01-22 07:25:10 marco
* IOPERM for FreeBSD. Port routines moved from linsysca to Unix again .
Revision 1.2 2001-06-02 00:31:30 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
Revision 1.6 2001/01/22 07:25:10 marco
* IOPERM for FreeBSD. Port routines moved from unixsysc to Unix again .
Revision 1.5 2000/12/28 20:50:04 peter
* merged fixes from 1.0.x

21
rtl/unix/dos.pp
View File

@ -319,7 +319,7 @@ var
Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
var
pid : longint;
status : longint;
// The Error-Checking in the previous Version failed, since halt($7F) gives an WaitPid-status of $7F00
Begin
LastDosExitCode:=0;
pid:=Fork;
@ -328,7 +328,7 @@ Begin
{The child does the actual exec, and then exits}
Execl (Path+' '+ComLine);
{If the execve fails, we return an exitvalue of 127, to let it be known}
halt (127)
ExitProcess(127);
end
else
if pid=-1 then {Fork failed}
@ -337,14 +337,11 @@ Begin
exit
end;
{We're in the parent, let's wait.}
Waitpid (pid,@status,0);
if status=127 then {The child couldn't execve !!}
DosError:=8 {We set this error, erroneously, since we cannot get to the real error}
LastDosExitCode:=WaitProcess(pid); // WaitPid and result-convert
if (LastDosExitCode>=0) and (LastDosExitCode<>127) then
DosError:=0
else
begin
LastDosExitCode:=status shr 8;
DosError:=0
end;
DosError:=8; // perhaps one time give an better error
End;
@ -880,7 +877,11 @@ End.
{
$Log$
Revision 1.4 2001-05-06 14:23:21 peter
Revision 1.5 2001-06-02 00:31:30 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
Revision 1.4 2001/05/06 14:23:21 peter
* fixed adddisk
Revision 1.3 2001/01/21 20:21:40 marco

312
rtl/unix/linux.pp
View File

@ -51,9 +51,14 @@ const
Prio_PGrp = 1;
Prio_User = 2;
{$ifdef Solaris}
WNOHANG = $100;
WUNTRACED = $4;
{$ELSE}
WNOHANG = $1;
WUNTRACED = $2;
__WCLONE = $80000000;
{$ENDIF}
{********************
@ -99,11 +104,22 @@ const
F_SetFd = 2;
F_GetFl = 3;
F_SetFl = 4;
{$ifdef Solaris}
F_DupFd = 0;
F_Dup2Fd = 9;
F_GetOwn = 23;
F_SetOwn = 24;
F_GetLk = 14;
F_SetLk = 6;
F_SetLkW = 7;
F_FreeSp = 11;
{$else}
F_GetLk = 5;
F_SetLk = 6;
F_SetLkW = 7;
F_SetOwn = 8;
F_GetOwn = 9;
{$endif}
{********************
IOCtl(TermIOS)
@ -215,7 +231,8 @@ Function Fork:longint;
{Clone for FreeBSD is copied from the LinuxThread port, and rfork based}
function Clone(func:TCloneFunc;sp:pointer;flags:longint;args:pointer):longint;
Procedure ExitProcess(val:longint);
Function WaitPid(Pid:longint;Status:pointer;Options:longint):Longint;
Function WaitPid(Pid:longint;Status:pointer;Options:Longint):Longint; {=>PID (Status Valid), 0 (No Status), -1: Error, special case errno=EINTR }
Function WaitProcess(Pid:longint):Longint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
Procedure Nice(N:integer);
{$ifdef bsd}
Function GetPriority(Which,Who:longint):longint;
@ -242,7 +259,7 @@ Function fdOpen(pathname:pchar;flags:longint):longint;
Function fdOpen(pathname:pchar;flags,mode:longint):longint;
Function fdClose(fd:longint):boolean;
Function fdRead(fd:longint;var buf;size:longint):longint;
Function fdWrite(fd:longint;var buf;size:longint):longint;
Function fdWrite(fd:longint;const buf;size:longint):longint;
Function fdTruncate(fd,size:longint):boolean;
Function fdSeek (fd,pos,seektype :longint): longint;
Function fdFlush (fd : Longint) : Boolean;
@ -295,6 +312,7 @@ Function Dup2(var oldfile,newfile:file):Boolean;
Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:PTimeVal):longint;
Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:Longint):longint;
Function SelectText(var T:Text;TimeOut :PTimeVal):Longint;
Function SelectText(var T:Text;TimeOut :Longint):Longint;
{**************************
Directory Handling
@ -385,10 +403,10 @@ const
PROT_NONE = $0; { page can not be accessed }
MAP_SHARED = $1; { Share changes }
MAP_PRIVATE = $2; { Changes are private }
// MAP_PRIVATE = $2; { Changes are private }
MAP_TYPE = $f; { Mask for type of mapping }
MAP_FIXED = $10; { Interpret addr exactly }
MAP_ANONYMOUS = $20; { don't use a file }
// MAP_ANONYMOUS = $20; { don't use a file }
MAP_GROWSDOWN = $100; { stack-like segment }
MAP_DENYWRITE = $800; { ETXTBSY }
@ -413,9 +431,11 @@ function MUnMap (P : Pointer; Size : Longint) : Boolean;
Port IO functions
***************************}
{$ifndef BSD}
Function IOperm (From,Num : Cardinal; Value : Longint) : boolean;
{$IFDEF I386}
{$ifndef BSD}
Function IoPL(Level : longint) : Boolean;
{$endif}
{$ifdef i386}
Procedure WritePort (Port : Longint; Value : Byte);
Procedure WritePort (Port : Longint; Value : Word);
Procedure WritePort (Port : Longint; Value : Longint);
@ -435,7 +455,6 @@ Procedure ReadPortL (Port : Longint; Var Buf; Count: longint);
Procedure ReadPortW (Port : Longint; Var Buf; Count: longint);
Procedure ReadPortB (Port : Longint; Var Buf; Count: longint);
{$endif}
{$endif}
{**************************
Utility functions
@ -484,36 +503,65 @@ Uses Strings;
{ Raw System calls are in Syscalls.inc}
{$i syscalls.inc}
{$ifdef BSD}
{$i bsdsysca.inc}
{$else}
{$i linsysca.inc}
{$endif}
{$i unixsysc.inc} {Syscalls only used in unit Unix/Linux}
{******************************************************************************
Process related calls
******************************************************************************}
function CreateShellArgV(const prog:string):ppchar;
{ Most calls of WaitPID do not handle the result correctly, this funktion treats errors more correctly }
Function WaitProcess(Pid:longint):Longint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
var r,s : LongInt;
begin
repeat
s:=$7F00;
r:=WaitPid(Pid,@s,0);
until (r<>-1) or (LinuxError<>Sys_EINTR);
if (r=-1) or (r=0) then // 0 is not a valid return and should never occur (it means status invalid when using WNOHANG)
WaitProcess:=-1 // return -1 to indicate an error
else
begin
{$ifndef Solaris}
WaitProcess:=s; // s<0 should not occur, but wie return also a negativ value
{$else}
if (s and $FF)=0 then // Only this is a valid returncode
WaitProcess:=s shr 8
else if (s>0) then // Until now there is not use of the highest bit , but check this for the future
WaitProcess:=-s // normal case
else
WaitProcess:=s; // s<0 should not occur, but wie return also a negativ value
{$endif}
end;
end;
function InternalCreateShellArgV(cmd:pChar; len:longint):ppchar;
{
Create an argv which executes a command in a shell using /bin/sh -c
}
const Shell = '/bin/sh'#0'-c'#0;
var
pp,p : ppchar;
temp : string;
// temp : string; !! Never pass a local var back!!
begin
getmem(pp,4*4);
temp:='/bin/sh'#0'-c'#0+prog+#0;
p:=pp;
p^:=@temp[1];
p^:=@Shell[1];
inc(p);
p^:=@temp[9];
p^:=@Shell[9];
inc(p);
p^:=@temp[12];
getmem(p^,len+1);
move(cmd^,p^^,len);
pchar(p^)[len]:=#0;
inc(p);
p^:=Nil;
CreateShellArgV:=pp;
InternalCreateShellArgV:=pp;
end;
function CreateShellArgV(const prog:string):ppchar;
begin
CreateShellArgV:=InternalCreateShellArgV(@prog[1],length(prog));
end;
function CreateShellArgV(const prog:Ansistring):ppchar;
@ -521,25 +569,19 @@ function CreateShellArgV(const prog:Ansistring):ppchar;
Create an argv which executes a command in a shell using /bin/sh -c
using a AnsiString;
}
var
pp,p : ppchar;
temp : AnsiString;
begin
getmem(pp,4*4);
temp:='/bin/sh'#0'-c'#0+prog+#0;
p:=pp;
GetMem(p^,Length(Temp));
Move(Temp[1],p^^,Length(Temp));
inc(p);
p^:=@pp[0][8];
inc(p);
p^:=@pp[0][11];
inc(p);
p^:=Nil;
CreateShellArgV:=pp;
CreateShellArgV:=InternalCreateShellArgV(@prog[1],length(prog)); // if ppc works like delphi this also work when @prog[1] is invalid (len=0)
end;
procedure FreeShellArgV(p:ppchar);
begin
if (p<>nil) then begin
freemem(p[2]);
freemem(p);
end;
end;
Procedure Execv(const path:pathstr;args:ppchar);
{
@ -552,7 +594,6 @@ begin
end;
Procedure Execvp(Path:Pathstr;Args:ppchar;Ep:ppchar);
{
This does the same as Execve, only it searches the PATH environment
@ -578,7 +619,6 @@ begin
end;
Procedure Execle(Todo:string;Ep:ppchar);
{
This procedure takes the string 'Todo', parses it for command and
@ -598,7 +638,6 @@ begin
end;
Procedure Execl(const Todo:string);
{
This procedure takes the string 'Todo', parses it for command and
@ -613,7 +652,6 @@ begin
end;
Procedure Execlp(Todo:string;Ep:ppchar);
{
This procedure takes the string 'Todo', parses it for command and
@ -632,6 +670,7 @@ begin
ExecVP(StrPas(p^),p,EP);
end;
Function Shell(const Command:String):Longint;
{
Executes the shell, and passes it the string Command. (Through /bin/sh -c)
@ -639,50 +678,56 @@ Function Shell(const Command:String):Longint;
It waits for the shell to exit, and returns its exit status.
If the Exec call failed exit status 127 is reported.
}
{ Changed the structure:
- the previous version returns an undefinied value if fork fails
- it returns the status of Waitpid instead of the Process returnvalue (see the doc to Shell)
- it uses exit(127) not ExitProc (The Result in pp386: going on Compiling in 2 processes!)
- ShellArgs are now released
- The Old CreateShellArg gives back pointers to a local var
}
var
p : ppchar;
temp,pid : longint;
p : ppchar;
pid : longint;
begin
p:=CreateShellArgv(command);
pid:=fork;
if pid=-1 then
exit; {Linuxerror already set in Fork}
if pid=0 then
if pid=0 then // We are in the Child
begin
{This is the child.}
p:=CreateShellArgv(command);
Execve(p^,p,envp);
exit(127);
end;
temp:=0;
WaitPid(pid,@temp,0);{Linuxerror is set there}
Shell:=temp;{ Return exit status }
ExitProcess(127); // was Exit(127)
end
else if (pid<>-1) then // Successfull started
Shell:=WaitProcess(pid) {Linuxerror is set there}
else // no success
Shell:=-1; // indicate an error
FreeShellArgV(p);
end;
Function Shell(const Command:AnsiString):Longint;
{
AnsiString version of Shell
}
var
p : ppchar;
temp,pid : longint;
begin
p : ppchar;
pid : longint;
begin { Changes as above }
p:=CreateShellArgv(command);
pid:=fork;
if pid=-1 then
exit; {Linuxerror already set in Fork}
if pid=0 then
if pid=0 then // We are in the Child
begin
{This is the child.}
p:=CreateShellArgv(command);
Execve(p^,p,envp);
exit(127);
end;
temp:=0;
WaitPid(pid,@temp,0);{Linuxerror is set there}
Shell:=temp;{ Return exit status }
ExitProcess(127); // was exit(127)!! We must exit the Process, not the function
end
else if (pid<>-1) then // Successfull started
Shell:=WaitProcess(pid) {Linuxerror is set there}
else // no success
Shell:=-1;
FreeShellArgV(p);
end;
{******************************************************************************
Date and Time related calls
******************************************************************************}
@ -885,7 +930,7 @@ end;
Function fdWrite(fd:longint;var buf;size:longint):longint;
Function fdWrite(fd:longint;const buf;size:longint):longint;
begin
fdWrite:=Sys_Write(fd,pchar(@buf),size);
LinuxError:=Errno;
@ -1208,6 +1253,23 @@ begin
end;
Function SelectText(var T:Text;TimeOut :Longint):Longint;
var
p : PTimeVal;
tv : TimeVal;
begin
if TimeOut=-1 then
p:=nil
else
begin
tv.Sec:=Timeout div 1000;
tv.Usec:=(Timeout mod 1000)*1000;
p:=@tv;
end;
SelectText:=SelectText(T,p);
end;
{******************************************************************************
Directory
******************************************************************************}
@ -1936,28 +1998,16 @@ begin
end;
Function TCFlush(fd,qsel:longint):boolean;
var com:longint;
begin
{$ifndef BSD}
TCFlush:=IOCtl(fd,TCFLSH,pointer(qsel));
{$else}
{
CASE Qsel of
TCIFLUSH : com:=fread;
TCOFLUSH : com:=FWRITE;
TCIOFLUSH: com:=FREAD OR FWRITE;
else
exit(false);
end;
}
TCFlush:=IOCtl(fd,TIOCFLUSH,pointer(qsel));
{$endif}
end;
Function IsATTY(Handle:Longint):Boolean;
{
Check if the filehandle described by 'handle' is a TTY (Terminal)
@ -2126,75 +2176,22 @@ begin
end;
{
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
}
Function FExpand(Const Path:PathStr):PathStr;
var
temp : pathstr;
i,j : longint;
p : pchar;
Begin
{Remove eventual drive - doesn't exist in Linux}
if path[2]=':' then
i:=3
else
i:=1;
temp:='';
{Replace ~/ with $HOME}
if (path[i]='~') and ((i+1>length(path)) or (path[i+1]='/')) then
begin
p:=getenv('HOME');
if not (p=nil) then
Insert(StrPas(p),temp,i);
i:=1;
temp:=temp+Copy(Path,2,255);
end;
{Do we have an absolute path ? No - prefix the current dir}
if temp='' then
begin
if path[i]<>'/' then
begin
{$I-}
getdir(0,temp);
{$I+}
if ioresult<>0 then;
end
else
inc(i);
temp:=temp+'/'+copy(path,i,length(path)-i+1)+'/';
end;
{First remove all references to '/./'}
while pos('/./',temp)<>0 do
delete(temp,pos('/./',temp),2);
{Now remove also all references to '/../' + of course previous dirs..}
repeat
i:=pos('/../',temp);
{Find the pos of the previous dir}
if i>1 then
begin
j:=i-1;
while (j>1) and (temp[j]<>'/') do
dec (j);{temp[1] is always '/'}
delete(temp,j,i-j+3);
end
else
if i=1 then {i=1, so we have temp='/../something', just delete '/../'}
delete(temp,1,3);
until i=0;
{ Remove ending /.. }
i:=pos('/..',temp);
if (i<>0) and (i =length(temp)-2) then
begin
j:=i-1;
while (j>1) and (temp[j]<>'/') do
dec (j);
delete (temp,j,i-j+3);
end;
{ if last character is / then remove it - dir is also a file :-) }
if (length(temp)>0) and (temp[length(temp)]='/') then
dec(byte(temp[0]));
fexpand:=temp;
End;
{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
{$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
const
LFNSupport = true;
FileNameCaseSensitive = true;
{$I fexpand.inc}
{$UNDEF FPC_FEXPAND_GETENVPCHAR}
{$UNDEF FPC_FEXPAND_TILDE}
Function FSearch(const path:pathstr;dirlist:string):pathstr;
@ -2618,7 +2615,6 @@ end;
--------------------------------}
{$IFDEF I386}
Procedure WritePort (Port : Longint; Value : Byte);
{
Writes 'Value' to port 'Port'
@ -2885,6 +2881,7 @@ end;
{$ENDIF}
Initialization
InitLocalTime;
@ -2895,11 +2892,30 @@ End.
{
$Log$
Revision 1.8 2001-03-27 11:46:38 michael
Revision 1.9 2001-06-02 00:31:30 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
Revision 1.7 2001/04/19 12:57:33 marco
* Readlink uncommented for FreeBSD.
Revision 1.6 2001/04/13 22:37:21 peter
* remove warning
Revision 1.5 2001/03/27 11:47:25 michael
+ Fixed F_[G,S]etOwn constants. By Alexander Sychev
Revision 1.7 2001/02/11 18:55:07 peter
* readded removed readport* from implementation
Revision 1.4 2001/03/17 16:04:37 hajny
* FExpand omission fixed
Revision 1.3 2001/03/16 20:09:58 hajny
* universal FExpand
Revision 1.2 2001/01/22 07:25:10 marco
* IOPERM for FreeBSD. Port routines moved from linsysca to Unix again .
Revision 1.1 2001/01/21 20:21:41 marco
* Rename fest II. Rtl OK
Revision 1.6 2000/12/28 20:42:12 peter
* ttyname fix from the mailinglist (merged)

15
rtl/unix/sockets.pp
View File

@ -139,15 +139,12 @@ Uses Unix;
{ Include filerec and textrec structures }
{$i filerec.inc}
{$i textrec.inc}
{******************************************************************************
Kernel Socket Callings
******************************************************************************}
{$ifdef BSD}
{$I bsdsock.inc}
{$else}
{$I linsock.inc}
{$endif}
{$I unixsock.inc}
{$i sockets.inc}
@ -155,7 +152,11 @@ end.
{
$Log$
Revision 1.3 2001-01-21 20:21:40 marco
Revision 1.4 2001-06-02 00:31:31 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
Revision 1.3 2001/01/21 20:21:40 marco
* Rename fest II. Rtl OK
Revision 1.2 2000/09/18 13:14:51 marco
@ -166,5 +167,5 @@ end.
Revision 1.2 2000/07/13 11:33:49 michael
+ removed logs
}

112
rtl/unix/sysunix.inc
View File

@ -4,6 +4,9 @@
Copyright (c) 1999-2000 by Michael Van Canneyt,
member of the Free Pascal development team.
This is the core of the system unit *nix systems (now FreeBSD
and Unix).
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -129,45 +132,14 @@ end ['D0'];
{$endif}
{$ifdef bsd}
Function sbrk(size : longint) : Longint;
CONST MAP_PRIVATE =2;
MAP_ANONYMOUS =$1000; {$20 under linux}
begin
Sbrk:=do_syscall(syscall_nr_mmap,0,size,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0,0);
if ErrNo<>0 then
Sbrk:=0;
sbrk:=Sys_mmap(0,Size,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0);
if sbrk<>-1 then
errno:=0;
{! It must be -1, not 0 as before, see heap.inc. Should be in sysmmap?}
end;
{$else}
Function sbrk(size : longint) : Longint;
type
tmmapargs=packed record
address : longint;
size : longint;
prot : longint;
flags : longint;
fd : longint;
offset : longint;
end;
var
t : syscallregs;
mmapargs : tmmapargs;
begin
mmapargs.address:=0;
mmapargs.size:=Size;
mmapargs.prot:=3;
mmapargs.flags:=$22;
mmapargs.fd:=-1;
mmapargs.offset:=0;
t.reg2:=longint(@mmapargs);
Sbrk:=syscall(syscall_nr_mmap,t);
if ErrNo<>0 then
Sbrk:=0;
end;
{$endif}
{ include standard heap management }
{$I heap.inc}
@ -190,6 +162,7 @@ Procedure Errno2Inoutres;
begin
if ErrNo=0 then { Else it will go through all the cases }
exit;
If errno<0 then Errno:=-errno;
case ErrNo of
Sys_ENFILE,
Sys_EMFILE : Inoutres:=4;
@ -266,54 +239,31 @@ End;
Procedure Do_Seek(Handle,Pos:Longint);
Begin
sys_lseek(Handle, pos, Seek_set);
errno2inoutres;
End;
Function Do_SeekEnd(Handle:Longint): Longint;
begin
Do_SeekEnd:=sys_lseek(Handle,0,Seek_End);
errno2inoutres;
end;
{$ifdef BSD}
Function Do_FileSize(Handle:Longint): Longint;
var
Info : Stat;
Begin
if do_SysCall(syscall_nr_fstat,handle,longint(@info))=0 then
if sys_fstat(handle,info)=0 then
Do_FileSize:=Info.Size
else
Do_FileSize:=0;
Errno2Inoutres;
End;
{$ELSE}
Function Do_FileSize(Handle:Longint): Longint;
var
regs : Syscallregs;
Info : Stat;
Begin
regs.reg2:=Handle;
regs.reg3:=longint(@Info);
if SysCall(SysCall_nr_fstat,regs)=0 then
Do_FileSize:=Info.Size
else
Do_FileSize:=0;
Errno2Inoutres;
End;
{$endif}
Procedure Do_Truncate(Handle,Pos:longint);
{$ifndef bsd}
var
sr : syscallregs;
{$endif}
Procedure Do_Truncate(Handle,fPos:longint);
begin
{$ifdef bsd}
do_syscall(syscall_nr_ftruncate,handle,pos,0);
{$else}
sr.reg2:=Handle;
sr.reg3:=Pos;
syscall(syscall_nr_ftruncate,sr);
{$endif}
sys_ftruncate(handle,fpos);
Errno2Inoutres;
end;
@ -401,19 +351,9 @@ Function Do_IsDevice(Handle:Longint):boolean;
data is function-dependent.
}
var
{$ifndef BSD}
sr: SysCallRegs;
{$endif}
Data : array[0..255] of byte; {Large enough for termios info}
begin
{$ifdef BSD}
Do_IsDevice:=(do_SysCall(syscall_nr_ioctl,handle,$5413,longint(@data))=0);
{$else}
sr.reg2:=Handle;
sr.reg3:=$5401; {=TCGETS}
sr.reg4:=Longint(@Data);
Do_IsDevice:=(SysCall(Syscall_nr_ioctl,sr)=0);
{$endif}
Do_IsDevice:=(sys_ioctl(handle,IOCTL_TCGETS,@data)<>-1);
end;
@ -489,7 +429,7 @@ var
dotdotino : longint;
rootdev,
thisdev,
dotdotdev : {$ifdef bsd}longint{$else}word{$endif};
dotdotdev : dev_t;
thedir,dummy : string[255];
dirstream : pdir;
d : pdirent;
@ -585,9 +525,13 @@ end;
{$ifdef BSD}
procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec;someptr:pointer); cdecl;
procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec;someptr:pointer); cdecl;
{$else}
procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec); cdecl;
{$ifdef Solaris}
procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec;someptr:pointer); cdecl;
{$else}
procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec); cdecl;
{$endif}
{$ENDIF}
var
@ -659,8 +603,12 @@ end;
Procedure InstallSignals;
const
{$Ifndef BSD}
{$ifdef solaris}
act: SigActionRec =(sa_flags:SA_SIGINFO;Handler:(sa:@signaltorunerror;sa_mask:0);
{$else}
act: SigActionRec = (handler:(Sa:@SignalToRunError);sa_mask:0;sa_flags:0;
Sa_restorer: NIL);
{$endif}
{$ELSE}
act: SigActionRec = (handler:(Sa:@SignalToRunError);sa_flags:SA_SIGINFO;
sa_mask:0);
@ -671,9 +619,11 @@ const
begin
ResetFPU;
SigAction(SIGFPE,@act,oldact);
{$ifndef Solaris}
SigAction(SIGSEGV,@act,oldact);
SigAction(SIGBUS,@act,oldact);
SigAction(SIGILL,@act,oldact);
{$endif}
end;
@ -753,7 +703,11 @@ End.
{
$Log$
Revision 1.10 2001-04-23 20:33:31 peter
Revision 1.11 2001-06-02 00:31:31 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
Revision 1.10 2001/04/23 20:33:31 peter
* also install sig handlers for sigill,sigbus
Revision 1.9 2001/04/13 22:39:05 peter

217
rtl/unix/unix.pp
View File

@ -51,9 +51,14 @@ const
Prio_PGrp = 1;
Prio_User = 2;
{$ifdef Solaris}
WNOHANG = $100;
WUNTRACED = $4;
{$ELSE}
WNOHANG = $1;
WUNTRACED = $2;
__WCLONE = $80000000;
{$ENDIF}
{********************
@ -99,11 +104,22 @@ const
F_SetFd = 2;
F_GetFl = 3;
F_SetFl = 4;
{$ifdef Solaris}
F_DupFd = 0;
F_Dup2Fd = 9;
F_GetOwn = 23;
F_SetOwn = 24;
F_GetLk = 14;
F_SetLk = 6;
F_SetLkW = 7;
F_FreeSp = 11;
{$else}
F_GetLk = 5;
F_SetLk = 6;
F_SetLkW = 7;
F_SetOwn = 8;
F_GetOwn = 9;
{$endif}
{********************
IOCtl(TermIOS)
@ -215,7 +231,8 @@ Function Fork:longint;
{Clone for FreeBSD is copied from the LinuxThread port, and rfork based}
function Clone(func:TCloneFunc;sp:pointer;flags:longint;args:pointer):longint;
Procedure ExitProcess(val:longint);
Function WaitPid(Pid:longint;Status:pointer;Options:longint):Longint;
Function WaitPid(Pid:longint;Status:pointer;Options:Longint):Longint; {=>PID (Status Valid), 0 (No Status), -1: Error, special case errno=EINTR }
Function WaitProcess(Pid:longint):Longint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
Procedure Nice(N:integer);
{$ifdef bsd}
Function GetPriority(Which,Who:longint):longint;
@ -242,14 +259,16 @@ Function fdOpen(pathname:pchar;flags:longint):longint;
Function fdOpen(pathname:pchar;flags,mode:longint):longint;
Function fdClose(fd:longint):boolean;
Function fdRead(fd:longint;var buf;size:longint):longint;
Function fdWrite(fd:longint;var buf;size:longint):longint;
Function fdWrite(fd:longint;const buf;size:longint):longint;
Function fdTruncate(fd,size:longint):boolean;
Function fdSeek (fd,pos,seektype :longint): longint;
Function fdFlush (fd : Longint) : Boolean;
Function Link(OldPath,NewPath:pathstr):boolean;
Function SymLink(OldPath,NewPath:pathstr):boolean;
{$ifndef bsd}
Function ReadLink(name,linkname:pchar;maxlen:longint):longint;
Function ReadLink(name:pathstr):pathstr;
{$endif}
Function UnLink(Path:pathstr):boolean;
Function UnLink(Path:pchar):Boolean;
Function FReName (OldName,NewName : Pchar) : Boolean;
@ -293,6 +312,7 @@ Function Dup2(var oldfile,newfile:file):Boolean;
Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:PTimeVal):longint;
Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:Longint):longint;
Function SelectText(var T:Text;TimeOut :PTimeVal):Longint;
Function SelectText(var T:Text;TimeOut :Longint):Longint;
{**************************
Directory Handling
@ -383,10 +403,10 @@ const
PROT_NONE = $0; { page can not be accessed }
MAP_SHARED = $1; { Share changes }
MAP_PRIVATE = $2; { Changes are private }
// MAP_PRIVATE = $2; { Changes are private }
MAP_TYPE = $f; { Mask for type of mapping }
MAP_FIXED = $10; { Interpret addr exactly }
MAP_ANONYMOUS = $20; { don't use a file }
// MAP_ANONYMOUS = $20; { don't use a file }
MAP_GROWSDOWN = $100; { stack-like segment }
MAP_DENYWRITE = $800; { ETXTBSY }
@ -412,6 +432,9 @@ function MUnMap (P : Pointer; Size : Longint) : Boolean;
***************************}
Function IOperm (From,Num : Cardinal; Value : Longint) : boolean;
{$ifndef BSD}
Function IoPL(Level : longint) : Boolean;
{$endif}
{$ifdef i386}
Procedure WritePort (Port : Longint; Value : Byte);
Procedure WritePort (Port : Longint; Value : Word);
@ -480,36 +503,65 @@ Uses Strings;
{ Raw System calls are in Syscalls.inc}
{$i syscalls.inc}
{$ifdef BSD}
{$i bsdsysca.inc}
{$else}
{$i linsysca.inc}
{$endif}
{$i unixsysc.inc} {Syscalls only used in unit Unix/Linux}
{******************************************************************************
Process related calls
******************************************************************************}
function CreateShellArgV(const prog:string):ppchar;
{ Most calls of WaitPID do not handle the result correctly, this funktion treats errors more correctly }
Function WaitProcess(Pid:longint):Longint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
var r,s : LongInt;
begin
repeat
s:=$7F00;
r:=WaitPid(Pid,@s,0);
until (r<>-1) or (LinuxError<>Sys_EINTR);
if (r=-1) or (r=0) then // 0 is not a valid return and should never occur (it means status invalid when using WNOHANG)
WaitProcess:=-1 // return -1 to indicate an error
else
begin
{$ifndef Solaris}
WaitProcess:=s; // s<0 should not occur, but wie return also a negativ value
{$else}
if (s and $FF)=0 then // Only this is a valid returncode
WaitProcess:=s shr 8
else if (s>0) then // Until now there is not use of the highest bit , but check this for the future
WaitProcess:=-s // normal case
else
WaitProcess:=s; // s<0 should not occur, but wie return also a negativ value
{$endif}
end;
end;
function InternalCreateShellArgV(cmd:pChar; len:longint):ppchar;
{
Create an argv which executes a command in a shell using /bin/sh -c
}
const Shell = '/bin/sh'#0'-c'#0;
var
pp,p : ppchar;
temp : string;
// temp : string; !! Never pass a local var back!!
begin
getmem(pp,4*4);
temp:='/bin/sh'#0'-c'#0+prog+#0;
p:=pp;
p^:=@temp[1];
p^:=@Shell[1];
inc(p);
p^:=@temp[9];
p^:=@Shell[9];
inc(p);
p^:=@temp[12];
getmem(p^,len+1);
move(cmd^,p^^,len);
pchar(p^)[len]:=#0;
inc(p);
p^:=Nil;
CreateShellArgV:=pp;
InternalCreateShellArgV:=pp;
end;
function CreateShellArgV(const prog:string):ppchar;
begin
CreateShellArgV:=InternalCreateShellArgV(@prog[1],length(prog));
end;
function CreateShellArgV(const prog:Ansistring):ppchar;
@ -517,25 +569,19 @@ function CreateShellArgV(const prog:Ansistring):ppchar;
Create an argv which executes a command in a shell using /bin/sh -c
using a AnsiString;
}
var
pp,p : ppchar;
temp : AnsiString;
begin
getmem(pp,4*4);
temp:='/bin/sh'#0'-c'#0+prog+#0;
p:=pp;
GetMem(p^,Length(Temp));
Move(Temp[1],p^^,Length(Temp));
inc(p);
p^:=@pp[0][8];
inc(p);
p^:=@pp[0][11];
inc(p);
p^:=Nil;
CreateShellArgV:=pp;
CreateShellArgV:=InternalCreateShellArgV(@prog[1],length(prog)); // if ppc works like delphi this also work when @prog[1] is invalid (len=0)
end;
procedure FreeShellArgV(p:ppchar);
begin
if (p<>nil) then begin
freemem(p[2]);
freemem(p);
end;
end;
Procedure Execv(const path:pathstr;args:ppchar);
{
@ -548,7 +594,6 @@ begin
end;
Procedure Execvp(Path:Pathstr;Args:ppchar;Ep:ppchar);
{
This does the same as Execve, only it searches the PATH environment
@ -574,7 +619,6 @@ begin
end;
Procedure Execle(Todo:string;Ep:ppchar);
{
This procedure takes the string 'Todo', parses it for command and
@ -594,7 +638,6 @@ begin
end;
Procedure Execl(const Todo:string);
{
This procedure takes the string 'Todo', parses it for command and
@ -609,7 +652,6 @@ begin
end;
Procedure Execlp(Todo:string;Ep:ppchar);
{
This procedure takes the string 'Todo', parses it for command and
@ -628,6 +670,7 @@ begin
ExecVP(StrPas(p^),p,EP);
end;
Function Shell(const Command:String):Longint;
{
Executes the shell, and passes it the string Command. (Through /bin/sh -c)
@ -635,50 +678,56 @@ Function Shell(const Command:String):Longint;
It waits for the shell to exit, and returns its exit status.
If the Exec call failed exit status 127 is reported.
}
{ Changed the structure:
- the previous version returns an undefinied value if fork fails
- it returns the status of Waitpid instead of the Process returnvalue (see the doc to Shell)
- it uses exit(127) not ExitProc (The Result in pp386: going on Compiling in 2 processes!)
- ShellArgs are now released
- The Old CreateShellArg gives back pointers to a local var
}
var
p : ppchar;
temp,pid : longint;
p : ppchar;
pid : longint;
begin
p:=CreateShellArgv(command);
pid:=fork;
if pid=-1 then
exit; {Linuxerror already set in Fork}
if pid=0 then
if pid=0 then // We are in the Child
begin
{This is the child.}
p:=CreateShellArgv(command);
Execve(p^,p,envp);
exit(127);
end;
temp:=0;
WaitPid(pid,@temp,0);{Linuxerror is set there}
Shell:=temp;{ Return exit status }
ExitProcess(127); // was Exit(127)
end
else if (pid<>-1) then // Successfull started
Shell:=WaitProcess(pid) {Linuxerror is set there}
else // no success
Shell:=-1; // indicate an error
FreeShellArgV(p);
end;
Function Shell(const Command:AnsiString):Longint;
{
AnsiString version of Shell
}
var
p : ppchar;
temp,pid : longint;
begin
p : ppchar;
pid : longint;
begin { Changes as above }
p:=CreateShellArgv(command);
pid:=fork;
if pid=-1 then
exit; {Linuxerror already set in Fork}
if pid=0 then
if pid=0 then // We are in the Child
begin
{This is the child.}
p:=CreateShellArgv(command);
Execve(p^,p,envp);
exit(127);
end;
temp:=0;
WaitPid(pid,@temp,0);{Linuxerror is set there}
Shell:=temp;{ Return exit status }
ExitProcess(127); // was exit(127)!! We must exit the Process, not the function
end
else if (pid<>-1) then // Successfull started
Shell:=WaitProcess(pid) {Linuxerror is set there}
else // no success
Shell:=-1;
FreeShellArgV(p);
end;
{******************************************************************************
Date and Time related calls
******************************************************************************}
@ -881,7 +930,7 @@ end;
Function fdWrite(fd:longint;var buf;size:longint):longint;
Function fdWrite(fd:longint;const buf;size:longint):longint;
begin
fdWrite:=Sys_Write(fd,pchar(@buf),size);
LinuxError:=Errno;
@ -1204,6 +1253,23 @@ begin
end;
Function SelectText(var T:Text;TimeOut :Longint):Longint;
var
p : PTimeVal;
tv : TimeVal;
begin
if TimeOut=-1 then
p:=nil
else
begin
tv.Sec:=Timeout div 1000;
tv.Usec:=(Timeout mod 1000)*1000;
p:=@tv;
end;
SelectText:=SelectText(T,p);
end;
{******************************************************************************
Directory
******************************************************************************}
@ -1932,28 +1998,16 @@ begin
end;
Function TCFlush(fd,qsel:longint):boolean;
{var com:longint;}
begin
{$ifndef BSD}
TCFlush:=IOCtl(fd,TCFLSH,pointer(qsel));
{$else}
{
CASE Qsel of
TCIFLUSH : com:=fread;
TCOFLUSH : com:=FWRITE;
TCIOFLUSH: com:=FREAD OR FWRITE;
else
exit(false);
end;
}
TCFlush:=IOCtl(fd,TIOCFLUSH,pointer(qsel));
{$endif}
end;
Function IsATTY(Handle:Longint):Boolean;
{
Check if the filehandle described by 'handle' is a TTY (Terminal)
@ -2122,13 +2176,13 @@ begin
end;
(*
{
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
*)
}
{$DEFINE FPC_FEXPAND_TILDE} (* Tilde is expanded to home *)
{$DEFINE FPC_FEXPAND_GETENVPCHAR} (* GetEnv result is a PChar *)
{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
{$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
const
LFNSupport = true;
@ -2561,7 +2615,6 @@ end;
--------------------------------}
{$IFDEF I386}
Procedure WritePort (Port : Longint; Value : Byte);
{
Writes 'Value' to port 'Port'
@ -2839,7 +2892,11 @@ End.
{
$Log$
Revision 1.7 2001-04-19 12:57:33 marco
Revision 1.8 2001-06-02 00:31:31 peter
* merge unix updates from the 1.0 branch, mostly related to the
solaris target
Revision 1.7 2001/04/19 12:57:33 marco
* Readlink uncommented for FreeBSD.
Revision 1.6 2001/04/13 22:37:21 peter