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

+ Initial version of customapplication object

Browse Source
This commit is contained in:
michael 2003-05-29 09:58:30 +00:00
parent ec1caa3e51
commit 4f91ae9605
12 changed files with 809 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

319
fcl/Makefile
View File

@ -1,8 +1,8 @@
#
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/04/25]
# Don't edit, this file is generated by FPCMake Version 1.1 [2002/10/05]
#
default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos macosx emx
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx
override PATH:=$(subst \,/,$(PATH))
ifeq ($(findstring ;,$(PATH)),)
inUnix=1
@ -58,7 +58,7 @@ ifdef inUnix
PATHSEP=/
else
PATHSEP:=$(subst /,\,/)
ifdef inCygWin
ifneq ($(findstring sh.exe,$(SHELL)),)
PATHSEP=/
endif
endif
@ -111,11 +111,38 @@ endif
override FPC:=$(subst $(SRCEXEEXT),,$(FPC))
override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT)
ifndef FPC_VERSION
FPC_COMPILERINFO:=$(shell $(FPC) -iVSPTPSOTO)
FPC_VERSION:=$(word 1,$(FPC_COMPILERINFO))
FPC_VERSION:=$(shell $(FPC) -iV)
endif
export FPC FPC_VERSION FPC_COMPILERINFO
export FPC FPC_VERSION
unexport CHECKDEPEND ALLDEPENDENCIES
ifeq ($(findstring 1.0.,$(FPC_VERSION)),)
COMPILERINFO:=$(shell $(FPC) -iSP -iTP -iSO -iTO)
ifndef CPU_SOURCE
CPU_SOURCE:=$(word 1,$(COMPILERINFO))
endif
ifndef CPU_TARGET
CPU_TARGET:=$(word 2,$(COMPILERINFO))
endif
ifndef OS_SOURCE
OS_SOURCE:=$(word 3,$(COMPILERINFO))
endif
ifndef OS_TARGET
OS_TARGET:=$(word 4,$(COMPILERINFO))
endif
else
ifndef CPU_SOURCE
CPU_SOURCE:=$(shell $(FPC) -iSP)
endif
ifndef CPU_TARGET
CPU_TARGET:=$(shell $(FPC) -iTP)
endif
ifndef OS_SOURCE
OS_SOURCE:=$(shell $(FPC) -iSO)
endif
ifndef OS_TARGET
OS_TARGET:=$(shell $(FPC) -iTO)
endif
endif
ifndef CPU_TARGET
ifdef CPU_TARGET_DEFAULT
CPU_TARGET=$(CPU_TARGET_DEFAULT)
@ -126,24 +153,6 @@ ifdef OS_TARGET_DEFAULT
OS_TARGET=$(OS_TARGET_DEFAULT)
endif
endif
ifneq ($(words $(FPC_COMPILERINFO)),5)
FPC_COMPILERINFO+=$(shell $(FPC) -iSP)
FPC_COMPILERINFO+=$(shell $(FPC) -iTP)
FPC_COMPILERINFO+=$(shell $(FPC) -iSO)
FPC_COMPILERINFO+=$(shell $(FPC) -iTO)
endif
ifndef CPU_SOURCE
CPU_SOURCE:=$(word 2,$(FPC_COMPILERINFO))
endif
ifndef CPU_TARGET
CPU_TARGET:=$(word 3,$(FPC_COMPILERINFO))
endif
ifndef OS_SOURCE
OS_SOURCE:=$(word 4,$(FPC_COMPILERINFO))
endif
ifndef OS_TARGET
OS_TARGET:=$(word 5,$(FPC_COMPILERINFO))
endif
FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
ifneq ($(FULL_TARGET),$(FULL_SOURCE))
@ -206,7 +215,7 @@ PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/ext
override PACKAGE_NAME=fcl
override PACKAGE_VERSION=1.0.6
override TARGET_DIRS+=xml db shedit passrc net
override TARGET_UNITS+=classes contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry eventlog
override TARGET_UNITS+=classes contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry eventlog custapp
ifeq ($(OS_TARGET),linux)
override TARGET_UNITS+=process resolve ssockets fpasync
endif
@ -225,7 +234,7 @@ endif
ifeq ($(OS_TARGET),openbsd)
override TARGET_UNITS+=process ssockets resolve fpasync
endif
override TARGET_RSTS+=classes ssockets cachecls resolve
override TARGET_RSTS+=classes ssockets cachecls resolve custapp
override TARGET_EXAMPLEDIRS+=tests
override CLEAN_UNITS+=adler gzcrc gzio infblock infcodes inffast inftrees infutil minigzip paszlib trees zbase zcompres zdeflate zinflate zuncompr zutil
override INSTALL_FPCPACKAGE=y
@ -249,9 +258,6 @@ endif
ifeq ($(OS_TARGET),openbsd)
override COMPILER_INCLUDEDIR+=unix
endif
ifeq ($(OS_TARGET),emx)
override COMPILER_INCLUDEDIR+=os2
endif
override COMPILER_SOURCEDIR+=$(OS_TARGET) inc
override COMPILER_TARGETDIR+=$(OS_TARGET)
ifdef REQUIRE_UNITSDIR
@ -473,97 +479,6 @@ SHAREDLIBEXT=.so
STATICLIBPREFIX=libp
RSTEXT=.rst
FPCMADE=fpcmade
ifeq ($(findstring 1.0.,$(FPC_VERSION)),)
ifeq ($(OS_TARGET),go32v1)
STATICLIBPREFIX=
FPCMADE=fpcmade.v1
PACKAGESUFFIX=v1
endif
ifeq ($(OS_TARGET),go32v2)
STATICLIBPREFIX=
FPCMADE=fpcmade.dos
ZIPSUFFIX=go32
endif
ifeq ($(OS_TARGET),linux)
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.lnx
ZIPSUFFIX=linux
endif
ifeq ($(OS_TARGET),freebsd)
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.freebsd
ZIPSUFFIX=freebsd
endif
ifeq ($(OS_TARGET),netbsd)
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.netbsd
ZIPSUFFIX=netbsd
endif
ifeq ($(OS_TARGET),openbsd)
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.openbsd
ZIPSUFFIX=openbsd
endif
ifeq ($(OS_TARGET),win32)
SHAREDLIBEXT=.dll
FPCMADE=fpcmade.w32
ZIPSUFFIX=w32
endif
ifeq ($(OS_TARGET),os2)
AOUTEXT=.out
STATICLIBPREFIX=
SHAREDLIBEXT=.dll
FPCMADE=fpcmade.os2
ZIPSUFFIX=os2
ECHO=echo
endif
ifeq ($(OS_TARGET),emx)
AOUTEXT=.out
STATICLIBPREFIX=
SHAREDLIBEXT=.dll
FPCMADE=fpcmade.emx
ZIPSUFFIX=emx
ECHO=echo
endif
ifeq ($(OS_TARGET),amiga)
EXEEXT=
SHAREDLIBEXT=.library
FPCMADE=fpcmade.amg
endif
ifeq ($(OS_TARGET),atari)
EXEEXT=.ttp
FPCMADE=fpcmade.ata
endif
ifeq ($(OS_TARGET),beos)
EXEEXT=
FPCMADE=fpcmade.be
ZIPSUFFIX=be
endif
ifeq ($(OS_TARGET),sunos)
EXEEXT=
FPCMADE=fpcmade.sun
ZIPSUFFIX=sun
endif
ifeq ($(OS_TARGET),qnx)
EXEEXT=
FPCMADE=fpcmade.qnx
ZIPSUFFIX=qnx
endif
ifeq ($(OS_TARGET),netware)
EXEEXT=.nlm
STATICLIBPREFIX=
FPCMADE=fpcmade.nw
ZIPSUFFIX=nw
endif
ifeq ($(OS_TARGET),macos)
EXEEXT=
FPCMADE=fpcmade.mcc
endif
else
ifeq ($(OS_TARGET),go32v1)
PPUEXT=.pp1
OEXT=.o1
@ -678,8 +593,8 @@ ZIPSUFFIX=qnx
endif
ifeq ($(OS_TARGET),netware)
STATICLIBPREFIX=
PPUEXT=.ppu
OEXT=.o
PPUEXT=.ppn
OEXT=.on
ASMEXT=.s
SMARTEXT=.sl
STATICLIBEXT=.a
@ -688,16 +603,6 @@ FPCMADE=fpcmade.nw
ZIPSUFFIX=nw
EXEEXT=.nlm
endif
ifeq ($(OS_TARGET),macos)
PPUEXT=.ppu
ASMEXT=.s
OEXT=.o
SMARTEXT=.sl
STATICLIBEXT=.a
EXEEXT=
FPCMADE=fpcmade.mcc
endif
endif
ifndef ECHO
ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(ECHO),)
@ -921,7 +826,6 @@ TAREXT=.tar.gz
endif
override REQUIRE_PACKAGES=rtl paszlib
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
@ -929,57 +833,13 @@ REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),sparc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),x86_64)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),go32v2)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),win32)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
@ -987,17 +847,13 @@ REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),os2)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),freebsd)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
@ -1005,27 +861,13 @@ REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),freebsd)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),beos)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
@ -1033,67 +875,37 @@ REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),amiga)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),atari)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),sunos)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),sunos)
ifeq ($(CPU_TARGET),sparc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),qnx)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),netware)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),openbsd)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
@ -1101,57 +913,12 @@ REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),openbsd)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
endif
endif
ifeq ($(OS_TARGET),wdosx)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),palmos)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),macos)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),macosx)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),emx)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifdef REQUIRE_PACKAGES_RTL
PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/$(OS_TARGET)/Makefile.fpc,$(PACKAGESDIR))))))
ifneq ($(PACKAGEDIR_RTL),)
@ -1398,11 +1165,6 @@ override COMPILER_UNITTARGETDIR=$(COMPILER_TARGETDIR)
override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX)
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(FPC_VERSION),1.0.6)
override FPCOPTDEF+=HASUNIX
endif
endif
ifdef GCCLIBDIR
override FPCOPT+=-Fl$(GCCLIBDIR)
endif
@ -1427,7 +1189,7 @@ override COMPILER:=$(FPC) $(FPCOPT)
ifeq (,$(findstring -s ,$(COMPILER)))
EXECPPAS=
else
ifeq ($(FULL_SOURCE),$(FULL_TARGET))
ifeq ($(OS_SOURCE),$(OS_TARGET))
EXECPPAS:=@$(PPAS)
endif
endif
@ -1454,9 +1216,6 @@ override CLEANEXEFILES+=$(EXAMPLEFILES) $(EXAMPLEOFILES)
ifeq ($(OS_TARGET),os2)
override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_EXAMPLES))
endif
ifeq ($(OS_TARGET),emx)
override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_EXAMPLES))
endif
endif
ifdef TARGET_EXAMPLEDIRS
HASEXAMPLES=1
@ -2060,7 +1819,7 @@ distinstall: fpc_distinstall
zipinstall: fpc_zipinstall
zipsourceinstall: fpc_zipsourceinstall
zipexampleinstall: fpc_zipexampleinstall $(addsuffix _zipexampleinstall,$(TARGET_DIRS))
zipdistinstall: fpc_zipdistinstall
zipdistinstall: fpc_zipdistinstall $(addsuffix _zipdistinstall,$(TARGET_DIRS))
clean: fpc_clean $(addsuffix _clean,$(TARGET_DIRS)) $(addsuffix _clean,$(TARGET_EXAMPLEDIRS))
distclean: fpc_distclean $(addsuffix _distclean,$(TARGET_DIRS))
cleanall: fpc_cleanall $(addsuffix _cleanall,$(TARGET_DIRS))

14
fcl/Makefile.fpc
View File

@ -19,15 +19,15 @@ packages_win32=netdb
units=adler gzcrc gzio infblock infcodes inffast inftrees infutil minigzip paszlib trees zbase zcompres zdeflate zinflate zuncompr zutil
[target]
dirs=xml db shedit passrc
units=classes contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry eventlog
units_freebsd=process asyncio ssockets http resolve http fpasync
units_netbsd=process asyncio ssockets http resolve http fpasync
units_openbsd=process asyncio ssockets http resolve http fpasync
units_linux=process asyncio resolve ssockets http fpasync
dirs=xml db shedit passrc net
units=classes contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry eventlog custapp
units_freebsd=process ssockets resolve fpasync
units_netbsd=process ssockets resolve fpasync
units_openbsd=process ssockets resolve fpasync
units_linux=process resolve ssockets fpasync
units_win32=process fileinfo resolve ssockets
units_netware=resolve ssockets
rsts=classes ssockets cachecls resolve
rsts=classes ssockets cachecls resolve custapp
exampledirs=tests
[compiler]

41
fcl/go32v2/custapp.inc Normal file
View File

@ -0,0 +1,41 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2003 by the Free Pascal development team
Linux version of custom app object routines.
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.
**********************************************************************}
Procedure SysGetEnvironmentList(List : TStrings;NamesOnly : Boolean);
Var
P : PPChar;
S : String;
I : Integer;
begin
List.Clear;
P:=EnvP;
if (P<>Nil) then
While (P^<>Nil) do
begin
S:=StrPas(P^);
If NamesOnly then
begin
I:=Pos('=',S);
If (I>1) then
S:=Copy(S,1,I-1);
end;
List.Add(S);
Inc(P);
end;
end;

436
fcl/inc/custapp.pp Normal file
View File

@ -0,0 +1,436 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2003 by the Free Pascal development team
CustomApplication class.
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}
{$h+}
unit CustApp;
Interface
uses SysUtils,Classes;
Type
TExceptionEvent = Procedure (Sender : TObject; E : Exception) Of Object;
TCustomApplication = Class(TComponent)
Private
FOnException: TExceptionEvent;
FTerminated : Boolean;
FHelpFile,
FTitle : String;
FOptionChar : Char;
FCaseSensitiveOptions : Boolean;
FStopOnException : Boolean;
function GetEnvironmentVar(VarName : String): String;
function GetExeName: string;
Function GetLocation : String;
function GetTitle: string;
Protected
procedure SetTitle(const AValue: string); Virtual;
Function GetConsoleApplication : boolean; Virtual;
Procedure DoRun; Virtual;
Function GetParams(Index : Integer) : String;virtual;
function GetParamCount: Integer;Virtual;
Public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// Some Delphi methods.
procedure HandleException(Sender: TObject); virtual;
procedure Initialize; virtual;
procedure Run;
procedure ShowException(E: Exception);virtual;
procedure Terminate; virtual;
// Extra methods.
function FindOptionIndex(Const S : String; Var Longopt : Boolean) : Integer;
Function GetOptionValue(Const S : String) : String;
Function GetOptionValue(Const C: Char; Const S : String) : String;
Function HasOption(Const S : String) : Boolean;
Function HasOption(Const C : Char; Const S : String) : Boolean;
Function CheckOptions(Const ShortOptions : String; Const Longopts : TStrings; Opts,NonOpts : TStrings) : String;
Function CheckOptions(Const ShortOptions : String; Const Longopts : TStrings) : String;
Function CheckOptions(Const ShortOptions : String; Const LongOpts : Array of string) : String;
Function CheckOptions(Const ShortOptions : String; Const LongOpts : String) : String;
Procedure GetEnvironmentList(List : TStrings;NamesOnly : Boolean);
Procedure GetEnvironmentList(List : TStrings);
// Delphi properties
property ExeName: string read GetExeName;
property HelpFile: string read FHelpFile write FHelpFile;
property Terminated: Boolean read FTerminated;
property Title: string read FTitle write SetTitle;
property OnException: TExceptionEvent read FOnException write FOnException;
// Extra properties
Property ConsoleApplication : Boolean Read GetConsoleApplication;
Property Location : String Read GetLocation;
Property Params [Index : integer] : String Read GetParams;
Property ParamCount : Integer Read GetParamCount;
Property EnvironmentVariable[Name : String] : String Read GetEnvironmentVar;
Property OptionChar : Char Read FoptionChar Write FOptionChar;
Property CaseSensitiveOptions : Boolean Read FCaseSensitiveOptions Write FCaseSensitiveOptions;
Property StopOnException : Boolean Read FStopOnException Write FStopOnException;
end;
Implementation
{$i custapp.inc}
{ TCustomApplication }
function TCustomApplication.GetExeName: string;
begin
Result:=Paramstr(0);
end;
function TCustomApplication.GetEnvironmentVar(VarName : String): String;
begin
Result:=GetEnvironmentVariable(VarName);
end;
Procedure TCustomApplication.GetEnvironmentList(List : TStrings;NamesOnly : Boolean);
begin
// Routine must be in custapp.inc
SysGetEnvironmentList(List,NamesOnly);
end;
Procedure TCustomApplication.GetEnvironmentList(List : TStrings);
begin
GetEnvironmentList(List,False);
end;
function TCustomApplication.GetLocation: String;
begin
Result:=ExtractFilePath(GetExeName);
end;
function TCustomApplication.GetParamCount: Integer;
begin
Result:=System.ParamCount;
end;
function TCustomApplication.GetTitle: string;
begin
Result:=FTitle;
end;
function TCustomApplication.GetParams(Index: Integer): String;
begin
Result:=ParamStr(Index);
end;
procedure TCustomApplication.SetTitle(const AValue: string);
begin
FTitle:=AValue;
end;
function TCustomApplication.GetConsoleApplication: boolean;
begin
Result:=IsConsole;
end;
procedure TCustomApplication.DoRun;
begin
// Do nothing. Override in descendent classes.
end;
constructor TCustomApplication.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FOptionChar:='-';
FCaseSensitiveOptions:=True;
FStopOnException:=False;
end;
destructor TCustomApplication.Destroy;
begin
inherited Destroy;
end;
procedure TCustomApplication.HandleException(Sender: TObject);
begin
If Not (ExceptObject is Exception) then
SysUtils.showexception(ExceptObject,ExceptAddr)
else
begin
If Not Assigned(FOnexception) then
ShowException(Exception(ExceptObject))
else
FOnException(Sender,Exception(ExceptObject));
end;
If FStopOnException then
FTerminated:=True;
end;
procedure TCustomApplication.Initialize;
begin
FTerminated:=False;
end;
procedure TCustomApplication.Run;
begin
Repeat
Try
DoRun;
except
HandleException(Self);
end;
Until FTerminated;
end;
procedure TCustomApplication.ShowException(E: Exception);
begin
Sysutils.ShowException(E,ExceptAddr)
end;
procedure TCustomApplication.Terminate;
begin
FTerminated:=True;
end;
function TCustomApplication.GetOptionValue(Const S: String): String;
begin
Result:=GetoptionValue(#255,S);
end;
function TCustomApplication.GetOptionValue(Const C: Char; Const S: String): String;
Var
B : Boolean;
I,P : integer;
O : String;
begin
Result:='';
I:=FindOptionIndex(C,B);
If (I=-1) then
I:=FindoptionIndex(S,B);
If (I<>-1) then
begin
If B then
begin // Long options have form --option=value
O:=Params[I];
P:=Pos('=',O);
If (P=0) then
P:=Length(O);
Delete(O,1,P);
Result:=O;
end
else
begin // short options have form '-o value'
If (I<ParamCount) then
Result:=Params[I+1];
end;
end;
end;
function TCustomApplication.HasOption(Const S: String): Boolean;
Var
B : Boolean;
begin
Result:=FindOptionIndex(S,B)<>-1;
end;
function TCustomApplication.FindOptionIndex(Const S : String; Var Longopt : Boolean) : Integer;
Var
SO,O : String;
I,P : Integer;
begin
If Not CaseSensitiveOptions then
SO:=UpperCase(S)
else
SO:=S;
Result:=-1;
I:=ParamCount;
While (Result=-1) and (I>0) do
begin
O:=Params[i];
If (Length(O)>0) and (O[1]=FOptionChar) then
begin
Delete(O,1,1);
LongOpt:=(Length(O)>0) and (O[1]=FOptionChar);
If LongOpt then
begin
Delete(O,1,1);
P:=Pos('=',O);
If (P<>0) then
O:=Copy(O,1,P-1);
end;
If Not CaseSensitiveOptions then
O:=UpperCase(O);
If (O=SO) then
Result:=i;
end;
Dec(i);
end;
end;
function TCustomApplication.HasOption(Const C: Char; Const S: String): Boolean;
Var
B : Boolean;
begin
Result:=(FindOptionIndex(C,B)<>-1) or (FindOptionIndex(S,B)<>-1);
end;
Function TCustomApplication.CheckOptions(Const ShortOptions : String; Const Longopts : TStrings) : String;
begin
Result:=CheckOptions(ShortOptions,LongOpts,Nil,Nil);
end;
ResourceString
SErrInvalidOption = 'Invalid option at position %d: "%s"';
SErrNoOptionAllowed = 'Option at position %d does not allow an argument: %s';
SErrOptionNeeded = 'Option at position %d needs an argument : %s';
Function TCustomApplication.CheckOptions(Const ShortOptions : String; Const Longopts : TStrings; Opts,NonOpts : TStrings) : String;
Var
I,J,L,P : Integer;
O,OV : String;
HaveArg : Boolean;
begin
Result:='';
I:=1;
While (I<=ParamCount) and (Result='') do
begin
O:=Paramstr(I);
If (Length(O)=0) or (O[1]<>FOptionChar) then
begin
If Assigned(NonOpts) then
NonOpts.Add(O)
end
else
begin
If (Length(O)<2) then
Result:=Format(SErrInvalidOption,[i,O])
else
begin
HaveArg:=False;
OV:='';
// Long option ?
If (O[2]=FOptionChar) then
begin
Delete(O,1,2);
J:=Pos('=',O);
If J<>0 then
begin
HaveArg:=true;
OV:=O;
Delete(OV,1,J);
O:=Copy(O,1,J-1);
end;
// Switch Option
If Longopts.IndexOf(O)<>-1 then
begin
If HaveArg then
Result:=Format(SErrNoOptionAllowed,[I,O])
end
else
begin // Required argument
If LongOpts.IndexOf(O+':')<>-1 then
begin
If Not HaveArg then
Result:=Format(SErrOptionNeeded,[I,O]);
end
else
begin // Optional Argument.
If LongOpts.IndexOf(O+'::')=-1 then
Result:=Format(SErrInvalidOption,[I,O]);
end;
end;
end
else // Short Option.
begin
HaveArg:=(I<ParamCount) and (Length(ParamStr(I+1))>0) and (ParamStr(I+1)[i]<>FOptionChar);
If HaveArg then
OV:=Paramstr(I+1);
L:=Length(O);
For J:=2 to L do
begin
P:=Pos(O[J],ShortOptions);
If P=0 then
Result:=Format(SErrInvalidOption,[I,O[J]])
else
begin
If (P<Length(ShortOptions)) and (Shortoptions[P+1]=':') then
begin
// Required argument
If ((P+1)<Length(ShortOptions)) and (Shortoptions[P+2]<>':') Then
If (J<L) or not haveArg then // Must be last in multi-opt !!
Result:=Format(SErrOptionNeeded,[I,O[J]]);
O:=O[j]; // O is added to arguments.
end;
end;
end;
If HaveArg then
begin
Inc(I); // Skip argument.
O:=O[Length(O)]; // O is added to arguments !
end;
end;
If HaveArg and (Result='') then
If Assigned(Opts) then
Opts.Add(O+'='+OV);
end;
end;
Inc(I);
end;
end;
Function TCustomApplication.CheckOptions(Const ShortOptions : String; Const LongOpts : Array of string) : String;
Var
L : TStringList;
I : Integer;
begin
L:=TStringList.Create;
Try
For I:=0 to High(LongOpts) do
L.Add(LongOpts[i]);
Result:=CheckOptions(ShortOptions,L);
Finally
L.Free;
end;
end;
Function TCustomApplication.CheckOptions(Const ShortOptions : String; Const LongOpts : String) : String;
Var
L : TStringList;
begin
L:=TStringList.Create;
Try
Result:=CheckOptions(Shortoptions,L);
Finally
L.Free;
end;
end;
end.

68
fcl/os2/custapp.inc Normal file
View File

@ -0,0 +1,68 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2003 by the Free Pascal development team
Linux version of custom app object routines.
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.
**********************************************************************}
{ taken from dos unit }
type
PPchar = ^Pchar;
function envs:PPchar;assembler;
asm
movl envp,%eax
end ['EAX'];
function envcount:longint;assembler;
asm
movl envc,%eax
end ['EAX'];
function envstr(index : longint) : string;
var hp:Pchar;
begin
if (index<=0) or (index>envcount) then
begin
envstr:='';
exit;
end;
hp:=envs[index-1];
envstr:=strpas(hp);
end;
Procedure SysGetEnvironmentList(List : TStrings;NamesOnly : Boolean);
Var
S : String;
J,I : Integer;
begin
List.Clear;
For J:=1 to envcount-1 do
begin
S:=Envsttr(J);
If NamesOnly then
begin
I:=Pos('=',S);
If (I>1) then
S:=Copy(S,1,I-1);
end;
List.Add(S);
end;
end;

41
fcl/posix/custapp.inc Normal file
View File

@ -0,0 +1,41 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2003 by the Free Pascal development team
Linux version of custom app object routines.
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.
**********************************************************************}
Procedure SysGetEnvironmentList(List : TStrings;NamesOnly : Boolean);
Var
P : PPChar;
S : String;
I : Integer;
begin
List.Clear;
P:=EnvP;
if (P<>Nil) then
While (P^<>Nil) do
begin
S:=StrPas(P^);
If NamesOnly then
begin
I:=Pos('=',S);
If (I>1) then
S:=Copy(S,1,I-1);
end;
List.Add(S);
Inc(P);
end;
end;

2
fcl/tests/Makefile
View File

@ -212,7 +212,7 @@ else
UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
endif
PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testcgi tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd
override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testcgi tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp
ifeq ($(OS_TARGET),linux)
override TARGET_PROGRAMS+=sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
endif

3
fcl/tests/Makefile.fpc
View File

@ -6,7 +6,8 @@
programs=stringl dparser fstream mstream list threads testrtf \
cfgtest xmldump htdump testcgi tidea \
b64test b64test2 b64enc b64dec restest testz testz2 \
istream doecho testol testcont txmlreg testreg tstelcmd
istream doecho testol testcont txmlreg testreg tstelcmd \
testapp
programs_win32=showver testproc testhres testnres testsres testrhre \
testrnre testrsre testur
programs_linux=sockcli isockcli dsockcli socksvr isocksvr dsocksvr \

1
fcl/tests/README
View File

@ -57,3 +57,4 @@ testreg.pp Test of registry unit. (MVC)
tstelcmd.pp Test of eventlog unit, command-line version.
tstelgtk.pp Test of eventlog unit, FPGTK version. Not built by default. (MVC)
testur.pp Test of TURIParser class
testapp.pp Test of TCustomApplication

88
fcl/tests/testapp.pp Normal file
View File

@ -0,0 +1,88 @@
{$mode objfpc}
{$h+}
program testapp;
uses custapp,classes;
Const
ShortOpts = 'abc:d:012';
Longopts : Array[1..6] of String = (
'add:','append','delete:','verbose','create:','file:');
Type
TTestApp = Class(TCustomApplication)
Procedure DoRun ; Override;
end;
Procedure TTestApp.DoRun;
Var
I : Integer;
S : String;
Opts,FN,Args : TStrings;
begin
Writeln('Exe name : ',ExeName);
Writeln('Help file : ',HelpFile);
Writeln('Terminated : ',Terminated);
Writeln('Title : ',Title);
Writeln('Console app : ',ConsoleApplication);
Writeln('Location : ',Location);
Writeln('ParamCount : ',ParamCount);
For I:=0 to ParamCount do
Writeln('Params [',I:3,'] : ',Params[i]);
Writeln('Option char : ',OptionChar);
Writeln('Case sensitive opts : ',CaseSensitiveOptions);
Writeln('StopOnException : ',StopOnException);
Writeln('----------------------------------------');
Writeln('Simple options check');
S:=CheckOptions(ShortOpts,LongOpts);
If (S<>'') then
Writeln(S);
Writeln('Longer options check');
Opts:=TstringList.Create;
FN:=TStringList.Create;
Args:=TStringList.Create;
Try
For I:=1 to 6 do
Opts.Add(LongOpts[i]);
S:=CheckOptions(ShortOpts,Opts,Args,FN);
Writeln('Found ',Args.Count,' options and ',FN.Count,' non-options (filenames)');
For I:=0 to Args.Count-1 do
Writeln('Option ',I:2,': ',Args[i]);
For I:=0 to FN.Count-1 do
Writeln('Non-Option ',I:2,': ',FN[i]);
Writeln('Getting option value "add"');
S:=GetOptionValue('add');
Writeln('Value for "add": ',S);
Writeln('Testing Hasoption "a"');
Writeln('Option append found: ',HasOption('append'));
Writeln('Option a or append found: ',HasOption('a','append'));
Writeln('-----------------------');
GetEnvironmentList(Opts,True);
Writeln('Found ',Opts.Count,' environment variables');
For I:=0 to Opts.Count-1 do
Writeln(I:3,': ',Opts[i],' with value "',EnvironmentVariable[Opts[i]],'"');
Finally
Opts.Free;
FN.Free;
Args.Free;
end;
Terminate;
Writeln('-------------------------');
Writeln('After terminate, "terminated" is ',Terminated);
end;
Var
App : TTestApp;
begin
App:=TTestApp.Create(Nil);
App.Initialize;
App.Title:='CustomApplication class test application.';
App.Run;
App.Free;
end.

41
fcl/unix/custapp.inc Normal file
View File

@ -0,0 +1,41 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2003 by the Free Pascal development team
Linux version of custom app object routines.
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.
**********************************************************************}
Procedure SysGetEnvironmentList(List : TStrings;NamesOnly : Boolean);
Var
P : PPChar;
S : String;
I : Integer;
begin
List.Clear;
P:=EnvP;
if (P<>Nil) then
While (P^<>Nil) do
begin
S:=StrPas(P^);
If NamesOnly then
begin
I:=Pos('=',S);
If (I>0) then
S:=Copy(S,1,I-1);
end;
List.Add(S);
Inc(P);
end;
end;

44
fcl/win32/custapp.inc Normal file
View File

@ -0,0 +1,44 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2003 by the Free Pascal development team
Linux version of custom app object routines.
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.
**********************************************************************}
function GetEnvironmentStrings : pchar; external 'kernel32' name 'GetEnvironmentStringsA';
function FreeEnvironmentStrings(p : pchar) : longbool; external 'kernel32' name 'FreeEnvironmentStringsA';
Procedure SysGetEnvironmentList(List : TStrings;NamesOnly : Boolean);
var
s : string;
i,l : longint;
hp,p : pchar;
begin
p:=GetEnvironmentStrings;
hp:=p;
while hp^<>#0 do
begin
s:=strpas(hp);
l:=Length(s);
If NamesOnly then
begin
I:=pos('=',s);
If (I>0) then
S:=Copy(S,1,I-1);
end;
List.Add(S);
hp:=hp+l+1;
end;
FreeEnvironmentStrings(p);
end;