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

+ Added RTTIUtils unit

Browse Source
This commit is contained in:
michael 2004-07-17 18:37:13 +00:00
parent 93c356f300
commit 7ef820a990
3 changed files with 997 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

314
fcl/Makefile
View File

@ -1,25 +1,15 @@
#
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/05/23]
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/09/24]
#
default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
BSDs = freebsd netbsd openbsd darwin
UNIXs = linux $(BSDs) sunos qnx
FORCE:
.PHONY: FORCE
override PATH:=$(patsubst %/,%,$(subst \,/,$(PATH)))
ifneq ($(findstring darwin,$(OSTYPE)),)
inUnix=1 #darwin
SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH)))
else
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx
override PATH:=$(subst \,/,$(PATH))
ifeq ($(findstring ;,$(PATH)),)
inUnix=1
SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH)))
else
SEARCHPATH:=$(subst ;, ,$(PATH))
endif
endif
SEARCHPATH+=$(patsubst %/,%,$(subst \,/,$(dir $(MAKE))))
PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(SEARCHPATH))))
ifeq ($(PWD),)
PWD:=$(strip $(wildcard $(addsuffix /pwd,$(SEARCHPATH))))
@ -46,13 +36,22 @@ ifneq ($(findstring cygdrive,$(PATH)),)
inCygWin=1
endif
endif
ifeq ($(OS_TARGET),freebsd)
BSDhier=1
endif
ifeq ($(OS_TARGET),netbsd)
BSDhier=1
endif
ifeq ($(OS_TARGET),openbsd)
BSDhier=1
endif
ifdef inUnix
SRCBATCHEXT=.sh
BATCHEXT=.sh
else
ifdef inOS2
SRCBATCHEXT=.cmd
BATCHEXT=.cmd
else
SRCBATCHEXT=.bat
BATCHEXT=.bat
endif
endif
ifdef inUnix
@ -155,12 +154,6 @@ ifeq ($(findstring $(OS_TARGET),$(MAKEFILETARGETS)),)
$(error The Makefile doesn't support target $(OS_TARGET), please run fpcmake first)
endif
endif
ifneq ($(findstring $(OS_TARGET),$(BSDs)),)
BSDhier=1
endif
ifeq ($(OS_TARGET),linux)
linuxHier=1
endif
export OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE CROSSCOMPILE
ifdef FPCDIR
override FPCDIR:=$(subst \,/,$(FPCDIR))
@ -190,14 +183,11 @@ override FPCDIR:=$(FPCDIR)/..
ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
override FPCDIR:=$(FPCDIR)/..
ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
override FPCDIR:=$(BASEDIR)
ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
override FPCDIR=c:/pp
endif
endif
endif
endif
endif
ifndef CROSSDIR
CROSSDIR:=$(FPCDIR)/cross/$(FULL_TARGET)
endif
@ -219,7 +209,7 @@ ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
CLASSES10=classes
endif
override TARGET_DIRS+=xml image db shedit passrc net
override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry eventlog custapp cgiapp wformat whtml wtex
override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils
ifeq ($(OS_TARGET),linux)
override TARGET_UNITS+=process resolve ssockets fpasync syncobjs
endif
@ -283,12 +273,42 @@ ifdef REQUIRE_PACKAGESDIR
override PACKAGESDIR+=$(REQUIRE_PACKAGESDIR)
endif
ifdef ZIPINSTALL
ifneq ($(findstring $(OS_TARGET),$(UNIXs)),)
UNIXHier=1
ifeq ($(OS_TARGET),linux)
UNIXINSTALLDIR=1
endif
ifeq ($(OS_TARGET),freebsd)
UNIXINSTALLDIR=1
endif
ifeq ($(OS_TARGET),netbsd)
UNIXINSTALLDIR=1
endif
ifeq ($(OS_TARGET),openbsd)
UNIXINSTALLDIR=1
endif
ifeq ($(OS_TARGET),sunos)
UNIXINSTALLDIR=1
endif
ifeq ($(OS_TARGET),qnx)
UNIXINSTALLDIR=1
endif
else
ifneq ($(findstring $(OS_SOURCE),$(UNIXs)),)
UNIXHier=1
ifeq ($(OS_SOURCE),linux)
UNIXINSTALLDIR=1
endif
ifeq ($(OS_SOURCE),freebsd)
UNIXINSTALLDIR=1
endif
ifeq ($(OS_SOURCE),netbsd)
UNIXINSTALLDIR=1
endif
ifeq ($(OS_SOURCE),openbsd)
UNIXINSTALLDIR=1
endif
ifeq ($(OS_TARGET),sunos)
UNIXINSTALLDIR=1
endif
ifeq ($(OS_TARGET),qnx)
UNIXINSTALLDIR=1
endif
endif
ifndef INSTALL_PREFIX
@ -297,7 +317,7 @@ INSTALL_PREFIX=$(PREFIX)
endif
endif
ifndef INSTALL_PREFIX
ifdef UNIXHier
ifdef UNIXINSTALLDIR
INSTALL_PREFIX=/usr/local
else
ifdef INSTALL_FPCPACKAGE
@ -316,7 +336,7 @@ DIST_DESTDIR:=$(BASEDIR)
endif
export DIST_DESTDIR
ifndef INSTALL_BASEDIR
ifdef UNIXHier
ifdef UNIXINSTALLDIR
ifdef INSTALL_FPCPACKAGE
INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/fpc/$(FPC_VERSION)
else
@ -327,18 +347,10 @@ INSTALL_BASEDIR:=$(INSTALL_PREFIX)
endif
endif
ifndef INSTALL_BINDIR
ifdef UNIXHier
ifdef CROSSCOMPILE
INSTALL_BINDIR:=$(INSTALL_BASEDIR)/cross/$(FULL_TARGET)/bin
else
ifdef UNIXINSTALLDIR
INSTALL_BINDIR:=$(INSTALL_PREFIX)/bin
endif
else
ifdef CROSSCOMPILE
INSTALL_BINDIR:=$(INSTALL_BASEDIR)/cross/$(FULL_TARGET)/bin
else
INSTALL_BINDIR:=$(INSTALL_BASEDIR)/bin
endif
ifdef INSTALL_FPCPACKAGE
INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(OS_TARGET)
endif
@ -357,23 +369,19 @@ endif
endif
endif
ifndef INSTALL_LIBDIR
ifdef UNIXHier
ifdef UNIXINSTALLDIR
INSTALL_LIBDIR:=$(INSTALL_PREFIX)/lib
else
INSTALL_LIBDIR:=$(INSTALL_UNITDIR)
endif
endif
ifndef INSTALL_SOURCEDIR
ifdef UNIXHier
ifdef UNIXINSTALLDIR
ifdef BSDhier
SRCPREFIXDIR=share/src
else
ifdef linuxHier
SRCPREFIXDIR=share/src
else
SRCPREFIXDIR=src
endif
endif
ifdef INSTALL_FPCPACKAGE
ifdef INSTALL_FPCSUBDIR
INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/fpc-$(FPC_VERSION)/$(INSTALL_FPCSUBDIR)/$(PACKAGE_NAME)
@ -396,16 +404,12 @@ endif
endif
endif
ifndef INSTALL_DOCDIR
ifdef UNIXHier
ifdef UNIXINSTALLDIR
ifdef BSDhier
DOCPREFIXDIR=share/doc
else
ifdef linuxHier
DOCPREFIXDIR=share/doc
else
DOCPREFIXDIR=doc
endif
endif
ifdef INSTALL_FPCPACKAGE
INSTALL_DOCDIR:=$(INSTALL_PREFIX)/$(DOCPREFIXDIR)/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
else
@ -420,28 +424,20 @@ endif
endif
endif
ifndef INSTALL_EXAMPLEDIR
ifdef UNIXHier
ifdef UNIXINSTALLDIR
ifdef INSTALL_FPCPACKAGE
ifdef BSDhier
INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
else
ifdef linuxHier
INSTALL_EXAMPLEDIR:=$(INSTALL_DOCDIR)/examples
else
INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/fpc-$(FPC_VERSION)/examples/$(PACKAGE_NAME)
endif
endif
else
ifdef BSDhier
INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
else
ifdef linuxHier
INSTALL_EXAMPLEDIR:=$(INSTALL_DOCDIR)/examples/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
else
INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
endif
endif
endif
else
ifdef INSTALL_FPCPACKAGE
INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples/$(PACKAGE_NAME)
@ -463,33 +459,20 @@ endif
else
CROSSBINDIR=
endif
ifeq ($(OS_SOURCE),linux)
ifdef inUnix
ifndef GCCLIBDIR
ifeq ($(CPU_TARGET),i386)
ifneq ($(findstring x86_64,$(shell uname -a)),)
ifeq ($(BINUTILSPREFIX),)
GCCLIBDIR:=$(shell dirname `gcc -m32 -print-libgcc-file-name`)
else
GCCLIBDIR:=$(shell dirname `$(BINUTILSPREFIX)gcc -print-libgcc-file-name`)
endif
else
GCCLIBDIR:=$(shell dirname `$(BINUTILSPREFIX)gcc -print-libgcc-file-name`)
endif
else
GCCLIBDIR:=$(shell dirname `$(BINUTILSPREFIX)gcc -print-libgcc-file-name`)
endif
GCCLIBDIR:=$(shell dirname `(gcc -v 2>&1)| head -n 1| awk '{ print $$4 } '`)
endif
ifeq ($(OS_TARGET),linux)
ifndef OTHERLIBDIR
OTHERLIBDIR:=$(shell grep -v "^\#" /etc/ld.so.conf | awk '{ ORS=" "; print $1 }')
endif
endif
ifdef inUnix
ifeq ($(OS_SOURCE),netbsd)
ifeq ($(OS_TARGET),netbsd)
OTHERLIBDIR+=/usr/pkg/lib
endif
export GCCLIBDIR OTHERLIB
endif
BATCHEXT=.bat
LOADEREXT=.as
EXEEXT=.exe
PPLEXT=.ppl
@ -513,37 +496,25 @@ STATICLIBPREFIX=
FPCMADE=fpcmade.dos
ZIPSUFFIX=go32
endif
ifeq ($(OS_TARGET),watcom)
STATICLIBPREFIX=
FPCMADE=fpcmade.wat
ZIPSUFFIX=watc
OEXT=.obj
ASMEXT=.asm
SHAREDLIBEXT=.dll
endif
ifeq ($(OS_TARGET),linux)
BATCHEXT=.sh
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.lnx
ZIPSUFFIX=linux
endif
ifeq ($(OS_TARGET),freebsd)
BATCHEXT=.sh
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.freebsd
ZIPSUFFIX=freebsd
endif
ifeq ($(OS_TARGET),netbsd)
BATCHEXT=.sh
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.netbsd
ZIPSUFFIX=netbsd
endif
ifeq ($(OS_TARGET),openbsd)
BATCHEXT=.sh
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.openbsd
@ -555,7 +526,6 @@ FPCMADE=fpcmade.w32
ZIPSUFFIX=w32
endif
ifeq ($(OS_TARGET),os2)
BATCHEXT=.cmd
AOUTEXT=.out
STATICLIBPREFIX=
SHAREDLIBEXT=.dll
@ -564,7 +534,6 @@ ZIPSUFFIX=os2
ECHO=echo
endif
ifeq ($(OS_TARGET),emx)
BATCHEXT=.cmd
AOUTEXT=.out
STATICLIBPREFIX=
SHAREDLIBEXT=.dll
@ -582,19 +551,16 @@ EXEEXT=.ttp
FPCMADE=fpcmade.ata
endif
ifeq ($(OS_TARGET),beos)
BATCHEXT=.sh
EXEEXT=
FPCMADE=fpcmade.be
ZIPSUFFIX=be
endif
ifeq ($(OS_TARGET),sunos)
BATCHEXT=.sh
EXEEXT=
FPCMADE=fpcmade.sun
ZIPSUFFIX=sun
endif
ifeq ($(OS_TARGET),qnx)
BATCHEXT=.sh
EXEEXT=
FPCMADE=fpcmade.qnx
ZIPSUFFIX=qnx
@ -606,14 +572,10 @@ FPCMADE=fpcmade.nw
ZIPSUFFIX=nw
endif
ifeq ($(OS_TARGET),macos)
BATCHEXT=
EXEEXT=
FPCMADE=fpcmade.macos
ZIPSUFFIX=macos
DEBUGSYMEXT=.xcoff
FPCMADE=fpcmade.mcc
endif
ifeq ($(OS_TARGET),darwin)
BATCHEXT=.sh
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.darwin
@ -636,34 +598,25 @@ STATICLIBPREFIX=
FPCMADE=fpcmade.dos
ZIPSUFFIX=go32
endif
ifeq ($(OS_TARGET),watcom)
STATICLIBPREFIX=
FPCMADE=fpcmade.dos
ZIPSUFFIX=watcom
endif
ifeq ($(OS_TARGET),linux)
BATCHEXT=.sh
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.lnx
ZIPSUFFIX=linux
endif
ifeq ($(OS_TARGET),freebsd)
BATCHEXT=.sh
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.freebsd
ZIPSUFFIX=freebsd
endif
ifeq ($(OS_TARGET),netbsd)
BATCHEXT=.sh
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.netbsd
ZIPSUFFIX=netbsd
endif
ifeq ($(OS_TARGET),openbsd)
BATCHEXT=.sh
EXEEXT=
HASSHAREDLIB=1
FPCMADE=fpcmade.openbsd
@ -680,7 +633,6 @@ FPCMADE=fpcmade.w32
ZIPSUFFIX=w32
endif
ifeq ($(OS_TARGET),os2)
BATCHEXT=.cmd
PPUEXT=.ppo
ASMEXT=.so2
OEXT=.oo2
@ -713,7 +665,6 @@ EXEEXT=.ttp
FPCMADE=fpcmade.ata
endif
ifeq ($(OS_TARGET),beos)
BATCHEXT=.sh
PPUEXT=.ppu
ASMEXT=.s
OEXT=.o
@ -724,7 +675,6 @@ FPCMADE=fpcmade.be
ZIPSUFFIX=be
endif
ifeq ($(OS_TARGET),sunos)
BATCHEXT=.sh
PPUEXT=.ppu
ASMEXT=.s
OEXT=.o
@ -735,7 +685,6 @@ FPCMADE=fpcmade.sun
ZIPSUFFIX=sun
endif
ifeq ($(OS_TARGET),qnx)
BATCHEXT=.sh
PPUEXT=.ppu
ASMEXT=.s
OEXT=.o
@ -758,15 +707,13 @@ ZIPSUFFIX=nw
EXEEXT=.nlm
endif
ifeq ($(OS_TARGET),macos)
BATCHEXT=
PPUEXT=.ppu
ASMEXT=.s
OEXT=.o
SMARTEXT=.sl
STATICLIBEXT=.a
EXEEXT=
DEBUGSYMEXT=.xcoff
FPCMADE=fpcmade.macos
FPCMADE=fpcmade.mcc
endif
endif
ifndef ECHO
@ -774,7 +721,7 @@ ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(ECHO),)
ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(ECHO),)
ECHO= __missing_command__
ECHO=
else
ECHO:=$(firstword $(ECHO))
endif
@ -788,7 +735,7 @@ DATE:=$(strip $(wildcard $(addsuffix /gdate$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(DATE),)
DATE:=$(strip $(wildcard $(addsuffix /date$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(DATE),)
DATE= __missing_command__
DATE=
else
DATE:=$(firstword $(DATE))
endif
@ -802,7 +749,7 @@ GINSTALL:=$(strip $(wildcard $(addsuffix /ginstall$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(GINSTALL),)
GINSTALL:=$(strip $(wildcard $(addsuffix /install$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(GINSTALL),)
GINSTALL= __missing_command__
GINSTALL=
else
GINSTALL:=$(firstword $(GINSTALL))
endif
@ -814,7 +761,7 @@ export GINSTALL
ifndef CPPROG
CPPROG:=$(strip $(wildcard $(addsuffix /cp$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(CPPROG),)
CPPROG= __missing_command__
CPPROG=
else
CPPROG:=$(firstword $(CPPROG))
endif
@ -823,7 +770,7 @@ export CPPROG
ifndef RMPROG
RMPROG:=$(strip $(wildcard $(addsuffix /rm$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(RMPROG),)
RMPROG= __missing_command__
RMPROG=
else
RMPROG:=$(firstword $(RMPROG))
endif
@ -832,18 +779,14 @@ export RMPROG
ifndef MVPROG
MVPROG:=$(strip $(wildcard $(addsuffix /mv$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(MVPROG),)
MVPROG= __missing_command__
MVPROG=
else
MVPROG:=$(firstword $(MVPROG))
endif
endif
export MVPROG
ifndef ECHOREDIR
ifndef inUnix
ECHOREDIR=echo
else
ECHOREDIR=$(ECHO)
endif
ECHOREDIR:=$(subst /,$(PATHSEP),$(ECHO))
endif
ifndef COPY
COPY:=$(CPPROG) -fp
@ -881,7 +824,7 @@ export ECHOREDIR COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR
ifndef PPUMOVE
PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(PPUMOVE),)
PPUMOVE= __missing_command__
PPUMOVE=
else
PPUMOVE:=$(firstword $(PPUMOVE))
endif
@ -890,7 +833,7 @@ export PPUMOVE
ifndef FPCMAKE
FPCMAKE:=$(strip $(wildcard $(addsuffix /fpcmake$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(FPCMAKE),)
FPCMAKE= __missing_command__
FPCMAKE=
else
FPCMAKE:=$(firstword $(FPCMAKE))
endif
@ -899,7 +842,7 @@ export FPCMAKE
ifndef ZIPPROG
ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(ZIPPROG),)
ZIPPROG= __missing_command__
ZIPPROG=
else
ZIPPROG:=$(firstword $(ZIPPROG))
endif
@ -908,25 +851,21 @@ export ZIPPROG
ifndef TARPROG
TARPROG:=$(strip $(wildcard $(addsuffix /tar$(SRCEXEEXT),$(SEARCHPATH))))
ifeq ($(TARPROG),)
TARPROG= __missing_command__
TARPROG=
else
TARPROG:=$(firstword $(TARPROG))
endif
endif
export TARPROG
ASNAME=$(BINUTILSPREFIX)as
LDNAME=$(BINUTILSPREFIX)ld
ARNAME=$(BINUTILSPREFIX)ar
RCNAME=$(BINUTILSPREFIX)rc
ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
ASNAME=as
LDNAME=ld
ARNAME=ar
RCNAME=rc
ifeq ($(OS_TARGET),win32)
ifeq ($(CROSSBINDIR),)
ASNAME=asw
LDNAME=ldw
ARNAME=arw
endif
endif
endif
ifndef ASPROG
ifdef CROSSBINDIR
ASPROG=$(CROSSBINDIR)/$(ASNAME)$(SRCEXEEXT)
@ -959,7 +898,7 @@ AS=$(ASPROG)
LD=$(LDPROG)
RC=$(RCPROG)
AR=$(ARPROG)
PPAS=ppas$(SRCBATCHEXT)
PPAS=ppas$(BATCHEXT)
ifdef inUnix
LDCONFIG=ldconfig
else
@ -1064,19 +1003,6 @@ REQUIRE_PACKAGES_IBASE=1
REQUIRE_PACKAGES_SQLITE=1
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),arm)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_PTHREADS=1
REQUIRE_PACKAGES_PASJPEG=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
REQUIRE_PACKAGES_SQLITE=1
endif
endif
ifeq ($(OS_TARGET),go32v2)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
@ -1133,19 +1059,6 @@ REQUIRE_PACKAGES_IBASE=1
REQUIRE_PACKAGES_SQLITE=1
endif
endif
ifeq ($(OS_TARGET),freebsd)
ifeq ($(CPU_TARGET),x86_64)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_PTHREADS=1
REQUIRE_PACKAGES_PASJPEG=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
REQUIRE_PACKAGES_SQLITE=1
endif
endif
ifeq ($(OS_TARGET),beos)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
@ -1179,30 +1092,6 @@ REQUIRE_PACKAGES_IBASE=1
REQUIRE_PACKAGES_SQLITE=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_PASJPEG=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
REQUIRE_PACKAGES_SQLITE=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),sparc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
REQUIRE_PACKAGES_PASJPEG=1
REQUIRE_PACKAGES_MYSQL=1
REQUIRE_PACKAGES_IBASE=1
REQUIRE_PACKAGES_SQLITE=1
endif
endif
ifeq ($(OS_TARGET),amiga)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
@ -1330,15 +1219,6 @@ REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),watcom)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_PASZLIB=1
REQUIRE_PACKAGES_PASJPEG=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),)
@ -1582,14 +1462,6 @@ endif
ifeq ($(OS_SOURCE),openbsd)
override FPCOPT+=-FD$(NEW_BINUTILS_PATH)
endif
ifndef CROSSBOOTSTRAP
ifneq ($(BINUTILSPREFIX),)
override FPCOPT+=-XP$(BINUTILSPREFIX) -Xc
endif
ifneq ($(BINUTILSPREFIX),)
override FPCOPT+=-Xr$(RLINKPATH)
endif
endif
ifdef UNITDIR
override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
endif
@ -1616,12 +1488,8 @@ ifdef RELEASE
ifeq ($(CPU_TARGET),i386)
FPCCPUOPT:=-OG2p3
else
ifeq ($(CPU_TARGET),powerpc)
FPCCPUOPT:=-O1
else
FPCCPUOPT:=
endif
endif
override FPCOPT+=-Xs $(FPCCPUOPT) -n
override FPCOPTDEF+=RELEASE
endif
@ -1709,7 +1577,7 @@ EXECPPAS:=@$(PPAS)
endif
endif
.PHONY: fpc_units
ifneq ($(TARGET_UNITS),)
ifdef TARGET_UNITS
override ALLTARGET+=fpc_units
override UNITPPUFILES=$(addsuffix $(PPUEXT),$(TARGET_UNITS))
override IMPLICITUNITPPUFILES=$(addsuffix $(PPUEXT),$(TARGET_IMPLICITUNITS))
@ -1722,9 +1590,9 @@ override RSTFILES=$(addsuffix $(RSTEXT),$(TARGET_RSTS))
override CLEANRSTFILES+=$(RSTFILES)
endif
.PHONY: fpc_examples
ifneq ($(TARGET_EXAMPLES),)
ifdef TARGET_EXAMPLES
HASEXAMPLES=1
override EXAMPLESOURCEFILES:=$(wildcard $(addsuffix .pp,$(TARGET_EXAMPLES)) $(addsuffix .pas,$(TARGET_EXAMPLES)) $(addsuffix .dpr,$(TARGET_EXAMPLES)))
override EXAMPLESOURCEFILES:=$(wildcard $(addsuffix .pp,$(TARGET_EXAMPLES)) $(addsuffix .pas,$(TARGET_EXAMPLES)))
override EXAMPLEFILES:=$(addsuffix $(EXEEXT),$(TARGET_EXAMPLES))
override EXAMPLEOFILES:=$(addsuffix $(OEXT),$(TARGET_EXAMPLES)) $(addprefix $(STATICLIBPREFIX),$(addsuffix $(STATICLIBEXT),$(TARGET_EXAMPLES)))
override CLEANEXEFILES+=$(EXAMPLEFILES) $(EXAMPLEOFILES)
@ -1735,7 +1603,7 @@ ifeq ($(OS_TARGET),emx)
override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_EXAMPLES))
endif
endif
ifneq ($(TARGET_EXAMPLEDIRS),)
ifdef TARGET_EXAMPLEDIRS
HASEXAMPLES=1
endif
fpc_examples: all $(EXAMPLEFILES) $(addsuffix _all,$(TARGET_EXAMPLEDIRS))
@ -1749,7 +1617,7 @@ fpc_debug:
$(MAKE) all DEBUG=1
fpc_release:
$(MAKE) all RELEASE=1
.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .dpr .pp .rc .res
.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp .rc .res
%$(PPUEXT): %.pp
$(COMPILER) $<
$(EXECPPAS)
@ -1762,14 +1630,10 @@ fpc_release:
%$(EXEEXT): %.pas
$(COMPILER) $<
$(EXECPPAS)
%$(EXEEXT): %.dpr
$(COMPILER) $<
$(EXECPPAS)
%.res: %.rc
windres -i $< -o $@
vpath %.pp $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
vpath %.pas $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
vpath %.dpr $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
vpath %$(PPUEXT) $(COMPILER_UNITTARGETDIR)
.PHONY: fpc_install fpc_sourceinstall fpc_exampleinstall
ifdef INSTALL_UNITS
@ -1871,7 +1735,7 @@ USEZIPWRAPPER=1
endif
ifdef USEZIPWRAPPER
ZIPPATHSEP=$(PATHSEP)
ZIPWRAPPER=$(subst /,$(PATHSEP),$(DIST_DESTDIR)/fpczip$(SRCBATCHEXT))
ZIPWRAPPER=$(subst /,$(PATHSEP),$(DIST_DESTDIR)/fpczip$(BATCHEXT))
else
ZIPPATHSEP=/
endif
@ -1925,9 +1789,6 @@ override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(CLEAN_UNITS))
endif
ifdef CLEANPPUFILES
override CLEANPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES)))
ifdef DEBUGSYMEXT
override CLEANPPULINKFILES+=$(subst $(PPUEXT),$(DEBUGSYMEXT),$(CLEANPPUFILES))
endif
override CLEANPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILES))
override CLEANPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILES)))
endif
@ -1951,7 +1812,6 @@ ifdef LIB_NAME
-$(DEL) $(LIB_NAME) $(LIB_FULLNAME)
endif
-$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
-$(DEL) *$(ASMEXT) *_ppas$(BATCHEXT)
fpc_distclean: clean
ifdef COMPILER_UNITTARGETDIR
TARGETDIRCLEAN=fpc_clean
@ -1963,13 +1823,9 @@ endif
-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
-$(DELTREE) *$(SMARTEXT)
-$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
-$(DEL) *_ppas$(BATCHEXT)
ifdef AOUTEXT
-$(DEL) *$(AOUTEXT)
endif
ifdef DEBUGSYMEXT
-$(DEL) *$(DEBUGSYMEXT)
endif
.PHONY: fpc_baseinfo
override INFORULES+=fpc_baseinfo
fpc_baseinfo:

2
fcl/Makefile.fpc
View File

@ -23,7 +23,7 @@ units=adler gzcrc gzio infblock infcodes inffast inftrees infutil minigzip paszl
dirs=xml image db shedit passrc net
units=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext \
iostream zstream cachecls xmlreg registry eventlog custapp cgiapp \
wformat whtml wtex
wformat whtml wtex rttiutils
units_freebsd=process ssockets resolve fpasync syncobjs
units_darwin=process ssockets resolve fpasync syncobjs
units_netbsd=process ssockets resolve fpasync

911
fcl/inc/rttiutils.pp Normal file
View File

@ -0,0 +1,911 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2004 by the Free Pascal development team
Some RTTI utils, based on RX rtti utils.
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.
**********************************************************************}
{ **********************************************************************
Based on the rttiutils unit that comes with RXLib.
Adapted to work with FCL, free of VCL dependencies.
Fixed some errors along the way as well. MVC.
To make it work across the 'Root Component' (Form/Datamodule etc),
you MUST set the FindGlobalComponentCallBack event handler.
Original copyright:
Delphi VCL Extensions (RX)
Copyright (c) 1995, 1996 AO ROSNO
Copyright (c) 1997 Master-Bank
**********************************************************************}
{$mode objfpc}
{$H+}
unit rttiutils;
interface
uses
SysUtils, Classes, {Graphics, Controls, Forms,} TypInfo, StrUtils;
type
{ TPropInfoList }
TPropInfoList = class(TObject)
private
FList: PPropList;
FCount: Integer;
FSize: Integer;
function Get(Index: Integer): PPropInfo;
public
constructor Create(AObject: TObject; Filter: TTypeKinds);
destructor Destroy; override;
function Contains(P: PPropInfo): Boolean;
function Find(const AName: string): PPropInfo;
procedure Delete(Index: Integer);
procedure Intersect(List: TPropInfoList);
property Count: Integer read FCount;
property Items[Index: Integer]: PPropInfo read Get; default;
end;
{ TPropsStorage }
TReadStrEvent = function(const ASection, Item, Default: string): string of object;
TWriteStrEvent = procedure(const ASection, Item, Value: string) of object;
TEraseSectEvent = procedure(const ASection: string) of object;
TPropsStorage = class(TObject)
private
FObject: TObject;
FOwner: TComponent;
FPrefix: string;
FSection: string;
FOnReadString: TReadStrEvent;
FOnWriteString: TWriteStrEvent;
FOnEraseSection: TEraseSectEvent;
function StoreIntegerProperty(PropInfo: PPropInfo): string;
function StoreCharProperty(PropInfo: PPropInfo): string;
function StoreEnumProperty(PropInfo: PPropInfo): string;
function StoreFloatProperty(PropInfo: PPropInfo): string;
function StoreStringProperty(PropInfo: PPropInfo): string;
function StoreSetProperty(PropInfo: PPropInfo): string;
function StoreClassProperty(PropInfo: PPropInfo): string;
function StoreStringsProperty(PropInfo: PPropInfo): string;
function StoreComponentProperty(PropInfo: PPropInfo): string;
function StoreLStringProperty(PropInfo: PPropInfo): string;
function StoreWCharProperty(PropInfo: PPropInfo): string;
function StoreVariantProperty(PropInfo: PPropInfo): string;
procedure LoadLStringProperty(const S: string; PropInfo: PPropInfo);
procedure LoadWCharProperty(const S: string; PropInfo: PPropInfo);
procedure LoadVariantProperty(const S: string; PropInfo: PPropInfo);
function StoreInt64Property(PropInfo: PPropInfo): string;
procedure LoadInt64Property(const S: string; PropInfo: PPropInfo);
procedure LoadIntegerProperty(const S: string; PropInfo: PPropInfo);
procedure LoadCharProperty(const S: string; PropInfo: PPropInfo);
procedure LoadEnumProperty(const S: string; PropInfo: PPropInfo);
procedure LoadFloatProperty(const S: string; PropInfo: PPropInfo);
procedure LoadStringProperty(const S: string; PropInfo: PPropInfo);
procedure LoadSetProperty(const S: string; PropInfo: PPropInfo);
procedure LoadClassProperty(const S: string; PropInfo: PPropInfo);
procedure LoadStringsProperty(const S: string; PropInfo: PPropInfo);
procedure LoadComponentProperty(const S: string; PropInfo: PPropInfo);
function CreateInfoList(AComponent: TComponent; StoredList: TStrings): TStrings;
procedure FreeInfoLists(Info: TStrings);
protected
function ReadString(const ASection, Item, Default: string): string; virtual;
procedure WriteString(const ASection, Item, Value: string); virtual;
procedure EraseSection(const ASection: string); virtual;
function GetItemName(const APropName: string): string; virtual;
function CreateStorage: TPropsStorage; virtual;
public
procedure StoreAnyProperty(PropInfo: PPropInfo);
procedure LoadAnyProperty(PropInfo: PPropInfo);
procedure StoreProperties(PropList: TStrings);
procedure LoadProperties(PropList: TStrings);
procedure LoadObjectsProps(AComponent: TComponent; StoredList: TStrings);
procedure StoreObjectsProps(AComponent: TComponent; StoredList: TStrings);
property AObject: TObject read FObject write FObject;
property Prefix: string read FPrefix write FPrefix;
property Section: string read FSection write FSection;
property OnReadString: TReadStrEvent read FOnReadString write FOnReadString;
property OnWriteString: TWriteStrEvent read FOnWriteString write FOnWriteString;
property OnEraseSection: TEraseSectEvent read FOnEraseSection write FOnEraseSection;
end;
{ Utility routines }
procedure UpdateStoredList(AComponent: TComponent; AStoredList: TStrings; FromForm: Boolean);
function CreateStoredItem(const CompName, PropName: string): string;
function ParseStoredItem(const Item: string; var CompName, PropName: string): Boolean;
const
sPropNameDelimiter: string = '_';
Type
TFindComponentEvent = Function (Const Name : String) : TComponent;
Var
FindGlobalComponentCallBack : TFindComponentEvent;
implementation
const
sCount = 'Count';
sItem = 'Item%d';
sNull = '(null)';
type
TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;
function GetPropType(PropInfo: PPropInfo): PTypeInfo;
begin
Result := PropInfo^.PropType;
end;
{ TPropInfoList }
constructor TPropInfoList.Create(AObject: TObject; Filter: TTypeKinds);
begin
if AObject <> nil then
begin
FCount := GetPropList(AObject.ClassInfo, Filter, nil);
FSize := FCount * SizeOf(Pointer);
GetMem(FList, FSize);
GetPropList(AObject.ClassInfo, Filter, FList);
end
else
begin
FCount := 0;
FList := nil;
end;
end;
destructor TPropInfoList.Destroy;
begin
if FList <> nil then FreeMem(FList, FSize);
end;
function TPropInfoList.Contains(P: PPropInfo): Boolean;
var
I: Integer;
begin
for I := 0 to FCount - 1 do
with FList^[I]^ do
if (PropType = P^.PropType) and (CompareText(Name, P^.Name) = 0) then
begin
Result := True;
Exit;
end;
Result := False;
end;
function TPropInfoList.Find(const AName: string): PPropInfo;
var
I: Integer;
begin
for I := 0 to FCount - 1 do
with FList^[I]^ do
if (CompareText(Name, AName) = 0) then
begin
Result := FList^[I];
Exit;
end;
Result := nil;
end;
procedure TPropInfoList.Delete(Index: Integer);
begin
Dec(FCount);
if Index < FCount then Move(FList^[Index + 1], FList^[Index],
(FCount - Index) * SizeOf(Pointer));
end;
function TPropInfoList.Get(Index: Integer): PPropInfo;
begin
Result := FList^[Index];
end;
procedure TPropInfoList.Intersect(List: TPropInfoList);
var
I: Integer;
begin
for I := FCount - 1 downto 0 do
if not List.Contains(FList^[I]) then Delete(I);
end;
{ Utility routines }
function CreateStoredItem(const CompName, PropName: string): string;
begin
Result := '';
if (CompName <> '') and (PropName <> '') then
Result := CompName + '.' + PropName;
end;
function ParseStoredItem(const Item: string; var CompName, PropName: string): Boolean;
var
I: Integer;
begin
Result := False;
if Length(Item) = 0 then Exit;
I := Pos('.', Item);
if I > 0 then begin
CompName := Trim(Copy(Item, 1, I - 1));
PropName := Trim(Copy(Item, I + 1, MaxInt));
Result := (Length(CompName) > 0) and (Length(PropName) > 0);
end;
end;
function ReplaceComponentName(const Item, CompName: string): string;
var
ACompName, APropName: string;
begin
Result := '';
if ParseStoredItem(Item, ACompName, APropName) then
Result := CreateStoredItem(CompName, APropName);
end;
procedure UpdateStoredList(AComponent: TComponent; AStoredList: TStrings; FromForm: Boolean);
var
I: Integer;
Component: TComponent;
CompName, PropName: string;
begin
if (AStoredList = nil) or (AComponent = nil) then
Exit;
for I := AStoredList.Count - 1 downto 0 do
begin
if ParseStoredItem(AStoredList[I], CompName, PropName) then
begin
if FromForm then
begin
Component := AComponent.FindComponent(CompName);
if Component = nil then
AStoredList.Delete(I)
else
AStoredList.Objects[I]:=Component;
end
else
begin
Component := TComponent(AStoredList.Objects[I]);
if Component <> nil then
AStoredList[I] := ReplaceComponentName(AStoredList[I], Component.Name)
else
AStoredList.Delete(I);
end;
end
else
AStoredList.Delete(I);
end;
end;
function FindGlobalComponent(const Name: string): TComponent;
begin
Result:=Nil;
If Assigned(FindGlobalComponentCallBack) then
Result:=FindGlobalComponentCallBack(Name);
end;
{ TPropsStorage }
function TPropsStorage.GetItemName(const APropName: string): string;
begin
Result := Prefix + APropName;
end;
procedure TPropsStorage.LoadAnyProperty(PropInfo: PPropInfo);
var
S, Def: string;
begin
try
if PropInfo <> nil then
begin
case PropInfo^.PropType^.Kind of
tkBool,
tkInteger: Def := StoreIntegerProperty(PropInfo);
tkChar: Def := StoreCharProperty(PropInfo);
tkEnumeration: Def := StoreEnumProperty(PropInfo);
tkFloat: Def := StoreFloatProperty(PropInfo);
tkWChar: Def := StoreWCharProperty(PropInfo);
tkAstring,
tkLString: Def := StoreLStringProperty(PropInfo);
tkWString: Def := StoreLStringProperty(PropInfo);
tkVariant: Def := StoreVariantProperty(PropInfo);
tkInt64: Def := StoreInt64Property(PropInfo);
tkString: Def := StoreStringProperty(PropInfo);
tkSet: Def := StoreSetProperty(PropInfo);
tkClass: Def := '';
else
Exit;
end;
if (Def <> '') or (PropInfo^.PropType^.Kind in [tkString, tkClass])
or (PropInfo^.PropType^.Kind in [tkAString,tkLString, tkWString, tkWChar]) then
S := Trim(ReadString(Section, GetItemName(PropInfo^.Name), Def))
else
S := '';
case PropInfo^.PropType^.Kind of
tkBool:LoadIntegerProperty(S,PropInfo);
tkInteger: LoadIntegerProperty(S, PropInfo);
tkChar: LoadCharProperty(S, PropInfo);
tkEnumeration: LoadEnumProperty(S, PropInfo);
tkFloat: LoadFloatProperty(S, PropInfo);
tkWChar: LoadWCharProperty(S, PropInfo);
tkAString,
tkLString: LoadLStringProperty(S, PropInfo);
tkWString: LoadLStringProperty(S, PropInfo);
tkVariant: LoadVariantProperty(S, PropInfo);
tkInt64: LoadInt64Property(S, PropInfo);
tkString: LoadStringProperty(S, PropInfo);
tkSet: LoadSetProperty(S, PropInfo);
tkClass: LoadClassProperty(S, PropInfo);
else
Exit;
end;
end;
except
{ ignore any exception }
end;
end;
procedure TPropsStorage.StoreAnyProperty(PropInfo: PPropInfo);
var
S: string;
begin
if PropInfo <> nil then
begin
case PropInfo^.PropType^.Kind of
tkInteger: S := StoreIntegerProperty(PropInfo);
tkChar: S := StoreCharProperty(PropInfo);
tkEnumeration: S := StoreEnumProperty(PropInfo);
tkFloat: S := StoreFloatProperty(PropInfo);
tkAstring: S := StoreLStringProperty(PropInfo);
tkWString: S := StoreLStringProperty(PropInfo);
tkWChar: S := StoreWCharProperty(PropInfo);
tkVariant: S := StoreVariantProperty(PropInfo);
tkInt64: S := StoreInt64Property(PropInfo);
tkString: S := StoreStringProperty(PropInfo);
tkSet: S := StoreSetProperty(PropInfo);
tkClass: S := StoreClassProperty(PropInfo);
tkBool: S:=StoreIntegerProperty(PropInfo);
else
Exit;
end;
if (S <> '') or (PropInfo^.PropType^.Kind in [tkString
, tkLString, tkWString, tkWChar ]) then
WriteString(Section, GetItemName(PropInfo^.Name), Trim(S));
end;
end;
function TPropsStorage.StoreIntegerProperty(PropInfo: PPropInfo): string;
begin
Result := IntToStr(GetOrdProp(FObject, PropInfo));
end;
function TPropsStorage.StoreCharProperty(PropInfo: PPropInfo): string;
begin
Result := Char(GetOrdProp(FObject, PropInfo));
end;
function TPropsStorage.StoreEnumProperty(PropInfo: PPropInfo): string;
begin
Result := GetEnumName(GetPropType(PropInfo), GetOrdProp(FObject, PropInfo));
end;
function TPropsStorage.StoreFloatProperty(PropInfo: PPropInfo): string;
const
Precisions: array[TFloatType] of Integer = (7, 15, 18, 18, 19);
begin
Result := StringReplace(FloatToStrF(GetFloatProp(FObject, PropInfo), ffGeneral,
Precisions[GetTypeData(GetPropType(PropInfo))^.FloatType], 0),
DecimalSeparator, '.',[rfReplaceAll]);
end;
function TPropsStorage.StoreStringProperty(PropInfo: PPropInfo): string;
begin
Result := GetStrProp(FObject, PropInfo);
end;
function TPropsStorage.StoreLStringProperty(PropInfo: PPropInfo): string;
begin
Result := GetStrProp(FObject, PropInfo);
end;
function TPropsStorage.StoreWCharProperty(PropInfo: PPropInfo): string;
begin
Result := Char(GetOrdProp(FObject, PropInfo));
end;
function TPropsStorage.StoreVariantProperty(PropInfo: PPropInfo): string;
begin
Result := GetVariantProp(FObject, PropInfo);
end;
function TPropsStorage.StoreInt64Property(PropInfo: PPropInfo): string;
begin
Result := IntToStr(GetInt64Prop(FObject, PropInfo));
end;
function TPropsStorage.StoreSetProperty(PropInfo: PPropInfo): string;
var
TypeInfo: PTypeInfo;
W: Cardinal;
I: Integer;
begin
Result := '[';
W := GetOrdProp(FObject, PropInfo);
TypeInfo := GetTypeData(GetPropType(PropInfo))^.CompType;
for I := 0 to SizeOf(TCardinalSet) * 8 - 1 do
if I in TCardinalSet(W) then begin
if Length(Result) <> 1 then Result := Result + ',';
Result := Result + GetEnumName(TypeInfo, I);
end;
Result := Result + ']';
end;
function TPropsStorage.StoreStringsProperty(PropInfo: PPropInfo): string;
var
List: TObject;
I: Integer;
SectName: string;
begin
Result := '';
List := TObject(GetOrdProp(Self.FObject, PropInfo));
SectName := Format('%s.%s', [Section, GetItemName(PropInfo^.Name)]);
EraseSection(SectName);
if (List is TStrings) and (TStrings(List).Count > 0) then begin
WriteString(SectName, sCount, IntToStr(TStrings(List).Count));
for I := 0 to TStrings(List).Count - 1 do
WriteString(SectName, Format(sItem, [I]), TStrings(List)[I]);
end;
end;
function TPropsStorage.StoreComponentProperty(PropInfo: PPropInfo): string;
var
Comp: TComponent;
RootName: string;
begin
Comp := TComponent(GetOrdProp(FObject, PropInfo));
if Comp <> nil then begin
Result := Comp.Name;
if (Comp.Owner <> nil) and (Comp.Owner <> FOwner) then begin
RootName := Comp.Owner.Name;
if RootName = '' then begin
RootName := Comp.Owner.ClassName;
if (RootName <> '') and (UpCase(RootName[1]) = 'T') then
Delete(RootName, 1, 1);
end;
Result := Format('%s.%s', [RootName, Result]);
end;
end
else Result := sNull;
end;
function TPropsStorage.StoreClassProperty(PropInfo: PPropInfo): string;
var
Saver: TPropsStorage;
I: Integer;
Obj: TObject;
procedure StoreObjectProps(Obj: TObject; const APrefix, ASection: string);
var
I: Integer;
Props: TPropInfoList;
begin
with Saver do begin
AObject := Obj;
Prefix := APrefix;
Section := ASection;
FOnWriteString := Self.FOnWriteString;
FOnEraseSection := Self.FOnEraseSection;
Props := TPropInfoList.Create(AObject, tkProperties);
try
for I := 0 to Props.Count - 1 do StoreAnyProperty(Props.Items[I]);
finally
Props.Free;
end;
end;
end;
begin
Result := '';
Obj := TObject(GetOrdProp(Self.FObject, PropInfo));
if (Obj <> nil) then begin
if Obj is TStrings then StoreStringsProperty(PropInfo)
else if Obj is TCollection then begin
EraseSection(Format('%s.%s', [Section, Prefix + PropInfo^.Name]));
Saver := CreateStorage;
try
WriteString(Section, Format('%s.%s', [Prefix + PropInfo^.Name, sCount]),
IntToStr(TCollection(Obj).Count));
for I := 0 to TCollection(Obj).Count - 1 do begin
StoreObjectProps(TCollection(Obj).Items[I],
Format(sItem, [I]) + sPropNameDelimiter,
Format('%s.%s', [Section, Prefix + PropInfo^.Name]));
end;
finally
Saver.Free;
end;
end
else if Obj is TComponent then begin
Result := StoreComponentProperty(PropInfo);
Exit;
end;
end;
Saver := CreateStorage;
try
with Saver do begin
StoreObjectProps(Obj, Self.Prefix + PropInfo^.Name, Self.Section);
end;
finally
Saver.Free;
end;
end;
procedure TPropsStorage.LoadIntegerProperty(const S: string; PropInfo: PPropInfo);
begin
SetOrdProp(FObject, PropInfo, StrToIntDef(S, 0));
end;
procedure TPropsStorage.LoadCharProperty(const S: string; PropInfo: PPropInfo);
begin
SetOrdProp(FObject, PropInfo, Integer(S[1]));
end;
procedure TPropsStorage.LoadEnumProperty(const S: string; PropInfo: PPropInfo);
var
I: Integer;
EnumType: PTypeInfo;
begin
EnumType := GetPropType(PropInfo);
with GetTypeData(EnumType)^ do
for I := MinValue to MaxValue do
if CompareText(GetEnumName(EnumType, I), S) = 0 then
begin
SetOrdProp(FObject, PropInfo, I);
Exit;
end;
end;
procedure TPropsStorage.LoadFloatProperty(const S: string; PropInfo: PPropInfo);
begin
SetFloatProp(FObject, PropInfo, StrToFloat(StringReplace(S, '.',
DecimalSeparator,[rfReplaceAll])));
end;
procedure TPropsStorage.LoadInt64Property(const S: string; PropInfo: PPropInfo);
begin
SetInt64Prop(FObject, PropInfo, StrToInt64Def(S, 0));
end;
procedure TPropsStorage.LoadLStringProperty(const S: string; PropInfo: PPropInfo);
begin
SetStrProp(FObject, PropInfo, S);
end;
procedure TPropsStorage.LoadWCharProperty(const S: string; PropInfo: PPropInfo);
begin
SetOrdProp(FObject, PropInfo, Longint(S[1]));
end;
procedure TPropsStorage.LoadVariantProperty(const S: string; PropInfo: PPropInfo);
begin
SetVariantProp(FObject, PropInfo, S);
end;
procedure TPropsStorage.LoadStringProperty(const S: string; PropInfo: PPropInfo);
begin
SetStrProp(FObject, PropInfo, S);
end;
procedure TPropsStorage.LoadSetProperty(const S: string; PropInfo: PPropInfo);
const
Delims = [' ', ',', '[', ']'];
var
TypeInfo: PTypeInfo;
W: Cardinal;
I, N: Integer;
Count: Integer;
EnumName: string;
begin
W := 0;
TypeInfo := GetTypeData(GetPropType(PropInfo))^.CompType;
Count := WordCount(S, Delims);
for N := 1 to Count do begin
EnumName := ExtractWord(N, S, Delims);
try
I := GetEnumValue(TypeInfo, EnumName);
if I >= 0 then Include(TCardinalSet(W), I);
except
end;
end;
SetOrdProp(FObject, PropInfo, W);
end;
procedure TPropsStorage.LoadStringsProperty(const S: string; PropInfo: PPropInfo);
var
List: TObject;
Temp: TStrings;
I, Cnt: Integer;
SectName: string;
begin
List := TObject(GetOrdProp(Self.FObject, PropInfo));
if (List is TStrings) then begin
SectName := Format('%s.%s', [Section, GetItemName(PropInfo^.Name)]);
Cnt := StrToIntDef(Trim(ReadString(SectName, sCount, '0')), 0);
if Cnt > 0 then begin
Temp := TStringList.Create;
try
for I := 0 to Cnt - 1 do
Temp.Add(ReadString(SectName, Format(sItem, [I]), ''));
TStrings(List).Assign(Temp);
finally
Temp.Free;
end;
end;
end;
end;
procedure TPropsStorage.LoadComponentProperty(const S: string; PropInfo: PPropInfo);
var
RootName, Name: string;
Root: TComponent;
P: Integer;
begin
if Trim(S) = '' then Exit;
if CompareText(SNull, Trim(S)) = 0 then begin
SetOrdProp(FObject, PropInfo, Longint(nil));
Exit;
end;
P := Pos('.', S);
if P > 0 then begin
RootName := Trim(Copy(S, 1, P - 1));
Name := Trim(Copy(S, P + 1, MaxInt));
end
else begin
RootName := '';
Name := Trim(S);
end;
if RootName <> '' then Root := FindGlobalComponent(RootName)
else Root := FOwner;
if (Root <> nil) then
SetOrdProp(FObject, PropInfo, Longint(Root.FindComponent(Name)));
end;
procedure TPropsStorage.LoadClassProperty(const S: string; PropInfo: PPropInfo);
var
Loader: TPropsStorage;
I: Integer;
Cnt: Integer;
Recreate: Boolean;
Obj: TObject;
procedure LoadObjectProps(Obj: TObject; const APrefix, ASection: string);
var
I: Integer;
Props: TPropInfoList;
begin
with Loader do begin
AObject := Obj;
Prefix := APrefix;
Section := ASection;
FOnReadString := Self.FOnReadString;
Props := TPropInfoList.Create(AObject, tkProperties);
try
for I := 0 to Props.Count - 1 do LoadAnyProperty(Props.Items[I]);
finally
Props.Free;
end;
end;
end;
begin
Obj := TObject(GetOrdProp(Self.FObject, PropInfo));
if (Obj <> nil) then begin
if Obj is TStrings then LoadStringsProperty(S, PropInfo)
else if Obj is TCollection then begin
Loader := CreateStorage;
try
Cnt := TCollection(Obj).Count;
Cnt := StrToIntDef(ReadString(Section, Format('%s.%s',
[Prefix + PropInfo^.Name, sCount]), IntToStr(Cnt)), Cnt);
Recreate := TCollection(Obj).Count <> Cnt;
TCollection(Obj).BeginUpdate;
try
if Recreate then TCollection(Obj).Clear;
for I := 0 to Cnt - 1 do begin
if Recreate then TCollection(Obj).Add;
LoadObjectProps(TCollection(Obj).Items[I],
Format(sItem, [I]) + sPropNameDelimiter,
Format('%s.%s', [Section, Prefix + PropInfo^.Name]));
end;
finally
TCollection(Obj).EndUpdate;
end;
finally
Loader.Free;
end;
end
else if Obj is TComponent then begin
LoadComponentProperty(S, PropInfo);
Exit;
end;
end;
Loader := CreateStorage;
try
LoadObjectProps(Obj, Self.Prefix + PropInfo^.Name, Self.Section);
finally
Loader.Free;
end;
end;
procedure TPropsStorage.StoreProperties(PropList: TStrings);
var
I: Integer;
Props: TPropInfoList;
begin
Props := TPropInfoList.Create(AObject, tkProperties);
try
for I := 0 to PropList.Count - 1 do
StoreAnyProperty(Props.Find(PropList[I]));
finally
Props.Free;
end;
end;
procedure TPropsStorage.LoadProperties(PropList: TStrings);
var
I: Integer;
Props: TPropInfoList;
begin
Props := TPropInfoList.Create(AObject, tkProperties);
try
for I := 0 to PropList.Count - 1 do
LoadAnyProperty(Props.Find(PropList[I]));
finally
Props.Free;
end;
end;
function TPropsStorage.CreateInfoList(AComponent: TComponent; StoredList: TStrings): TStrings;
var
I: Integer;
Obj: TComponent;
Props: TPropInfoList;
begin
UpdateStoredList(AComponent, StoredList, False);
Result := TStringList.Create;
try
TStringList(Result).Sorted := True;
for I := 0 to StoredList.Count - 1 do
begin
Obj := TComponent(StoredList.Objects[I]);
if Result.IndexOf(Obj.Name) < 0 then
begin
Props := TPropInfoList.Create(Obj, tkProperties);
try
Result.AddObject(Obj.Name, Props);
except
Props.Free;
raise;
end;
end;
end;
except
On E : Exception do
begin
Result.Free;
Result := nil;
end;
end;
end;
procedure TPropsStorage.FreeInfoLists(Info: TStrings);
var
I: Integer;
begin
for I := Info.Count - 1 downto 0 do Info.Objects[I].Free;
Info.Free;
end;
procedure TPropsStorage.LoadObjectsProps(AComponent: TComponent; StoredList: TStrings);
var
Info: TStrings;
I, Idx: Integer;
Props: TPropInfoList;
CompName, PropName: string;
begin
Info := CreateInfoList(AComponent, StoredList);
if Info <> nil then
try
FOwner := AComponent;
for I := 0 to StoredList.Count - 1 do
begin
if ParseStoredItem(StoredList[I], CompName, PropName) then
begin
AObject := StoredList.Objects[I];
Prefix := TComponent(AObject).Name;
Idx := Info.IndexOf(Prefix);
if Idx >= 0 then
begin
Prefix := Prefix + sPropNameDelimiter;
Props := TPropInfoList(Info.Objects[Idx]);
if Props <> nil then
LoadAnyProperty(Props.Find(PropName));
end;
end;
end;
finally
FOwner := nil;
FreeInfoLists(Info);
end;
end;
procedure TPropsStorage.StoreObjectsProps(AComponent: TComponent; StoredList: TStrings);
var
Info: TStrings;
I, Idx: Integer;
Props: TPropInfoList;
CompName, PropName: string;
begin
Info := CreateInfoList(AComponent, StoredList);
if Info <> nil then
try
FOwner := AComponent;
for I := 0 to StoredList.Count - 1 do
begin
if ParseStoredItem(StoredList[I], CompName, PropName) then
begin
AObject := StoredList.Objects[I];
Prefix := TComponent(AObject).Name;
Idx := Info.IndexOf(Prefix);
if Idx >= 0 then
begin
Prefix := Prefix + sPropNameDelimiter;
Props := TPropInfoList(Info.Objects[Idx]);
if Props <> nil then
StoreAnyProperty(Props.Find(PropName));
end;
end;
end;
finally
FOwner := nil;
FreeInfoLists(Info);
end;
end;
function TPropsStorage.CreateStorage: TPropsStorage;
begin
Result := TPropsStorage.Create;
end;
function TPropsStorage.ReadString(const ASection, Item, Default: string): string;
begin
if Assigned(FOnReadString) then Result := FOnReadString(ASection, Item, Default)
else Result := '';
end;
procedure TPropsStorage.WriteString(const ASection, Item, Value: string);
begin
if Assigned(FOnWriteString) then FOnWriteString(ASection, Item, Value);
end;
procedure TPropsStorage.EraseSection(const ASection: string);
begin
if Assigned(FOnEraseSection) then FOnEraseSection(ASection);
end;
end.