From b564e018d1d658d86bba7994a98a0f38bbab6d94 Mon Sep 17 00:00:00 2001 From: marco Date: Wed, 5 Sep 2001 14:30:04 +0000 Subject: [PATCH] * NetBSD fcl makefile fixes. Plain copy from FreeBSD --- fcl/Makefile | 6 +- fcl/Makefile.fpc | 2 + fcl/netbsd/classes.pp | 109 ++++++++++++++ fcl/netbsd/process.inc | 141 ++++++++++++++++++ fcl/netbsd/thread.inc | 330 +++++++++++++++++++++++++++++++++++++++++ 5 files changed, 587 insertions(+), 1 deletion(-) create mode 100644 fcl/netbsd/classes.pp create mode 100644 fcl/netbsd/process.inc create mode 100644 fcl/netbsd/thread.inc diff --git a/fcl/Makefile b/fcl/Makefile index 7a9950ba7b..576267080d 100644 --- a/fcl/Makefile +++ b/fcl/Makefile @@ -1,5 +1,5 @@ # -# Don't edit, this file is generated by FPCMake Version 1.1 [2001/08/30] +# Don't edit, this file is generated by FPCMake Version 1.1 [2001/09/05] # default: all override PATH:=$(subst \,/,$(PATH)) @@ -146,6 +146,9 @@ endif ifeq ($(OS_TARGET),freebsd) override TARGET_UNITS+=process asyncio ssockets http endif +ifeq ($(OS_TARGET),netbsd) +override TARGET_UNITS+=process asyncio ssockets http +endif override TARGET_RSTS+=classes ssockets cachecls override TARGET_EXAMPLEDIRS+=tests override INSTALL_FPCPACKAGE=y @@ -605,6 +608,7 @@ endif ifeq ($(OS_TARGET),netbsd) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_PASZLIB=1 +REQUIRE_PACKAGES_INET=1 endif ifeq ($(OS_TARGET),amiga) REQUIRE_PACKAGES_RTL=1 diff --git a/fcl/Makefile.fpc b/fcl/Makefile.fpc index d428d38a87..086f29de67 100644 --- a/fcl/Makefile.fpc +++ b/fcl/Makefile.fpc @@ -10,11 +10,13 @@ version=1.0.5 packages=paszlib packages_linux=inet packages_freebsd=inet +packages_netbsd=inet [target] dirs=xml db shedit units=classes inifiles registry ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls units_freebsd=process asyncio ssockets http +units_netbsd=process asyncio ssockets http units_linux=process asyncio ssockets http units_win32=process fileinfo rsts=classes ssockets cachecls diff --git a/fcl/netbsd/classes.pp b/fcl/netbsd/classes.pp new file mode 100644 index 0000000000..da6082fa6e --- /dev/null +++ b/fcl/netbsd/classes.pp @@ -0,0 +1,109 @@ +{ + $Id$ + This file is part of the Free Component Library (FCL) + Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl + + Classes unit for linux + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +{$mode objfpc} + +{ determine the type of the resource/form file } +{$define Win16Res} + +unit Classes; + +interface + +uses + sysutils, + typinfo; + +{$i classesh.inc} + +implementation + +uses +{$ifdef ver1_0} + linux +{$else} + unix +{$endif} + ; + +{ OS - independent class implementations are in /inc directory. } +{$i classes.inc} + + +initialization + CommonInit; + +finalization + CommonCleanup; + + if ThreadsInited then + DoneThreads; + +end. +{ + $Log$ + Revision 1.1 2001-09-05 14:30:04 marco + * NetBSD fcl makefile fixes. Plain copy from FreeBSD + + Revision 1.4 2001/04/08 11:26:03 peter + * update so it can be compiled by both 1.0.x and 1.1 + + Revision 1.3 2001/01/21 20:45:09 marco + * Rename fest II FCL version. + + Revision 1.2 2000/10/26 22:30:21 peter + * freebsd update + * classes.rst + + Revision 1.1.2.1 2000/10/17 13:47:43 marco + * Copy of fcl/linux dir with adapted makefiles to ease FreeBSD 1.0.2 + packaging + + Revision 1.1 2000/07/13 06:31:32 michael + + Initial import + + Revision 1.19 2000/07/01 09:49:02 peter + * fixed go32v2,win32 build + + Revision 1.18 2000/06/29 16:32:06 sg + * Changes in initialisation/finalisation for streaming support + + Revision 1.17 2000/06/27 17:17:34 lazarus + Added code for registerclass, GetClass and RegisterClasses + Shane + + Revision 1.16 2000/06/27 15:55:19 lazarus + Added TThreadlist code. Shane + + Revision 1.15 2000/01/07 01:24:34 peter + * updated copyright to 2000 + + Revision 1.14 2000/01/07 00:01:33 peter + * uses typinfo moved to interface + + Revision 1.13 2000/01/06 01:20:33 peter + * moved out of packages/ back to topdir + + Revision 1.2 2000/01/04 18:07:58 michael + + Added typinfo unit + + Revision 1.1 2000/01/03 19:33:09 peter + * moved to packages dir + + Revision 1.11 1999/05/30 10:46:41 peter + * start of tthread for linux,win32 + +} diff --git a/fcl/netbsd/process.inc b/fcl/netbsd/process.inc new file mode 100644 index 0000000000..a4e8357bcf --- /dev/null +++ b/fcl/netbsd/process.inc @@ -0,0 +1,141 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt + + Linux specific part of TProcess. + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +uses +{$ifdef ver1_0} + Linux +{$else} + Unix +{$endif} + ; + +Function TProcess.GetRunning : Boolean; + +begin + IF FRunning then + FRunning:=GetExitStatus=-1; + Result:=FRunning; +end; + +Procedure TProcess.Execute; + +begin + FreeStreams; + CreatePipeStreams (FChildInputSTream,FParentOutPutStream); + CreatePipeStreams (FParentInputStream,FChildOutPutStream); + If poUsePipes in FCreateOptions then + begin + if poStdErrToOutPut in FCreateOptions then + CreatePipeStreams (FParentErrorStream,FChildErrorStream) + else + begin + FChildErrorStream:=FChildOutPutStream; + FParentErrorStream:=FParentInputStream; + end; + end + else + CreatePipeStreams (FParentErrorStream,FChildErrorStream); + If FCurrentDirectory<>'' then + Chdir(FCurrentDirectory); + FHandle:=fork(); + if FHandle=0 then + begin + // Child + fdClose(0); + fdClose(1); + fdclose(2); + dup2(FChildInputStream.Handle,0); + dup2(FCHildOutputStream.Handle,1); + dup2(FChildErrorStream.Handle,2); + execl(FCommandline); + halt(127); + end + else + begin + // Parent + FPID:=FHandle; + FThreadHandle:=FHandle; + fdclose(FChildOutputStream.Handle); + fdclose(FChildInputStream.Handle); + fdclose(FChildErrorStream.Handle); + FRunning:=True; + if (poWaitOnExit in FCreateOptions) and + not (poRunSuspended in FCreateOptions) then + WaitOnExit; + end; +end; + +Function TProcess.WaitOnExit : Dword; + +begin + waitpid(FPID, nil, 0); +{ + Result:=WaitForSingleObject (FprocessInformation.hProcess,Infinite); + If Result<>Wait_Failed then + GetExitStatus; +} FRunning:=False; + Result := 0; +end; + +Function TProcess.Suspend : Longint; + +begin + Result:=Kill(Handle,SIGSTOP); +end; + +Function TProcess.Resume : LongInt; + +begin + Result:=Kill(FHandle,SIGCONT); +end; + +Function TProcess.Terminate(AExitCode : Integer) : Boolean; + +begin + Result:=False; + If ExitStatus=-1 then + Result:=Kill(FHandle,SIGTERM)=0; +end; + +{ + $Log$ + Revision 1.1 2001-09-05 14:30:04 marco + * NetBSD fcl makefile fixes. Plain copy from FreeBSD + + Revision 1.4 2001/04/08 11:26:03 peter + * update so it can be compiled by both 1.0.x and 1.1 + + Revision 1.3 2001/01/21 20:45:09 marco + * Rename fest II FCL version. + + Revision 1.2 2000/10/26 22:30:21 peter + * freebsd update + * classes.rst + + Revision 1.1.2.1 2000/10/17 13:47:43 marco + * Copy of fcl/linux dir with adapted makefiles to ease FreeBSD 1.0.2 + packaging + + Revision 1.1 2000/07/13 06:33:44 michael + + Initial import + + Revision 1.5 2000/02/15 22:03:38 sg + * Inserted wrong copyright notice ;) Fixed. + + Revision 1.4 2000/02/15 21:57:51 sg + * Added copyright notice and CVS log tags where necessary + +} diff --git a/fcl/netbsd/thread.inc b/fcl/netbsd/thread.inc new file mode 100644 index 0000000000..66cd3f4ae6 --- /dev/null +++ b/fcl/netbsd/thread.inc @@ -0,0 +1,330 @@ +{ + $Id$ + This file is part of the Free Component Library (FCL) + Copyright (c) 1999-2000 by Peter Vreman + + Linux TThread implementation + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +type + PThreadRec=^TThreadRec; + TThreadRec=record + thread : TThread; + next : PThreadRec; + end; + +var + ThreadRoot : PThreadRec; + ThreadsInited : boolean; +// MainThreadID: longint; + +Const + ThreadCount: longint = 0; + +function ThreadSelf:TThread; +var + hp : PThreadRec; + sp : longint; +begin + sp:=SPtr; + hp:=ThreadRoot; + while assigned(hp) do + begin + if (sp<=hp^.Thread.FStackPointer) and + (sp>(hp^.Thread.FStackPointer-hp^.Thread.FStackSize)) then + begin + Result:=hp^.Thread; + exit; + end; + hp:=hp^.next; + end; + Result:=nil; +end; + + +//function SIGCHLDHandler(Sig: longint): longint; cdecl;//this is std linux C declaration as function +procedure SIGCHLDHandler(Sig: longint); cdecl; +begin + waitpid(-1, nil, WNOHANG); +end; + +procedure InitThreads; +var + Act, OldAct: 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() + + GetMem(Act, SizeOf(SigActionRec)); + GetMem(OldAct, SizeOf(SigActionRec)); + + Act^.handler.sh := @SIGCHLDHandler; + Act^.sa_flags := SA_NOCLDSTOP {or SA_NOMASK or SA_RESTART}; + Act^.sa_mask := 0; //Do not block all signals ??. Don't need if SA_NOMASK in flags + + SigAction(SIGCHLD, Act, OldAct); + + FreeMem(Act, SizeOf(SigActionRec)); + FreeMem(OldAct, SizeOf(SigActionRec)); +end; + + +procedure DoneThreads; +var + hp : PThreadRec; +begin + while assigned(ThreadRoot) do + begin + ThreadRoot^.Thread.Destroy; + hp:=ThreadRoot; + ThreadRoot:=ThreadRoot^.Next; + dispose(hp); + end; + ThreadsInited:=false; +end; + + +procedure AddThread(t:TThread); +var + hp : PThreadRec; +begin + { Need to initialize threads ? } + if not ThreadsInited then + InitThreads; + + { Put thread in the linked list } + new(hp); + hp^.Thread:=t; + hp^.next:=ThreadRoot; + ThreadRoot:=hp; + + inc(ThreadCount, 1); +end; + + +procedure RemoveThread(t:TThread); +var + lasthp,hp : PThreadRec; +begin + hp:=ThreadRoot; + lasthp:=nil; + while assigned(hp) do + begin + if hp^.Thread=t then + begin + if assigned(lasthp) then + lasthp^.next:=hp^.next + else + ThreadRoot:=hp^.next; + dispose(hp); + exit; + end; + lasthp:=hp; + hp:=hp^.next; + end; + + Dec(ThreadCount, 1); + if ThreadCount = 0 then DoneThreads; +end; + + +{ TThread } +function ThreadProc(args:pointer): Integer;cdecl; +var + FreeThread: Boolean; + Thread : TThread absolute args; +begin + Thread.Execute; + FreeThread := Thread.FFreeOnTerminate; + Result := Thread.FReturnValue; + Thread.FFinished := True; + Thread.DoTerminate; + if FreeThread then + Thread.Free; + ExitProcess(Result); +end; + + +constructor TThread.Create(CreateSuspended: Boolean); +var + Flags: Integer; +begin + inherited Create; + AddThread(self); + FSuspended := CreateSuspended; + Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD; + { Setup 16k of stack } + FStackSize:=16384; + Getmem(pointer(FStackPointer),FStackSize); + inc(FStackPointer,FStackSize); + FCallExitProcess:=false; + { Clone } + FHandle:= Clone(@ThreadProc,pointer(FStackPointer),Flags,self); + if FSuspended then Suspend; + FThreadID := FHandle; +end; + + +destructor TThread.Destroy; +begin + if not FFinished and not Suspended then + begin + Terminate; + WaitFor; + end; + if FHandle <> -1 then + Kill(FHandle, SIGKILL); + dec(FStackPointer,FStackSize); + Freemem(pointer(FStackPointer),FStackSize); + inherited Destroy; + RemoveThread(self); +end; + + +procedure TThread.CallOnTerminate; +begin + FOnTerminate(Self); +end; + +procedure TThread.DoTerminate; +begin + if Assigned(FOnTerminate) then + Synchronize(@CallOnTerminate); +end; + + +const +{ I Don't know idle or timecritical, value is also 20, so the largest other + possibility is 19 (PFV) } + Priorities: array [TThreadPriority] of Integer = + (-20,-19,-10,9,10,19,20); + +function TThread.GetPriority: TThreadPriority; +var + P: Integer; + I: TThreadPriority; +begin + P := {$ifdef ver1_0}Linux{$else}Unix{$endif}.GetPriority(Prio_Process,FHandle); + Result := tpNormal; + for I := Low(TThreadPriority) to High(TThreadPriority) do + if Priorities[I] = P then + Result := I; +end; + + +procedure TThread.SetPriority(Value: TThreadPriority); +begin + {$ifdef ver1_0}Linux{$else}Unix{$endif}.SetPriority(Prio_Process,FHandle, Priorities[Value]); +end; + + +procedure TThread.Synchronize(Method: TThreadMethod); +begin + FSynchronizeException := nil; + FMethod := Method; +{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); } + if Assigned(FSynchronizeException) then + raise FSynchronizeException; +end; + + +procedure TThread.SetSuspended(Value: Boolean); +begin + if Value <> FSuspended then + if Value then + Suspend + else + Resume; +end; + + +procedure TThread.Suspend; +begin + Kill(FHandle, SIGSTOP); + FSuspended := true; +end; + + +procedure TThread.Resume; +begin + Kill(FHandle, SIGCONT); + FSuspended := False; +end; + + +procedure TThread.Terminate; +begin + FTerminated := True; +end; + +function TThread.WaitFor: Integer; +var + status : longint; +begin + if FThreadID = MainThreadID then + WaitPid(0,@status,0) + else + WaitPid(FHandle,@status,0); + Result:=status; +end; + +{ + $Log$ + Revision 1.1 2001-09-05 14:30:04 marco + * NetBSD fcl makefile fixes. Plain copy from FreeBSD + + Revision 1.4 2001/04/08 11:26:03 peter + * update so it can be compiled by both 1.0.x and 1.1 + + Revision 1.3 2001/01/21 20:45:09 marco + * Rename fest II FCL version. + + Revision 1.2 2000/10/26 22:30:21 peter + * freebsd update + * classes.rst + + Revision 1.1.2.1 2000/10/17 13:47:43 marco + * Copy of fcl/linux dir with adapted makefiles to ease FreeBSD 1.0.2 + packaging + + Revision 1.1 2000/07/13 06:33:44 michael + + Initial import + + Revision 1.9 2000/05/17 18:31:18 peter + * fixed for new sigactionrec + + Revision 1.8 2000/01/07 01:24:34 peter + * updated copyright to 2000 + + Revision 1.7 2000/01/06 01:20:33 peter + * moved out of packages/ back to topdir + + Revision 1.1 2000/01/03 19:33:09 peter + * moved to packages dir + + Revision 1.5 1999/10/27 10:40:30 peter + * fixed threadproc decl + + Revision 1.4 1999/08/28 09:32:26 peter + * readded header/log + + Revision 1.2 1999/05/31 12:47:59 peter + * classes unit to unitobjects + + Revision 1.1 1999/05/30 10:46:42 peter + * start of tthread for linux,win32 + +}