paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-07 14:27:59 +02:00
Code Issues Packages Projects Releases Wiki Activity

* threads for FreeBSD. Not working tho

Browse Source
This commit is contained in:
marco 2003-11-17 10:05:51 +00:00
parent 20bd2d0e06
commit 0c999e0c9b
16 changed files with 544 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
ide/fpdebug.pas
View File

@ -774,7 +774,7 @@ begin
Assign(Debuggeefile,DebuggeeTTY);
system.Reset(Debuggeefile);
ResetOK:=IOResult=0;
If ResetOK and IsATTY(textrec(Debuggeefile).handle) then
If ResetOK and (IsATTY(textrec(Debuggeefile).handle)<>-1) then
begin
Command('tty '+DebuggeeTTY);
TTYUsed:=true;
@ -3603,7 +3603,10 @@ end.
{
$Log$
Revision 1.46 2003-03-30 12:12:12 armin
Revision 1.47 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.46 2003/03/30 12:12:12 armin
* allow local and remote debugging if SUPPORT_REMOTE is given
Revision 1.45 2003/03/27 14:10:55 pierre

9
ide/fpusrscr.pas
View File

@ -774,7 +774,7 @@ begin
TTYFd:=-1;
IsXterm:=getenv('TERM')='xterm';
ThisTTY:=TTYName(stdinputhandle);
if Not IsXterm and IsATTY(stdinputhandle) then
if Not IsXterm and (IsATTY(stdinputhandle)<>-1) then
begin
Console:=TTyNetwork; {Default: Network or other vtxxx tty}
if (Copy(ThisTTY, 1, 8) = '/dev/tty') and (ThisTTY[9]<>'p') Then
@ -910,7 +910,7 @@ begin
ConsCursorY:=0;
ConsVideoBuf:=nil;
end;
ConsTioValid:=TCGetAttr(1,ConsTio);
ConsTioValid:=(TCGetAttr(1,ConsTio)<>-1);
end;
@ -1441,7 +1441,10 @@ end;
end.
{
$Log$
Revision 1.29 2003-11-14 21:52:58 marco
Revision 1.30 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.29 2003/11/14 21:52:58 marco
* octal() is not necessary anymore. Use &xxx
Revision 1.28 2003/09/27 14:03:45 peter

4
rtl/freebsd/Makefile
View File

@ -1,5 +1,5 @@
#
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/11/02]
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/11/11]
#
default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
@ -233,7 +233,7 @@ GRAPHDIR=$(INC)/graph
ifndef USELIBGGI
USELIBGGI=NO
endif
override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings baseunix syscall unixutil $(LINUXUNIT) unix initc dos dl crt objects printer sysutils typinfo classes math varutils cpu mmx charset ucomplex getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard console serial variants types systhrds sysctl
override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings baseunix syscall unixutil $(LINUXUNIT) unix initc dos dl crt objects printer sysutils typinfo systhrds classes math varutils cpu mmx charset ucomplex getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard console serial variants types sysctl
override TARGET_LOADERS+=prt0 cprt0 gprt0
override TARGET_RSTS+=math varutils typinfo classes variants
override INSTALL_FPCPACKAGE=y y

4
rtl/freebsd/Makefile.fpc
View File

@ -13,10 +13,10 @@ loaders=prt0 cprt0 gprt0
units=$(SYSTEMUNIT) objpas strings baseunix syscall unixutil \
$(LINUXUNIT) unix initc \
dos dl crt objects printer \
sysutils typinfo classes math varutils \
sysutils typinfo systhrds classes math varutils \
cpu mmx charset ucomplex getopts heaptrc lineinfo \
errors sockets gpm ipc terminfo \
video mouse keyboard console serial variants types systhrds sysctl
video mouse keyboard console serial variants types sysctl
rsts=math varutils typinfo classes variants
[require]

7
rtl/freebsd/classes.pp
View File

@ -32,7 +32,7 @@ uses
implementation
uses
baseunix,unix
baseunix,unix,Systhrds
;
{ OS - independent class implementations are in /inc directory. }
@ -51,7 +51,10 @@ finalization
end.
{
$Log$
Revision 1.2 2003-10-09 10:55:20 marco
Revision 1.3 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.2 2003/10/09 10:55:20 marco
* fix for moving classes to rtl while cycling with 1.0 start
Revision 1.1 2003/10/06 21:01:06 peter

2
rtl/freebsd/console.pp
View File

@ -1828,7 +1828,7 @@ function physicalconsole(fd:longint) : boolean;
var name:string;
begin
if isatty(fd) then
if (isatty(fd)<>-1) then
begin
name:=ttyname(fd);
if Copy(name,1,8)<>'/dev/tty' then

393
rtl/freebsd/tthread.inc
View File

@ -14,6 +14,8 @@
**********************************************************************}
{$IFDEF VER1_0} // leaving the old implementation in for now...
type
PThreadRec=^TThreadRec;
TThreadRec=record
@ -56,15 +58,14 @@ begin
fpwaitpid(-1, nil, WNOHANG);
end;
const zeroset :sigset = (0,0,0,0);
procedure InitThreads;
var
Act, OldAct: PSigActionRec;
Act, OldAct: Baseunix.PSigActionRec;
begin
ThreadRoot:=nil;
ThreadsInited:=true;
// This will install SIGCHLD signal handler
// signal() installs "one-shot" handler,
// so it is better to install and set up handler with sigaction()
@ -72,13 +73,10 @@ begin
GetMem(Act, SizeOf(SigActionRec));
GetMem(OldAct, SizeOf(SigActionRec));
signalhandler(Act^.sa_handler) := @SIGCHLDHandler;
fillchar(Act^.sa_mask,sizeof(sigset_t),#0);
Act^.sa_handler := @SIGCHLDHandler;
Act^.sa_flags := SA_NOCLDSTOP {or SA_NOMASK or SA_RESTART};
//Do not block all signals ??. Don't need if SA_NOMASK in flags
fpsigaction(SIGCHLD, @Act, @OldAct);
Fillchar(Act^.sa_mask,sizeof(Act^.sa_mask),0); //Do not block all signals ??. Don't need if SA_NOMASK in flags
FpSigAction(SIGCHLD, Act, OldAct);
FreeMem(Act, SizeOf(SigActionRec));
FreeMem(OldAct, SizeOf(SigActionRec));
@ -150,6 +148,8 @@ var
FreeThread: Boolean;
Thread : TThread absolute args;
begin
while Thread.FHandle = 0 do fpsleep(1);
if Thread.FSuspended then Thread.suspend();
try
Thread.Execute;
except
@ -161,7 +161,7 @@ begin
Thread.DoTerminate;
if FreeThread then
Thread.Free;
fpExit(Result);
fpexit(Result);
end;
@ -175,12 +175,12 @@ begin
Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD;
{ Setup 16k of stack }
FStackSize:=16384;
Getmem(pointer(FStackPointer),FStackSize);
Getmem(FStackPointer,FStackSize);
inc(FStackPointer,FStackSize);
FCallExitProcess:=false;
{ Clone }
FHandle:= Clone(@ThreadProc,pointer(FStackPointer),Flags,self);
if FSuspended then Suspend;
FHandle:= Clone(@ThreadProc,FStackPointer,Flags,self);
// if FSuspended then Suspend;
FThreadID := FHandle;
IsMultiThread := TRUE;
FFatalException := nil;
@ -195,9 +195,9 @@ begin
WaitFor;
end;
if FHandle <> -1 then
fpkill(FHandle, SIGKILL);
fpkill(FHandle, SIGKILL);
dec(FStackPointer,FStackSize);
Freemem(pointer(FStackPointer),FStackSize);
Freemem(FStackPointer);
FFatalException.Free;
FFatalException := nil;
inherited Destroy;
@ -228,8 +228,7 @@ var
P: Integer;
I: TThreadPriority;
begin
P :=
Unix.fpGetPriority (Prio_Process,FHandle);
P := fpGetPriority(Prio_Process,FHandle);
Result := tpNormal;
for I := Low(TThreadPriority) to High(TThreadPriority) do
if Priorities[I] = P then
@ -239,8 +238,7 @@ end;
procedure TThread.SetPriority(Value: TThreadPriority);
begin
Unix.fpSetPriority
(Prio_Process,FHandle, Priorities[Value]);
fpSetPriority(Prio_Process,FHandle,Priorities[Value]);
end;
@ -266,14 +264,14 @@ end;
procedure TThread.Suspend;
begin
fpkill(FHandle, SIGSTOP);
FSuspended := true;
fpKill(FHandle, SIGSTOP);
end;
procedure TThread.Resume;
begin
fpkill(FHandle, SIGCONT);
fpKill(FHandle, SIGCONT);
FSuspended := False;
end;
@ -288,45 +286,350 @@ var
status : longint;
begin
if FThreadID = MainThreadID then
fpWaitPid(0,@status,0)
fpwaitpid(0,@status,0)
else
fpWaitPid(FHandle,@status,0);
fpwaitpid(FHandle,@status,0);
Result:=status;
end;
{$ELSE}
{
What follows, is a short description on my implementation of TThread.
Most information can also be found by reading the source and accompanying
comments.
A thread is created using BeginThread, which in turn calls
pthread_create. So the threads here are always posix threads.
Posix doesn't define anything for suspending threads as this is
inherintly unsafe. Just don't suspend threads at points they cannot
control. Therefore, I didn't implement .Suspend() if its called from
outside the threads execution flow (except on Linux _without_ NPTL).
The implementation for .suspend uses a semaphore, which is initialized
at thread creation. If the thread tries to suspend itself, we simply
let it wait on the semaphore until it is unblocked by someone else
who calls .Resume.
If a thread is supposed to be suspended (from outside its own path of
execution) on a system where the symbol LINUX is defined, two things
are possible.
1) the system has the LinuxThreads pthread implementation
2) the system has NPTL as the pthread implementation.
In the first case, each thread is a process on its own, which as far as
know actually violates posix with respect to signal handling.
But we can detect this case, because getpid(2) will
return a different PID for each thread. In that case, sending SIGSTOP
to the PID associated with a thread will actually stop that thread
only.
In the second case, this is not possible. But getpid(2) returns the same
PID across all threads, which is detected, and TThread.Suspend() does
nothing in that case. This should probably be changed, but I know of
no way to suspend a thread when using NPTL.
If the symbol LINUX is not defined, then the unimplemented
function SuspendThread is called.
Johannes Berg <johannes@sipsolutions.de>, Sunday, November 16 2003
}
// ========== semaphore stuff ==========
{
I don't like this. It eats up 2 filedescriptors for each thread,
and those are a limited resource. If you have a server programm
handling client connections (one per thread) it will not be able
to handle many if we use 2 fds already for internal structures.
However, right now I don't see a better option unless some sem_*
functions are added to systhrds.
I encapsulated all used functions here to make it easier to
change them completely.
}
function SemaphoreInit: Pointer;
begin
SemaphoreInit := GetMem(SizeOf(TFilDes));
fppipe(PFilDes(SemaphoreInit)^);
end;
procedure SemaphoreWait(const FSem: Pointer);
var
b: byte;
begin
fpread(PFilDes(FSem)^[0], b, 1);
end;
procedure SemaphorePost(const FSem: Pointer);
begin
fpwrite(PFilDes(FSem)^[1], #0, 1);
end;
procedure SemaphoreDestroy(const FSem: Pointer);
begin
fpclose(PFilDes(FSem)^[0]);
fpclose(PFilDes(FSem)^[1]);
FreeMemory(FSem);
end;
// =========== semaphore end ===========
var
ThreadsInited: boolean = false;
{$IFDEF LINUX}
GMainPID: LongInt = 0;
{$ENDIF}
const
// stupid, considering its not even implemented...
Priorities: array [TThreadPriority] of Integer =
(-20,-19,-10,0,9,18,19);
procedure InitThreads;
begin
if not ThreadsInited then begin
ThreadsInited := true;
{$IFDEF LINUX}
GMainPid := fpgetpid();
{$ENDIF}
end;
end;
procedure DoneThreads;
begin
ThreadsInited := false;
end;
{ ok, so this is a hack, but it works nicely. Just never use
a multiline argument with WRITE_DEBUG! }
{$MACRO ON}
{$IFDEF DEBUG_MT}
{$define WRITE_DEBUG := writeln} // actually write something
{$ELSE}
{$define WRITE_DEBUG := //} // just comment out those lines
{$ENDIF}
function ThreadFunc(parameter: Pointer): LongInt; cdecl;
var
LThread: TThread;
c: char;
begin
WRITE_DEBUG('ThreadFunc is here...');
LThread := TThread(parameter);
{$IFDEF LINUX}
// save the PID of the "thread"
// this is different from the PID of the main thread if
// the LinuxThreads implementation is used
LThread.FPid := fpgetpid();
{$ENDIF}
WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
try
if LThread.FInitialSuspended then begin
SemaphoreWait(LThread.FSem);
if not LThread.FInitialSuspended then begin
WRITE_DEBUG('going into LThread.Execute');
LThread.Execute;
end;
end else begin
WRITE_DEBUG('going into LThread.Execute');
LThread.Execute;
end;
except
on e: exception do begin
WRITE_DEBUG('got exception: ',e.message);
LThread.FFatalException := TObject(AcquireExceptionObject);
// not sure if we should really do this...
// but .Destroy was called, so why not try FreeOnTerminate?
if e is EThreadDestroyCalled then LThread.FFreeOnTerminate := true;
end;
end;
WRITE_DEBUG('thread done running');
Result := LThread.FReturnValue;
WRITE_DEBUG('Result is ',Result);
LThread.FFinished := True;
LThread.DoTerminate;
if LThread.FreeOnTerminate then begin
WRITE_DEBUG('Thread should be freed');
LThread.Free;
WRITE_DEBUG('Thread freed');
end;
WRITE_DEBUG('thread func exiting');
end;
{ TThread }
constructor TThread.Create(CreateSuspended: Boolean);
begin
// lets just hope that the user doesn't create a thread
// via BeginThread and creates the first TThread Object in there!
InitThreads;
inherited Create;
FSem := SemaphoreInit;
FSuspended := true;
FSuspendedExternal := false;
FInitialSuspended := CreateSuspended;
FFatalException := nil;
WRITE_DEBUG('creating thread, self = ',longint(self));
FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID);
WRITE_DEBUG('TThread.Create done');
end;
destructor TThread.Destroy;
begin
if FThreadID = GetCurrentThreadID then begin
raise EThreadDestroyCalled.Create('A thread cannot destroy itself except by setting FreeOnTerminate and leaving!');
end;
// if someone calls .Free on a thread with
// FreeOnTerminate, then don't crash!
FFreeOnTerminate := false;
if not FFinished and not FSuspended then begin
Terminate;
WaitFor;
end;
if (FInitialSuspended) then begin
// thread was created suspended but never woken up.
SemaphorePost(FSem);
WaitFor;
end;
FFatalException.Free;
FFatalException := nil;
SemaphoreDestroy(FSem);
inherited Destroy;
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then
Suspend
else
Resume;
end;
procedure TThread.Suspend;
begin
if not FSuspended then begin
if FThreadID = GetCurrentThreadID then begin
FSuspended := true;
SemaphoreWait(FSem);
end else begin
FSuspendedExternal := true;
{$IFDEF LINUX}
// naughty hack if the user doesn't have Linux with NPTL...
// in that case, the PID of threads will not be identical
// to the other threads, which means that our thread is a normal
// process that we can suspend via SIGSTOP...
// this violates POSIX, but is the way it works on the
// LinuxThreads pthread implementation. Not with NPTL, but in that case
// getpid(2) also behaves properly and returns the same PID for
// all threads. Thats actually (FINALLY!) native thread support :-)
if FPid <> GMainPID then begin
FSuspended := true;
fpkill(FPid, SIGSTOP);
end;
{$ELSE}
SuspendThread(FHandle);
{$ENDIF}
end;
end;
end;
procedure TThread.Resume;
begin
if (not FSuspendedExternal) then begin
if FSuspended then begin
SemaphorePost(FSem);
FInitialSuspended := false;
FSuspended := False;
end;
end else begin
{$IFDEF LINUX}
// see .Suspend
if FPid <> GMainPID then begin
fpkill(FPid, SIGCONT);
FSuspended := False;
end;
{$ELSE}
ResumeThread(FHandle);
{$ENDIF}
FSuspendedExternal := false;
end;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: Integer;
begin
WRITE_DEBUG('waiting for thread ',FHandle);
WaitFor := WaitForThreadTerminate(FHandle, 0);
WRITE_DEBUG('thread terminated');
end;
procedure TThread.CallOnTerminate;
begin
// no need to check if FOnTerminate <> nil, because
// thats already done in DoTerminate
FOnTerminate(self);
end;
procedure TThread.DoTerminate;
begin
if Assigned(FOnTerminate) then
Synchronize(@CallOnTerminate);
end;
function TThread.GetPriority: TThreadPriority;
var
P: Integer;
I: TThreadPriority;
begin
P := ThreadGetPriority(FHandle);
Result := tpNormal;
for I := Low(TThreadPriority) to High(TThreadPriority) do
if Priorities[I] = P then
Result := I;
end;
procedure TThread.Synchronize(Method: TThreadMethod);
begin
{$TODO someone with more clue of the GUI stuff will have to do this}
end;
procedure TThread.SetPriority(Value: TThreadPriority);
begin
ThreadSetPriority(FHandle, Priorities[Value]);
end;
{$ENDIF}
{
$Log$
Revision 1.4 2003-11-03 09:42:27 marco
Revision 1.5 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.4 2003/11/17 08:27:49 marco
* pthreads based ttread from Johannes Berg
Revision 1.3 2003/11/10 16:54:28 marco
* new oldlinux unit. 1_0 defines killed in some former FCL parts.
Revision 1.2 2003/11/03 09:42:28 marco
* Peter's Cardinal<->Longint fixes patch
Revision 1.3 2003/10/27 17:12:45 marco
* fixes for signal handling.
Revision 1.2 2003/10/09 10:55:20 marco
* fix for moving classes to rtl while cycling with 1.0 start
Revision 1.1 2003/10/06 21:01:06 peter
* moved classes unit to rtl
Revision 1.12 2003/10/06 17:06:55 florian
Revision 1.9 2003/10/06 17:06:55 florian
* applied Johannes Berg's patch for exception handling in threads
Revision 1.11 2003/09/20 14:51:42 marco
* small v1_0 fix
Revision 1.8 2003/09/20 15:10:30 marco
* small fixes. fcl now compiles
Revision 1.10 2003/09/20 12:38:29 marco
* FCL now compiles for FreeBSD with new 1.1. Now Linux.
Revision 1.7 2002/12/18 20:44:36 peter
* use fillchar to clear sigset
Revision 1.9 2003/01/17 19:01:07 marco
* small fix
Revision 1.8 2002/11/17 21:09:44 marco
* 16byte sigset
Revision 1.7 2002/10/24 12:47:54 marco
* Fix emptying sa_mask
Revision 1.6 2002/09/07 15:15:24 peter
Revision 1.6 2002/09/07 15:15:27 peter
* old logs removed and tabs fixed
}

24
rtl/freebsd/unixsysc.inc
View File

@ -75,20 +75,19 @@ begin
do_syscall(syscall_nr_gettimeofday,longint(@tv),longint(@tz));
end;
}
Function fdFlush (fd : Longint) : Boolean;
Function fdFlush (fd : cint) : cint;
begin
fdflush:=do_syscall(syscall_nr_fsync,fd)=0;
fdflush:=do_syscall(syscall_nr_fsync,fd);
end;
Function Flock (fd,mode : longint) : boolean;
Function Flock (fd,mode : longint) : cint;
begin
Flock:=do_syscall(syscall_nr_flock,fd,mode)=0;
Flock:=do_syscall(syscall_nr_flock,fd,mode);
end;
Function StatFS(Path:Pathstr;Var Info:Tstatfs):Boolean;
Function StatFS(Path:Pathstr;Var Info:Tstatfs):cint;
{
Get all information on a fileSystem, and return it in Info.
@ -98,10 +97,10 @@ Function StatFS(Path:Pathstr;Var Info:Tstatfs):Boolean;
begin
path:=path+#0;
StatFS:=Do_Syscall(syscall_nr_statfs,longint(@path[1]),longint(@info))=0;
StatFS:=Do_Syscall(syscall_nr_statfs,longint(@path[1]),longint(@info));
end;
Function StatFS(Fd:Longint;Var Info:tstatfs):Boolean;
Function fStatFS(Fd:Longint;Var Info:tstatfs):cint;
{
Get all information on a fileSystem, and return it in Info.
Fd is the file descriptor of a file/directory on the fileSystem
@ -109,7 +108,7 @@ Function StatFS(Fd:Longint;Var Info:tstatfs):Boolean;
}
begin
StatFS:=do_syscall(syscall_nr_fstatfs,fd,longint(@info))=0;
fStatFS:=do_syscall(syscall_nr_fstatfs,fd,longint(@info));
end;
// needs oldfpccall;
@ -142,7 +141,7 @@ begin
end;
// can't have oldfpccall here, linux doesn't need it.
Function AssignPipe(var pipe_in,pipe_out:longint):cint; [public, alias : 'FPC_SYSC_ASSIGNPIPE'];
Function AssignPipe(var pipe_in,pipe_out:cint):cint; [public, alias : 'FPC_SYSC_ASSIGNPIPE'];
{
Sets up a pair of file variables, which act as a pipe. The first one can
be read from, the second one can be written to.
@ -244,7 +243,10 @@ end;
{
$Log$
Revision 1.13 2003-11-14 16:21:59 marco
Revision 1.14 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.13 2003/11/14 16:21:59 marco
* linuxerror elimination
Revision 1.12 2003/11/09 12:00:16 marco

39
rtl/linux/unixsysc.inc
View File

@ -14,17 +14,17 @@
**********************************************************************}
Function fdFlush (fd : Longint) : Boolean;
Function fdFlush (fd : cint) : cint;
begin
fdFlush := (do_SysCall(syscall_nr_fsync, fd)=0);
fdFlush := do_SysCall(syscall_nr_fsync, fd);
end;
Function Flock (fd,mode : longint) : boolean;
Function Flock (fd,mode : cint) : cint;
begin
flock:=do_Syscall(Syscall_nr_flock,fd,mode)=0;
flock:=do_Syscall(Syscall_nr_flock,fd,mode);
end;
Function StatFS(Path:Pathstr;Var Info:tstatfs):Boolean;
Function StatFS(Path:Pathstr;Var Info:tstatfs):cint;
{
Get all information on a fileSystem, and return it in Info.
Path is the name of a file/directory on the fileSystem you wish to
@ -32,20 +32,20 @@ Function StatFS(Path:Pathstr;Var Info:tstatfs):Boolean;
}
begin
path:=path+#0;
StatFS:=(do_SysCall(SysCall_nr_statfs,longint(@path[1]),longint(@Info))=0);
StatFS:=(do_SysCall(SysCall_nr_statfs,longint(@path[1]),longint(@Info));
end;
Function StatFS(Fd:Longint;Var Info:tstatfs):Boolean;
Function fStatFS(Fd:cint;Var Info:tstatfs):cint;
{
Get all information on a fileSystem, and return it in Info.
Fd is the file descriptor of a file/directory on the fileSystem
you wish to investigate.
}
begin
StatFS:=(do_SysCall(SysCall_nr_fstatfs,fd,longint(@info))=0);
fStatFS:=(do_SysCall(SysCall_nr_fstatfs,fd,longint(@info)));
end;
Function AssignPipe(var pipe_in,pipe_out:longint):cint; [public, alias : 'FPC_SYSC_ASSIGNPIPE'];
Function AssignPipe(var pipe_in,pipe_out:cint):cint; [public, alias : 'FPC_SYSC_ASSIGNPIPE'];
{
Sets up a pair of file variables, which act as a pipe. The first one can
@ -60,10 +60,10 @@ begin
pipe_out:=pip[2];
end;
Function PClose(Var F:text) :longint;
Function PClose(Var F:text) :cint;
var
pl : ^longint;
res : longint;
pl : ^cint;
res : cint;
begin
do_SysCall (syscall_nr_close,Textrec(F).Handle);
{ closed our side, Now wait for the other - this appears to be needed ?? }
@ -72,10 +72,10 @@ begin
pclose:=res shr 8;
end;
Function PClose(Var F:file) : longint;
Function PClose(Var F:file) : cint;
var
pl : ^longint;
res : longint;
pl : ^cint;
res : cint;
begin
do_SysCall (Syscall_nr_close,filerec(F).Handle);
{ closed our side, Now wait for the other - this appears to be needed ?? }
@ -90,7 +90,7 @@ end;
{$ifdef cpui386}
Function IOperm (From,Num : Cardinal; Value : Longint) : boolean;
Function IOperm (From,Num : cuint; Value : cint) : boolean;
{
Set permissions on NUM ports starting with port FROM to VALUE
this works ONLY as root.
@ -100,7 +100,7 @@ begin
IOPerm:=do_Syscall(Syscall_nr_ioperm,from,num,value)=0;
end;
Function IoPL(Level : longint) : Boolean;
Function IoPL(Level : cint) : Boolean;
begin
IOPL:=do_Syscall(Syscall_nr_iopl,level)=0;
@ -110,7 +110,10 @@ end;
{
$Log$
Revision 1.18 2003-11-13 17:40:12 marco
Revision 1.19 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.18 2003/11/13 17:40:12 marco
* small fixes
Revision 1.17 2003/11/13 13:36:23 marco

11
rtl/unix/crt.pp
View File

@ -1329,7 +1329,7 @@ var
c : char;
i : longint;
Begin
if isATTY(F.Handle) then
if isATTY(F.Handle)<>-1 then
begin
F.BufPos := 0;
i := 0;
@ -1636,10 +1636,10 @@ Initialization
Reset(Input);
TextRec(Input).Handle:=StdInputHandle;
{ Are we redirected to a file ? }
OutputRedir:= not IsAtty(TextRec(Output).Handle);
OutputRedir:= IsAtty(TextRec(Output).Handle)=-1;
{ does the input come from another console or from a file? }
InputRedir :=
not IsAtty(TextRec(Input).Handle) or
(IsAtty(TextRec(Input).Handle)=-1) or
(not OutputRedir and
(TTYName(TextRec(Input).Handle) <> TTYName(TextRec(Output).Handle)));
{ Get Size of terminal and set WindMax to the window }
@ -1681,7 +1681,10 @@ Finalization
End.
{
$Log$
Revision 1.13 2003-09-16 20:52:24 marco
Revision 1.14 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.13 2003/09/16 20:52:24 marco
* small cleanups. Mostly killing of already commented code in unix etc
Revision 1.12 2003/09/16 16:13:56 marco

13
rtl/unix/dos.pp
View File

@ -402,8 +402,8 @@ Function DiskFree(Drive: Byte): int64;
var
fs : tstatfs;
Begin
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and StatFS(StrPas(fixdrivestr[drive]),fs)) or
((not (drivestr[Drive]=nil)) and StatFS(StrPas(drivestr[drive]),fs)) then
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (StatFS(StrPas(fixdrivestr[drive]),fs)<>-1)) or
((not (drivestr[Drive]=nil)) and (StatFS(StrPas(drivestr[drive]),fs)<>-1)) then
Diskfree:=int64(fs.bavail)*int64(fs.bsize)
else
Diskfree:=-1;
@ -415,8 +415,8 @@ Function DiskSize(Drive: Byte): int64;
var
fs : tstatfs;
Begin
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and StatFS(StrPas(fixdrivestr[drive]),fs)) or
((not (drivestr[Drive]=nil)) and StatFS(StrPas(drivestr[drive]),fs)) then
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (StatFS(StrPas(fixdrivestr[drive]),fs)<>-1)) or
((not (drivestr[Drive]=nil)) and (StatFS(StrPas(drivestr[drive]),fs)<>-1)) then
DiskSize:=int64(fs.blocks)*int64(fs.bsize)
else
DiskSize:=-1;
@ -903,7 +903,10 @@ End.
{
$Log$
Revision 1.19 2003-10-17 22:13:30 olle
Revision 1.20 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.19 2003/10/17 22:13:30 olle
* changed i386 to cpui386
Revision 1.18 2003/09/27 12:51:33 peter

7
rtl/unix/keyboard.pp
View File

@ -307,7 +307,7 @@ var
begin
IsConsole:=false;
{ check for tty }
if IsATTY(stdinputhandle) then
if (IsATTY(stdinputhandle)<>-1) then
begin
{ running on a tty, find out whether locally or remotely }
ThisTTY:=TTYName(stdinputhandle);
@ -1532,7 +1532,10 @@ begin
end.
{
$Log$
Revision 1.15 2003-09-16 16:13:56 marco
Revision 1.16 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.15 2003/09/16 16:13:56 marco
* fdset functions renamed to fp<posix name>
Revision 1.14 2003/09/14 20:15:01 marco

13
rtl/unix/systhrds.pp
View File

@ -91,7 +91,9 @@ function pthread_mutex_init (p:ppthread_mutex_t;o:ppthread_mutex_attr_t):cint;
function pthread_mutex_destroy (p:ppthread_mutex_attr_t):cint; cdecl;external;
function pthread_mutex_lock (p:ppthread_mutex_attr_t):cint; cdecl;external;
function pthread_mutex_unlock (p:ppthread_mutex_attr_t):cint; cdecl;external;
function pthread_cancel(_para1:pthread_t):cint;cdecl;external;
function pthread_detach(_para1:pthread_t):cint;cdecl;external;
function pthread_join(_para1:pthread_t; _para2:Ppointer):cint;cdecl;external;
{$endif}
{*****************************************************************************
@ -230,7 +232,7 @@ CONST
{$endif DEBUG_MT}
ThreadMain:=pointer(ti.f(ti.p));
DoneThread;
pthread_detach(pthread_self);
pthread_detach(pointer(pthread_self));
end;
@ -286,7 +288,7 @@ CONST
procedure EndThread(ExitCode : DWord);
begin
DoneThread;
pthread_detach(pthread_self);
pthread_detach(pointer(pthread_self));
pthread_exit(pointer(ExitCode));
end;
@ -418,7 +420,10 @@ initialization
end.
{
$Log$
Revision 1.16 2003-11-17 08:27:50 marco
Revision 1.17 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.16 2003/11/17 08:27:50 marco
* pthreads based ttread from Johannes Berg
Revision 1.15 2003/10/01 21:00:09 peter

13
rtl/unix/sysutils.pp
View File

@ -357,8 +357,8 @@ Function DiskFree(Drive: Byte): int64;
var
fs : tstatfs;
Begin
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and statfs(StrPas(fixdrivestr[drive]),fs)) or
((not (drivestr[Drive]=nil)) and statfs(StrPas(drivestr[drive]),fs)) then
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (statfs(StrPas(fixdrivestr[drive]),fs)<>-1)) or
((not (drivestr[Drive]=nil)) and (statfs(StrPas(drivestr[drive]),fs)<>-1)) then
Diskfree:=int64(fs.bavail)*int64(fs.bsize)
else
Diskfree:=-1;
@ -370,8 +370,8 @@ Function DiskSize(Drive: Byte): int64;
var
fs : tstatfs;
Begin
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and statfs(StrPas(fixdrivestr[drive]),fs)) or
((not (drivestr[Drive]=nil)) and statfs(StrPas(drivestr[drive]),fs)) then
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (statfs(StrPas(fixdrivestr[drive]),fs)<>-1)) or
((not (drivestr[Drive]=nil)) and (statfs(StrPas(drivestr[drive]),fs)<>-1)) then
DiskSize:=int64(fs.blocks)*int64(fs.bsize)
else
DiskSize:=-1;
@ -490,7 +490,10 @@ end.
{
$Log$
Revision 1.24 2003-10-25 23:43:59 hajny
Revision 1.25 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.24 2003/10/25 23:43:59 hajny
* THandle in sysutils common using System.THandle
Revision 1.23 2003/10/07 08:28:49 marco

195
rtl/unix/unix.pp
View File

@ -62,7 +62,7 @@ Const
LOCK_NB = 4;
Type
Tpipe = array[1..2] of longint;
Tpipe = array[1..2] of cint;
pglob = ^tglob;
tglob = record
@ -115,12 +115,12 @@ var
tzname : array[boolean] of pchar;
{ timezone support }
procedure GetLocalTimezone(timer:longint;var leap_correct,leap_hit:longint);
procedure GetLocalTimezone(timer:longint);
procedure GetLocalTimezone(timer:cint;var leap_correct,leap_hit:cint);
procedure GetLocalTimezone(timer:cint);
procedure ReadTimezoneFile(fn:string);
function GetTimezoneFile:string;
Function GetEpochTime: longint;
Function GetEpochTime: cint;
procedure GetTime(var hour,min,sec,msec,usec:word);
procedure GetTime(var hour,min,sec,sec100:word);
procedure GetTime(var hour,min,sec:word);
@ -150,12 +150,12 @@ Function Execle(Todo: AnsiString;Ep:ppchar):cint;
Function Execlp(Todo: string;Ep:ppchar):cint;
Function Execlp(Todo: Ansistring;Ep:ppchar):cint;
Function Shell(const Command:String):Longint;
Function Shell(const Command:AnsiString):Longint;
Function Shell(const Command:String):cint;
Function Shell(const Command:AnsiString):cint;
{Clone for FreeBSD is copied from the LinuxThread port, and rfork based}
function Clone(func:TCloneFunc;sp:pointer;flags:longint;args:pointer):longint;
Function WaitProcess(Pid:longint):cint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
function Clone(func:TCloneFunc;sp:pointer;flags:cint;args:pointer):cint;
Function WaitProcess(Pid:cint):cint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
Function WIFSTOPPED(Status: Integer): Boolean;
Function W_EXITCODE(ReturnCode, Signal: Integer): Integer;
@ -165,30 +165,30 @@ Function W_STOPCODE(Signal: Integer): Integer;
File Handling
***************************}
Function fdFlush (fd : Longint) : Boolean;
Function fdFlush (fd : cint) : cint;
Function Flock (fd,mode : longint) : boolean;
Function Flock (var T : text;mode : longint) : boolean;
Function Flock (var F : File;mode : longint) : boolean;
Function Flock (fd,mode : cint) : cint ;
Function Flock (var T : text;mode : cint) : cint;
Function Flock (var F : File;mode : cint) : cint;
Function StatFS(Path:Pathstr;Var Info:tstatfs):Boolean;
Function StatFS(Fd: Longint;Var Info:tstatfs):Boolean;
Function StatFS(Path:Pathstr;Var Info:tstatfs):cint;
Function fStatFS(Fd: cint;Var Info:tstatfs):cint;
Function SelectText(var T:Text;TimeOut :PTimeVal):Longint;
Function SelectText(var T:Text;TimeOut :Longint):Longint;
Function SelectText(var T:Text;TimeOut :PTimeVal):cint;
Function SelectText(var T:Text;TimeOut :cint):cint;
{**************************
Directory Handling
***************************}
procedure SeekDir(p:pdir;off:longint);
function TellDir(p:pdir):longint;
procedure SeekDir(p:pdir;loc:clong);
function TellDir(p:pdir):clong;
{**************************
Pipe/Fifo/Stream
***************************}
Function AssignPipe(var pipe_in,pipe_out:longint):cint;
Function AssignPipe(var pipe_in,pipe_out:cint):cint;
Function AssignPipe(var pipe_in,pipe_out:text):cint;
Function AssignPipe(var pipe_in,pipe_out:file):cint;
Function PClose(Var F:text) : cint;
@ -208,21 +208,21 @@ Function GetHostName:String;
IOCtl/Termios Functions
***************************}
Function TCGetAttr(fd:longint;var tios:TermIOS):boolean;
Function TCSetAttr(fd:longint;OptAct:longint;const tios:TermIOS):boolean;
Procedure CFSetISpeed(var tios:TermIOS;speed:Cardinal);
Procedure CFSetOSpeed(var tios:TermIOS;speed:Cardinal);
Procedure CFMakeRaw(var tios:TermIOS);
Function TCSendBreak(fd,duration:longint):boolean;
Function TCSetPGrp(fd,id:longint):boolean;
Function TCGetPGrp(fd:longint;var id:longint):boolean;
Function TCFlush(fd,qsel:longint):boolean;
Function TCDrain(fd:longint):boolean;
Function TCFlow(fd,act:longint):boolean;
Function IsATTY(Handle:Longint):Boolean;
Function IsATTY(var f:text):Boolean;
function TTYname(Handle:Longint):string;
function TTYname(var F:Text):string;
Function TCGetAttr (fd:cint;var tios:TermIOS):cint;
Function TCSetAttr (fd:cint;OptAct:cint;const tios:TermIOS):cint;
Procedure CFSetISpeed (var tios:TermIOS;speed:Cardinal);
Procedure CFSetOSpeed (var tios:TermIOS;speed:Cardinal);
Procedure CFMakeRaw (var tios:TermIOS);
Function TCSendBreak (fd,duration:cint):cint;
Function TCSetPGrp (fd,id:cint) :cint;
Function TCGetPGrp (fd:cint;var id:cint):cint;
Function TCFlush (fd,qsel:cint):cint;
Function TCDrain (fd:cint) :cint;
Function TCFlow (fd,act:cint) :cint;
Function IsATTY (Handle:cint) :cint;
Function IsATTY (var f:text) :cint;
function TTYname (Handle:cint):string;
function TTYname (var F:Text) :string;
{**************************
Memory functions
@ -250,7 +250,6 @@ const
Utility functions
***************************}
Function Octal(l:longint):longint;
Function FExpand(Const Path: PathStr):PathStr;
Function FSearch(const path:pathstr;dirlist:string):pathstr;
Function Glob(Const path:pathstr):pglob;
@ -294,8 +293,8 @@ Function getenv(name:string):Pchar; external name 'FPC_SYSC_FPGETENV';
******************************************************************************}
{ Most calls of WaitPID do not handle the result correctly, this funktion treats errors more correctly }
Function WaitProcess(Pid:longint):cint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
var ret,r,s : LongInt;
Function WaitProcess(Pid:cint):cint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
var ret,r,s : cint;
begin
s:=$7F00;
@ -322,7 +321,7 @@ begin
end;
end;
function InternalCreateShellArgV(cmd:pChar; len:longint):ppchar;
function InternalCreateShellArgV(cmd:pChar; len:cint):ppchar;
{
Create an argv which executes a command in a shell using /bin/sh -c
}
@ -546,7 +545,7 @@ Function Shell(const Command:String):cint;
}
var
p : ppchar;
pid : longint;
pid : cint;
begin
p:=CreateShellArgv(command);
pid:=fpfork;
@ -569,7 +568,7 @@ Function Shell(const Command:AnsiString):cint;
}
var
p : ppchar;
pid : longint;
pid : cint;
begin { Changes as above }
p:=CreateShellArgv(command);
pid:=fpfork;
@ -606,7 +605,7 @@ end;
Date and Time related calls
******************************************************************************}
Function GetEpochTime: longint;
Function GetEpochTime: cint;
{
Get the number of seconds since 00:00, January 1 1970, GMT
the time NOT corrected any way
@ -670,15 +669,15 @@ End;
{$ifndef BSD}
{$ifdef linux}
Function stime (t : longint) : Boolean;
Function stime (t : cint) : Boolean;
begin
stime:=do_SysCall(Syscall_nr_stime,longint(@t))=0;
stime:=do_SysCall(Syscall_nr_stime,cint(@t))=0;
end;
{$endif}
{$endif}
{$ifdef BSD}
Function stime (t : longint) : Boolean;
Function stime (t : cint) : Boolean;
begin
end;
{$endif}
@ -722,18 +721,18 @@ begin
Execl:=ExecLE(ToDo,EnvP);
end;
Function Flock (var T : text;mode : longint) : boolean;
Function Flock (var T : text;mode : cint) : cint;
begin
Flock:=Flock(TextRec(T).Handle,mode);
end;
Function Flock (var F : File;mode : longint) : boolean;
Function Flock (var F : File;mode : cint) :cint;
begin
Flock:=Flock(FileRec(F).Handle,mode);
end;
Function SelectText(var T:Text;TimeOut :PTimeval):Longint;
Function SelectText(var T:Text;TimeOut :PTimeval):cint;
Var
F:TfdSet;
begin
@ -750,7 +749,7 @@ begin
SelectText:=fpselect(textrec(T).handle+1,nil,@f,nil,TimeOut);
end;
Function SelectText(var T:Text;TimeOut :Longint):Longint;
Function SelectText(var T:Text;TimeOut :cint):cint;
var
p : PTimeVal;
tv : TimeVal;
@ -770,7 +769,7 @@ end;
Directory
******************************************************************************}
procedure SeekDir(p:pdir;off:longint);
procedure SeekDir(p:pdir;loc:clong);
begin
if p=nil then
begin
@ -778,13 +777,13 @@ begin
exit;
end;
{$ifndef bsd}
p^.dd_nextoff:=fplseek(p^.dd_fd,off,seek_set);
p^.dd_nextoff:=fplseek(p^.dd_fd,loc,seek_set);
{$endif}
p^.dd_size:=0;
p^.dd_loc:=0;
end;
function TellDir(p:pdir):longint;
function TellDir(p:pdir):clong;
begin
if p=nil then
begin
@ -857,7 +856,7 @@ Function AssignPipe(var pipe_in,pipe_out:text):cint;
be read from, the second one can be written to.
}
var
f_in,f_out : longint;
f_in,f_out : cint;
begin
if AssignPipe(f_in,f_out)=-1 then
exit(-1);
@ -889,7 +888,7 @@ Function AssignPipe(var pipe_in,pipe_out:file):cint;
If the operation was unsuccesful,
}
var
f_in,f_out : longint;
f_in,f_out : cint;
begin
if AssignPipe(f_in,f_out)=-1 then
exit(-1);
@ -1006,8 +1005,8 @@ Function POpen(var F:file;const Prog:String;rw:char):cint;
var
pipi,
pipo : file;
pid : longint;
pl : ^longint;
pid : cint;
pl : ^cint;
p,pp : ppchar;
temp : string[255];
ret : cint;
@ -1095,8 +1094,8 @@ Function AssignStream(Var StreamIn,Streamout:text;Const Prog:String) : cint;
var
pipi,
pipo : text;
pid : longint;
pl : ^Longint;
pid : cint;
pl : ^cint;
begin
AssignStream:=-1;
if AssignPipe(streamin,pipo)=-1 Then
@ -1144,7 +1143,7 @@ begin
end;
end;
function AssignStream(var StreamIn, StreamOut, StreamErr: Text; const prog: String): LongInt;
function AssignStream(var StreamIn, StreamOut, StreamErr: Text; const prog: String):cint;
{
Starts the program in 'prog' and makes its input, output and error output the
other end of three pipes, which are the stdin, stdout and stderr of a program
@ -1159,8 +1158,8 @@ function AssignStream(var StreamIn, StreamOut, StreamErr: Text; const prog: Stri
}
var
PipeIn, PipeOut, PipeErr: text;
pid: LongInt;
pl: ^LongInt;
pid: cint;
pl: ^cint;
begin
AssignStream := -1;
@ -1284,19 +1283,19 @@ end;
IOCtl and Termios calls
******************************************************************************}
Function TCGetAttr(fd:longint;var tios:TermIOS):boolean;
Function TCGetAttr(fd:cint;var tios:TermIOS):cint;
begin
{$ifndef BSD}
TCGetAttr:=fpIOCtl(fd,TCGETS,@tios)=0;
TCGetAttr:=fpIOCtl(fd,TCGETS,@tios);
{$else}
TCGETAttr:=fpIoCtl(Fd,TIOCGETA,@tios)=0;
TCGETAttr:=fpIoCtl(Fd,TIOCGETA,@tios);
{$endif}
end;
Function TCSetAttr(fd:longint;OptAct:longint;const tios:TermIOS):boolean;
Function TCSetAttr(fd:cint;OptAct:cint;const tios:TermIOS):cint;
var
nr:longint;
nr:cint;
begin
{$ifndef BSD}
case OptAct of
@ -1312,11 +1311,11 @@ begin
else
begin
fpsetErrNo(ESysEINVAL);
TCSetAttr:=false;
TCSetAttr:=-1;
exit;
end;
end;
TCSetAttr:=fpIOCtl(fd,nr,@Tios)=0;
TCSetAttr:=fpIOCtl(fd,nr,@Tios);
end;
@ -1369,60 +1368,60 @@ begin
{$endif}
end;
Function TCSendBreak(fd,duration:longint):boolean;
Function TCSendBreak(fd,duration:cint):cint;
begin
{$ifndef BSD}
TCSendBreak:=fpIOCtl(fd,TCSBRK,pointer(duration))=0;
TCSendBreak:=fpIOCtl(fd,TCSBRK,pointer(duration));
{$else}
TCSendBreak:=fpIOCtl(fd,TIOCSBRK,0)=0;
TCSendBreak:=fpIOCtl(fd,TIOCSBRK,0);
{$endif}
end;
Function TCSetPGrp(fd,id:longint):boolean;
Function TCSetPGrp(fd,id:cint):cint;
begin
TCSetPGrp:=fpIOCtl(fd,TIOCSPGRP,pointer(id))=0;
TCSetPGrp:=fpIOCtl(fd,TIOCSPGRP,pointer(id));
end;
Function TCGetPGrp(fd:longint;var id:longint):boolean;
Function TCGetPGrp(fd:cint;var id:cint):cint;
begin
TCGetPGrp:=fpIOCtl(fd,TIOCGPGRP,@id)=0;
TCGetPGrp:=fpIOCtl(fd,TIOCGPGRP,@id);
end;
Function TCDrain(fd:longint):boolean;
Function TCDrain(fd:cint):cint;
begin
{$ifndef BSD}
TCDrain:=fpIOCtl(fd,TCSBRK,pointer(1))=0;
TCDrain:=fpIOCtl(fd,TCSBRK,pointer(1));
{$else}
TCDrain:=fpIOCtl(fd,TIOCDRAIN,0)=0; {Should set timeout to 1 first?}
TCDrain:=fpIOCtl(fd,TIOCDRAIN,0); {Should set timeout to 1 first?}
{$endif}
end;
Function TCFlow(fd,act:longint):boolean;
Function TCFlow(fd,act:cint):cint;
begin
{$ifndef BSD}
TCFlow:=fpIOCtl(fd,TCXONC,pointer(act))=0;
TCFlow:=fpIOCtl(fd,TCXONC,pointer(act));
{$else}
case act OF
TCOOFF : TCFlow:=fpIoctl(fd,TIOCSTOP,0)=0;
TCOOn : TCFlow:=fpIOctl(Fd,TIOCStart,0)=0;
TCOOFF : TCFlow:=fpIoctl(fd,TIOCSTOP,0);
TCOOn : TCFlow:=fpIOctl(Fd,TIOCStart,0);
TCIOFF : {N/I}
end;
{$endif}
end;
Function TCFlush(fd,qsel:longint):boolean;
Function TCFlush(fd,qsel:cint):cint;
begin
{$ifndef BSD}
TCFlush:=fpIOCtl(fd,TCFLSH,pointer(qsel))=0;
TCFlush:=fpIOCtl(fd,TCFLSH,pointer(qsel));
{$else}
TCFlush:=fpIOCtl(fd,TIOCFLUSH,pointer(qsel))=0;
TCFlush:=fpIOCtl(fd,TIOCFLUSH,pointer(qsel));
{$endif}
end;
Function IsATTY (Handle:Longint):Boolean;
Function IsATTY (Handle:cint):cint;
{
Check if the filehandle described by 'handle' is a TTY (Terminal)
}
@ -1433,7 +1432,7 @@ begin
end;
Function IsATTY(var f: text):Boolean;
Function IsATTY(var f: text):cint;
{
Idem as previous, only now for text variables.
}
@ -1442,7 +1441,7 @@ begin
end;
function TTYName(Handle:Longint):string;
function TTYName(Handle:cint):string;
{
Return the name of the current tty described by handle f.
returns empty string in case of an error.
@ -1499,8 +1498,7 @@ var
begin
TTYName:='';
fpfstat(handle,st);
if (fpgeterrno<>0) and isatty (handle) then
if (fpfstat(handle,st)=-1) and (isatty (handle)<>-1) then
exit;
mydev:=st.st_dev;
myino:=st.st_ino;
@ -1521,13 +1519,14 @@ end;
Utility calls
******************************************************************************}
Function Octal(l:longint):longint;
{
Function Octal(l:cint):cint;
{
Convert an octal specified number to decimal;
}
var
octnr,
oct : longint;
oct : cint;
begin
octnr:=0;
oct:=0;
@ -1539,7 +1538,7 @@ begin
end;
Octal:=oct;
end;
}
{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
{$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
@ -1557,7 +1556,7 @@ Function FSearch(const path:pathstr;dirlist:string):pathstr;
}
Var
NewDir : PathStr;
p1 : Longint;
p1 : cint;
Info : Stat;
Begin
{Replace ':' with ';'}
@ -1677,7 +1676,7 @@ begin
glob:=root;
end;
Function GetFS (var T:Text):longint;
Function GetFS (var T:Text):cint;
{
Get File Descriptor of a text file.
}
@ -1689,7 +1688,7 @@ begin
end;
Function GetFS(Var F:File):longint;
Function GetFS(Var F:File):cint;
{
Get File Descriptor of an unTyped file.
}
@ -1705,7 +1704,6 @@ end;
Stat.Mode Macro's
--------------------------------}
Initialization
InitLocalTime;
@ -1715,7 +1713,10 @@ End.
{
$Log$
Revision 1.47 2003-11-14 17:30:14 marco
Revision 1.48 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.47 2003/11/14 17:30:14 marco
* weeehoo linuxerror is no more :-)
Revision 1.46 2003/11/14 16:44:48 marco

9
rtl/unix/video.pp
View File

@ -625,7 +625,7 @@ begin
{$endif CPUI386}
{ check for tty }
ThisTTY:=TTYName(stdinputhandle);
if IsATTY(stdinputhandle) then
if (IsATTY(stdinputhandle)<>-1) then
begin
{ save current terminal characteristics and remove rawness }
prepareInitVideo;
@ -641,7 +641,7 @@ begin
Case ThisTTY[9] of
'0'..'9' : begin { running Linux on native console or native-emulation }
FName:='/dev/vcsa' + ThisTTY[9];
TTYFd:=fpOpen(FName, Octal(666), Open_RdWr); { open console }
TTYFd:=fpOpen(FName, &666, Open_RdWr); { open console }
IF TTYFd <>-1 Then
Console:=ttyLinux;
end;
@ -898,7 +898,10 @@ initialization
end.
{
$Log$
Revision 1.18 2003-10-26 15:32:25 marco
Revision 1.19 2003-11-17 10:05:51 marco
* threads for FreeBSD. Not working tho
Revision 1.18 2003/10/26 15:32:25 marco
* partial fix for bug 2212.
Revision 1.17 2003/10/25 22:48:52 marco