From 4f91ae9605baedcc38e6a17faf509e083294c4e8 Mon Sep 17 00:00:00 2001
From: michael <michael@freepascal.org>
Date: Thu, 29 May 2003 09:58:30 +0000
Subject: [PATCH] + Initial version of customapplication object
---
fcl/Makefile | 319 ++++--------------------------
fcl/Makefile.fpc | 14 +-
fcl/go32v2/custapp.inc | 41 ++++
fcl/inc/custapp.pp | 436 +++++++++++++++++++++++++++++++++++++++++
fcl/os2/custapp.inc | 68 +++++++
fcl/posix/custapp.inc | 41 ++++
fcl/tests/Makefile | 2 +-
fcl/tests/Makefile.fpc | 3 +-
fcl/tests/README | 1 +
fcl/tests/testapp.pp | 88 +++++++++
fcl/unix/custapp.inc | 41 ++++
fcl/win32/custapp.inc | 44 +++++
12 files changed, 809 insertions(+), 289 deletions(-)
create mode 100644 fcl/go32v2/custapp.inc
create mode 100644 fcl/inc/custapp.pp
create mode 100644 fcl/os2/custapp.inc
create mode 100644 fcl/posix/custapp.inc
create mode 100644 fcl/tests/testapp.pp
create mode 100644 fcl/unix/custapp.inc
create mode 100644 fcl/win32/custapp.inc
diff --git a/fcl/Makefile b/fcl/Makefile
index 0953389efd..c7f9839fad 100644
--- a/fcl/Makefile
+++ b/fcl/Makefile
@@ -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))
diff --git a/fcl/Makefile.fpc b/fcl/Makefile.fpc
index 4194f90f01..1d48c9c9ae 100644
--- a/fcl/Makefile.fpc
+++ b/fcl/Makefile.fpc
@@ -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]
diff --git a/fcl/go32v2/custapp.inc b/fcl/go32v2/custapp.inc
new file mode 100644
index 0000000000..8d15522a72
--- /dev/null
+++ b/fcl/go32v2/custapp.inc
@@ -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;
+
diff --git a/fcl/inc/custapp.pp b/fcl/inc/custapp.pp
new file mode 100644
index 0000000000..b2a9e41d12
--- /dev/null
+++ b/fcl/inc/custapp.pp
@@ -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.
+
diff --git a/fcl/os2/custapp.inc b/fcl/os2/custapp.inc
new file mode 100644
index 0000000000..25698fa732
--- /dev/null
+++ b/fcl/os2/custapp.inc
@@ -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;
diff --git a/fcl/posix/custapp.inc b/fcl/posix/custapp.inc
new file mode 100644
index 0000000000..8d15522a72
--- /dev/null
+++ b/fcl/posix/custapp.inc
@@ -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;
+
diff --git a/fcl/tests/Makefile b/fcl/tests/Makefile
index 417620cfc1..21991ede33 100644
--- a/fcl/tests/Makefile
+++ b/fcl/tests/Makefile
@@ -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
diff --git a/fcl/tests/Makefile.fpc b/fcl/tests/Makefile.fpc
index c1eb67ad88..92d8fdef3a 100644
--- a/fcl/tests/Makefile.fpc
+++ b/fcl/tests/Makefile.fpc
@@ -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 \
diff --git a/fcl/tests/README b/fcl/tests/README
index c57351c2a9..2d5453db19 100644
--- a/fcl/tests/README
+++ b/fcl/tests/README
@@ -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
\ No newline at end of file
diff --git a/fcl/tests/testapp.pp b/fcl/tests/testapp.pp
new file mode 100644
index 0000000000..adccb28be5
--- /dev/null
+++ b/fcl/tests/testapp.pp
@@ -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.
+
+
\ No newline at end of file
diff --git a/fcl/unix/custapp.inc b/fcl/unix/custapp.inc
new file mode 100644
index 0000000000..2bbaa315a6
--- /dev/null
+++ b/fcl/unix/custapp.inc
@@ -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;
+
diff --git a/fcl/win32/custapp.inc b/fcl/win32/custapp.inc
new file mode 100644
index 0000000000..f652c1f9b8
--- /dev/null
+++ b/fcl/win32/custapp.inc
@@ -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;