Merged revisions 896,913-914,916-917,930-931,944,985 via svnmerge from

/trunk

git-svn-id: branches/fixes_2_0@995 -

.gitattributes

@@ -725,6 +725,7 @@ fcl/inc/cachecls.pp svneol=native#text/plain
 fcl/inc/cgiapp.pp svneol=native#text/plain
 fcl/inc/contnrs.pp svneol=native#text/plain
 fcl/inc/custapp.pp svneol=native#text/plain
+fcl/inc/dbugintf.pp svneol=native#text/plain
 fcl/inc/eventlog.pp svneol=native#text/plain
 fcl/inc/ezcgi.pp svneol=native#text/plain
 fcl/inc/felog.inc svneol=native#text/plain
@@ -733,6 +734,7 @@ fcl/inc/gettext.pp svneol=native#text/plain
 fcl/inc/idea.pp svneol=native#text/plain
 fcl/inc/inifiles.pp svneol=native#text/plain
 fcl/inc/iostream.pp svneol=native#text/plain
+fcl/inc/msgintf.pp svneol=native#text/plain
 fcl/inc/pipes.pp svneol=native#text/plain
 fcl/inc/process.pp svneol=native#text/plain
 fcl/inc/process.txt svneol=native#text/plain
@@ -743,6 +745,7 @@ fcl/inc/resolve.pp svneol=native#text/plain
 fcl/inc/rtfdata.inc svneol=native#text/plain
 fcl/inc/rtfpars.pp svneol=native#text/plain
 fcl/inc/rttiutils.pp svneol=native#text/plain
+fcl/inc/simpleipc.pp svneol=native#text/plain
 fcl/inc/ssockets.pp svneol=native#text/plain
 fcl/inc/streamex.pp svneol=native#text/plain
 fcl/inc/streamio.pp svneol=native#text/plain
@@ -794,7 +797,6 @@ fcl/passrc/paswrite.pp svneol=native#text/plain
 fcl/passrc/pparser.pp svneol=native#text/plain
 fcl/passrc/pscanner.pp svneol=native#text/plain
 fcl/passrc/readme.txt svneol=native#text/plain
-fcl/posix/custapp.inc svneol=native#text/plain
 fcl/posix/ezcgi.inc svneol=native#text/plain
 fcl/posix/pipes.inc svneol=native#text/plain
 fcl/posix/readme.txt svneol=native#text/plain
@@ -835,6 +837,8 @@ fcl/tests/b64test.pp svneol=native#text/plain
 fcl/tests/b64test2.pp svneol=native#text/plain
 fcl/tests/cachetest.pp svneol=native#text/plain
 fcl/tests/cfgtest.pp svneol=native#text/plain
+fcl/tests/dbugsrv.pp svneol=native#text/plain
+fcl/tests/debugtest.pp svneol=native#text/plain
 fcl/tests/doecho.pp svneol=native#text/plain
 fcl/tests/dparser.pp svneol=native#text/plain
 fcl/tests/dsockcli.pp svneol=native#text/plain
@@ -851,6 +855,8 @@ fcl/tests/intl/restest.fr.po -text
 fcl/tests/intl/restest.nl.mo -text
 fcl/tests/intl/restest.nl.po -text
 fcl/tests/intl/resttest.po -text
+fcl/tests/ipcclient.pp svneol=native#text/plain
+fcl/tests/ipcserver.pp svneol=native#text/plain
 fcl/tests/isockcli.pp svneol=native#text/plain
 fcl/tests/isocksvr.pp svneol=native#text/plain
 fcl/tests/istream.pp svneol=native#text/plain
@@ -896,13 +902,12 @@ fcl/tests/txmlreg.pp svneol=native#text/plain
 fcl/tests/xmldump.pp svneol=native#text/plain
 fcl/unix/asyncio.inc svneol=native#text/plain
 fcl/unix/asyncioh.inc svneol=native#text/plain
-fcl/unix/custapp.inc svneol=native#text/plain
 fcl/unix/eventlog.inc svneol=native#text/plain
 fcl/unix/ezcgi.inc svneol=native#text/plain
 fcl/unix/pipes.inc svneol=native#text/plain
 fcl/unix/process.inc svneol=native#text/plain
 fcl/unix/resolve.inc svneol=native#text/plain
-fcl/win32/custapp.inc svneol=native#text/plain
+fcl/unix/simpleipc.inc svneol=native#text/plain
 fcl/win32/eventlog.inc svneol=native#text/plain
 fcl/win32/ezcgi.inc svneol=native#text/plain
 fcl/win32/fclel.mc -text
@@ -913,6 +918,7 @@ fcl/win32/httpapp.pp svneol=native#text/plain
 fcl/win32/pipes.inc svneol=native#text/plain
 fcl/win32/process.inc svneol=native#text/plain
 fcl/win32/resolve.inc svneol=native#text/plain
+fcl/win32/simpleipc.inc svneol=native#text/plain
 fcl/win32/syncobjs.pp svneol=native#text/plain
 fcl/win32/winreg.inc svneol=native#text/plain
 fcl/xml/Makefile svneol=native#text/plain

fcl/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/08/11]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/08/15]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-emx i386-watcom i386-netwlibc i386-wince m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos powerpc-linux powerpc-netbsd powerpc-macos powerpc-darwin powerpc-morphos sparc-linux sparc-netbsd sparc-solaris x86_64-linux x86_64-freebsd x86_64-win64 arm-linux arm-wince
@@ -344,25 +344,25 @@ ifeq ($(FULL_TARGET),arm-wince)
 override TARGET_DIRS+=xml image db shedit passrc net fpcunit
 endif
 ifeq ($(FULL_TARGET),i386-linux)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),i386-go32v2)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
 endif
 ifeq ($(FULL_TARGET),i386-win32)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process fileinfo resolve ssockets syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process fileinfo resolve ssockets syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),i386-os2)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  resolve ssockets
 endif
 ifeq ($(FULL_TARGET),i386-freebsd)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),i386-beos)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
 endif
 ifeq ($(FULL_TARGET),i386-netbsd)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),i386-solaris)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
@@ -374,7 +374,7 @@ ifeq ($(FULL_TARGET),i386-netware)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  resolve ssockets
 endif
 ifeq ($(FULL_TARGET),i386-openbsd)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),i386-wdosx)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
@@ -392,13 +392,13 @@ ifeq ($(FULL_TARGET),i386-wince)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
 endif
 ifeq ($(FULL_TARGET),m68k-linux)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),m68k-freebsd)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),m68k-netbsd)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),m68k-amiga)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
@@ -407,157 +407,157 @@ ifeq ($(FULL_TARGET),m68k-atari)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
 endif
 ifeq ($(FULL_TARGET),m68k-openbsd)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),m68k-palmos)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
 endif
 ifeq ($(FULL_TARGET),powerpc-linux)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),powerpc-netbsd)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),powerpc-macos)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
 endif
 ifeq ($(FULL_TARGET),powerpc-darwin)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),powerpc-morphos)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
 endif
 ifeq ($(FULL_TARGET),sparc-linux)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),sparc-netbsd)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),sparc-solaris)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
 endif
 ifeq ($(FULL_TARGET),x86_64-linux)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),x86_64-freebsd)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process ssockets resolve fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),x86_64-win64)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
 endif
 ifeq ($(FULL_TARGET),arm-linux)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),arm-wince)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex
 endif
 ifeq ($(FULL_TARGET),i386-linux)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-go32v2)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-win32)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-os2)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-freebsd)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-beos)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-netbsd)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-solaris)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-qnx)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-netware)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-openbsd)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-wdosx)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-emx)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-watcom)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-netwlibc)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-wince)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),m68k-linux)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),m68k-freebsd)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),m68k-netbsd)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),m68k-amiga)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),m68k-atari)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),m68k-openbsd)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),m68k-palmos)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),powerpc-linux)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),powerpc-netbsd)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),powerpc-macos)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),powerpc-darwin)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),powerpc-morphos)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),sparc-linux)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),sparc-netbsd)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),sparc-solaris)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),x86_64-linux)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),x86_64-freebsd)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),x86_64-win64)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),arm-linux)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),arm-wince)
-override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 endif
 ifeq ($(FULL_TARGET),i386-linux)
 override TARGET_EXAMPLEDIRS+=tests
@@ -3798,3 +3798,4 @@ classes$(PPUEXT): $(COMPILER_UNITTARGETDIR)
 	$(COMPILER) -Ficlasses -Ficlasses/$(OS_TARGET) classes/$(OS_TARGET)/classes.pp
 endif
 xmlreg.pp: avl_tree$(PPUEXT) xml
+dbugintf$(PPUEXT): msgintf.pp simpleipc.pp

fcl/Makefile.fpc

@@ -26,17 +26,17 @@ dirs=xml image db shedit passrc net fpcunit
 units=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext \
       iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp \
       wformat whtml wtex rttiutils bufstream streamex
-units_freebsd=process ssockets resolve fpasync syncobjs
-units_darwin=process ssockets resolve fpasync syncobjs
-units_netbsd=process ssockets resolve fpasync
-units_openbsd=process ssockets resolve fpasync
-units_linux=process resolve ssockets fpasync syncobjs
-units_win32=process fileinfo resolve ssockets syncobjs
+units_freebsd=process ssockets resolve fpasync syncobjs simpleipc msgintf dbugintf
+units_darwin=process ssockets resolve fpasync syncobjs simpleipc msgintf dbugintf
+units_netbsd=process ssockets resolve fpasync simpleipc msgintf dbugintf
+units_openbsd=process ssockets resolve fpasync simpleipc msgintf dbugintf
+units_linux=process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
+units_win32=process fileinfo resolve ssockets syncobjs simpleipc msgintf dbugintf
 units_os2=resolve ssockets
 units_emx=resolve ssockets
 units_netware=resolve ssockets
 units_netwlibc=resolve ssockets syncobjs
-rsts=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
+rsts=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry simpleipc
 exampledirs=tests
 
 [compiler]
@@ -76,3 +76,6 @@ endif
 
 # xmlreg needs the XML units, XML units depend on avl_tree
 xmlreg.pp: avl_tree$(PPUEXT) xml
+
+[rules]
+dbugintf$(PPUEXT): msgintf.pp simpleipc.pp

fcl/db/bufdataset.inc

@@ -73,7 +73,7 @@ begin
   FOpen:=False;
   CancelUpdates;
   for i := 0 to FBRecordCount-1 do FreeRecordBuffer(FBBuffers[i]);
-  If FBRecordCount > 0 then ReAllocMem(FBBuffers,0);
+  If FBBufferCount > 0 then ReAllocMem(FBBuffers,0);
   FBRecordcount := 0;
   FBBuffercount := 0;
   FBCurrentrecord := -1;

fcl/db/sqldb/interbase/ibconnection.pp

@@ -20,8 +20,8 @@ type
     protected
     Status               : array [0..19] of ISC_STATUS;
     Statement            : pointer;
-    FFieldFlag           : array of shortint;
-    FinFieldFlag         : array of shortint;
+    FFieldFlag           : PByte;
+    FinFieldFlag         : PByte;
     SQLDA                : PXSQLDA;
     in_SQLDA             : PXSQLDA;
     ParamBinding         : array of integer;
@@ -59,8 +59,8 @@ type
     Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override;
     Function AllocateTransactionHandle : TSQLHandle; override;
 
-    procedure CloseStatement(cursor : TSQLCursor); override;
     procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); override;
+    procedure UnPrepareStatement(cursor : TSQLCursor); override;
     procedure FreeFldBuffers(cursor : TSQLCursor); override;
     procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); override;
     procedure AddFieldDefs(cursor: TSQLCursor;FieldDefs : TfieldDefs); override;
@@ -389,6 +389,7 @@ begin
   curs := TIBCursor.create;
   curs.sqlda := nil;
   curs.statement := nil;
+  curs.FPrepared := False;
   AllocSQLDA(curs.SQLDA,1);
   AllocSQLDA(curs.in_SQLDA,1);
   result := curs;
@@ -401,6 +402,8 @@ begin
     begin
     reAllocMem(SQLDA,0);
     reAllocMem(in_SQLDA,0);
+    reAllocMem(FFieldFlag,0);
+    reAllocMem(FInFieldFlag,0);
     end;
   FreeAndNil(cursor);
 end;
@@ -411,16 +414,6 @@ begin
   result := TIBTrans.create;
 end;
 
-procedure TIBConnection.CloseStatement(cursor : TSQLCursor);
-begin
-  with cursor as TIBcursor do
-    begin
-    if isc_dsql_free_statement(@Status, @Statement, DSQL_Drop) <> 0 then
-      CheckError('FreeStatement', Status);
-    Statement := nil;
-    end;
-end;
-
 procedure TIBConnection.PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams);
 
 var dh    : pointer;
@@ -430,7 +423,6 @@ var dh    : pointer;
     i     : integer;
 
 begin
-//  ObtainSQLStatementType(cursor,buf);
   with cursor as TIBcursor do
     begin
     dh := GetHandle;
@@ -463,6 +455,7 @@ begin
 
     if isc_dsql_prepare(@Status, @tr, @Statement, 0, @Buf[1], Dialect, nil) <> 0 then
       CheckError('PrepareStatement', Status);
+    FPrepared := True;
     if assigned(AParams) and (AParams.count > 0) then
       begin
       AllocSQLDA(in_SQLDA,Length(ParamBinding));
@@ -471,7 +464,7 @@ begin
       if in_SQLDA^.SQLD > in_SQLDA^.SQLN then
         DatabaseError(SParameterCountIncorrect,self);
       {$R-}
-      SetLength(FinFieldFlag,in_SQLDA^.SQLD);
+      ReAllocMem(FInFieldFlag,SQLDA^.SQLD+1);
       for x := 0 to in_SQLDA^.SQLD - 1 do with in_SQLDA^.SQLVar[x] do
         begin
         if ((SQLType and not 1) = SQL_VARYING) then
@@ -484,6 +477,7 @@ begin
       end;
     if FStatementType = stselect then
       begin
+      FPrepared := False;
       if isc_dsql_describe(@Status, @Statement, 1, SQLDA) <> 0 then
         CheckError('PrepareSelect', Status);
       if SQLDA^.SQLD > SQLDA^.SQLN then
@@ -493,13 +487,15 @@ begin
           CheckError('PrepareSelect', Status);
         end;
       {$R-}
-      SetLength(FFieldFlag,SQLDA^.SQLD);
+      ReAllocMem(FFieldFlag,SQLDA^.SQLD+1);
       for x := 0 to SQLDA^.SQLD - 1 do with SQLDA^.SQLVar[x] do
         begin
         if ((SQLType and not 1) = SQL_VARYING) then
           SQLData := AllocMem(SQLDA^.SQLVar[x].SQLLen+2)
+//          ReAllocMem(SQLData,SQLDA^.SQLVar[x].SQLLen+2)
         else
           SQLData := AllocMem(SQLDA^.SQLVar[x].SQLLen);
+//             ReAllocMem(SQLData,SQLDA^.SQLVar[x].SQLLen);
         SQLInd  := @FFieldFlag[x];
         end;
       {$R+}
@@ -507,6 +503,18 @@ begin
     end;
 end;
 
+procedure TIBConnection.UnPrepareStatement(cursor : TSQLCursor);
+
+begin
+  with cursor as TIBcursor do
+    begin
+    if isc_dsql_free_statement(@Status, @Statement, DSQL_Drop) <> 0 then
+      CheckError('FreeStatement', Status);
+    Statement := nil;
+    FPrepared := False;
+    end;
+end;
+
 procedure TIBConnection.FreeFldBuffers(cursor : TSQLCursor);
 var
   x  : shortint;

fcl/db/sqldb/mysql/mysql4conn.pas

@@ -54,7 +54,6 @@ Type
     Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override;
     Function AllocateTransactionHandle : TSQLHandle; override;
 
-    procedure CloseStatement(cursor : TSQLCursor); override;
     procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); override;
     procedure FreeFldBuffers(cursor : TSQLCursor); override;
     procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction;AParams : TParams); override;
@@ -218,26 +217,6 @@ begin
   Result:=TMySQLTransaction.Create;
 end;
 
-procedure TMySQLConnection.CloseStatement(cursor: TSQLCursor);
-
-Var
-  C : TMySQLCursor;
-
-begin
-  C:=Cursor as TMysqlCursor;
-  if c.FStatementType=stSelect then
-    c.FNeedData:=False;
-  If (C.FRes<>Nil) then
-    begin
-    C.FRes:=Nil;
-    end;
-  if (c.FQMySQL <> Nil) then
-    begin
-    mysql_close(c.FQMySQL);
-    c.FQMySQL:=Nil;
-    end;
-end;
-
 procedure TMySQLConnection.PrepareStatement(cursor: TSQLCursor;
   ATransaction: TSQLTransaction; buf: string;AParams : TParams);
 begin
@@ -261,6 +240,17 @@ Var
 
 begin
   C:=Cursor as TMysqlCursor;
+  if c.FStatementType=stSelect then
+    c.FNeedData:=False;
+  If (C.FRes<>Nil) then
+    begin
+    C.FRes:=Nil;
+    end;
+  if (c.FQMySQL <> Nil) then
+    begin
+    mysql_close(c.FQMySQL);
+    c.FQMySQL:=Nil;
+    end;
   If (C.FRes<>Nil) then
     begin
     Mysql_free_result(C.FRes);

fcl/db/sqldb/postgres/pqconnection.pp

@@ -45,7 +45,6 @@ type
     Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override;
     Function AllocateTransactionHandle : TSQLHandle; override;
 
-    procedure CloseStatement(cursor : TSQLCursor); override;
     procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); override;
     procedure FreeFldBuffers(cursor : TSQLCursor); override;
     procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); override;
@@ -420,26 +419,6 @@ begin
     end;
 end;
 
-procedure TPQConnection.CloseStatement(cursor : TSQLCursor);
-
-begin
-  with cursor as TPQCursor do
-   if (PQresultStatus(res) <> PGRES_FATAL_ERROR) then //Don't try to do anything if the transaction has already encountered an error.
-    begin
-    if FStatementType = stselect then
-      begin
-      Res := pqexec(tr,pchar('CLOSE slctst' + name + nr));
-      if (PQresultStatus(res) <> PGRES_COMMAND_OK) then
-        begin
-        pqclear(res);
-        DatabaseError(SErrClearSelection + ' (PostgreSQL: ' + PQerrorMessage(tr) + ')',self)
-        end
-      end;
-    pqclear(baseres);
-    pqclear(res);
-    end;
-end;
-
 procedure TPQConnection.UnPrepareStatement(cursor : TSQLCursor);
 
 begin
@@ -459,7 +438,21 @@ end;
 procedure TPQConnection.FreeFldBuffers(cursor : TSQLCursor);
 
 begin
-// Do nothing
+  with cursor as TPQCursor do
+   if (PQresultStatus(res) <> PGRES_FATAL_ERROR) then //Don't try to do anything if the transaction has already encountered an error.
+    begin
+    if FStatementType = stselect then
+      begin
+      Res := pqexec(tr,pchar('CLOSE slctst' + name + nr));
+      if (PQresultStatus(res) <> PGRES_COMMAND_OK) then
+        begin
+        pqclear(res);
+        DatabaseError(SErrClearSelection + ' (PostgreSQL: ' + PQerrorMessage(tr) + ')',self)
+        end
+      end;
+    pqclear(baseres);
+    pqclear(res);
+    end;
 end;
 
 procedure TPQConnection.Execute(cursor: TSQLCursor;atransaction:tSQLtransaction;AParams : TParams);

fcl/db/sqldb/readme.txt

@@ -0,0 +1,81 @@
+SQLDB readme file, 20 Aug 2005, Joost van der Sluis
+
+since there is no real documentation about sqldb yet, this should be regarded as
+a small reminder to myself, and to others who want to write their own
+connections.
+
+From the TSQLConnection point-of-view the following methods are called if a
+select-statement is used:
+
+OPEN:
+  Prepare: (is only called when prepared is false)
+            - AllocateCursorHandle (only if the cursor <> nil)
+            - Preparestatement
+  Execute:
+            - Execute
+            - AddFieldDefs (only if called for the first time after a prepare)
+
+GETNEXTPAKCET: (probably called several times, offcourse)
+            - Fetch
+            - Loadfield
+
+CLOSE:
+            - FreeFieldBuffers
+            - UnPrepareStatement (Only if prepare is False, thus if prepared queries
+                         were not supported)
+UnPrepare:
+            - UnPrepareStatement
+            
+DESTROY:
+            - DeAllocateCursorHandle (Also called if the Connection is changed)
+            
+
+From the TSQLConnection point-of-view the following methods are called if a non-
+select-statement is used (execsql):
+
+Prepare: (is only called when prepared is false)
+            - AllocateCursorHandle (only if the cursor <> nil)
+            - Preparestatement
+
+Execute:
+            - Execute
+            - UnPrepareStatement (Only if prepare is False, thus if prepared queries
+                         were not supported)
+
+
+UNPREPARE:
+            - UnPrepareStatement
+
+DESTROY:
+            - DeAllocateCursorHandle (Also called if the Connection is changed)
+
+
+A short description of what each method in a TSQLConnection should do:
+
+* Function AllocateCursorHandle : TSQLCursor; override;
+
+This function creates and returns a TSQLcursor which can be used by any query
+for the used type of database. The cursor is only database-dependent, it is
+deallocated when the connection of the query changes, or if the query is
+destroyed.
+
+* Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override;
+
+This function deallocates the TSQLCursor, and sets its value to nil.
+
+* procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); override;
+
+This functions prepares the query which is given in buf.
+
+It's only called if Prepared is True.
+If the database supports prepared queries for the kind of sql-statement (in
+cursor.FStatementType) and the prepare was successfully, then cursor.FPrepared
+is set to True, so that prepare will not be called again, until UnPrepared
+is called. (which sets FPrepared to False)
+
+* procedure FreeFldBuffers(cursor : TSQLCursor); override;
+
+This procedure is called if a Select-query is closed. This procedure is used to
+handle all actions which are needed to close a select-statement.
+
+

fcl/db/sqldb/sqldb.pp

@@ -41,6 +41,7 @@ type
   TSQLCursor = Class(TSQLHandle)
   public
     FPrepared      : Boolean;
+    FInitFieldDef  : Boolean;
     FStatementType : TStatementType;
   end;
 
@@ -86,7 +87,6 @@ type
     procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); virtual; abstract;
     function Fetch(cursor : TSQLCursor) : boolean; virtual; abstract;
     procedure AddFieldDefs(cursor: TSQLCursor; FieldDefs : TfieldDefs); virtual; abstract;
-    procedure CloseStatement(cursor : TSQLCursor); virtual; abstract;
     procedure UnPrepareStatement(cursor : TSQLCursor); virtual; abstract;
 
     procedure FreeFldBuffers(cursor : TSQLCursor); virtual; abstract;
@@ -173,7 +173,6 @@ type
     FParseSQL            : boolean;
 //    FSchemaInfo          : TSchemaInfo;
 
-    procedure CloseStatement;
     procedure FreeFldBuffers;
     procedure InitUpdates(SQL : string);
     function GetIndexDefs : TIndexDefs;
@@ -335,7 +334,7 @@ begin
 
     PrepareStatement(cursor,Transaction,SQL,Nil);
     execute(cursor,Transaction, Nil);
-    CloseStatement(Cursor);
+    UnPrepareStatement(Cursor);
   finally;
     DeAllocateCursorHandle(Cursor);
   end;
@@ -504,6 +503,7 @@ begin
   if (Database <> Value) then
     begin
     UnPrepare;
+    if assigned(FCursor) then (Database as TSQLConnection).DeAllocateCursorHandle(FCursor);
     db := value as tsqlconnection;
     inherited setdatabase(value);
     if assigned(value) and (Transaction = nil) and (Assigned(db.Transaction)) then
@@ -511,12 +511,6 @@ begin
     end;
 end;
 
-procedure TSQLQuery.CloseStatement;
-begin
-  if assigned(FCursor) then
-    (Database as tsqlconnection).CloseStatement(FCursor);
-end;
-
 Function TSQLQuery.IsPrepared : Boolean;
 
 begin
@@ -543,7 +537,8 @@ begin
   if Value and not FParseSQL then DatabaseErrorFmt(SNoParseSQL,['Filtering ']);
   if (Filtered <> Value) and Active then
     begin
-    CloseStatement;
+    FreeFldBuffers;
+    (Database as tsqlconnection).UnPrepareStatement(FCursor);
     FIsEOF := False;
     inherited internalclose;
 
@@ -578,8 +573,9 @@ begin
     if not Db.Connected then db.Open;
     if not sqltr.Active then sqltr.StartTransaction;
 
-    if assigned(fcursor) then FreeAndNil(fcursor);
-    FCursor := Db.AllocateCursorHandle;
+//    if assigned(fcursor) then FreeAndNil(fcursor);
+    if not assigned(fcursor) then
+      FCursor := Db.AllocateCursorHandle;
 
     FSQLBuf := TrimRight(FSQL.Text);
     
@@ -593,8 +589,11 @@ begin
     else
       Db.PrepareStatement(Fcursor,sqltr,FSQLBuf,FParams);
 
-    if (FCursor.FStatementType = stSelect) and not ReadOnly then
-      InitUpdates(FSQLBuf);
+    if (FCursor.FStatementType = stSelect) then
+      begin
+      FCursor.FInitFieldDef := True;
+      if not ReadOnly then InitUpdates(FSQLBuf);
+      end;
     end;
 end;
 
@@ -603,10 +602,7 @@ procedure TSQLQuery.UnPrepare;
 begin
   CheckInactive;
   if IsPrepared then with Database as TSQLConnection do
-    begin
     UnPrepareStatement(FCursor);
-    DeAllocateCursorHandle(FCursor);
-    end;
 end;
 
 procedure TSQLQuery.FreeFldBuffers;
@@ -641,8 +637,8 @@ end;
 
 procedure TSQLQuery.InternalClose;
 begin
-  FreeFldBuffers;
-  CloseStatement;
+  if StatementType = stSelect then FreeFldBuffers;
+  if not IsPrepared then (database as TSQLconnection).UnPrepareStatement(FCursor);
   if DefaultFields then
     DestroyFields;
   FIsEOF := False;
@@ -789,15 +785,13 @@ procedure TSQLQuery.InternalOpen;
 var tel         : integer;
     f           : TField;
     s           : string;
-    WasPrepared : boolean;
 begin
   try
-    WasPrepared := IsPrepared;
     Prepare;
     if FCursor.FStatementType in [stSelect] then
       begin
       Execute;
-      if not WasPrepared then InternalInitFieldDefs; // if query was prepared before opening, fields are already created
+      if FCursor.FInitFieldDef then InternalInitFieldDefs;
       if DefaultFields then
         begin
         CreateFields;
@@ -836,7 +830,7 @@ begin
     Prepare;
     Execute;
   finally
-    CloseStatement;
+    if not IsPrepared then (database as TSQLConnection).UnPrepareStatement(Fcursor);
   end;
 end;
 
@@ -859,6 +853,7 @@ destructor TSQLQuery.Destroy;
 begin
   if Active then Close;
   UnPrepare;
+  if assigned(FCursor) then (Database as TSQLConnection).DeAllocateCursorHandle(FCursor);
   FreeAndNil(FSQL);
   FreeAndNil(FIndexDefs);
   inherited Destroy;
@@ -1037,6 +1032,7 @@ end;
 procedure TSQLQuery.SetSchemaInfo( SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string);
 
 begin
+  ReadOnly := True;
   SQL.Clear;
   SQL.Add((DataBase as tsqlconnection).GetSchemaInfoSQL(SchemaType, SchemaObjectName, SchemaPattern));
 end;

fcl/db/sqlite/customsqliteds.pas

@@ -76,7 +76,7 @@ type
     FExpectedUpdates: Integer;
     FSaveOnClose: Boolean;
     FSaveOnRefetch: Boolean;
-    FComplexSql: Boolean;
+    FSqlMode: Boolean;
     FUpdatedItems: TFPList;
     FAddedItems: TFPList;
     FDeletedItems: TFPList;
@@ -136,7 +136,8 @@ type
     procedure InternalOpen; override;
     procedure InternalPost; override;
     procedure InternalSetToRecord(Buffer: PChar); override;
-    function IsCursorOpen: Boolean; override;    
+    function IsCursorOpen: Boolean; override;
+    function Locate(const keyfields: string; const keyvalues: Variant; options: TLocateOptions) : boolean; override;    
     procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
     procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
     procedure SetExpectedAppends(AValue:Integer);
@@ -169,7 +170,6 @@ type
     property AddedItems: TFPList read FAddedItems;
     property DeletedItems: TFPList read FDeletedItems;
     {$endif}
-    property ComplexSql: Boolean read FComplexSql write FComplexSql;
     property ExpectedAppends: Integer read FExpectedAppends write SetExpectedAppends;
     property ExpectedUpdates: Integer read FExpectedUpdates write SetExpectedUpdates;
     property ExpectedDeletes: Integer read FExpectedDeletes write SetExpectedDeletes;
@@ -184,13 +184,13 @@ type
     property SaveOnClose: Boolean read FSaveOnClose write FSaveOnClose; 
     property SaveOnRefetch: Boolean read FSaveOnRefetch write FSaveOnRefetch;
     property SQL: String read FSql write FSql;
+    property SqlMode: Boolean read FSqlMode write FSqlMode;
     property TableName: String read FTableName write FTableName;   
     property MasterSource: TDataSource read GetMasterSource write SetMasterSource;
     property MasterFields: string read GetMasterFields write SetMasterFields;
     
     property Active;
-    property FieldDefs;
-     
+       
     //Events
     property BeforeOpen;
     property AfterOpen;
@@ -215,7 +215,7 @@ type
 implementation
 
 uses
-  strutils;
+  strutils, variants;
 
 const
   SQLITE_OK = 0;//sqlite2.x.x and sqlite3.x.x defines this equal
@@ -635,9 +635,9 @@ procedure TCustomSqliteDataset.InternalOpen;
 begin
   FAutoIncFieldNo:=-1;
   if not FileExists(FFileName) then
-    DatabaseError('TCustomSqliteDataset - File "'+FFileName+'" not found',Self);
-  if (FTablename = '') and not (FComplexSql) then
-    DatabaseError('TCustomSqliteDataset - Tablename not set',Self);
+    DatabaseError('File "'+ExpandFileName(FFileName)+'" not found',Self);
+  if (FTablename = '') and not (FSqlMode) then
+    DatabaseError('Tablename not set',Self);
 
   if MasterSource <> nil then
   begin
@@ -689,9 +689,58 @@ begin
    Result := FDataAllocated;
 end;
 
+function TCustomSqliteDataset.Locate(const keyfields: string; const keyvalues: Variant; options: TLocateOptions) : boolean;
+var
+  AValue:String;
+  AField:TField;
+  AFieldIndex:Integer;
+  TempItem:PDataRecord;
+begin
+  Result:=False;
+  // Now, it allows to search only one field and ignores options 
+  AField:=Fields.FindField(keyfields);
+  if AField <> nil then
+    AFieldIndex:=AField.FieldNo - 1  
+  else
+    DatabaseError('Field "'+keyfields+'" not found',Self);
+  //get float types in appropriate format
+  if not (AField.DataType in [ftFloat,ftDateTime,ftTime,ftDate]) then
+    AValue:=keyvalues
+  else
+  begin
+    Str(VarToDateTime(keyvalues),AValue);
+    AValue:=Trim(AValue);
+  end;  
+  {$ifdef DEBUG}
+  writeln('=Locate=');
+  writeln('keyfields: ',keyfields);
+  writeln('keyvalues: ',keyvalues);
+  writeln('AValue: ',AValue);
+  {$endif}        
+  //Search the list
+  TempItem:=FBeginItem^.Next;
+  while TempItem <> FEndItem do
+  begin
+    if TempItem^.Row[AFieldIndex] <> nil then
+    begin
+      writeln('TempItem^.Row[AFieldIndex]: ',TempItem^.Row[AFieldIndex]);
+      writeln('PChar(AValue):              ',PChar(AValue));
+      writeln('StrComp result: ',StrComp(TempItem^.Row[AFieldIndex],PChar(AValue)));
+      if StrComp(TempItem^.Row[AFieldIndex],PChar(AValue)) = 0 then
+      begin
+        Result:=True;
+        FCurrentItem:=TempItem;
+        Resync([]);
+        Break;
+      end;
+    end;    
+    TempItem:=TempItem^.Next;
+  end;      
+end;
+
 procedure TCustomSqliteDataset.SetBookmarkData(Buffer: PChar; Data: Pointer);
 begin
-  //The BookMarkData is the Buffer itsef;
+  //The BookMarkData is the Buffer itself;
 end;
 
 procedure TCustomSqliteDataset.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
@@ -760,11 +809,12 @@ var
   TempItem:PDataRecord;
 begin
   if (Value >= FRecordCount) or (Value < 0) then
-    DatabaseError('SqliteDs - Record Number Out Of Range',Self);
+    DatabaseError('Record Number Out Of Range',Self);
   TempItem:=FBeginItem;
   for Counter := 0 to Value do
     TempItem:=TempItem^.Next;
-  PPDataRecord(ActiveBuffer)^:=TempItem;   
+  FCurrentItem:=TempItem;
+  Resync([]);
 end;
 
 // Specific functions 
@@ -874,7 +924,7 @@ var
   SqlTemp,KeyName,ASqlLine,TemplateStr:String;
 begin
   Result:=False;
-  if (FPrimaryKeyNo <> -1) and not FComplexSql then
+  if (FPrimaryKeyNo <> -1) and not FSqlMode then
   begin
     StatementsCounter:=0;
     KeyName:=Fields[FPrimaryKeyNo].FieldName;

fcl/db/sqlite/sqlite3ds.pas

@@ -308,7 +308,7 @@ var
   begin
     while FSqliteReturnId = SQLITE_ROW do
     begin
-      AStrList.AddObject(StrPas(sqlite3_column_text(vm,0)),TObject(sqlite3_column_int(vm,1)));
+      AStrList.AddObject(StrPas(sqlite3_column_text(vm,0)),TObject(PtrInt(sqlite3_column_int(vm,1))));
       FSqliteReturnId:=sqlite3_step(vm);  
     end;
   end;    
@@ -319,12 +319,12 @@ begin
     if FileExists(FFileName) then
       AHandle:=GetSqliteHandle
     else
-      DatabaseError('File '+FFileName+' not Exists',Self);    
+      DatabaseError('File "'+FFileName+'" not Exists',Self);    
   Result:='';
-  if AStrList <> nil then
-    AStrList.Clear;
+  // It's up to the caller clear or not the list
+  //if AStrList <> nil then
+  //  AStrList.Clear;
   FSqliteReturnId:=sqlite3_prepare(AHandle,Pchar(ASql),-1,@vm,nil);
-  //FSqliteReturnId:=sqlite_compile(AHandle,Pchar(ASql),nil,@vm,nil);
   if FSqliteReturnId <> SQLITE_OK then
     DatabaseError('Error returned by sqlite in QuickQuery: '+SqliteReturnString,Self);
     

fcl/db/sqlite/sqliteds.pas

@@ -331,7 +331,7 @@ var
     while FSqliteReturnId = SQLITE_ROW do
     begin
       // I know, this code is really dirty!!
-      AStrList.AddObject(StrPas(ColumnValues[0]),TObject(StrToInt(StrPas(ColumnValues[1]))));
+      AStrList.AddObject(StrPas(ColumnValues[0]),TObject(PtrInt(StrToInt(StrPas(ColumnValues[1])))));
       FSqliteReturnId:=sqlite_step(vm,@ColCount,@ColumnValues,@ColumnNames);  
     end;
   end;    
@@ -344,8 +344,9 @@ begin
     else
       DatabaseError('File '+FFileName+' not Exists',Self);    
   Result:='';
-  if AStrList <> nil then
-    AStrList.Clear;
+  // It's up to the caller clear or not the list
+  //if AStrList <> nil then
+  //  AStrList.Clear;
   FSqliteReturnId:=sqlite_compile(AHandle,Pchar(ASql),nil,@vm,nil);
   if FSqliteReturnId <> SQLITE_OK then
     DatabaseError('Error returned by sqlite in QuickQuery: '+SqliteReturnString,Self);

fcl/inc/dbugintf.pp

@@ -0,0 +1,245 @@
+{
+    This file is part of the Free Component library.
+    Copyright (c) 2005 by Michael Van Canneyt, member of
+    the Free Pascal development team
+
+    Debugserver client interface, based on SimpleIPC
+
+    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 dbugintf;
+
+interface
+
+uses
+   simpleipc,
+   msgintf,
+   classes;
+
+Type
+  TDebugLevel = (dlInformation,dlWarning,dlError);
+
+procedure SendBoolean(const Identifier: string; const Value: Boolean);
+procedure SendDateTime(const Identifier: string; const Value: TDateTime);
+procedure SendDebugEx(const Msg: string; MType: TDebugLevel);
+procedure SendDebug(const Msg: string);
+procedure SendInteger(const Identifier: string; const Value: Integer);
+procedure SendMethodEnter(const MethodName: string);
+procedure SendMethodExit(const MethodName: string);
+procedure SendSeparator;
+procedure SendDebugFmt(const Msg: string; const Args: array of const);
+procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel);
+
+{ low-level routines }
+
+Procedure SendDebugMessage(Const Msg : TDebugMessage);
+Function  StartDebugServer : integer;
+Procedure InitDebugClient;
+
+Const
+  SendError       : String = '';
+
+ResourceString
+  SProcessID = 'Process %s';
+  SEntering = '> Entering ';
+  SExiting  = '< Exiting ';
+  SSeparator = '>-=-=-=-=-=-=-=-=-=-=-=-=-=-=-<';
+
+implementation
+
+Uses SysUtils,process;
+
+Const
+  DmtInformation = lctInformation;
+  DmtWarning     = lctWarning;
+  DmtError       = lctError;
+  ErrorLevel     : Array[TDebugLevel] of integer
+                 = (dmtInformation,dmtWarning,dmtError);
+
+var
+  DebugClient : TSimpleIPCClient = nil;
+  MsgBuffer : TMemoryStream = Nil;
+  ServerID : Integer;
+  
+Procedure WriteMessage(Const Msg : TDebugMessage);
+
+begin
+  MsgBuffer.Seek(0,soFrombeginning);
+  WriteDebugMessageToStream(MsgBuffer,Msg);
+  DebugClient.SendMessage(mtUnknown,MsgBuffer);
+end;
+
+
+procedure SendDebugMessage(Const Msg : TDebugMessage);
+
+begin
+  try
+    If (DebugClient=Nil) then
+      InitDebugClient;
+    WriteMessage(Msg);
+  except
+    On E : Exception do
+      SendError:=E.Message;
+  end;
+end;
+
+procedure SendBoolean(const Identifier: string; const Value: Boolean);
+
+Const
+  Booleans : Array[Boolean] of string = ('False','True');
+
+begin
+  SendDebugFmt('%s = %s',[Identifier,Booleans[value]]);
+end;
+
+procedure SendDateTime(const Identifier: string; const Value: TDateTime);
+
+begin
+  SendDebugFmt('%s = %s',[Identifier,DateTimeToStr(Value)]);
+end;
+
+procedure SendDebugEx(const Msg: string; MType: TDebugLevel);
+
+Var
+  Mesg : TDebugMessage;
+
+begin
+  Mesg.MsgTimeStamp:=Now;
+  Mesg.MsgType:=ErrorLevel[MTYpe];
+  Mesg.Msg:=Msg;
+  SendDebugMessage(Mesg);
+end;
+
+procedure SendDebug(const Msg: string);
+
+Var
+  Mesg : TDebugMessage;
+begin
+  Mesg.MsgTimeStamp:=Now;
+  Mesg.MsgType:=dmtInformation;
+  Mesg.Msg:=Msg;
+  SendDebugMessage(Mesg);
+end;
+
+procedure SendInteger(const Identifier: string; const Value: Integer);
+
+begin
+  SendDebugFmt('%s = %d',[identifier,Value]);
+end;
+
+procedure SendMethodEnter(const MethodName: string);
+
+begin
+  SendDebug(SEntering+MethodName);
+end;
+
+procedure SendMethodExit(const MethodName: string);
+
+begin
+  SendDebug(SExiting+MethodName);
+end;
+
+procedure SendSeparator;
+
+begin
+  SendDebug(SSeparator);
+end;
+
+procedure SendDebugFmt(const Msg: string; const Args: array of const);
+
+Var
+  Mesg : TDebugMessage;
+
+begin
+  Mesg.MsgTimeStamp:=Now;
+  Mesg.MsgType:=dmtInformation;
+  Mesg.Msg:=Format(Msg,Args);
+  SendDebugMessage(Mesg);
+end;
+
+procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel);
+
+Var
+  Mesg : TDebugMessage;
+
+begin
+  Mesg.MsgTimeStamp:=Now;
+  Mesg.MsgType:=ErrorLevel[mType];
+  Mesg.Msg:=Format(Msg,Args);
+  SendDebugMessage(Mesg);
+end;
+
+function StartDebugServer : Integer;
+
+begin
+  With TProcess.Create(Nil) do
+    Try
+      CommandLine:='debugserver';
+      Execute;
+      Result:=ProcessID;
+    Finally
+      Free;
+    end;
+end;
+
+procedure FreeDebugClient;
+
+Var
+  msg : TDebugMessage;
+
+begin
+  try
+    If (DebugClient<>Nil) and
+       (DebugClient.ServerRunning) then
+      begin
+      Msg.MsgType:=lctStop;
+      Msg.MsgTimeStamp:=Now;
+      Msg.Msg:=Format(SProcessID,[ApplicationName]);
+      WriteMessage(Msg);
+      end;
+    FreeAndNil(MsgBuffer);
+    FreeAndNil(DebugClient);
+  except
+  end;
+end;
+
+Procedure InitDebugClient;
+
+Var
+  msg : TDebugMessage;
+  I : Integer;
+  
+begin
+  DebugClient:=TSimpleIPCClient.Create(Nil);
+  DebugClient.ServerID:=DebugServerID;
+  If not DebugClient.ServerRunning then
+    begin
+    ServerID:=StartDebugServer;
+    I:=0;
+    While (I<10) and not DebugClient.ServerRunning do
+      begin
+      Inc(I);
+      Sleep(100);
+      end;
+    end;
+  DebugClient.Connect;
+  MsgBuffer:=TMemoryStream.Create;
+  Msg.MsgType:=lctIdentify;
+  Msg.MsgTimeStamp:=Now;
+  Msg.Msg:=Format(SProcessID,[ApplicationName]);
+  WriteMessage(Msg);
+end;
+
+Initialization
+
+Finalization
+  FreeDebugClient;
+end.

fcl/inc/msgintf.pp

@@ -0,0 +1,102 @@
+{
+    This file is part of the Free Component library.
+    Copyright (c) 2005 by Michael Van Canneyt, member of
+    the Free Pascal development team
+
+    Debugserver Client/Server common code.
+
+    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 msgintf;
+
+interface
+
+uses Classes;
+
+Const
+  DebugServerID  : String = 'fpcdebugserver';
+
+  lctStop        = -1;
+  lctInformation = 0;
+  lctWarning     = 1;
+  lctError       = 2;
+  lctIdentify    = 3;
+
+Type
+  TDebugMessage = Record
+    MsgType      : Integer;
+    MsgTimeStamp : TDateTime;
+    Msg          : String;
+  end;
+
+Procedure ReadDebugMessageFromStream(AStream : TStream; Var Msg : TDebugMessage);
+Procedure WriteDebugMessageToStream(AStream : TStream; Const Msg : TDebugMessage);
+Function DebugMessageName(msgType : Integer) : String;
+
+
+implementation
+
+resourcestring
+  SStop        = 'Stop';
+  SInformation = 'Information';
+  SWarning     = 'Warning';
+  SError       = 'Error';
+  SIdentify    = 'Identify';
+  SUnknown     = 'Unknown';
+
+procedure ReadDebugMessageFromStream(AStream : TStream; Var Msg : TDebugMessage);
+
+Var
+  MsgSize : Integer;
+
+begin
+  With AStream do
+    begin
+    ReadBuffer(Msg.MsgType,SizeOf(Integer));
+    ReadBuffer(Msg.MsgTimeStamp,SizeOf(TDateTime));
+    ReadBuffer(MsgSize,SizeOf(Integer));
+    SetLength(Msg.Msg,MsgSize);
+    If (MsgSize<>0) then
+      ReadBuffer(Msg.msg[1],MsgSize);
+    end;
+end;
+
+procedure WriteDebugMessageToStream(AStream : TStream; Const Msg : TDebugMessage);
+
+Var
+  MsgSize : Integer;
+
+begin
+  With AStream do
+    begin
+    WriteBuffer(Msg.MsgType,SizeOf(Integer));
+    WriteBuffer(Msg.MsgTimeStamp,SizeOf(TDateTime));
+    MsgSize:=Length(Msg.Msg);
+    WriteBuffer(MsgSize,SizeOf(Integer));
+    WriteBuffer(Msg.msg[1],MsgSize);
+    end;
+end;
+
+Function DebugMessageName(msgType : Integer) : String;
+
+begin
+  Case MsgType of
+    lctStop        : Result:=SStop;
+    lctInformation : Result:=SInformation;
+    lctWarning     : Result:=SWarning;
+    lctError       : Result:=SError;
+    lctIdentify    : Result:=SIdentify;
+  else
+    Result:=SUnknown;
+  end;
+end;
+
+end.

fcl/inc/simpleipc.pp

@@ -0,0 +1,415 @@
+{
+    This file is part of the Free Component library.
+    Copyright (c) 2005 by Michael Van Canneyt, member of
+    the Free Pascal development team
+
+    Unit implementing one-way IPC between 2 processes
+
+    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.
+
+ **********************************************************************}
+unit simpleipc;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+Const
+  MsgVersion = 1;
+  
+Type
+
+  TMessageType = (mtUnknown,mtString); // For now
+  TMsgHeader = Packed record
+    Version : Byte;
+    msgType : TMessageType;
+    MsgLen  : Integer;
+  end;
+
+  TSimpleIPCServer = class;
+  TSimpleIPCClient = class;
+
+  { TIPCServerComm }
+  
+  TIPCServerComm = Class(TObject)
+  Private
+    FOwner  : TSimpleIPCServer;
+  Public
+    Constructor Create(AOwner : TSimpleIPCServer); virtual;
+    Property Owner : TSimpleIPCServer read FOwner;
+    Procedure StartServer; virtual; Abstract;
+    Procedure StopServer;virtual; Abstract;
+    Function  PeekMessage(TimeOut : Integer) : Boolean;virtual; Abstract;
+    Function  GetInstanceID : String; virtual; abstract;
+    Procedure ReadMessage ;virtual; Abstract;
+    Property InstanceID : String read GetInstanceID;
+  end;
+  TIPCServerCommClass = Class of TIPCServerComm;
+
+  { TSimpleIPC }
+  TSimpleIPC = Class(TComponent)
+  Private
+    procedure SetActive(const AValue: Boolean);
+    procedure SetServerID(const AValue: String);
+  Protected
+    FBusy: Boolean;
+    FActive : Boolean;
+    FServerID : String;
+    Procedure DoError(Msg : String; Args : Array of const);
+    Procedure CheckInactive;
+    Procedure CheckActive;
+    Procedure Activate; virtual; abstract;
+    Procedure Deactivate; virtual; abstract;
+    Property Busy : Boolean Read FBusy;
+  Published
+    Property Active : Boolean Read FActive Write SetActive;
+    Property ServerID : String Read FServerID Write SetServerID;
+  end;
+
+  { TSimpleIPCServer }
+
+  TSimpleIPCServer = Class(TSimpleIPC)
+  private
+    FGlobal: Boolean;
+    FOnMessage: TNotifyEvent;
+    FMsgData : TStream;
+    function GetInstanceID: String;
+    function GetStringMessage: String;
+    procedure SetGlobal(const AValue: Boolean);
+  Protected
+    FIPCComm: TIPCServerComm;
+    Function CommClass : TIPCServerCommClass; virtual;
+    Procedure Activate; override;
+    Procedure Deactivate; override;
+    Procedure ReadMessage;
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor destroy; override;
+    Procedure StartServer;
+    Procedure StopServer;
+    Function PeekMessage(TimeOut : Integer; DoReadMessage : Boolean): Boolean;
+    Property  StringMessage : String Read GetStringMessage;
+    Procedure GetMessageData(Stream : TStream);
+    Property  MsgData : TStream Read FMsgData;
+    Property  InstanceID : String Read GetInstanceID;
+  Published
+    Property Global : Boolean Read FGlobal Write SetGlobal;
+    Property OnMessage : TNotifyEvent Read FOnMessage Write FOnMessage;
+  end;
+
+
+  { TIPCClientComm}
+  TIPCClientComm = Class(TObject)
+  private
+    FOwner: TSimpleIPCClient;
+  Public
+    Constructor Create(AOwner : TSimpleIPCClient); virtual;
+    Property  Owner : TSimpleIPCClient read FOwner;
+    Procedure Connect; virtual; abstract;
+    Procedure Disconnect; virtual; abstract;
+    Function  ServerRunning : Boolean; virtual; abstract;
+    Procedure SendMessage(MsgType : TMessageType; Stream : TStream);virtual;Abstract;
+  end;
+  TIPCClientCommClass = Class of TIPCClientComm;
+  
+  { TSimpleIPCClient }
+  TSimpleIPCClient = Class(TSimpleIPC)
+  Private
+    FServerInstance: String;
+    procedure SetServerInstance(const AValue: String);
+  Protected
+    FIPCComm : TIPCClientComm;
+    Procedure Activate; override;
+    Procedure Deactivate; override;
+    Function CommClass : TIPCClientCommClass; virtual;
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor destroy; override;
+    Procedure Connect;
+    Procedure Disconnect;
+    Function  ServerRunning : Boolean;
+    Procedure SendMessage(MsgType : TMessageType; Stream: TStream);
+    Procedure SendStringMessage(Msg : String);
+    Procedure SendStringmessageFmt(Msg : String; Args : Array of const);
+    Property  ServerInstance : String Read FServerInstance Write SetServerInstance;
+  end;
+
+
+  EIPCError = Class(Exception);
+
+Var
+  DefaultIPCServerClass : TIPCServerCommClass = Nil;
+  DefaultIPCClientClass : TIPCClientCommClass = Nil;
+
+resourcestring
+  SErrServerNotActive = 'Server with ID %s is not active.';
+  SErrActive = 'This operation is illegal when the server is active.';
+  SErrInActive = 'This operation is illegal when the server is inactive.';
+
+
+implementation
+
+{ ---------------------------------------------------------------------
+  Include platform specific implementation. 
+  Should implement the CommClass method of both server and client component, 
+  as well as the communication class itself.
+  
+  This comes first, to allow the uses clause to be set.
+  --------------------------------------------------------------------- }
+
+{$i simpleipc.inc}
+
+{ ---------------------------------------------------------------------
+    TIPCServerComm
+  ---------------------------------------------------------------------}
+
+constructor TIPCServerComm.Create(AOwner: TSimpleIPCServer);
+begin
+  FOwner:=AOWner;
+end;
+
+{ ---------------------------------------------------------------------
+    TIPCClientComm
+  ---------------------------------------------------------------------}
+  
+constructor TIPCClientComm.Create(AOwner: TSimpleIPCClient);
+begin
+  FOwner:=AOwner;
+end;
+
+{ ---------------------------------------------------------------------
+    TSimpleIPC
+  ---------------------------------------------------------------------}
+
+procedure TSimpleIPC.DoError(Msg: String; Args: array of const);
+begin
+  Raise EIPCError.Create(Name+': '+Format(Msg,Args));
+end;
+
+procedure TSimpleIPC.CheckInactive;
+begin
+  If Active then
+    DoError(SErrActive,[]);
+end;
+
+procedure TSimpleIPC.CheckActive;
+begin
+  If Not Active then
+    DoError(SErrInActive,[]);
+end;
+
+procedure TSimpleIPC.SetActive(const AValue: Boolean);
+begin
+  if (FActive<>AValue) then
+    begin
+    If AValue then
+      Activate
+    else
+      Deactivate;
+    end;
+end;
+
+procedure TSimpleIPC.SetServerID(const AValue: String);
+begin
+  if (FServerID<>AValue) then
+    begin
+    CheckInactive;
+    FServerID:=AValue
+    end;
+end;
+
+{ ---------------------------------------------------------------------
+    TSimpleIPCServer
+  ---------------------------------------------------------------------}
+
+constructor TSimpleIPCServer.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FGlobal:=False;
+  FActive:=False;
+  FBusy:=False;
+  FMsgData:=TStringStream.Create('');
+end;
+
+destructor TSimpleIPCServer.destroy;
+begin
+  Active:=False;
+  inherited destroy;
+end;
+
+procedure TSimpleIPCServer.SetGlobal(const AValue: Boolean);
+begin
+  if (FGlobal<>AValue) then
+    begin
+    CheckInactive;
+    FGlobal:=AValue;
+    end;
+end;
+
+function TSimpleIPCServer.GetInstanceID: String;
+begin
+  Result:=FIPCComm.InstanceID;
+end;
+
+
+function TSimpleIPCServer.GetStringMessage: String;
+begin
+  Result:=TStringStream(FMsgData).DataString;
+end;
+
+
+procedure TSimpleIPCServer.StartServer;
+begin
+  If (FServerID='') then
+    FServerID:=ApplicationName;
+  FIPCComm:=CommClass.Create(Self);
+  FIPCComm.StartServer;
+  FActive:=True;
+end;
+
+procedure TSimpleIPCServer.StopServer;
+begin
+  FIPCComm.StopServer;
+  FreeAndNil(FIPCComm);
+  FActive:=False;
+end;
+
+function TSimpleIPCServer.PeekMessage(TimeOut: Integer; DoReadMessage: Boolean
+  ): Boolean;
+begin
+  CheckActive;
+  FBusy:=True;
+  Try
+    Result:=FIPCComm.PeekMessage(Timeout);
+  Finally
+    FBusy:=False;
+  end;
+  If Result then
+    If DoReadMessage then
+      Readmessage;
+end;
+
+procedure TSimpleIPCServer.ReadMessage;
+begin
+  CheckActive;
+  FBusy:=True;
+  Try
+    FIPCComm.ReadMessage;
+    If Assigned(FOnMessage) then
+      FOnMessage(Self);
+  Finally
+    FBusy:=False;
+  end;
+end;
+
+procedure TSimpleIPCServer.GetMessageData(Stream: TStream);
+begin
+  Stream.CopyFrom(FMsgData,0);
+end;
+
+procedure TSimpleIPCServer.Activate;
+begin
+  StartServer;
+end;
+
+procedure TSimpleIPCServer.Deactivate;
+begin
+  StopServer;
+end;
+
+{ ---------------------------------------------------------------------
+    TSimpleIPCClient
+  ---------------------------------------------------------------------}
+
+procedure TSimpleIPCClient.SetServerInstance(const AValue: String);
+begin
+  CheckInactive;
+  FServerInstance:=AVAlue;
+end;
+
+procedure TSimpleIPCClient.Activate;
+begin
+  Connect;
+end;
+
+procedure TSimpleIPCClient.Deactivate;
+begin
+  DisConnect;
+end;
+constructor TSimpleIPCClient.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+end;
+
+destructor TSimpleIPCClient.destroy;
+begin
+  Active:=False;
+  Inherited;
+end;
+
+procedure TSimpleIPCClient.Connect;
+begin
+  FIPCComm:=CommClass.Create(Self);
+  FIPCComm.Connect;
+  FActive:=True;
+end;
+
+procedure TSimpleIPCClient.Disconnect;
+begin
+  FIPCComm.DisConnect;
+  FreeAndNil(FIPCComm);
+  FActive:=False;
+end;
+
+function TSimpleIPCClient.ServerRunning: Boolean;
+
+begin
+  If Assigned(FIPCComm) then
+    Result:=FIPCComm.ServerRunning
+  else
+    With CommClass.Create(Self) do
+      Try
+        Result:=ServerRunning;
+      finally
+        Free;
+      end;
+end;
+
+procedure TSimpleIPCClient.SendMessage(MsgType : TMessageType; Stream: TStream);
+
+begin
+  CheckActive;
+  FBusy:=True;
+  Try
+    FIPCComm.SendMessage(MsgType,Stream);
+  Finally
+    FBusy:=False;
+  end;
+end;
+
+procedure TSimpleIPCClient.SendStringMessage(Msg: String);
+
+Var
+  S : TStringStream;
+
+begin
+  S:=TStringStream.Create(Msg);
+  SendMessage(mtString,S);
+end;
+
+procedure TSimpleIPCClient.SendStringmessageFmt(Msg: String;
+  Args: array of const);
+begin
+  SendStringmessage(Format(Msg,Args));
+end;
+
+end.
+

fcl/tests/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/08/11]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/08/15]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-emx i386-watcom i386-netwlibc i386-wince m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos powerpc-linux powerpc-netbsd powerpc-macos powerpc-darwin powerpc-morphos sparc-linux sparc-netbsd sparc-solaris x86_64-linux x86_64-freebsd x86_64-win64 arm-linux arm-wince
@@ -231,19 +231,19 @@ UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
 endif
 PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
 ifeq ($(FULL_TARGET),i386-linux)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),i386-go32v2)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
 endif
 ifeq ($(FULL_TARGET),i386-win32)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  showver testproc testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  showver testproc testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),i386-os2)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  isockcli isocksvr testhres testnres testsres testrhre testrnre testrsre testur
 endif
 ifeq ($(FULL_TARGET),i386-freebsd)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),i386-beos)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
@@ -279,10 +279,10 @@ ifeq ($(FULL_TARGET),i386-wince)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
 endif
 ifeq ($(FULL_TARGET),m68k-linux)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),m68k-freebsd)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),m68k-netbsd)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
@@ -300,7 +300,7 @@ ifeq ($(FULL_TARGET),m68k-palmos)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
 endif
 ifeq ($(FULL_TARGET),powerpc-linux)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),powerpc-netbsd)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
@@ -309,13 +309,13 @@ ifeq ($(FULL_TARGET),powerpc-macos)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
 endif
 ifeq ($(FULL_TARGET),powerpc-darwin)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),powerpc-morphos)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
 endif
 ifeq ($(FULL_TARGET),sparc-linux)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),sparc-netbsd)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
@@ -324,16 +324,16 @@ ifeq ($(FULL_TARGET),sparc-solaris)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
 endif
 ifeq ($(FULL_TARGET),x86_64-linux)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),x86_64-freebsd)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),x86_64-win64)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs
 endif
 ifeq ($(FULL_TARGET),arm-linux)
-override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur
+override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs  sockcli isockcli dsockcli socksvr isocksvr dsocksvr testhres testnres testsres testrhre testrnre testrsre testur ipcserver ipcclient debugtest dbugsrv
 endif
 ifeq ($(FULL_TARGET),arm-wince)
 override TARGET_PROGRAMS+=stringl dparser fstream mstream list threads testrtf cfgtest xmldump htdump testez tidea b64test b64test2 b64enc b64dec restest testz testz2 istream doecho testol testcont txmlreg testreg tstelcmd testapp testcgi testbs

fcl/tests/Makefile.fpc

@@ -7,15 +7,19 @@ programs=stringl dparser fstream mstream list threads testrtf \
          cfgtest xmldump htdump testez tidea \
          b64test b64test2 b64enc b64dec restest testz testz2 \
          istream doecho testol testcont txmlreg testreg tstelcmd \
-         testapp testcgi testbs
+         testapp testcgi testbs 
 programs_win32=showver testproc testhres testnres testsres testrhre \
-               testrnre testrsre testur
+               testrnre testrsre testur ipcserver ipcclient debugtest \
+               dbugsrv
 programs_linux=sockcli isockcli dsockcli socksvr isocksvr dsocksvr \
-               testhres testnres testsres testrhre testrnre testrsre testur
+               testhres testnres testsres testrhre testrnre testrsre testur \
+               ipcserver ipcclient debugtest dbugsrv
 programs_darwin=sockcli isockcli dsockcli socksvr isocksvr dsocksvr \
-               testhres testnres testsres testrhre testrnre testrsre testur
+               testhres testnres testsres testrhre testrnre testrsre testur \
+               ipcserver ipcclient debugtest dbugsrv
 programs_freebsd=sockcli isockcli dsockcli socksvr isocksvr dsocksvr \
-               testhres testnres testsres testrhre testrnre testrsre testur
+               testhres testnres testsres testrhre testrnre testrsre testur \
+               ipcserver ipcclient debugtest dbugsrv
 programs_os2=isockcli isocksvr testhres testnres testsres testrhre \
              testrnre testrsre testur
 programs_emx=isockcli isocksvr testhres testnres testsres testrhre \

fcl/tests/README

@@ -60,3 +60,6 @@ testur.pp    Test of TURIParser class. (MVC)
 testapp.pp   Test of TCustomApplication. (MVC)
 testcgi.pp   Test of TCGIApplication class. (MVC)
 testbs.pp    Test of TBufStream buffered stream (MVC)
+ipcserver    Server part of SimpleIPC unit test, console app (MVC)
+ipcclient    Client part of SimpleIPC unit test, console app (MVC)
+testdebug    Client part of dbugintf debugging info test (MVC)

fcl/tests/dbugsrv.pp

@@ -0,0 +1,37 @@
+program dbugsrv;
+
+{$APPTYPE CONSOLE}
+
+uses
+  classes,SysUtils,simpleipc,msgintf;
+
+Var
+  Srv : TSimpleIPCServer;
+  S : String;
+  Msg : TDebugMessage;
+  
+begin
+  Srv:=TSimpleIPCServer.Create(Nil);
+  Try
+    Srv.ServerID:=DebugServerID;
+    Srv.Global:=True;
+    Srv.Active:=True;
+    Srv.StartServer;
+    Writeln('Server started. Listening for debug messages');
+    Repeat
+      If Srv.PeekMessage(1,True) then
+        begin
+        Srv.MsgData.Seek(0,soFrombeginning);
+        ReadDebugMessageFromStream(Srv.MsgData,MSg);
+        Write(FormatDateTime('hh:nn:ss.zzz',Msg.MsgTimeStamp),': ');
+        Write(DebugMessageName(MSg.MsgType):12,' ');
+        Writeln(Msg.Msg);
+        end
+      else
+        Sleep(10);
+    Until False;
+  Finally
+    Srv.Free;
+  end;
+end.
+

fcl/posix/custapp.inc → fcl/tests/debugtest.pp

@@ -2,7 +2,7 @@
     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.
+    Interactive test for debugserver.
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -12,29 +12,20 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
  **********************************************************************}
+program testdebug;
 
-Procedure SysGetEnvironmentList(List : TStrings;NamesOnly : Boolean);
+uses dbugintf;
 
 Var
-  P : PPChar;
-  S : String;
-  I : Integer;
+ S : String;
 
 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;
-
+  Repeat
+    Writeln('Enter message to send to debug server (STOP exits): ');
+    Write('> ');
+    Readln(S);
+    SendDebugEx(S,dlError);
+    If (SendError<>'') then
+      Writeln('Error : ',SendError);
+  Until (S='STOP');
+end.

fcl/tests/ipcclient.pp

@@ -0,0 +1,19 @@
+{$mode objfpc}
+{$h+}
+program ipcclient;
+
+uses simpleipc;
+
+begin
+  With TSimpleIPCClient.Create(Nil) do
+    try
+      ServerID:='ipcserver';
+      If (ParamCount>0) then
+        ServerInstance:=Paramstr(1);
+      Active:=True;
+      SendStringMessage('Testmessage from client');
+      Active:=False;
+    finally
+      Free;
+    end;
+end.

fcl/tests/ipcserver.pp

@@ -0,0 +1,33 @@
+program ipccerver;
+
+{$APPTYPE CONSOLE}
+
+uses
+  SysUtils,
+  simpleipc;
+
+Var
+  Srv : TSimpleIPCServer;
+  S : String;
+
+begin
+  Srv:=TSimpleIPCServer.Create(Nil);
+  Try
+    Srv.ServerID:='ipcserver';
+    Srv.Global:=True;
+    Srv.StartServer;
+    Writeln('Server started. Listening for messages');
+    Repeat
+      If Srv.PeekMessage(1,True) then
+        begin
+        S:=Srv.StringMessage;
+        Writeln('Received message : ',S);
+        end
+      else
+        Sleep(10);
+    Until CompareText(S,'stop')=0;
+  Finally
+    Srv.Free;
+  end;
+end.
+

fcl/unix/custapp.inc

@@ -1,40 +0,0 @@
-{
-    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;
-

fcl/unix/simpleipc.inc

@@ -0,0 +1,188 @@
+{
+    This file is part of the Free Component library.
+    Copyright (c) 2005 by Michael Van Canneyt, member of
+    the Free Pascal development team
+
+    Unix implementation of one-way IPC between 2 processes
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+uses baseunix;
+
+ResourceString
+  SErrFailedToCreatePipe = 'Failed to create named pipe: %s';
+  SErrFailedToRemovePipe = 'Failed to remove named pipe: %s';
+
+{ ---------------------------------------------------------------------
+    TPipeClientComm
+  ---------------------------------------------------------------------}
+
+Type
+  TPipeClientComm = Class(TIPCClientComm)
+  Private
+    FFileName: String;
+    FStream: TFileStream;
+  Public
+    Constructor Create(AOWner : TSimpleIPCClient); override;
+    Procedure Connect; override;
+    Procedure Disconnect; override;
+    Procedure SendMessage(MsgType : TMessageType; Stream : TStream); override;
+    Function  ServerRunning : Boolean; override;
+    Property FileName : String Read FFileName;
+    Property Stream : TFileStream Read FStream;
+  end;
+
+
+constructor TPipeClientComm.Create(AOWner: TSimpleIPCClient);
+
+Var
+  D : String;
+
+begin
+  inherited Create(AOWner);
+  FFileName:=Owner.ServerID;
+  If (Owner.ServerInstance<>'') then
+    FFileName:=FFileName+'-'+Owner.ServerInstance;
+  D:='/tmp/'; // Change to something better later
+  FFileName:=D+FFileName;
+end;
+
+
+procedure TPipeClientComm.Connect;
+begin
+  If Not ServerRunning then
+    Owner.DoError(SErrServerNotActive,[Owner.ServerID]);
+  FStream:=TFileStream.Create(FFileName,fmOpenReadWrite);
+end;
+
+procedure TPipeClientComm.Disconnect;
+begin
+  FreeAndNil(FStream);
+end;
+
+procedure TPipeClientComm.SendMessage(MsgType : TMessagetype; Stream: TStream);
+
+Var
+  Hdr : TMsgHeader;
+  P,L,Count : Integer;
+
+begin
+  Hdr.Version:=MsgVersion;
+  Hdr.msgType:=mtString;
+  Hdr.MsgLen:=Stream.Size;
+  FStream.WriteBuffer(hdr,SizeOf(hdr));
+  FStream.CopyFrom(Stream,0);
+end;
+
+function TPipeClientComm.ServerRunning: Boolean;
+begin
+  Result:=FileExists(FFileName);
+end;
+
+
+{ ---------------------------------------------------------------------
+    TPipeServerComm
+  ---------------------------------------------------------------------}
+  
+Type
+  TPipeServerComm = Class(TIPCServerComm)
+  Private
+    FFileName: String;
+    FStream: TFileStream;
+  Public
+    Constructor Create(AOWner : TSimpleIPCServer); override;
+    Procedure StartServer; override;
+    Procedure StopServer; override;
+    Function  PeekMessage(TimeOut : Integer) : Boolean; override;
+    Procedure ReadMessage ; override;
+    Function GetInstanceID : String;override;
+    Property FileName : String Read FFileName;
+    Property Stream : TFileStream Read FStream;
+  end;
+
+constructor TPipeServerComm.Create(AOWner: TSimpleIPCServer);
+
+Var
+  D : String;
+
+begin
+  inherited Create(AOWner);
+  FFileName:=Owner.ServerID;
+  If Not Owner.Global then
+    FFileName:=FFileName+'-'+IntToStr(fpGetPID);
+  D:='/tmp/'; // Change to something better later
+  FFileName:=D+FFileName;
+end;
+
+
+procedure TPipeServerComm.StartServer;
+begin
+  If not FileExists(FFileName) then
+    If (fpmkFifo(FFileName,438)<>0) then
+      Owner.DoError(SErrFailedToCreatePipe,[FFileName]);
+  FStream:=TFileStream.Create(FFileName,fmOpenReadWrite);
+end;
+
+procedure TPipeServerComm.StopServer;
+begin
+  FreeAndNil(FStream);
+  if Not DeleteFile(FFileName) then
+    Owner.DoError(SErrFailedtoRemovePipe,[FFileName]);
+end;
+
+function TPipeServerComm.PeekMessage(TimeOut: Integer): Boolean;
+
+Var
+  FDS : TFDSet;
+
+begin
+  fpfd_zero(FDS);
+  fpfd_set(FStream.Handle,FDS);
+  Result:=fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0;
+end;
+
+procedure TPipeServerComm.ReadMessage;
+
+Var
+  L,P,Count : Integer;
+  Hdr : TMsgHeader;
+
+begin
+  FStream.ReadBuffer(Hdr,SizeOf(Hdr));
+  Count:=Hdr.MsgLen;
+  Owner.FMsgData.Seek(0,soFrombeginning);
+  Owner.FMsgData.CopyFrom(FStream,Count);
+end;
+
+function TPipeServerComm.GetInstanceID: String;
+begin
+  Result:=IntToStr(fpGetPID);
+end;
+
+{ ---------------------------------------------------------------------
+    Set TSimpleIPCClient / TSimpleIPCServer defaults.
+  ---------------------------------------------------------------------}
+
+Function TSimpleIPCServer.CommClass : TIPCServerCommClass;
+
+begin
+  if (DefaultIPCServerClass<>Nil) then
+    Result:=DefaultIPCServerClass
+  else  
+    Result:=TPipeServerComm;
+end;
+
+function TSimpleIPCClient.CommClass: TIPCClientCommClass;
+begin
+  if (DefaultIPCClientClass<>Nil) then
+    Result:=DefaultIPCClientClass
+  else  
+    Result:=TPipeClientComm;
+end;

fcl/win32/custapp.inc

@@ -1,43 +0,0 @@
-{
-    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; stdcall; external 'kernel32' name 'GetEnvironmentStringsA';
-function FreeEnvironmentStrings(p : pchar) : longbool; stdcall; 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;

fcl/win32/simpleipc.inc

@@ -0,0 +1,291 @@
+{
+    This file is part of the Free Component library.
+    Copyright (c) 2005 by Michael Van Canneyt, member of
+    the Free Pascal development team
+
+    Windows implementation of one-way IPC between 2 processes
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+uses Windows,messages;
+
+Const
+  MsgWndClassName : pchar = 'FPCMsgWindowCls';
+
+Resourcestring
+  SErrFailedToRegisterWindowClass = 'Failed to register message window class';
+  SErrFailedToCreateWindow = 'Failed to create message window %s';
+
+var
+  MsgWindowClass: TWndClass = (
+    style: 0;
+    lpfnWndProc: Nil;
+    cbClsExtra: 0;
+    cbWndExtra: 0;
+    hInstance: 0;
+    hIcon: 0;
+    hCursor: 0;
+    hbrBackground: 0;
+    lpszMenuName: nil;
+    lpszClassName: Nil);
+  
+{ ---------------------------------------------------------------------
+    TWinMsgServerComm
+  ---------------------------------------------------------------------}
+
+Type
+  TWinMsgServerComm = Class(TIPCServerComm)
+  Private
+    FHWND : HWND;
+    FWindowName : String;
+    FDataPushed : Boolean;
+    FUnction AllocateHWnd(Const aWindowName : String) : HWND;
+  Public
+    Constructor Create(AOWner : TSimpleIPCServer); override;
+    procedure ReadMsgData(var Msg: TMsg);
+    Procedure StartServer; override;
+    Procedure StopServer; override;
+    Function  PeekMessage(TimeOut : Integer) : Boolean; override;
+    Procedure ReadMessage ; override;
+    Function GetInstanceID : String;override;
+    Property WindowName : String Read FWindowName;
+  end;
+
+
+function MsgWndProc(HWindow: HWnd; Message, WParam, LParam: Longint): Longint;stdcall;
+
+Var
+  I   : TWinMsgServerComm;
+  Msg : TMsg;
+
+begin
+  Result:=0;
+  If (Message=WM_COPYDATA) then
+    begin
+    I:=TWinMsgServerComm(GetWindowLong(HWindow,GWL_USERDATA));
+    If (I<>NIl) then
+      begin
+      Msg.Message:=Message;
+      Msg.WParam:=WParam;
+      Msg.LParam:=LParam;
+      I.ReadMsgData(Msg);
+      I.FDataPushed:=True;
+      If Assigned(I.Owner.OnMessage) then
+        I.Owner.ReadMessage;
+      Result:=1;
+      end
+    end
+  else
+    Result:=DefWindowProc(HWindow,Message,WParam,LParam);
+end;
+
+
+function TWinMsgServerComm.AllocateHWnd(const aWindowName: String): HWND;
+
+var
+  cls: TWndClass;
+  isreg : Boolean;
+
+begin
+  Pointer(MsgWindowClass.lpfnWndProc):=@MsgWndProc;
+  MsgWindowClass.hInstance := HInstance;
+  MsgWindowClass.lpszClassName:=MsgWndClassName;
+  isreg:=GetClassInfo(HInstance,MsgWndClassName,cls);
+  if not isreg then
+    if (Windows.RegisterClass(MsgWindowClass)=0) then
+      Owner.DoError(SErrFailedToRegisterWindowClass,[]);
+  Result:=CreateWindowEx(WS_EX_TOOLWINDOW, MsgWndClassName,
+    PChar(aWindowName), WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
+  if (Result=0) then
+    Owner.DoError(SErrFailedToCreateWindow,[aWindowName]);
+  SetWindowLong(Result,GWL_USERDATA,Longint(Self));
+end;
+
+constructor TWinMsgServerComm.Create(AOWner: TSimpleIPCServer);
+begin
+  inherited Create(AOWner);
+  FWindowName:=Owner.ServerID;
+  If not Owner.Global then
+    FWindowName:=FWindowName+'_'+InstanceID;
+end;
+
+procedure TWinMsgServerComm.StartServer;
+
+begin
+  FHWND:=AllocateHWND(FWindowName);
+end;
+
+procedure TWinMsgServerComm.StopServer;
+begin
+  DestroyWindow(FHWND);
+  FHWND:=0;
+end;
+
+function TWinMsgServerComm.PeekMessage(TimeOut: Integer): Boolean;
+
+Var
+  Msg : Tmsg;
+  B : Boolean;
+  R : DWORD;
+
+begin
+  Result:=FDataPushed;
+  If Result then
+    Exit;
+  B:=Windows.PeekMessage(Msg, FHWND, 0, 0, PM_NOREMOVE);
+  If not B then
+    // No message yet. Wait for a message to arrive available within specified time.
+    begin
+    if (TimeOut=0) then
+      TimeOut:=Integer(INFINITE);
+    R:=MsgWaitForMultipleObjects(1,FHWND,False,TimeOut,QS_SENDMESSAGE);
+    B:=(R<>WAIT_TIMEOUT);
+    end;
+  If B then
+    Repeat
+    B:=Windows.PeekMessage(Msg, FHWND, 0, 0, PM_NOREMOVE);
+    if B then
+      begin
+      Result:=(Msg.Message=WM_COPYDATA);
+      // Remove non WM_COPY messages from Queue
+      if not Result then
+        GetMessage(Msg,FHWND,0,0);
+      end;
+    Until Result or (not B);
+end;
+
+procedure TWinMsgServerComm.ReadMsgData(var Msg: TMsg);
+
+Var
+  CDS : PCopyDataStruct;
+
+begin
+  CDS:=PCopyDataStruct(Msg.Lparam);
+  Owner.FMsgData.Seek(0,soFrombeginning);
+  Owner.FMsgData.WriteBuffer(CDS^.lpData^,CDS^.cbData);
+end;
+
+procedure TWinMsgServerComm.ReadMessage;
+
+Var
+  Msg : TMsg;
+
+begin
+  If FDataPushed then
+    FDataPushed:=False
+  else
+    If Windows.PeekMessage(Msg, FHWND, 0, 0, PM_REMOVE) then
+      if (Msg.Message=WM_COPYDATA) then
+        ReadMsgData(Msg);
+end;
+
+function TWinMsgServerComm.GetInstanceID: String;
+begin
+  Result:=IntToStr(HInstance);
+end;
+
+{ ---------------------------------------------------------------------
+    TWinMsgClientComm
+  ---------------------------------------------------------------------}
+  
+Type
+  TWinMsgClientComm = Class(TIPCClientComm)
+  Private
+    FWindowName: String;
+    FHWND : HWnd;
+  Public
+    Constructor Create(AOWner : TSimpleIPCClient); override;
+    Procedure Connect; override;
+    Procedure Disconnect; override;
+    Procedure SendMessage(MsgType : TMessageType; Stream : TStream); override;
+    Function  ServerRunning : Boolean; override;
+    Property WindowName : String Read FWindowName;
+  end;
+
+
+constructor TWinMsgClientComm.Create(AOWner: TSimpleIPCClient);
+begin
+  inherited Create(AOWner);
+  FWindowName:=Owner.ServerID;
+  If (Owner.ServerInstance<>'') then
+    FWindowName:=FWindowName+'_'+Owner.ServerInstance;
+end;
+
+procedure TWinMsgClientComm.Connect;
+begin
+  FHWND:=FindWindow(MsgWndClassName,PChar(FWindowName));
+  If (FHWND=0) then
+    Owner.DoError(SErrServerNotActive,[Owner.ServerID]);
+end;
+
+procedure TWinMsgClientComm.Disconnect;
+begin
+  FHWND:=0;
+end;
+
+procedure TWinMsgClientComm.SendMessage(MsgType: TMessageType; Stream: TStream
+  );
+Var
+  CDS : TCopyDataStruct;
+  Data,FMemstr : TMemorySTream;
+
+begin
+  If Stream is TMemoryStream then
+    begin
+    Data:=TMemoryStream(Stream);
+    FMemStr:=Nil
+    end
+  else
+    begin
+    FMemStr:=TMemoryStream.Create;
+    Data:=FMemstr;
+    end;
+  Try
+    If Assigned(FMemStr) then
+      begin
+      FMemStr.CopyFrom(Stream,0);
+      FMemStr.Seek(0,soFromBeginning);
+      end;
+    CDS.lpData:=Data.Memory;
+    CDS.cbData:=Data.Size;
+    Windows.SendMessage(FHWnd,WM_COPYDATA,0,Integer(@CDS));
+  Finally
+    FreeAndNil(FMemStr);
+  end;
+end;
+
+function TWinMsgClientComm.ServerRunning: Boolean;
+begin
+  Result:=FindWindow(MsgWndClassName,PChar(FWindowName))<>0;
+end;
+
+{ ---------------------------------------------------------------------
+    Set TSimpleIPCClient / TSimpleIPCServer defaults.
+  ---------------------------------------------------------------------}
+
+
+Function TSimpleIPCServer.CommClass : TIPCServerCommClass;
+
+begin
+  if (DefaultIPCServerClass<>Nil) then
+    Result:=DefaultIPCServerClass
+  else  
+    Result:=TWinMsgServerComm;
+end;
+
+Function TSimpleIPCClient.CommClass : TIPCClientCommClass;
+
+begin
+  if (DefaultIPCClientClass<>Nil) then
+    Result:=DefaultIPCClientClass
+  else  
+    Result:=TWinMsgClientComm;
+end;
+

fcl/xml/xmlcfg.pp

@@ -2,7 +2,7 @@
     This file is part of the Free Component Library
 
     Implementation of TXMLConfig class
-    Copyright (c) 1999 - 2001 by Sebastian Guenther, [email protected]
+    Copyright (c) 1999 - 2005 by Sebastian Guenther, [email protected]
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -29,10 +29,17 @@ interface
 
 uses
   {$IFDEF MEM_CHECK}MemCheck,{$ENDIF}
-  Classes, DOM, XMLRead, XMLWrite;
+  SysUtils, Classes, DOM, XMLRead, XMLWrite;
+
+resourcestring
+  SMissingPathName = 'A part of the pathname is invalid (missing)';
+  SEscapingNecessary = 'Invalid pathname, escaping must be enabled';
+  SWrongRootName = 'XML file has wrong root element name';
 
 type
 
+  EXMLConfigError = class(Exception);
+
   {"APath" is the path and name of a value: A XML configuration file is
    hierachical. "/" is the path delimiter, the part after the last "/"
    is the name of the value. The path components will be mapped to XML
@@ -41,16 +48,21 @@ type
   TXMLConfig = class(TComponent)
   private
     FFilename: String;
+    FStartEmpty: Boolean;
+    FUseEscaping: Boolean;
+    FRootName: DOMString;
+    procedure SetFilename(const AFilename: String; ForceReload: Boolean);
     procedure SetFilename(const AFilename: String);
+    procedure SetStartEmpty(AValue: Boolean);
+    procedure SetRootName(const AValue: DOMString);
   protected
-    doc: TXMLDocument;
+    Doc: TXMLDocument;
     FModified: Boolean;
-    fDoNotLoad: boolean;
     procedure Loaded; override;
     function FindNode(const APath: String; PathHasValue: boolean): TDomNode;
+    function Escape(const s: String): String;
   public
-    constructor Create(const AFilename: String); overload;
-    constructor CreateClean(const AFilename: String);
+    constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     procedure Clear;
     procedure Flush;    // Writes the XML file
@@ -68,6 +80,10 @@ type
     property Modified: Boolean read FModified;
   published
     property Filename: String read FFilename write SetFilename;
+    property StartEmpty: Boolean read FStartEmpty write SetStartEmpty;
+    property UseEscaping: Boolean read FUseEscaping write FUseEscaping
+      default True;
+    property RootName: DOMString read FRootName write SetRootName;
   end;
 
 
@@ -75,52 +91,36 @@ type
 
 implementation
 
-uses SysUtils;
 
-
-constructor TXMLConfig.Create(const AFilename: String);
+constructor TXMLConfig.Create(AOwner: TComponent);
 begin
-  inherited Create(nil);
-  SetFilename(AFilename);
-end;
-
-constructor TXMLConfig.CreateClean(const AFilename: String);
-begin
-  inherited Create(nil);
-  fDoNotLoad:=true;
-  SetFilename(AFilename);
+  inherited Create(AOwner);
+  FUseEscaping := True;
+  FRootName := 'CONFIG';
+  Doc := TXMLDocument.Create;
+  Doc.AppendChild(Doc.CreateElement(RootName));
 end;
 
 destructor TXMLConfig.Destroy;
 begin
-  if Assigned(doc) then
+  if Assigned(Doc) then
   begin
     Flush;
-    doc.Free;
+    Doc.Free;
   end;
   inherited Destroy;
 end;
 
 procedure TXMLConfig.Clear;
-var
-  cfg: TDOMElement;
 begin
-  // free old document
-  doc.Free;
-  // create new document
-  doc := TXMLDocument.Create;
-  cfg :=TDOMElement(doc.FindNode('CONFIG'));
-  if not Assigned(cfg) then begin
-    cfg := doc.CreateElement('CONFIG');
-    doc.AppendChild(cfg);
-  end;
+  Doc.ReplaceChild(Doc.CreateElement(RootName), Doc.DocumentElement);
 end;
 
 procedure TXMLConfig.Flush;
 begin
   if Modified then
   begin
-    WriteXMLFile(doc, Filename);
+    WriteXMLFile(Doc, Filename);
     FModified := False;
   end;
 end;
@@ -132,25 +132,30 @@ var
   PathLen: integer;
   StartPos, EndPos: integer;
 begin
-  Result:=ADefault;
-  PathLen:=length(APath);
-  Node := doc.DocumentElement;
-  StartPos:=1;
-  while True do begin
-    EndPos:=StartPos;
-    while (EndPos<=PathLen) and (APath[EndPos]<>'/') do inc(EndPos);
-    if EndPos>PathLen then break;
-    SetLength(NodeName,EndPos-StartPos);
-    Move(APath[StartPos],NodeName[1],EndPos-StartPos);
-    StartPos:=EndPos+1;
-    Child := Node.FindNode(NodeName);
-    if not Assigned(Child) then exit;
+  Result := ADefault;
+  PathLen := Length(APath);
+  Node := Doc.DocumentElement;
+  StartPos := 1;
+  while True do
+  begin
+    EndPos := StartPos;
+    while (EndPos <= PathLen) and (APath[EndPos] <> '/') do
+      Inc(EndPos);
+    if EndPos > PathLen then
+      break;
+    SetLength(NodeName, EndPos - StartPos);
+    Move(APath[StartPos], NodeName[1], EndPos - StartPos);
+    StartPos := EndPos + 1;
+    Child := Node.FindNode(Escape(NodeName));
+    if not Assigned(Child) then
+      exit;
     Node := Child;
   end;
-  if StartPos>PathLen then exit;
-  SetLength(NodeName,PathLen-StartPos+1);
-  Move(APath[StartPos],NodeName[1],length(NodeName));
-  Attr := Node.Attributes.GetNamedItem(NodeName);
+  if StartPos > PathLen then
+    exit;
+  SetLength(NodeName, PathLen - StartPos + 1);
+  Move(APath[StartPos], NodeName[1], Length(NodeName));
+  Attr := Node.Attributes.GetNamedItem(Escape(NodeName));
   if Assigned(Attr) then
     Result := Attr.NodeValue;
 end;
@@ -171,9 +176,9 @@ begin
 
   s := GetValue(APath, s);
 
-  if AnsiCompareText(s,'TRUE')=0 then
+  if AnsiCompareText(s, 'TRUE')=0 then
     Result := True
-  else if AnsiCompareText(s,'FALSE')=0 then
+  else if AnsiCompareText(s, 'FALSE')=0 then
     Result := False
   else
     Result := ADefault;
@@ -187,15 +192,19 @@ var
   StartPos, EndPos: integer;
 begin
   Node := Doc.DocumentElement;
-  PathLen:=length(APath);
+  PathLen := Length(APath);
   StartPos:=1;
-  while True do begin
-    EndPos:=StartPos;
-    while (EndPos<=PathLen) and (APath[EndPos]<>'/') do inc(EndPos);
-    if EndPos>PathLen then break;
-    SetLength(NodeName,EndPos-StartPos);
-    Move(APath[StartPos],NodeName[1],EndPos-StartPos);
-    StartPos:=EndPos+1;
+  while True do
+  begin
+    EndPos := StartPos;
+    while (EndPos <= PathLen) and (APath[EndPos] <> '/') do
+      Inc(EndPos);
+    if EndPos > PathLen then
+      break;
+    SetLength(NodeName, EndPos - StartPos);
+    Move(APath[StartPos], NodeName[1], EndPos - StartPos);
+    StartPos := EndPos + 1;
+    NodeName := Escape(NodeName);
     Child := Node.FindNode(NodeName);
     if not Assigned(Child) then
     begin
@@ -205,9 +214,11 @@ begin
     Node := Child;
   end;
 
-  if StartPos>PathLen then exit;
-  SetLength(NodeName,PathLen-StartPos+1);
-  Move(APath[StartPos],NodeName[1],length(NodeName));
+  if StartPos > PathLen then
+    exit;
+  SetLength(NodeName, PathLen - StartPos + 1);
+  Move(APath[StartPos], NodeName[1], Length(NodeName));
+  NodeName := Escape(NodeName);
   if (not Assigned(TDOMElement(Node).GetAttributeNode(NodeName))) or
     (TDOMElement(Node)[NodeName] <> AValue) then
   begin
@@ -218,10 +229,10 @@ end;
 
 procedure TXMLConfig.SetDeleteValue(const APath, AValue, DefValue: String);
 begin
-  if AValue=DefValue then
+  if AValue = DefValue then
     DeleteValue(APath)
   else
-    SetValue(APath,AValue);
+    SetValue(APath, AValue);
 end;
 
 procedure TXMLConfig.SetValue(const APath: String; AValue: Integer);
@@ -232,10 +243,10 @@ end;
 procedure TXMLConfig.SetDeleteValue(const APath: String; AValue,
   DefValue: Integer);
 begin
-  if AValue=DefValue then
+  if AValue = DefValue then
     DeleteValue(APath)
   else
-    SetValue(APath,AValue);
+    SetValue(APath, AValue);
 end;
 
 procedure TXMLConfig.SetValue(const APath: String; AValue: Boolean);
@@ -249,7 +260,7 @@ end;
 procedure TXMLConfig.SetDeleteValue(const APath: String; AValue,
   DefValue: Boolean);
 begin
-  if AValue=DefValue then
+  if AValue = DefValue then
     DeleteValue(APath)
   else
     SetValue(APath,AValue);
@@ -259,8 +270,9 @@ procedure TXMLConfig.DeletePath(const APath: string);
 var
   Node: TDomNode;
 begin
-  Node:=FindNode(APath,false);
-  if (Node=nil) or (Node.ParentNode=nil) then exit;
+  Node := FindNode(APath, False);
+  if (Node = nil) or (Node.ParentNode = nil) then
+    exit;
   Node.ParentNode.RemoveChild(Node);
   FModified := True;
 end;
@@ -271,12 +283,15 @@ var
   StartPos: integer;
   NodeName: string;
 begin
-  Node:=FindNode(APath,true);
-  if (Node=nil) then exit;
-  StartPos:=length(APath);
-  while (StartPos>0) and (APath[StartPos]<>'/') do dec(StartPos);
-  NodeName:=copy(APath,StartPos+1,length(APath)-StartPos);
-  if (not Assigned(TDOMElement(Node).GetAttributeNode(NodeName))) then exit;
+  Node := FindNode(APath, True);
+  if not Assigned(Node) then
+    exit;
+  StartPos := Length(APath);
+  while (StartPos > 0) and (APath[StartPos] <> '/') do
+   Dec(StartPos);
+  NodeName := Escape(Copy(APath, StartPos+1, Length(APath) - StartPos));
+  if (not Assigned(TDOMElement(Node).GetAttributeNode(NodeName))) then
+    exit;
   TDOMElement(Node).RemoveAttribute(NodeName);
   FModified := True;
 end;
@@ -295,54 +310,122 @@ var
   StartPos, EndPos: integer;
   PathLen: integer;
 begin
-  Result := doc.DocumentElement;
-  PathLen:=length(APath);
-  StartPos:=1;
-  while (Result<>nil) do begin
-    EndPos:=StartPos;
-    while (EndPos<=PathLen) and (APath[EndPos]<>'/') do inc(EndPos);
-    if (EndPos>PathLen) and PathHasValue then exit;
-    if EndPos=StartPos then break;
-    SetLength(NodePath,EndPos-StartPos);
-    Move(APath[StartPos],NodePath[1],length(NodePath));
-    Result := Result.FindNode(NodePath);
-    StartPos:=EndPos+1;
-    if StartPos>PathLen then exit;
+  Result := Doc.DocumentElement;
+  PathLen := Length(APath);
+  StartPos := 1;
+  while Assigned(Result) do
+  begin
+    EndPos := StartPos;
+    while (EndPos <= PathLen) and (APath[EndPos] <> '/') do
+      Inc(EndPos);
+    if (EndPos > PathLen) and PathHasValue then
+      exit;
+    if EndPos = StartPos then
+      break;
+    SetLength(NodePath, EndPos - StartPos);
+    Move(APath[StartPos], NodePath[1], Length(NodePath));
+    Result := Result.FindNode(Escape(NodePath));
+    StartPos := EndPos + 1;
+    if StartPos > PathLen then
+      exit;
   end;
-  Result:=nil;
+  Result := nil;
 end;
 
-procedure TXMLConfig.SetFilename(const AFilename: String);
+function TXMLConfig.Escape(const s: String): String;
+const
+  AllowedChars = ['A'..'Z', 'a'..'z', '0'..'9', '.', '-', '_'];
 var
-  cfg: TDOMElement;
+  EscapingNecessary: Boolean;
+  i: Integer;
+begin
+  if Length(s) < 1 then
+    raise EXMLConfigError.Create(SMissingPathName);
+
+  if not (s[1] in ['A'..'Z', 'a'..'z', '_']) then
+    EscapingNecessary := True
+  else
+  begin
+    EscapingNecessary := False;
+    for i := 2 to Length(s) do
+      if not (s[i] in AllowedChars) then
+      begin
+        EscapingNecessary := True;
+	exit;
+      end;
+  end;
+
+  if EscapingNecessary then
+    if UseEscaping then
+    begin
+      Result := '_';
+      for i := 1 to Length(s) do
+        if s[i] in (AllowedChars - ['_']) then
+	  Result := Result + s[i]
+	else
+	  Result := Result + '_' + IntToHex(Ord(s[i]), 2);
+    end else
+      raise EXMLConfigError.Create(SEscapingNecessary)
+  else	// No escaping necessary
+    Result := s;
+end;
+
+procedure TXMLConfig.SetFilename(const AFilename: String; ForceReload: Boolean);
 begin
   {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename A '+AFilename);{$ENDIF}
-  if FFilename = AFilename then exit;
+  if (not ForceReload) and (FFilename = AFilename) then
+    exit;
   FFilename := AFilename;
 
   if csLoading in ComponentState then
     exit;
 
-  if Assigned(doc) then
-  begin
-    Flush;
-    doc.Free;
-  end;
+  Flush;
+  FreeAndNil(Doc);
 
-  doc:=nil;
-  if FileExists(AFilename) and (not fDoNotLoad) then
-    ReadXMLFile(doc,AFilename);
+  if FileExists(AFilename) and (not FStartEmpty) then
+    ReadXMLFile(Doc, AFilename);
 
-  if not Assigned(doc) then
-    doc := TXMLDocument.Create;
+  if not Assigned(Doc) then
+    Doc := TXMLDocument.Create;
+
+  if not Assigned(Doc.DocumentElement) then
+    Doc.AppendChild(Doc.CreateElement(RootName))
+  else
+    if Doc.DocumentElement.NodeName <> RootName then
+      raise EXMLConfigError.Create('XML file has wrong root element name');
 
-  cfg :=TDOMElement(doc.FindNode('CONFIG'));
-  if not Assigned(cfg) then begin
-    cfg := doc.CreateElement('CONFIG');
-    doc.AppendChild(cfg);
-  end;
   {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename END');{$ENDIF}
 end;
 
+procedure TXMLConfig.SetFilename(const AFilename: String);
+begin
+  SetFilename(AFilename, False);
+end;
+
+procedure TXMLConfig.SetRootName(const AValue: DOMString);
+var
+  Cfg: TDOMElement;
+begin
+  if AValue <> RootName then
+  begin
+    FRootName := AValue;
+    Cfg := Doc.CreateElement(AValue);
+    while Assigned(Doc.DocumentElement.FirstChild) do
+      Cfg.AppendChild(Doc.DocumentElement.FirstChild);
+    Doc.ReplaceChild(Cfg, Doc.DocumentElement);
+    FModified := True;
+  end;
+end;
+
+procedure TXMLConfig.SetStartEmpty(AValue: Boolean);
+begin
+  if AValue <> StartEmpty then
+  begin
+    FStartEmpty := AValue;
+    if (not AValue) and not Modified then
+      SetFilename(Filename, True);
+  end;
+end;
 
 end.