Merged revisions 9263-10571 via svnmerge from

svn+ssh://svn.freepascal.org/FPC/svn/fpc/branches/cleanroom

................
  r9269 | michael | 2007-11-17 13:58:31 +0100 (Sat, 17 Nov 2007) | 1 line
  
  * Cleaned initial list of tained routines
................
  r9270 | michael | 2007-11-17 14:00:25 +0100 (Sat, 17 Nov 2007) | 1 line
  
  * Test routines for cleanroom implementation
................
  r9271 | michael | 2007-11-17 14:04:43 +0100 (Sat, 17 Nov 2007) | 1 line
  
  DoVarClearArray also tainted
................
  r9272 | michael | 2007-11-17 15:25:04 +0100 (Sat, 17 Nov 2007) | 1 line
  
  * Removed possibly tainted code
................
  r9276 | Almindor | 2007-11-17 21:29:16 +0100 (Sat, 17 Nov 2007) | 2 lines
  
  * initial cleanroom implementation of TStringList.Find
................
  r9277 | Almindor | 2007-11-17 21:32:44 +0100 (Sat, 17 Nov 2007) | 2 lines
  
  * also commit forgotten part for "where would it instert" in case of sorted stringlist
................
  r9295 | michael | 2007-11-19 21:07:10 +0100 (Mon, 19 Nov 2007) | 1 line
  
  * More tests
................
  r9307 | michael | 2007-11-21 08:43:56 +0100 (Wed, 21 Nov 2007) | 1 line
  
  * More tests and reorganization per unit
................
  r9308 | michael | 2007-11-21 08:47:58 +0100 (Wed, 21 Nov 2007) | 1 line
  
  * More reorganization of files
................
  r9310 | michael | 2007-11-21 21:05:40 +0100 (Wed, 21 Nov 2007) | 1 line
  
  * Completed tccollection tests
................
  r9322 | marco | 2007-11-24 15:40:18 +0100 (Sat, 24 Nov 2007) | 1 line
  
   * getnamepath first version. Tests not run yet (fpcunit)
................
  r9337 | michael | 2007-11-27 09:21:31 +0100 (Tue, 27 Nov 2007) | 1 line
  
  * Removed TFPlist.Assign and TFPList.Extract
................
  r9340 | michael | 2007-11-27 22:33:07 +0100 (Tue, 27 Nov 2007) | 1 line
  
  Removed HandleSafeCallException 
................
  r9343 | Almindor | 2007-11-28 11:23:00 +0100 (Wed, 28 Nov 2007) | 2 lines
  
  * add cleanroom quicksort implementation [tested very little]
................
  r9344 | Almindor | 2007-11-28 11:25:54 +0100 (Wed, 28 Nov 2007) | 2 lines
  
  * update quicksort to use ExchangeItems instead of manual swap
................
  r9359 | vincents | 2007-11-30 20:10:03 +0100 (Fri, 30 Nov 2007) | 1 line
  
  + clean room implementation of HandleSafeCallException; compiles, but not tested.
................
  r9387 | michael | 2007-12-03 14:24:32 +0100 (Mon, 03 Dec 2007) | 1 line
  
  * Clean-room implementation of TParser by Giulio Bernardi
................
  r9396 | michael | 2007-12-05 21:36:41 +0100 (Wed, 05 Dec 2007) | 5 lines
  
  * Patch from Giulio Bernardi:
   - Fixes token positioning after HexToBinary 
   - Support for certain malformed negative integer values
................
  r9399 | michael | 2007-12-06 16:53:41 +0100 (Thu, 06 Dec 2007) | 1 line
  
  * More tests for classes unit
................
  r9401 | michael | 2007-12-06 21:58:16 +0100 (Thu, 06 Dec 2007) | 1 line
  
  * Added additional tests for collection streaming. Restructured
................
  r9402 | michael | 2007-12-06 22:35:56 +0100 (Thu, 06 Dec 2007) | 1 line
  
  * All compiles again, resolving references not quite yet done
................
  r9434 | michael | 2007-12-12 21:24:57 +0100 (Wed, 12 Dec 2007) | 1 line
  
  * New FindNestedComponent routine
................
  r9466 | michael | 2007-12-15 23:44:41 +0100 (Sat, 15 Dec 2007) | 1 line
  
  * Fixed all tests
................
  r9468 | michael | 2007-12-16 01:00:01 +0100 (Sun, 16 Dec 2007) | 1 line
  
  * Fixed reader fixup of references
................
  r9491 | joost | 2007-12-18 21:46:54 +0100 (Tue, 18 Dec 2007) | 3 lines
  
   * Implemented TWriter.WriteComponent
   * Implemented TWriter.WriteComponentData
   * Implemented TWriter.WriteDescendent
................
  r9492 | joost | 2007-12-18 21:56:32 +0100 (Tue, 18 Dec 2007) | 1 line
  
   * The BinaryObjectWriter of fpc stores TValueTypes as a byte, fixed the test for that
................
  r9566 | michael | 2007-12-29 15:53:32 +0100 (Sat, 29 Dec 2007) | 1 line
  
  * Clean (and complete) implementation of T(FP)List.Assign
................
  r9567 | michael | 2007-12-29 16:02:19 +0100 (Sat, 29 Dec 2007) | 1 line
  
  * Additional tests for reference resolving and TList.Assign
................
  r9568 | michael | 2007-12-29 16:12:33 +0100 (Sat, 29 Dec 2007) | 1 line
  
  * Cleanroom implementation of extract
................
  r9750 | yury | 2008-01-14 13:07:17 +0100 (Mon, 14 Jan 2008) | 1 line
  
  * My cleanroom implementation of DoVarClearArray.
................
  r10271 | michael | 2008-02-10 15:52:37 +0100 (Sun, 10 Feb 2008) | 1 line
  
  * Correct implementation committed
................
  r10273 | michael | 2008-02-10 17:08:59 +0100 (Sun, 10 Feb 2008) | 1 line
  
  * Added DecodeSoundexInt
................
  r10352 | vincents | 2008-02-18 08:23:18 +0100 (Mon, 18 Feb 2008) | 1 line
  
  + TStringList.Grow, used algorithm from TFPList.Expand
................
  r10353 | vincents | 2008-02-18 10:21:58 +0100 (Mon, 18 Feb 2008) | 1 line
  
  * use new TStringList.Grow implementation from trunk
................
  r10354 | vincents | 2008-02-18 10:23:07 +0100 (Mon, 18 Feb 2008) | 1 line
  
  * fixed TList tests
................
  r10355 | vincents | 2008-02-18 16:43:35 +0100 (Mon, 18 Feb 2008) | 1 line
  
  * fixed hint in test and removed session information from lpi
................
  r10356 | vincents | 2008-02-18 21:58:29 +0100 (Mon, 18 Feb 2008) | 1 line
  
  + implemented TStringList.Find
................
  r10358 | vincents | 2008-02-19 15:02:17 +0100 (Tue, 19 Feb 2008) | 1 line
  
  * fixed TTestTComponentNotifies test
................
  r10359 | vincents | 2008-02-19 15:48:43 +0100 (Tue, 19 Feb 2008) | 1 line
  
  * fixed memleak in TWriter.WriteProperties
................
  r10360 | vincents | 2008-02-19 15:49:20 +0100 (Tue, 19 Feb 2008) | 1 line
  
  + initial implementation of TReader.ReadCollection (needs further testing)
................
  r10364 | vincents | 2008-02-19 23:05:49 +0100 (Tue, 19 Feb 2008) | 1 line
  
  + TDataset.SetFieldValues (untested)
................
  r10365 | vincents | 2008-02-20 09:03:16 +0100 (Wed, 20 Feb 2008) | 1 line
  
  * initilize critical section used by resolving references
................
  r10366 | vincents | 2008-02-20 09:38:03 +0100 (Wed, 20 Feb 2008) | 2 lines
  
  * fixed resolve references test
  * removed unused variable
................
  r10369 | vincents | 2008-02-20 17:04:51 +0100 (Wed, 20 Feb 2008) | 1 line
  
  + initial version of TReader.FindComponentClass, works with a simple LCL application
................
  r10370 | michael | 2008-02-20 20:48:36 +0100 (Wed, 20 Feb 2008) | 1 line
  
  * Added tcollection stream read tests
................
  r10373 | vincents | 2008-02-21 00:33:10 +0100 (Thu, 21 Feb 2008) | 1 line
  
  * TReader.FindComponentClass: also search in FieldTables of parent classes.
................
  r10374 | michael | 2008-02-21 11:00:04 +0100 (Thu, 21 Feb 2008) | 1 line
  
  * Fix voor ResolveReferences
................
  r10376 | vincents | 2008-02-21 19:37:55 +0100 (Thu, 21 Feb 2008) | 1 line
  
  * reduced hints
................
  r10377 | vincents | 2008-02-22 14:56:22 +0100 (Fri, 22 Feb 2008) | 1 line
  
  * add check for valid NewIndex in TFPList.Move, so that an invalid NewIndex doesn't lead to memleak
................
  r10378 | vincents | 2008-02-22 15:16:56 +0100 (Fri, 22 Feb 2008) | 1 line
  
  * fixed TReader.ReadCollection in case more than one property was streamed
................
  r10379 | vincents | 2008-02-22 15:35:44 +0100 (Fri, 22 Feb 2008) | 3 lines
  
  + added another test for writing collections (shows how it should be written and thus read
  + added a test for a writing an enum with default value 
................
  r10380 | vincents | 2008-02-22 15:36:14 +0100 (Fri, 22 Feb 2008) | 1 line
  
  * fixed memleak
................
  r10381 | vincents | 2008-02-23 20:03:00 +0100 (Sat, 23 Feb 2008) | 1 line
  
  * fixed AV when streaming a component without published properties
................
  r10390 | michael | 2008-02-25 21:34:10 +0100 (Mon, 25 Feb 2008) | 1 line
  
  * Clean version of searchbuf inserted
................
  r10393 | vincents | 2008-02-26 23:06:14 +0100 (Tue, 26 Feb 2008) | 1 line
  
  * fixed TDataset.SetFieldValues
................
  r10398 | michael | 2008-02-27 21:58:49 +0100 (Wed, 27 Feb 2008) | 1 line
  
  * Added test for streaming 2 components
................
  r10400 | vincents | 2008-02-28 00:51:08 +0100 (Thu, 28 Feb 2008) | 1 line
  
  * improved tests for streaming components with owned subcomponents
................
  r10403 | vincents | 2008-02-28 22:19:32 +0100 (Thu, 28 Feb 2008) | 1 line
  
  * fixed writing child components
................
  r10441 | florian | 2008-03-04 20:11:46 +0100 (Tue, 04 Mar 2008) | 3 lines
  
  Initialized merge tracking via "svnmerge" with revisions "1-9261" from 
  http://svn.freepascal.org/svn/fpc/trunk
................
  r10444 | joost | 2008-03-05 11:31:07 +0100 (Wed, 05 Mar 2008) | 30 lines
  
  Merged revisions 9783,9786,9788,9814,9822,9825,9837-9850,9852,9854-9856,9863-9864,9867,9885,9895 via svnmerge from 
  svn+ssh://[email protected]/FPC/svn/fpc/trunk
  
  ........
    r9783 | joost | 2008-01-18 23:52:13 +0100 (Fri, 18 Jan 2008) | 1 line
    
     * DigestTestREport makes it possible to write the unittest results to a testsuite-digest
  ........
    r9786 | joost | 2008-01-19 00:40:44 +0100 (Sat, 19 Jan 2008) | 1 line
    
     * Added dependency on paszlib to fcl-fpcunit
  ........
    r9788 | jonas | 2008-01-19 01:20:49 +0100 (Sat, 19 Jan 2008) | 2 lines
    
      + also add fpc-unit dependency on paszlib to build dependencies
  ........
    r9854 | joost | 2008-01-21 17:26:20 +0100 (Mon, 21 Jan 2008) | 2 lines
    
     * Added Comment and Category properties to TDigestResultsWriter
     * Write Comment and Category to digest.cfg
  ........
    r9885 | joost | 2008-01-23 22:56:34 +0100 (Wed, 23 Jan 2008) | 1 line
    
     * Write RelSrcDir to digest.cfg
  ........
    r9895 | joost | 2008-01-24 18:02:47 +0100 (Thu, 24 Jan 2008) | 1 line
    
     * Add dash between hostname and date in digest-tarfile
  ........
................
  r10445 | joost | 2008-03-05 11:47:26 +0100 (Wed, 05 Mar 2008) | 9 lines
  
  Merged revisions 10431 via svnmerge from 
  svn+ssh://[email protected]/FPC/svn/fpc/trunk
  
  ........
    r10431 | joost | 2008-03-02 18:08:16 +0100 (Sun, 02 Mar 2008) | 1 line
    
     * Set Modified to false when te state of a dataset changes
  ........
................
  r10446 | joost | 2008-03-05 15:34:38 +0100 (Wed, 05 Mar 2008) | 9 lines
  
  Merged revisions 10350 via svnmerge from 
  svn+ssh://[email protected]/FPC/svn/fpc/trunk
  
  ........
    r10350 | joost | 2008-02-17 22:14:26 +0100 (Sun, 17 Feb 2008) | 1 line
    
     * Fixed bug #8464
  ........
................
  r10490 | Almindor | 2008-03-15 11:18:42 +0100 (Sat, 15 Mar 2008) | 3 lines
  
  * add TDataLink.CalcFirstRecord cleanroom implementation (blind)
  * add TField.RefreshLookupList cleanroom implementation (blind)
................
  r10491 | Almindor | 2008-03-15 11:29:54 +0100 (Sat, 15 Mar 2008) | 2 lines
  
  * fix compilation of the TField.RefreshLookuplist;
................
  r10510 | Almindor | 2008-03-20 18:57:22 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * implement cleanroom TDataset.CalculateFields
................
  r10511 | Almindor | 2008-03-20 19:16:55 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * add TDataSet.EnableControls cleanroom implementation
................
  r10512 | Almindor | 2008-03-20 19:27:27 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * add TField.CalcLookupValue cleanroom implementation
................
  r10513 | Almindor | 2008-03-20 19:30:23 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * fix potential bug in cleanroom TField.RefreshLookupList
................
  r10514 | Almindor | 2008-03-20 19:33:13 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * add forgotten function call in TDataset.CalculateFields
................
  r10515 | Almindor | 2008-03-20 19:37:19 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * fix potential bug in cleanroom TDataLink.CalcFirstRecord
................
  r10531 | Almindor | 2008-03-22 10:57:40 +0100 (Sat, 22 Mar 2008) | 2 lines
  
  * implement cleanroom TDataSet.DataEvent
................
  r10534 | Almindor | 2008-03-22 21:30:02 +0100 (Sat, 22 Mar 2008) | 2 lines
  
  * fix cleanroom TDataset.DataEvent, make it call all connected datasources
................
  r10537 | michael | 2008-03-23 11:19:05 +0100 (Sun, 23 Mar 2008) | 6 lines
  
  * Fixed some issues:
    - Memleak in TReader.ReadPropValue. FFixups was re-allocated in beginreferences !
    - FPC behaves different from Delphi if no Default value is declared, it assumes a
      default of ord(TEnum)=0, same for sets.
    - Fixed MemLeak when a reference was resolved, Removed item was not freed.
................
  r10547 | Almindor | 2008-03-24 10:57:28 +0100 (Mon, 24 Mar 2008) | 2 lines
  
  * first fix to cleanroom TDataSet.DataEvent only 6 tests fail now :)
................
  r10553 | joost | 2008-03-24 19:58:33 +0100 (Mon, 24 Mar 2008) | 9 lines
  
  Merged revisions 10470 via svnmerge from 
  svn+ssh://[email protected]/FPC/svn/fpc/trunk
  
  ........
    r10470 | joost | 2008-03-09 21:11:17 +0100 (Sun, 09 Mar 2008) | 1 line
    
     * Set TDataSet.InternalCalcFields if there are InternalCalcFields
  ........
................
  r10555 | joost | 2008-03-25 12:06:12 +0100 (Tue, 25 Mar 2008) | 9 lines
  
  Merged revisions 10519 via svnmerge from 
  svn+ssh://[email protected]/FPC/svn/fpc/trunk
  
  ........
    r10519 | joost | 2008-03-21 14:38:44 +0100 (Fri, 21 Mar 2008) | 1 line
    
     * Fix for ValueOfKey for multiple-fields keys
  ........
................
  r10565 | Almindor | 2008-03-25 18:28:58 +0100 (Tue, 25 Mar 2008) | 2 lines
  
  * fix cleanroom TDataLink.CalcFirstRecord (passes tests now)
................

git-svn-id: trunk@10572 -

.gitattributes

@@ -5520,6 +5520,8 @@ rtl/objpas/classes/lists.inc svneol=native#text/plain
 rtl/objpas/classes/parser.inc svneol=native#text/plain
 rtl/objpas/classes/persist.inc svneol=native#text/plain
 rtl/objpas/classes/reader.inc svneol=native#text/plain
+rtl/objpas/classes/resref.inc svneol=native#text/plain
+rtl/objpas/classes/sllist.inc svneol=native#text/plain
 rtl/objpas/classes/streams.inc svneol=native#text/plain
 rtl/objpas/classes/stringl.inc svneol=native#text/plain
 rtl/objpas/classes/twriter.inc svneol=native#text/plain

packages/Makefile

@@ -1,8 +1,8 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2008/03/24]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2008/03/20]
 #
 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-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded
+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-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded
 BSDs = freebsd netbsd openbsd darwin
 UNIXs = linux $(BSDs) solaris qnx
 LIMIT83fs = go32v2 os2 emx watcom
@@ -167,17 +167,6 @@ OS_TARGET:=$(word 5,$(FPC_COMPILERINFO))
 endif
 FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
 FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
-ifeq ($(CPU_TARGET),armeb)
-ARCH=arm
-override FPCOPT+=-Cb
-else
-ifeq ($(CPU_TARGET),armel)
-ARCH=arm
-override FPCOPT+=-CaEABI
-else
-ARCH=$(CPU_TARGET)
-endif
-endif
 ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
 TARGETSUFFIX=$(OS_TARGET)
 SOURCESUFFIX=$(OS_SOURCE)
@@ -199,7 +188,7 @@ endif
 ifeq ($(OS_TARGET),linux)
 linuxHier=1
 endif
-export OS_TARGET OS_SOURCE ARCH CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE TARGETSUFFIX SOURCESUFFIX CROSSCOMPILE
+export OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE TARGETSUFFIX SOURCESUFFIX CROSSCOMPILE
 ifdef FPCDIR
 override FPCDIR:=$(subst \,/,$(FPCDIR))
 ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
@@ -413,12 +402,6 @@ endif
 ifeq ($(FULL_TARGET),avr-embedded)
 override TARGET_DIRS+=hash pasjpeg paszlib fpmkunit fcl-base fcl-db fcl-image fcl-net fcl-passrc fcl-registry fcl-xml fcl-fpcunit fcl-json  fcl-process unzip regexpr chm fcl-res
 endif
-ifeq ($(FULL_TARGET),armeb-linux)
-override TARGET_DIRS+=hash pasjpeg paszlib fpmkunit fcl-base fcl-db fcl-image fcl-net fcl-passrc fcl-registry fcl-xml fcl-fpcunit fcl-json  fcl-process unzip regexpr chm fcl-res  fv fcl-web fcl-async ibase mysql ncurses unzip zlib oracle dbus odbc postgres sqlite pthreads imagemagick gdbint libpng x11 uuid ldap modplug dts mad  gdbm tcl syslog libcurl opengl cairo gtk1 gtk2  a52 bfd aspell svgalib newt cdrom users  imlib utmp  fpgtk openal lua oggvorbis xforms fftw pcap ggi sdl openssl gnome1 httpd22 pxlib numlib
-endif
-ifeq ($(FULL_TARGET),armeb-embedded)
-override TARGET_DIRS+=hash pasjpeg paszlib fpmkunit fcl-base fcl-db fcl-image fcl-net fcl-passrc fcl-registry fcl-xml fcl-fpcunit fcl-json  fcl-process unzip regexpr chm fcl-res
-endif
 override INSTALL_FPCPACKAGE=y
 override INSTALL_FPCSUBDIR=packages
 ifdef REQUIRE_UNITSDIR
@@ -1169,13 +1152,13 @@ TAROPT=vz
 TAREXT=.tar.gz
 endif
 ifndef NOCPUDEF
-override FPCOPTDEF=$(ARCH)
+override FPCOPTDEF=$(CPU_TARGET)
 endif
 ifneq ($(OS_TARGET),$(OS_SOURCE))
 override FPCOPT+=-T$(OS_TARGET)
 endif
 ifneq ($(CPU_TARGET),$(CPU_SOURCE))
-override FPCOPT+=-P$(ARCH)
+override FPCOPT+=-P$(CPU_TARGET)
 endif
 ifeq ($(OS_SOURCE),openbsd)
 override FPCOPT+=-FD$(NEW_BINUTILS_PATH)
@@ -3713,100 +3696,6 @@ TARGET_DIRS_REGEXPR=1
 TARGET_DIRS_CHM=1
 TARGET_DIRS_FCL-RES=1
 endif
-ifeq ($(FULL_TARGET),armeb-linux)
-TARGET_DIRS_HASH=1
-TARGET_DIRS_PASJPEG=1
-TARGET_DIRS_PASZLIB=1
-TARGET_DIRS_FPMKUNIT=1
-TARGET_DIRS_FCL-BASE=1
-TARGET_DIRS_FCL-DB=1
-TARGET_DIRS_FCL-IMAGE=1
-TARGET_DIRS_FCL-NET=1
-TARGET_DIRS_FCL-PASSRC=1
-TARGET_DIRS_FCL-REGISTRY=1
-TARGET_DIRS_FCL-XML=1
-TARGET_DIRS_FCL-FPCUNIT=1
-TARGET_DIRS_FCL-JSON=1
-TARGET_DIRS_FCL-PROCESS=1
-TARGET_DIRS_UNZIP=1
-TARGET_DIRS_REGEXPR=1
-TARGET_DIRS_CHM=1
-TARGET_DIRS_FCL-RES=1
-TARGET_DIRS_FV=1
-TARGET_DIRS_FCL-WEB=1
-TARGET_DIRS_FCL-ASYNC=1
-TARGET_DIRS_IBASE=1
-TARGET_DIRS_MYSQL=1
-TARGET_DIRS_NCURSES=1
-TARGET_DIRS_UNZIP=1
-TARGET_DIRS_ZLIB=1
-TARGET_DIRS_ORACLE=1
-TARGET_DIRS_DBUS=1
-TARGET_DIRS_ODBC=1
-TARGET_DIRS_POSTGRES=1
-TARGET_DIRS_SQLITE=1
-TARGET_DIRS_PTHREADS=1
-TARGET_DIRS_IMAGEMAGICK=1
-TARGET_DIRS_GDBINT=1
-TARGET_DIRS_LIBPNG=1
-TARGET_DIRS_X11=1
-TARGET_DIRS_UUID=1
-TARGET_DIRS_LDAP=1
-TARGET_DIRS_MODPLUG=1
-TARGET_DIRS_DTS=1
-TARGET_DIRS_MAD=1
-TARGET_DIRS_GDBM=1
-TARGET_DIRS_TCL=1
-TARGET_DIRS_SYSLOG=1
-TARGET_DIRS_LIBCURL=1
-TARGET_DIRS_OPENGL=1
-TARGET_DIRS_CAIRO=1
-TARGET_DIRS_GTK1=1
-TARGET_DIRS_GTK2=1
-TARGET_DIRS_A52=1
-TARGET_DIRS_BFD=1
-TARGET_DIRS_ASPELL=1
-TARGET_DIRS_SVGALIB=1
-TARGET_DIRS_NEWT=1
-TARGET_DIRS_CDROM=1
-TARGET_DIRS_USERS=1
-TARGET_DIRS_IMLIB=1
-TARGET_DIRS_UTMP=1
-TARGET_DIRS_FPGTK=1
-TARGET_DIRS_OPENAL=1
-TARGET_DIRS_LUA=1
-TARGET_DIRS_OGGVORBIS=1
-TARGET_DIRS_XFORMS=1
-TARGET_DIRS_FFTW=1
-TARGET_DIRS_PCAP=1
-TARGET_DIRS_GGI=1
-TARGET_DIRS_SDL=1
-TARGET_DIRS_OPENSSL=1
-TARGET_DIRS_GNOME1=1
-TARGET_DIRS_HTTPD22=1
-TARGET_DIRS_PXLIB=1
-TARGET_DIRS_NUMLIB=1
-endif
-ifeq ($(FULL_TARGET),armeb-embedded)
-TARGET_DIRS_HASH=1
-TARGET_DIRS_PASJPEG=1
-TARGET_DIRS_PASZLIB=1
-TARGET_DIRS_FPMKUNIT=1
-TARGET_DIRS_FCL-BASE=1
-TARGET_DIRS_FCL-DB=1
-TARGET_DIRS_FCL-IMAGE=1
-TARGET_DIRS_FCL-NET=1
-TARGET_DIRS_FCL-PASSRC=1
-TARGET_DIRS_FCL-REGISTRY=1
-TARGET_DIRS_FCL-XML=1
-TARGET_DIRS_FCL-FPCUNIT=1
-TARGET_DIRS_FCL-JSON=1
-TARGET_DIRS_FCL-PROCESS=1
-TARGET_DIRS_UNZIP=1
-TARGET_DIRS_REGEXPR=1
-TARGET_DIRS_CHM=1
-TARGET_DIRS_FCL-RES=1
-endif
 ifdef TARGET_DIRS_HASH
 hash_all:
 	$(MAKE) -C hash all

packages/fcl-db/src/base/dataset.inc

@@ -0,0 +1,2194 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Michael Van Canneyt, member of the
+    Free Pascal development team
+
+    Dataset implementation
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+{ ---------------------------------------------------------------------
+    TDataSet
+  ---------------------------------------------------------------------}
+
+Const
+  DefaultBufferCount = 10;
+
+constructor TDataSet.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  FFieldDefs:=TFieldDefs.Create(Self);
+  FFieldList:=TFields.Create(Self);
+  FDataSources:=TList.Create;
+  FConstraints:=TCheckConstraints.Create(Self);
+  
+// FBuffer must be allocated on create, to make Activebuffer return nil
+  ReAllocMem(FBuffers,SizeOf(PChar));
+//  pointer(FBuffers^) := nil;
+  FBuffers[0] := nil;
+  FActiveRecord := 0;
+  FBufferCount := 0;
+  FEOF := True;
+  FBOF := True;
+  FIsUniDirectional := False;
+end;
+
+
+
+destructor TDataSet.Destroy;
+
+var
+  i: Integer;
+
+begin
+  Active:=False;
+  FFieldDefs.Free;
+  FFieldList.Free;
+  With FDatasources do
+    begin
+    While Count>0 do
+      TDatasource(Items[Count - 1]).DataSet:=Nil;
+    Free;
+    end;
+  for i := 0 to FBufferCount do
+    FreeRecordBuffer(FBuffers[i]);
+  FConstraints.Free;
+  FreeMem(FBuffers);
+  Inherited Destroy;
+end;
+
+// This procedure must be called when the first record is made/read
+Procedure TDataset.ActivateBuffers;
+
+begin
+  FBOF:=False;
+  FEOF:=False;
+  FActiveRecord:=0;
+end;
+
+Procedure TDataset.UpdateFieldDefs;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.BindFields(Binding: Boolean);
+
+var i, FieldIndex: Integer;
+    FieldDef: TFieldDef;
+begin
+  {
+     Here some magic will be needed later; for now just simply set
+     Just set fieldno from listindex...
+     Later we should take it from the fielddefs.
+     // ATM Set by CreateField ...
+  For I:=0 to FFieldList.Count-1 do
+    FFieldList[i].FFieldNo:=I;
+  }
+  FCalcFieldsSize := 0;
+  FBlobFieldCount := 0;
+  for i := 0 to Fields.Count - 1 do
+    with Fields[i] do begin
+      if Binding then begin
+        if FieldKind in [fkCalculated, fkLookup] then begin
+          FFieldNo := -1;
+          FOffset := FCalcFieldsSize;
+          Inc(FCalcFieldsSize, DataSize + 1);
+          if FieldKind in [fkLookup] then begin
+            if ((FLookupDataSet = nil) or (FLookupKeyFields = '') or
+               (FLookupResultField = '') or (FKeyFields = '')) then
+              DatabaseErrorFmt(SLookupInfoError, [DisplayName]);
+            FFields.CheckFieldNames(FKeyFields);
+            FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
+            FLookupDataSet.FieldByName(FLookupResultField);
+            if FLookupCache then RefreshLookupList;
+          end
+        end else begin
+          FieldDef := nil;
+          FieldIndex := FieldDefs.IndexOf(Fields[i].FieldName);
+          if FieldIndex <> -1 then begin
+            FieldDef := FieldDefs[FieldIndex];
+            FFieldNo := FieldDef.FieldNo;
+            if FieldDef.InternalCalcField then FInternalCalcFields := True;
+            if IsBlob then begin
+              FSize := FieldDef.Size;
+              FOffset := FBlobFieldCount;
+              Inc(FBlobFieldCount);
+            end;
+          end else FFieldNo := FieldIndex;
+        end;
+      end else FFieldNo := 0;;
+    end;
+end;
+
+Function TDataset.BookmarkAvailable: Boolean;
+
+Const BookmarkStates = [dsBrowse,dsEdit,dsInsert];
+
+begin
+  Result:=(Not IsEmpty) and  not FIsUniDirectional and (State in BookmarkStates)
+          and (getBookMarkFlag(ActiveBuffer)=bfCurrent);
+end;
+
+Procedure TDataset.CalculateFields(Buffer: PChar);
+var
+  i: Integer;
+begin
+  FCalcBuffer := Buffer;
+  
+  if not IsUniDirectional and (FState <> dsInternalCalc) then try
+    ClearCalcFields(FCalcBuffer);
+    for i := 0 to FFieldList.Count - 1 do
+      if FFieldList[i].FieldKind = fkLookup then
+        FFieldList[i].CalcLookupValue;
+  finally
+    DoOnCalcFields;
+  end;
+end;
+
+Procedure TDataset.CheckActive;
+
+begin
+  If Not Active then
+    DataBaseError(SInactiveDataset);
+end;
+
+Procedure TDataset.CheckInactive;
+
+begin
+  If Active then
+    DataBaseError(SActiveDataset);
+end;
+
+Procedure TDataset.ClearBuffers;
+
+begin
+  FRecordCount:=0;
+  FactiveRecord:=0;
+  FCurrentRecord:=-1;
+  FBOF:=True;
+  FEOF:=True;
+end;
+
+Procedure TDataset.ClearCalcFields(Buffer: PChar);
+
+begin
+  if FCalcFieldsSize > 0 then
+    FillByte((Buffer+RecordSize)^,FCalcFieldsSize,0);
+end;
+
+Procedure TDataset.CloseBlob(Field: TField);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.CloseCursor;
+
+begin
+  FreeFieldBuffers;
+  ClearBuffers;
+  SetBufListSize(0);
+  InternalClose;
+  FInternalOpenComplete := False;
+end;
+
+Procedure TDataset.CreateFields;
+
+Var I : longint;
+
+begin
+{$ifdef DSDebug}
+  Writeln ('Creating fields');
+  Writeln ('Count : ',fielddefs.Count);
+  For I:=0 to FieldDefs.Count-1 do
+    Writeln('Def ',I,' : ',Fielddefs.items[i].Name,'(',Fielddefs.items[i].FieldNo,')');
+{$endif}
+  For I:=0 to fielddefs.Count-1 do
+    With Fielddefs.Items[I] do
+      If DataType<>ftUnknown then
+        begin
+        {$ifdef DSDebug}
+        Writeln('About to create field',FieldDefs.Items[i].Name);
+        {$endif}
+        CreateField(self);
+        end;
+end;
+
+Procedure TDataset.DataEvent(Event: TDataEvent; Info: Ptrint);
+
+  procedure HandleFieldChange(aField: TField);
+  begin
+    if aField.FieldKind in [fkData, fkInternalCalc] then
+      SetModified(True);
+      
+    if State <> dsSetKey then begin
+      if aField.FieldKind = fkData then begin
+        if FInternalCalcFields then
+          RefreshInternalCalcFields(ActiveBuffer)
+        else if FAutoCalcFields and (FCalcFieldsSize <> 0) then
+          CalculateFields(ActiveBuffer);
+      end;
+      
+      aField.Change;
+    end;
+  end;
+  
+  procedure HandleScrollOrChange;
+  begin
+    if State <> dsInsert then
+      UpdateCursorPos;
+  end;
+
+var
+  i: Integer;
+begin
+  case Event of
+    deFieldChange   : HandleFieldChange(TField(Info));
+    deDataSetChange,
+    deDataSetScroll : HandleScrollOrChange;
+  end;
+
+  if not ControlsDisabled then begin
+    for i := 0 to FDataSources.Count - 1 do
+      TDataSource(FDataSources[i]).ProcessEvent(Event, Info);
+  end;
+end;
+
+Procedure TDataset.DestroyFields;
+
+begin
+  FFieldList.Clear;
+end;
+
+Procedure TDataset.DoAfterCancel;
+
+begin
+ If assigned(FAfterCancel) then
+   FAfterCancel(Self);
+end;
+
+Procedure TDataset.DoAfterClose;
+
+begin
+ If assigned(FAfterClose) and not (csDestroying in ComponentState) then
+   FAfterClose(Self);
+end;
+
+Procedure TDataset.DoAfterDelete;
+
+begin
+ If assigned(FAfterDelete) then
+   FAfterDelete(Self);
+end;
+
+Procedure TDataset.DoAfterEdit;
+
+begin
+ If assigned(FAfterEdit) then
+   FAfterEdit(Self);
+end;
+
+Procedure TDataset.DoAfterInsert;
+
+begin
+ If assigned(FAfterInsert) then
+   FAfterInsert(Self);
+end;
+
+Procedure TDataset.DoAfterOpen;
+
+begin
+ If assigned(FAfterOpen) then
+   FAfterOpen(Self);
+end;
+
+Procedure TDataset.DoAfterPost;
+
+begin
+ If assigned(FAfterPost) then
+   FAfterPost(Self);
+end;
+
+Procedure TDataset.DoAfterScroll;
+
+begin
+ If assigned(FAfterScroll) then
+   FAfterScroll(Self);
+end;
+
+Procedure TDataset.DoAfterRefresh;
+
+begin
+ If assigned(FAfterRefresh) then
+   FAfterRefresh(Self);
+end;
+
+Procedure TDataset.DoBeforeCancel;
+
+begin
+ If assigned(FBeforeCancel) then
+   FBeforeCancel(Self);
+end;
+
+Procedure TDataset.DoBeforeClose;
+
+begin
+ If assigned(FBeforeClose) and not (csDestroying in ComponentState) then
+   FBeforeClose(Self);
+end;
+
+Procedure TDataset.DoBeforeDelete;
+
+begin
+ If assigned(FBeforeDelete) then
+   FBeforeDelete(Self);
+end;
+
+Procedure TDataset.DoBeforeEdit;
+
+begin
+ If assigned(FBeforeEdit) then
+   FBeforeEdit(Self);
+end;
+
+Procedure TDataset.DoBeforeInsert;
+
+begin
+ If assigned(FBeforeInsert) then
+   FBeforeInsert(Self);
+end;
+
+Procedure TDataset.DoBeforeOpen;
+
+begin
+ If assigned(FBeforeOpen) then
+   FBeforeOpen(Self);
+end;
+
+Procedure TDataset.DoBeforePost;
+
+begin
+ If assigned(FBeforePost) then
+   FBeforePost(Self);
+end;
+
+Procedure TDataset.DoBeforeScroll;
+
+begin
+ If assigned(FBeforeScroll) then
+   FBeforeScroll(Self);
+end;
+
+Procedure TDataset.DoBeforeRefresh;
+
+begin
+ If assigned(FBeforeRefresh) then
+   FBeforeRefresh(Self);
+end;
+
+Procedure TDataset.DoInternalOpen;
+
+begin
+  FDefaultFields:=FieldCount=0;
+  InternalOpen;
+  FInternalOpenComplete := True;
+{$ifdef dsdebug}
+  Writeln ('Calling internal open');
+{$endif}
+  FBOF:=True;
+{$ifdef dsdebug}
+  Writeln ('Calling RecalcBufListSize');
+{$endif}
+  FRecordcount := 0;
+  RecalcBufListSize;
+  FEOF := (FRecordcount = 0);
+end;
+
+Procedure TDataset.DoOnCalcFields;
+
+begin
+ If assigned(FOnCalcfields) then
+   FOnCalcFields(Self);
+end;
+
+Procedure TDataset.DoOnNewRecord;
+
+begin
+ If assigned(FOnNewRecord) then
+   FOnNewRecord(Self);
+end;
+
+Function TDataset.FieldByNumber(FieldNo: Longint): TField;
+
+begin
+  Result:=FFieldList.FieldByNumber(FieldNo);
+end;
+
+Function TDataset.FindRecord(Restart, GoForward: Boolean): Boolean;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.FreeFieldBuffers;
+
+Var I : longint;
+
+begin
+  For I:=0 to FFieldList.Count-1 do
+    FFieldList[i].FreeBuffers;
+end;
+
+Function TDataset.GetBookmarkStr: TBookmarkStr;
+
+begin
+  Result:='';
+  If BookMarkAvailable then
+    begin
+    SetLength(Result,FBookMarkSize);
+    GetBookMarkData(ActiveBuffer,Pointer(Result));
+    end
+end;
+
+Function TDataset.GetBuffer (Index : longint) : Pchar;
+
+begin
+  Result:=FBuffers[Index];
+end;
+
+Procedure TDataset.GetCalcFields(Buffer: PChar);
+
+var
+  dss: TDataSetState;
+begin
+  if (FCalcFieldsSize > 0) or FInternalCalcFields then
+  begin
+    dss := FState;
+    FState := dsCalcFields;
+    try
+      CalculateFields(Buffer);
+    finally
+      FState := dss;
+    end;
+  end;
+end;
+
+Function TDataset.GetCanModify: Boolean;
+
+begin
+  Result:= not FIsUnidirectional;
+end;
+
+Procedure TDataset.GetChildren(Proc: TGetChildProc; Root: TComponent);
+
+var
+ I: Integer;
+ Field: TField;
+
+begin
+ for I := 0 to Fields.Count - 1 do begin
+   Field := Fields[I];
+   if (Field.Owner = Root) then
+     Proc(Field);
+ end;
+end;
+
+Function TDataset.GetDataSource: TDataSource;
+begin
+  Result:=nil;
+end;
+
+function TDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
+
+begin
+  Result := False;
+end;
+
+procedure TDataSet.DataConvert(aField: TField; aSource, aDest: Pointer;
+  aToNative: Boolean);
+  
+var
+  DT : TFieldType;
+  
+begin
+  DT := aField.DataType;
+  if aToNative then
+    begin
+    case DT of
+      ftDate, ftTime, ftDateTime: TDateTimeRec(aDest^) := DateTimeToDateTimeRec(DT, TDateTime(aSource^));
+      ftTimeStamp               : TTimeStamp(aDest^) := TTimeStamp(aSource^);
+      ftBCD                     : TBCD(aDest^) := CurrToBCD(Currency(aSource^));
+      ftFMTBCD                  : TBcd(aDest^) := TBcd(aSource^);
+  // See notes from mantis bug-report 7204 for more information
+  //    ftBytes                   : ;
+  //    ftVarBytes                : ;
+  //    ftWideString              : ;
+
+      end
+    end
+  else
+    begin
+    case DT of
+      ftDate, ftTime, ftDateTime: TDateTime(aDest^) := DateTimeRecToDateTime(DT, TDateTimeRec(aSource^));
+      ftTimeStamp               : TTimeStamp(aDest^) := TTimeStamp(aSource^);
+      ftBCD                     : BCDToCurr(TBCD(aSource^),Currency(aDest^));
+      ftFMTBCD                  : TBcd(aDest^) := TBcd(aSource^);
+  //    ftBytes                   : ;
+  //    ftVarBytes                : ;
+  //    ftWideString              : ;
+
+      end
+    end
+end;
+
+function TDataSet.GetFieldData(Field: TField; Buffer: Pointer;
+  NativeFormat: Boolean): Boolean;
+
+Var
+  AStatBuffer : Array[0..dsMaxStringSize] of Char;
+  ADynBuffer : pchar;
+
+begin
+  If NativeFormat then
+    Result:=GetFieldData(Field, Buffer)
+  else
+    begin
+    if Field.DataSize <= dsMaxStringSize then
+      begin
+      Result := GetfieldData(Field, @AStatBuffer);
+      if Result then DataConvert(Field,@AStatBuffer,Buffer,False);
+      end
+    else
+      begin
+      GetMem(ADynBuffer,Field.DataSize);
+      try
+        Result := GetfieldData(Field, ADynBuffer);
+        if Result then DataConvert(Field,ADynBuffer,Buffer,False);
+      finally
+        FreeMem(ADynBuffer);
+        end;
+      end;
+    end;
+end;
+
+Function DateTimeRecToDateTime(DT: TFieldType; Data: TDateTimeRec): TDateTime;
+
+var
+  TS: TTimeStamp;
+
+begin
+  TS.Date:=0;
+  TS.Time:=0;
+  case DT of
+    ftDate: TS.Date := Data.Date;
+    ftTime: With TS do
+              begin
+              Time := Data.Time;
+              Date := DateDelta;
+              end;
+  else
+    try
+      TS:=MSecsToTimeStamp(trunc(Data.DateTime));
+    except
+    end;
+  end;
+  Result:=TimeStampToDateTime(TS);
+end;
+
+Function DateTimeToDateTimeRec(DT: TFieldType; Data: TDateTime): TDateTimeRec;
+
+var
+  TS : TTimeStamp;
+
+begin
+  TS:=DateTimeToTimeStamp(Data);
+  With Result do
+    case DT of
+      ftDate:
+        Date:=TS.Date;
+      ftTime:
+        Time:=TS.Time;
+    else
+      DateTime:=TimeStampToMSecs(TS);
+    end;
+end;
+
+procedure TDataSet.SetFieldData(Field: TField; Buffer: Pointer);
+
+begin
+// empty procedure
+end;
+
+procedure TDataSet.SetFieldData(Field: TField; Buffer: Pointer;
+  NativeFormat: Boolean);
+
+Var
+  AStatBuffer : Array[0..dsMaxStringSize] of Char;
+  ADynBuffer : pchar;
+
+begin
+  if NativeFormat then
+    SetFieldData(Field, Buffer)
+  else
+    begin
+    if Field.DataSize <= dsMaxStringSize then
+      begin
+      DataConvert(Field,Buffer,@AStatBuffer,True);
+      SetfieldData(Field, @AStatBuffer);
+      end
+    else
+      begin
+      GetMem(ADynBuffer,Field.DataSize);
+      try
+        DataConvert(Field,Buffer,@AStatBuffer,True);
+        SetfieldData(Field, @AStatBuffer);
+      finally
+        FreeMem(ADynBuffer);
+        end;
+      end;
+    end;
+end;
+
+Function TDataset.GetField (Index : Longint) : TField;
+
+begin
+  Result:=FFIeldList[index];
+end;
+
+Function TDataset.GetFieldClass(FieldType: TFieldType): TFieldClass;
+
+begin
+  Result := DefaultFieldClasses[FieldType];
+end;
+
+Function TDataset.GetIsIndexField(Field: TField): Boolean;
+
+begin
+  Result:=False;
+end;
+
+function TDataSet.GetIndexDefs(IndexDefs: TIndexDefs; IndexTypes: TIndexOptions
+  ): TIndexDefs;
+  
+var i,f : integer;
+    IndexFields : TStrings;
+    
+begin
+  IndexDefs.Update;
+  Result := TIndexDefs.Create(Self);
+  Result.Assign(IndexDefs);
+  i := 0;
+  IndexFields := TStringList.Create;
+  while i < result.Count do
+    begin
+    if (not ((IndexTypes = []) and (result[i].Options = []))) and
+       ((IndexTypes * result[i].Options) = []) then
+      begin
+      result.Delete(i);
+      dec(i);
+      end
+    else
+      begin
+      ExtractStrings([';'],[' '],pchar(result[i].Fields),Indexfields);
+      for f := 0 to IndexFields.Count-1 do if FindField(Indexfields[f]) = nil then
+        begin
+        result.Delete(i);
+        dec(i);
+        break;
+        end;
+      end;
+    inc(i);
+    end;
+  IndexFields.Free;
+end;
+
+Function TDataset.GetNextRecord: Boolean;
+
+  procedure ExchangeBuffers(var buf1,buf2 : pointer);
+
+  var tempbuf : pointer;
+
+  begin
+    tempbuf := buf1;
+    buf1 := buf2;
+    buf2 := tempbuf;
+  end;
+
+begin
+{$ifdef dsdebug}
+  Writeln ('Getting next record. Internal RecordCount : ',FRecordCount);
+{$endif}
+  If FRecordCount>0 Then SetCurrentRecord(FRecordCount-1);
+  Result:=GetRecord(FBuffers[FBuffercount],gmNext,True)=grOK;
+
+  if result then
+    begin
+      If FRecordCount=0 then ActivateBuffers;
+      if FRecordcount=FBuffercount then
+        shiftbuffersbackward
+      else
+        begin
+          inc(FRecordCount);
+          FCurrentRecord:=FRecordCount - 1;
+          ExchangeBuffers(Fbuffers[FCurrentRecord],FBuffers[FBuffercount]);
+        end;
+    end
+  else
+    cursorposchanged;
+{$ifdef dsdebug}
+  Writeln ('Result getting next record : ',Result);
+{$endif}
+end;
+
+Function TDataset.GetNextRecords: Longint;
+
+begin
+  Result:=0;
+{$ifdef dsdebug}
+  Writeln ('Getting next record(s), need :',FBufferCount);
+{$endif}
+  While (FRecordCount<FBufferCount) and GetNextRecord do
+    Inc(Result);
+{$ifdef dsdebug}
+  Writeln ('Result Getting next record(S), GOT :',RESULT);
+{$endif}
+end;
+
+Function TDataset.GetPriorRecord: Boolean;
+
+begin
+{$ifdef dsdebug}
+  Writeln ('GetPriorRecord: Getting previous record');
+{$endif}
+  CheckBiDirectional;
+  If FRecordCount>0 Then SetCurrentRecord(0);
+  Result:=GetRecord(FBuffers[FBuffercount],gmPrior,True)=grOK;
+  if result then
+    begin
+      If FRecordCount=0 then ActivateBuffers;
+      shiftbuffersforward;
+
+      if FRecordcount<FBuffercount then
+        inc(FRecordCount);
+    end
+  else
+    cursorposchanged;
+{$ifdef dsdebug}
+  Writeln ('Result getting prior record : ',Result);
+{$endif}
+end;
+
+Function TDataset.GetPriorRecords: Longint;
+
+begin
+  Result:=0;
+{$ifdef dsdebug}
+  Writeln ('Getting previous record(s), need :',FBufferCount);
+{$endif}
+  While (FRecordCount<FbufferCount) and GetPriorRecord do
+    Inc(Result);
+end;
+
+Function TDataset.GetRecNo: Longint;
+
+begin
+  Result := -1;
+end;
+
+Function TDataset.GetRecordCount: Longint;
+
+begin
+  Result := -1;
+end;
+
+Procedure TDataset.InitFieldDefs;
+
+begin
+  if IsCursorOpen then
+    InternalInitFieldDefs
+  else
+    begin
+    try
+      OpenCursor(True);
+    finally
+      CloseCursor;
+      end;
+    end;
+end;
+
+procedure TDataSet.InitFieldDefsFromfields;
+var i : integer;
+begin
+  if FieldDefs.count = 0 then
+    begin
+    FieldDefs.BeginUpdate;
+    try
+      for i := 0 to Fields.Count-1 do with fields[i] do
+        begin
+        with TFieldDef.Create(FieldDefs,FieldName,DataType,Size,Required,i+1) do
+          begin
+          if Required then Attributes := attributes + [faRequired];
+          if ReadOnly then Attributes := attributes + [faReadOnly];
+          if DataType = ftBCD then precision := (fields[i] as TBCDField).Precision
+          // this must change if TFMTBcdfield is implemented
+          else if DataType = ftFMTBcd then precision := (fields[i] as TBCDField).Precision;
+          end;
+        end;
+    finally
+      FieldDefs.EndUpdate;
+      end;
+    end;
+end;
+
+Procedure TDataset.InitRecord(Buffer: PChar);
+
+begin
+  InternalInitRecord(Buffer);
+  ClearCalcFields(Buffer);
+end;
+
+Procedure TDataset.InternalCancel;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.InternalEdit;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.InternalRefresh;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.OpenCursor(InfoQuery: Boolean);
+
+begin
+  if InfoQuery then
+    InternalInitfieldDefs
+  else if state <> dsOpening then
+    DoInternalOpen;
+end;
+
+procedure TDataSet.OpenCursorcomplete;
+begin
+  try
+    if FState = dsOpening then DoInternalOpen
+  finally
+    if FInternalOpenComplete then
+      begin
+      SetState(dsBrowse);
+      DoAfterOpen;
+      if not IsEmpty then
+        DoAfterScroll;
+      end
+    else
+      begin
+      SetState(dsInactive);
+      CloseCursor;
+      end;
+  end;
+end;
+
+Procedure TDataset.RefreshInternalCalcFields(Buffer: PChar);
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.SetTempState(const Value: TDataSetState): TDataSetState;
+
+begin
+  result := FState;
+  FState := value;
+  inc(FDisableControlsCount);
+end;
+
+Procedure TDataset.RestoreState(const Value: TDataSetState);
+
+begin
+  FState := value;
+  dec(FDisableControlsCount);
+end;
+
+function TDataset.GetActive : boolean;
+
+begin
+  result := (FState <> dsInactive) and (FState <> dsOpening);
+end;
+
+Procedure TDataset.InternalHandleException;
+
+begin
+  if assigned(classes.ApplicationHandleException) then
+    classes.ApplicationHandleException(self)
+  else
+    ShowException(ExceptObject,ExceptAddr);
+end;
+
+procedure TDataSet.InternalPost;
+
+  Procedure Checkrequired;
+
+  Var I : longint;
+
+  begin
+    For I:=0 to FFieldList.Count-1 do
+      With FFieldList[i] do
+        // Required fields that are NOT autoinc !! Autoinc cannot be set !!
+        if Required and not ReadOnly and
+           (FieldKind=fkData) and Not (DataType=ftAutoInc) and IsNull then
+          DatabaseErrorFmt(SNeedField,[DisplayName],Self);
+  end;
+
+begin
+  Checkrequired;
+end;
+
+procedure TDataSet.SetUniDirectional(const Value: Boolean);
+begin
+  FIsUniDirectional := Value;
+end;
+
+Procedure TDataset.SetActive (Value : Boolean);
+
+begin
+  if value and (Fstate = dsInactive) then
+    begin
+    if csLoading in ComponentState then
+      begin
+      FOpenAfterRead := true;
+      exit;
+      end
+    else
+      begin
+      DoBeforeOpen;
+      FInternalCalcFields:=False;
+      try
+        OpenCursor(False);
+      finally
+        if FState <> dsOpening then OpenCursorComplete;
+        end;
+      end;
+    FModified:=False;
+    end
+  else if not value and (Fstate <> dsinactive) then
+    begin
+    DoBeforeClose;
+    SetState(dsInactive);
+    CloseCursor;
+    DoAfterClose;
+    FModified:=False;
+    FModified:=False;
+    end
+end;
+
+procedure TDataset.Loaded;
+
+begin
+  inherited;
+  try
+    if FOpenAfterRead then SetActive(true);
+  except
+    if csDesigning in Componentstate then
+      InternalHandleException
+    else
+      raise;
+  end;
+end;
+
+
+procedure TDataSet.RecalcBufListSize;
+
+var
+  i, j, ABufferCount: Integer;
+  DataLink: TDataLink;
+
+begin
+{$ifdef dsdebug}
+  Writeln('Recalculating buffer list size - check cursor');
+{$endif}
+  If Not IsCursorOpen Then
+    Exit;
+{$ifdef dsdebug}
+  Writeln('Recalculating buffer list size');
+{$endif}
+  ABufferCount := DefaultBufferCount;
+  for i := 0 to FDataSources.Count - 1 do
+    for j := 0 to TDataSource(FDataSources[i]).DataLinks.Count - 1 do
+      begin
+      DataLink:=TDataLink(TDataSource(FDataSources[i]).DataLinks[j]);
+      if DataLink.BufferCount>ABufferCount then
+        ABufferCount:=DataLink.BufferCount;
+      end;
+
+  If (FBufferCount=ABufferCount) Then
+    exit;
+
+{$ifdef dsdebug}
+  Writeln('Setting buffer list size');
+{$endif}
+
+  SetBufListSize(ABufferCount);
+{$ifdef dsdebug}
+  Writeln('Getting next buffers');
+{$endif}
+  GetNextRecords;
+  if FRecordCount < FBufferCount then
+    begin
+    FActiveRecord := FActiveRecord + GetPriorRecords;
+    CursorPosChanged;
+    end;
+{$Ifdef dsDebug}
+  WriteLn(
+    'SetBufferCount: FActiveRecord=',FActiveRecord,
+    ' FCurrentRecord=',FCurrentRecord,
+    ' FBufferCount= ',FBufferCount,
+    ' FRecordCount=',FRecordCount);
+{$Endif}
+end;
+
+Procedure TDataset.SetBookmarkStr(const Value: TBookmarkStr);
+
+begin
+  GotoBookMark(Pointer(Value))
+end;
+
+Procedure TDataset.SetBufListSize(Value: Longint);
+
+Var I : longint;
+
+begin
+  if Value = 0 then Value := -1;
+{$ifdef dsdebug}
+  Writeln ('SetBufListSize: ',Value);
+{$endif}
+  If Value=FBufferCount Then
+    exit;
+  If Value>FBufferCount then
+    begin
+{$ifdef dsdebug}
+    Writeln ('   Reallocating memory :',(Value+1)*SizeOf(PChar));
+{$endif}
+    ReAllocMem(FBuffers,(Value+1)*SizeOf(PChar));
+{$ifdef dsdebug}
+    Writeln ('   Filling memory :',(Value+1-FBufferCount)*SizeOf(PChar));
+{$endif}
+    if FBufferCount > 0 then inc(FBufferCount); // Cause FBuffers[FBufferCount] is already allocated
+    FillChar(FBuffers[FBufferCount],(Value+1-FBufferCount)*SizeOF(Pchar),#0);
+{$ifdef dsdebug}
+    Writeln ('   Filled memory :');
+{$endif}
+    Try
+{$ifdef dsdebug}
+      Writeln ('   Assigning buffers :',(Value)*SizeOf(PChar));
+{$endif}
+      For I:=FBufferCount to Value do
+        FBuffers[i]:=AllocRecordBuffer;
+{$ifdef dsdebug}
+      Writeln ('   Assigned buffers ',FBufferCount,' :',(Value)*SizeOf(PChar));
+{$endif}
+    except
+      I:=FBufferCount;
+      While (I<(Value+1)) do
+        begin
+        FreeRecordBuffer(FBuffers[i]);
+        Inc(i);
+        end;
+      raise;
+    end;
+    end
+  else
+    begin
+{$ifdef dsdebug}
+    Writeln ('   Freeing buffers :',FBufferCount-Value);
+{$endif}
+    if (value > -1) and (FActiveRecord>Value-1) then
+      begin
+      for i := 0 to (FActiveRecord-Value) do
+        shiftbuffersbackward;
+      FActiverecord := Value -1;
+      end;
+
+    If Assigned(FBuffers) then
+      begin
+      For I:=Value+1 to FBufferCount do
+        FreeRecordBuffer(FBuffers[i]);
+      // FBuffer must stay allocated, to make sure that Activebuffer returns nil
+      if Value = -1 then
+        begin
+        ReAllocMem(FBuffers,SizeOf(Pchar));
+        FBuffers[0] := nil;
+        end
+      else
+        ReAllocMem(FBuffers,(Value+1)*SizeOf(Pchar));
+      end;
+    end;
+  If Value=-1 then
+    Value:=0;
+  if FRecordcount > Value then FRecordcount := Value;
+  FBufferCount:=Value;
+{$ifdef dsdebug}
+  Writeln ('   SetBufListSize: Final FBufferCount=',FBufferCount);
+{$endif}
+end;
+
+Procedure TDataset.SetChildOrder(Component: TComponent; Order: Longint);
+
+var
+  Field: TField;
+begin
+  Field := Component as TField;
+  if Fields.IndexOf(Field) >= 0 then
+    Field.Index := Order;
+end;
+
+Procedure TDataset.SetCurrentRecord(Index: Longint);
+
+begin
+  If FCurrentRecord<>Index then
+    begin
+{$ifdef DSdebug}
+    Writeln ('Setting current record to',index);
+{$endif}
+    if not FIsUniDirectional then Case GetBookMarkFlag(FBuffers[Index]) of
+      bfCurrent : InternalSetToRecord(FBuffers[Index]);
+      bfBOF : InternalFirst;
+      bfEOF : InternalLast;
+      end;
+    FCurrentRecord:=index;
+    end;
+end;
+
+Procedure TDataset.SetField (Index : Longint;Value : TField);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.CheckBiDirectional;
+
+begin
+  if FIsUniDirectional then DataBaseError(SUniDirectional);
+end;
+
+Procedure TDataset.SetFilterOptions(Value: TFilterOptions);
+
+begin
+  CheckBiDirectional;
+  FFilterOptions := Value;
+end;
+
+Procedure TDataset.SetFilterText(const Value: string);
+
+begin
+  FFilterText := value;
+end;
+
+Procedure TDataset.SetFiltered(Value: Boolean);
+
+begin
+  if Value then CheckBiDirectional;
+  FFiltered := value;
+end;
+
+Procedure TDataset.SetFound(const Value: Boolean);
+
+begin
+  FFound := Value;
+end;
+
+Procedure TDataset.SetModified(Value: Boolean);
+
+begin
+  FModified := value;
+end;
+
+Procedure TDataset.SetName(const Value: TComponentName);
+
+function CheckName(FieldName: string): string;
+var i,j: integer;
+begin
+  Result := FieldName;
+  i := 0;
+  j := 0;
+  while (i < Fields.Count) do begin
+    if Result = Fields[i].FieldName then begin
+      inc(j);
+      Result := FieldName + IntToStr(j);
+    end else Inc(i);
+  end;
+end;
+var i: integer;
+    nm: string;
+    old: string;
+begin
+  if Self.Name = Value then Exit;
+  old := Self.Name;
+  inherited SetName(Value);
+  if (csDesigning in ComponentState) then
+    for i := 0 to Fields.Count - 1 do begin
+      nm := old + Fields[i].FieldName;
+      if Copy(Fields[i].Name, 1, Length(nm)) = nm then
+        Fields[i].Name := CheckName(Value + Fields[i].FieldName);
+    end;
+end;
+
+Procedure TDataset.SetOnFilterRecord(const Value: TFilterRecordEvent);
+
+begin
+  CheckBiDirectional;
+  FOnFilterRecord := Value;
+end;
+
+Procedure TDataset.SetRecNo(Value: Longint);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetState(Value: TDataSetState);
+
+begin
+  If Value<>FState then
+    begin
+    FState:=Value;
+    DataEvent(deUpdateState,0);
+    end;
+end;
+
+Function TDataset.Tempbuffer: PChar;
+
+begin
+  Result := FBuffers[FRecordCount];
+end;
+
+Procedure TDataset.UpdateIndexDefs;
+
+begin
+  // Empty Abstract
+end;
+
+Function TDataset.ControlsDisabled: Boolean;
+
+begin
+  Result := (FDisableControlsCount > 0);
+end;
+
+Function TDataset.ActiveBuffer: PChar;
+
+begin
+{$ifdef dsdebug}
+  Writeln ('Active buffer requested. Returning:',ActiveRecord);
+{$endif}
+  Result:=FBuffers[FActiveRecord];
+end;
+
+Procedure TDataset.Append;
+
+begin
+  DoInsertAppend(True);
+end;
+
+Procedure TDataset.InternalInsert;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.AppendRecord(const Values: array of const);
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.BookmarkValid(ABookmark: TBookmark): Boolean;
+{
+  Should be overridden by descendant objects.
+}
+begin
+  Result:=False
+end;
+
+Procedure TDataset.Cancel;
+
+begin
+  If State in [dsEdit,dsInsert] then
+    begin
+    DataEvent(deCheckBrowseMode,0);
+    DoBeforeCancel;
+    UpdateCursorPos;
+    InternalCancel;
+    FreeFieldBuffers;
+    if (state = dsInsert) and (FRecordcount = 1) then
+      begin
+      FEOF := true;
+      FBOF := true;
+      FRecordcount := 0;
+      InitRecord(ActiveBuffer);
+      SetState(dsBrowse);
+      DataEvent(deDatasetChange,0);
+      end
+    else
+      begin
+      SetState(dsBrowse);
+      SetCurrentRecord(FActiverecord);
+      resync([]);
+      end;
+    DoAfterCancel;
+    end;
+end;
+
+Procedure TDataset.CheckBrowseMode;
+
+begin
+  CheckActive;
+  DataEvent(deCheckBrowseMode,0);
+  Case State of
+    dsedit,dsinsert: begin
+      UpdateRecord;
+      If Modified then Post else Cancel;
+    end;
+    dsSetKey: Post;
+  end;
+end;
+
+Procedure TDataset.ClearFields;
+
+
+begin
+  DataEvent(deCheckBrowseMode, 0);
+  FreeFieldBuffers;
+  InternalInitRecord(ActiveBuffer);
+  if State <> dsSetKey then GetCalcFields(ActiveBuffer);
+  DataEvent(deRecordChange, 0);
+end;
+
+Procedure TDataset.Close;
+
+begin
+  Active:=False;
+end;
+
+Function TDataset.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint;
+
+begin
+  Result:=0;
+end;
+
+Function TDataset.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
+
+
+begin
+  Result:=Nil;
+end;
+
+Procedure TDataset.CursorPosChanged;
+
+
+begin
+  FCurrentRecord:=-1;
+end;
+
+Procedure TDataset.Delete;
+
+begin
+  If Not CanModify then
+    DatabaseError(SDatasetReadOnly,Self);
+  If IsEmpty then
+    DatabaseError(SDatasetEmpty,Self);
+  if State in [dsInsert] then
+  begin
+    Cancel;
+  end else begin
+    DataEvent(deCheckBrowseMode,0);
+{$ifdef dsdebug}
+    writeln ('Delete: checking required fields');
+{$endif}
+    DoBeforeDelete;
+    DoBeforeScroll;
+    If Not TryDoing(@InternalDelete,OnPostError) then exit;
+{$ifdef dsdebug}
+    writeln ('Delete: Internaldelete succeeded');
+{$endif}
+    FreeFieldBuffers;
+    SetState(dsBrowse);
+{$ifdef dsdebug}
+    writeln ('Delete: Browse mode set');
+{$endif}
+    SetCurrentRecord(FActiverecord);
+    Resync([]);
+    DoAfterDelete;
+    DoAfterScroll;
+  end;
+end;
+
+Procedure TDataset.DisableControls;
+
+
+begin
+  If FDisableControlsCount=0 then
+    begin
+    { Save current state,
+      needed to detect change of state when enabling controls.
+    }
+    FDisableControlsState:=FState;
+    FEnableControlsEvent:=deDatasetChange;
+    end;
+  Inc(FDisableControlsCount);
+end;
+
+Procedure TDataset.DoInsertAppend(DoAppend : Boolean);
+
+
+  procedure DoInsert(DoAppend : Boolean);
+
+  Var BookBeforeInsert : TBookmarkStr;
+      TempBuf : pointer;
+
+  begin
+  // need to scroll up al buffers after current one,
+  // but copy current bookmark to insert buffer.
+  If FRecordcount > 0 then
+    BookBeforeInsert:=Bookmark;
+
+  if not DoAppend then
+    begin
+    if FRecordCount > 0 then
+      begin
+      TempBuf := FBuffers[FBuffercount];
+      move(FBuffers[FActiveRecord],FBuffers[FActiveRecord+1],(Fbuffercount-FActiveRecord)*sizeof(FBuffers[0]));
+      FBuffers[FActiveRecord]:=TempBuf;
+      end;
+    end
+  else if FRecordcount=FBuffercount then
+    shiftbuffersbackward
+  else
+    begin
+    if FRecordCount>0 then
+      inc(FActiveRecord);
+    end;
+
+  // Active buffer is now edit buffer. Initialize.
+  InitRecord(FBuffers[FActiveRecord]);
+  cursorposchanged;
+
+  // Put bookmark in edit buffer.
+  if FRecordCount=0 then
+    SetBookmarkFlag(ActiveBuffer,bfEOF)
+  else
+    begin
+    fBOF := false;
+    // 29:01:05, JvdS: Why is this here?!? It can result in records with the same bookmark-data?
+    // I would say that the 'internalinsert' should do this. But I don't know how Tdbf handles it
+
+    // 1-apr-06, JvdS: It just sets the bookmark of the newly inserted record to the place
+    // where the record should be inserted. So it is ok.
+    if FRecordcount > 0 then
+      SetBookMarkData(ActiveBuffer,pointer(BookBeforeInsert));
+    end;
+
+  InternalInsert;
+
+  // update buffer count.
+  If FRecordCount<FBufferCount then
+    Inc(FRecordCount);
+  end;
+
+begin
+  CheckBrowseMode;
+  If Not CanModify then
+    DatabaseError(SDatasetReadOnly,Self);
+  DoBeforeInsert;
+  DoBeforeScroll;
+  If Not DoAppend then
+    begin
+{$ifdef dsdebug}
+    Writeln ('going to insert mode');
+{$endif}
+    DoInsert(false);
+    end
+  else
+    begin
+{$ifdef dsdebug}
+    Writeln ('going to append mode');
+{$endif}
+    ClearBuffers;
+    InternalLast;
+    GetPriorRecords;
+    if FRecordCount>0 then
+      FActiveRecord:=FRecordCount-1;
+    DoInsert(True);
+    SetBookmarkFlag(ActiveBuffer,bfEOF);
+    FBOF :=False;
+    FEOF := true;
+    end;
+  SetState(dsInsert);
+  try
+    DoOnNewRecord;
+  except
+    SetCurrentRecord(FActiverecord);
+    resync([]);
+    raise;
+  end;
+  // mark as not modified.
+  FModified:=False;
+  // Final events.
+  DataEvent(deDatasetChange,0);
+  DoAfterInsert;
+  DoAfterScroll;
+{$ifdef dsdebug}
+  Writeln ('Done with append');
+{$endif}
+end;
+
+Procedure TDataset.Edit;
+
+begin
+  CheckBrowseMode;
+  If Not CanModify then
+    DatabaseError(SDatasetReadOnly,Self);
+  If State in [dsedit,dsinsert] then exit;
+  If FRecordCount = 0 then
+    begin
+    Append;
+    Exit;
+    end;
+  DoBeforeEdit;
+  If Not TryDoing(@InternalEdit,OnEditError) then exit;
+  GetCalcFields(ActiveBuffer);
+  SetState(dsedit);
+  DataEvent(deRecordChange,0);
+  DoAfterEdit;
+end;
+
+Procedure TDataset.EnableControls;
+
+
+begin
+  if FDisableControlsCount > 0 then
+    Dec(FDisableControlsCount);
+
+  if FDisableControlsCount = 0 then begin
+    if FState <> FDisableControlsState then
+      DataEvent(deUpdateState, 0);
+
+    if (FState <> dsInactive) and (FDisableControlsState <> dsInactive) then
+      DataEvent(FEnableControlsEvent, 0);
+  end;
+end;
+
+Function TDataset.FieldByName(const FieldName: string): TField;
+
+
+begin
+  Result:=FindField(FieldName);
+  If Result=Nil then
+    DatabaseErrorFmt(SFieldNotFound,[FieldName],Self);
+end;
+
+Function TDataset.FindField(const FieldName: string): TField;
+
+
+begin
+  Result:=FFieldList.FindField(FieldName);
+end;
+
+Function TDataset.FindFirst: Boolean;
+
+
+begin
+  Result:=False;
+end;
+
+Function TDataset.FindLast: Boolean;
+
+
+begin
+  Result:=False;
+end;
+
+Function TDataset.FindNext: Boolean;
+
+
+begin
+  Result:=False;
+end;
+
+Function TDataset.FindPrior: Boolean;
+
+
+begin
+  Result:=False;
+end;
+
+Procedure TDataset.First;
+
+
+begin
+  CheckBrowseMode;
+  DoBeforeScroll;
+  if not FIsUniDirectional then
+    ClearBuffers
+  else if not FBof then
+    begin
+    Active := False;
+    Active := True;
+    end;
+  try
+    InternalFirst;
+    if not FIsUniDirectional then GetNextRecords;
+  finally
+    FBOF:=True;
+    DataEvent(deDatasetChange,0);
+    DoAfterScroll;
+    end;
+end;
+
+Procedure TDataset.FreeBookmark(ABookmark: TBookmark);
+
+
+begin
+  FreeMem(ABookMark,FBookMarkSize);
+end;
+
+Function TDataset.GetBookmark: TBookmark;
+
+
+begin
+  if BookmarkAvailable then
+    begin
+    GetMem (Result,FBookMarkSize);
+    GetBookMarkdata(ActiveBuffer,Result);
+    end
+  else
+    Result:=Nil;
+end;
+
+Function TDataset.GetCurrentRecord(Buffer: PChar): Boolean;
+
+
+begin
+  Result:=False;
+end;
+
+Procedure TDataset.GetFieldList(List: TList; const FieldNames: string);
+
+  Function NextName(Var S : String) : String;
+
+  Var
+    P : integer;
+
+  begin
+    P:=Pos(';',S);
+    If (P=0) then
+      P:=Length(S)+1;
+    Result:=Copy(S,1,P-1);
+    system.Delete(S,1,P);
+  end;
+
+var
+  F: TField;
+  Names,N : String;
+
+begin
+  Names:=FieldNames;
+  N:=Nextname(Names);
+  while (N<>'') do
+    begin
+    F:=FieldByName(N);
+    If Assigned(List) then
+      List.Add(F);
+    N:=NextName(Names);
+    end;
+end;
+
+Procedure TDataset.GetFieldNames(List: TStrings);
+
+
+begin
+  FFieldList.GetFieldNames(List);
+end;
+
+Procedure TDataset.GotoBookmark(ABookmark: TBookmark);
+
+
+begin
+  If Assigned(ABookMark) then
+    begin
+    CheckBrowseMode;
+    DoBeforeScroll;
+    InternalGotoBookMark(ABookMark);
+    Resync([rmExact,rmCenter]);
+    DoAfterScroll;
+    end;
+end;
+
+Procedure TDataset.Insert;
+
+begin
+  DoInsertAppend(False);
+end;
+
+Procedure TDataset.InsertRecord(const Values: array of const);
+
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.IsEmpty: Boolean;
+
+begin
+  Result:=(fBof and fEof) and
+          (not (state = dsinsert)); // After an insert on an empty dataset, both fBof and fEof are true
+end;
+
+Function TDataset.IsLinkedTo(ADataSource: TDataSource): Boolean;
+
+begin
+//!! Not tested, I never used nested DS
+  if (ADataSource = nil) or (ADataSource.Dataset = nil) then begin
+    Result := False
+  end else if ADataSource.Dataset = Self then begin
+    Result := True;
+  end else begin
+    Result := ADataSource.Dataset.IsLinkedTo(ADataSource.Dataset.DataSource);
+  end;
+//!! DataSetField not implemented
+end;
+
+Function TDataset.IsSequenced: Boolean;
+
+begin
+  Result := True;
+end;
+
+Procedure TDataset.Last;
+
+begin
+  CheckBiDirectional;
+  CheckBrowseMode;
+  DoBeforeScroll;
+  ClearBuffers;
+  try
+    InternalLast;
+    GetPriorRecords;
+    if FRecordCount>0 then
+      FActiveRecord:=FRecordCount-1
+  finally
+    FEOF:=true;
+    DataEvent(deDataSetChange, 0);
+    DoAfterScroll;
+    end;
+end;
+
+Function TDataset.MoveBy(Distance: Longint): Longint;
+Var
+  TheResult: Integer;
+
+  Function Scrollforward : Integer;
+
+  begin
+    Result:=0;
+{$ifdef dsdebug}
+    Writeln('Scrolling forward :',Distance);
+    Writeln('Active buffer : ',FActiveRecord);
+    Writeln('RecordCount   : ',FRecordCount);
+    WriteLn('BufferCount   : ',FBufferCount);
+{$endif}
+    FBOF:=False;
+    While (Distance>0) and not FEOF do
+      begin
+      If FActiveRecord<FRecordCount-1 then
+        begin
+        Inc(FActiveRecord);
+        Dec(Distance);
+        Inc(TheResult); //Inc(Result);
+        end
+      else
+        begin
+{$ifdef dsdebug}
+       Writeln('Moveby : need next record');
+{$endif}
+        If GetNextRecord then
+          begin
+          Dec(Distance);
+          Dec(Result);
+          Inc(TheResult); //Inc(Result);
+          end
+        else
+          FEOF:=true;
+        end;
+      end
+  end;
+  Function ScrollBackward : Integer;
+
+  begin
+    CheckBiDirectional;
+    Result:=0;
+{$ifdef dsdebug}
+    Writeln('Scrolling backward:',Abs(Distance));
+    Writeln('Active buffer : ',FActiveRecord);
+    Writeln('RecordCunt    : ',FRecordCount);
+    WriteLn('BufferCount   : ',FBufferCount);
+{$endif}
+    FEOF:=False;
+    While (Distance<0) and not FBOF do
+      begin
+      If FActiveRecord>0 then
+        begin
+        Dec(FActiveRecord);
+        Inc(Distance);
+        Dec(TheResult); //Dec(Result);
+        end
+      else
+        begin
+       {$ifdef dsdebug}
+       Writeln('Moveby : need next record');
+       {$endif}
+        If GetPriorRecord then
+          begin
+          Inc(Distance);
+          Inc(Result);
+          Dec(TheResult); //Dec(Result);
+          end
+        else
+          FBOF:=true;
+        end;
+      end
+  end;
+
+Var
+  Scrolled : Integer;
+
+begin
+  CheckBrowseMode;
+  Result:=0; TheResult:=0;
+  DoBeforeScroll;
+  If (Distance = 0) or
+     ((Distance>0) and FEOF) or
+     ((Distance<0) and FBOF) then
+    exit;
+  Try
+    Scrolled := 0;
+    If Distance>0 then
+      Scrolled:=ScrollForward
+    else
+      Scrolled:=ScrollBackward;
+  finally
+{$ifdef dsdebug}
+    WriteLn('ActiveRecord=', FActiveRecord,' FEOF=',FEOF,' FBOF=',FBOF);
+{$Endif}
+    DataEvent(deDatasetScroll,Scrolled);
+    DoAfterScroll;
+    Result:=TheResult;
+  end;
+end;
+
+Procedure TDataset.Next;
+
+begin
+  MoveBy(1);
+end;
+
+Procedure TDataset.Open;
+
+begin
+  Active:=True;
+end;
+
+Procedure TDataset.Post;
+
+begin
+  if State in [dsEdit,dsInsert] then
+    begin
+    DataEvent(deUpdateRecord,0);
+    DataEvent(deCheckBrowseMode,0);
+{$ifdef dsdebug}
+    writeln ('Post: checking required fields');
+{$endif}
+    DoBeforePost;
+    If Not TryDoing(@InternalPost,OnPostError) then exit;
+    cursorposchanged;
+{$ifdef dsdebug}
+    writeln ('Post: Internalpost succeeded');
+{$endif}
+    FreeFieldBuffers;
+// First set the state to dsBrowse, then the Resync, to prevent the calling of
+// the deDatasetChange event, while the state is still 'editable', while the db isn't
+    SetState(dsBrowse);
+    Resync([]);
+{$ifdef dsdebug}
+    writeln ('Post: Browse mode set');
+{$endif}
+    DoAfterPost;
+    end
+  else
+    DatabaseErrorFmt(SNotEditing, [Name], Self);
+end;
+
+Procedure TDataset.Prior;
+
+begin
+  MoveBy(-1);
+end;
+
+Procedure TDataset.Refresh;
+
+begin
+  CheckbrowseMode;
+  DoBeforeRefresh;
+  UpdateCursorPos;
+  InternalRefresh;
+{ SetCurrentRecord is called by UpdateCursorPos already, so as long as
+  InternalRefresh doesn't do strange things this should be ok. }
+//  SetCurrentRecord(FActiverecord);
+  Resync([]);
+  DoAfterRefresh;
+end;
+
+Procedure TDataset.RegisterDataSource(ADatasource : TDataSource);
+
+begin
+  FDatasources.Add(ADataSource);
+  RecalcBufListSize;
+end;
+
+
+Procedure TDataset.Resync(Mode: TResyncMode);
+
+var i,count : integer;
+
+begin
+  // See if we can find the requested record.
+{$ifdef dsdebug}
+    Writeln ('Resync called');
+{$endif}
+  if FIsUnidirectional then Exit;
+// place the cursor of the underlying dataset to the active record
+//  SetCurrentRecord(FActiverecord);
+
+// Now look if the data on the current cursor of the underlying dataset is still available
+  If GetRecord(Fbuffers[0],gmcurrent,False)<>grOk Then
+// If that fails and rmExact is set, then raise an exception
+    If rmExact in Mode then
+      DatabaseError(SNoSuchRecord,Self)
+// else, if rmexact is not set, try to fetch the next  or prior record in the underlying dataset
+    else if (GetRecord(Fbuffers[0],gmnext,True)<>grOk) and
+            (GetRecord(Fbuffers[0],gmprior,True)<>grOk) then
+      begin
+{$ifdef dsdebug}
+      Writeln ('Resync: fuzzy resync');
+{$endif}
+      // nothing found, invalidate buffer and bail out.
+      ClearBuffers;
+      // Make sure that the active record is 'empty', ie: that all fields are null
+      InternalInitRecord(ActiveBuffer);
+      DataEvent(deDatasetChange,0);
+      exit;
+      end;
+  FCurrentRecord := 0;
+  FEOF := false;
+  FBOF := false;
+
+// If we've arrived here, FBuffer[0] is the current record
+  If (rmCenter in Mode) then
+    count := (FRecordCount div 2)
+  else
+    count := FActiveRecord;
+  i := 0;
+  FRecordcount := 1;
+  FActiveRecord := 0;
+
+// Fill the buffers before the active record
+  while (i < count) and GetPriorRecord do
+    inc(i);
+  FActiveRecord := i;
+// Fill the rest of the buffer
+  getnextrecords;
+// If the buffer is not full yet, try to fetch some more prior records
+  if FRecordcount < FBuffercount then inc(FActiverecord,getpriorrecords);
+// That's all folks!
+  DataEvent(deDatasetChange,0);
+end;
+
+Procedure TDataset.SetFields(const Values: array of const);
+
+Var I  : longint;
+begin
+  For I:=0 to high(Values) do
+    Fields[I].AssignValue(Values[I]);
+end;
+
+Function TDataset.Translate(Src, Dest: PChar; ToOem: Boolean): Integer;
+
+begin
+  strcopy(dest,src);
+  Result:=StrLen(dest);
+end;
+
+Function Tdataset.TryDoing (P : TDataOperation; Ev : TDatasetErrorEvent) : Boolean;
+
+Var Retry : TDataAction;
+
+begin
+{$ifdef dsdebug}
+  Writeln ('Trying to do');
+  If P=Nil then writeln ('Procedure to call is nil !!!');
+{$endif dsdebug}
+  Result:=True;
+  Retry:=daRetry;
+  while Retry=daRetry do
+    Try
+{$ifdef dsdebug}
+      Writeln ('Trying : updatecursorpos');
+{$endif dsdebug}
+      UpdateCursorPos;
+{$ifdef dsdebug}
+      Writeln ('Trying to do it');
+{$endif dsdebug}
+      P;
+      exit;
+    except
+      On E : EDatabaseError do
+        begin
+        retry:=daFail;
+        If Assigned(Ev) then
+          Ev(Self,E,Retry);
+        Case Retry of
+          daFail : Raise;
+          daAbort : Result:=False;
+        end;
+        end;
+    else
+      Raise;
+    end;
+{$ifdef dsdebug}
+  Writeln ('Exit Trying to do');
+{$endif dsdebug}
+end;
+
+Procedure TDataset.UpdateCursorPos;
+
+begin
+  If FRecordCount>0 then
+    SetCurrentRecord(FactiveRecord);
+end;
+
+Procedure TDataset.UpdateRecord;
+
+begin
+  if not (State in dsEditModes) then
+    DatabaseErrorFmt(SNotEditing, [Name], Self);
+  DataEvent(deUpdateRecord, 0);
+end;
+
+Function TDataSet.UpdateStatus: TUpdateStatus;
+
+begin
+  Result:=usUnmodified;
+end;
+
+Procedure TDataset.RemoveField (Field : TField);
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.Getfieldcount : Longint;
+
+begin
+  Result:=FFieldList.Count;
+end;
+
+Procedure TDataset.ShiftBuffersBackward;
+
+var TempBuf : pointer;
+
+begin
+  TempBuf := FBuffers[0];
+  move(FBuffers[1],FBuffers[0],(fbuffercount)*sizeof(FBuffers[0]));
+  FBuffers[buffercount]:=TempBuf;
+end;
+
+Procedure TDataset.ShiftBuffersForward;
+
+var TempBuf : pointer;
+
+begin
+  TempBuf := FBuffers[FBufferCount];
+  move(FBuffers[0],FBuffers[1],(fbuffercount)*sizeof(FBuffers[0]));
+  FBuffers[0]:=TempBuf;
+end;
+
+function TDataset.GetFieldValues(Fieldname: string): Variant;
+
+var i: Integer;
+    FieldList: TList;
+begin
+  if Pos(';', FieldName) <> 0 then begin
+    FieldList := TList.Create;
+    try
+      GetFieldList(FieldList, FieldName);
+      Result := VarArrayCreate([0, FieldList.Count - 1], varVariant);
+      for i := 0 to FieldList.Count - 1 do
+        Result[i] := TField(FieldList[i]).Value;
+    finally
+      FieldList.Free;
+    end;
+  end else
+    Result := FieldByName(FieldName).Value
+end;
+
+procedure TDataset.SetFieldValues(Fieldname: string; Value: Variant);
+
+var
+  i : Integer;
+  FieldList: TList;
+begin
+  if Pos(';', FieldName) <> 0 then begin
+    FieldList := TList.Create;
+    try
+      GetFieldList(FieldList, FieldName);
+      for i := 0 to FieldList.Count -1 do
+        TField(FieldList[i]).Value := Value[i];
+    finally
+      FieldList.Free;
+    end;
+  end else
+    FieldByName(Fieldname).Value := Value;
+end;
+
+Function TDataset.Locate(const keyfields: string; const keyvalues: Variant; options: TLocateOptions) : boolean;
+
+begin
+  CheckBiDirectional;
+  Result := False;
+end;
+
+Function TDataset.Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant;
+
+begin
+  Result := False;
+end;
+
+
+Procedure TDataset.UnRegisterDataSource(ADatasource : TDatasource);
+
+begin
+  FDataSources.Remove(ADataSource);
+end;
+

packages/fcl-db/src/base/datasource.inc

@@ -0,0 +1,662 @@
+{ ---------------------------------------------------------------------
+    TDatalink
+  ---------------------------------------------------------------------}
+
+Constructor TDataLink.Create;
+
+begin
+  Inherited Create;
+  FBufferCount:=1;
+  FFirstRecord := 0;
+  FDataSource := nil;
+  FDatasourceFixed:=False;
+end;
+
+
+Destructor TDataLink.Destroy;
+
+begin
+  Factive:=False;
+  FEditing:=False;
+  FDataSourceFixed:=False;
+  DataSource:=Nil;
+  Inherited Destroy;
+end;
+
+
+Procedure TDataLink.ActiveChanged;
+
+begin
+  FFirstRecord := 0;
+end;
+
+Procedure TDataLink.CheckActiveAndEditing;
+
+Var
+  B : Boolean;
+
+begin
+  B:=Assigned(DataSource) and (DataSource.State<>dsInactive);
+  If B<>FActive then
+    begin
+    FActive:=B;
+    ActiveChanged;
+    end;
+  B:=Assigned(DataSource) and (DataSource.State in dsEditModes) and Not FReadOnly;
+  If B<>FEditing Then
+    begin
+    FEditing:=B;
+    EditingChanged;
+    end;
+end;
+
+
+Procedure TDataLink.CheckBrowseMode;
+
+begin
+end;
+
+
+Function TDataLink.CalcFirstRecord(Index : Integer) : Integer;
+begin
+  if DataSource.DataSet.FActiveRecord > FFirstRecord + Index + FBufferCount - 1 then
+    Result := DataSource.DataSet.FActiveRecord - (FFirstRecord + Index + FBufferCount - 1)
+  else if DataSource.DataSet.FActiveRecord < FFirstRecord + Index then
+    Result := DataSource.DataSet.FActiveRecord - (FFirstRecord + Index)
+  else Result := 0;
+  
+  Inc(FFirstRecord, Index + Result);
+end;
+
+
+Procedure TDataLink.CalcRange;
+var
+    aMax, aMin: integer;
+begin
+  aMin:= DataSet.FActiveRecord - FBufferCount + 1;
+  If aMin < 0 Then aMin:= 0;
+  aMax:= Dataset.FBufferCount - FBufferCount;
+  If aMax < 0 then aMax:= 0;
+
+  If aMax>DataSet.FActiveRecord Then aMax:=DataSet.FActiveRecord;
+
+  If FFirstRecord < aMin Then FFirstRecord:= aMin;
+  If FFirstrecord > aMax Then FFirstRecord:= aMax;
+
+  If (FfirstRecord<>0) And
+     (DataSet.FActiveRecord - FFirstRecord < FBufferCount -1) Then
+    Dec(FFirstRecord, 1);
+
+end;
+
+
+Procedure TDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
+
+
+begin
+  Case Event of
+    deFieldChange, deRecordChange:
+      If Not FUpdatingRecord then
+        RecordChanged(TField(Info));
+    deDataSetChange: begin
+      SetActive(DataSource.DataSet.Active);
+      CalcRange;
+      CalcFirstRecord(Info);
+      DatasetChanged;
+    end;
+    deDataSetScroll: DatasetScrolled(CalcFirstRecord(Info));
+    deLayoutChange: begin
+      CalcFirstRecord(Info);
+      LayoutChanged;
+    end;
+    deUpdateRecord: UpdateRecord;
+    deUpdateState: CheckActiveAndEditing;
+    deCheckBrowseMode: CheckBrowseMode;
+    deFocusControl: FocusControl(TFieldRef(Info));
+  end;
+end;
+
+
+Procedure TDataLink.DataSetChanged;
+
+begin
+  RecordChanged(Nil);
+end;
+
+
+Procedure TDataLink.DataSetScrolled(Distance: Integer);
+
+begin
+  DataSetChanged;
+end;
+
+
+Procedure TDataLink.EditingChanged;
+
+begin
+end;
+
+
+Procedure TDataLink.FocusControl(Field: TFieldRef);
+
+begin
+end;
+
+
+Function TDataLink.GetActiveRecord: Integer;
+
+begin
+  Result:=Dataset.FActiveRecord - FFirstRecord;
+end;
+
+Function TDatalink.GetDataSet : TDataset;
+
+begin
+  If Assigned(Datasource) then
+    Result:=DataSource.DataSet
+  else
+    Result:=Nil;  
+end;
+
+
+Function TDataLink.GetBOF: Boolean;
+
+begin
+  Result:=DataSet.BOF
+end;
+
+
+Function TDataLink.GetBufferCount: Integer;
+
+begin
+  Result:=FBufferCount;
+end;
+
+
+Function TDataLink.GetEOF: Boolean;
+
+begin
+  Result:=DataSet.EOF
+end;
+
+
+Function TDataLink.GetRecordCount: Integer;
+
+begin
+  Result:=Dataset.FRecordCount;
+  If Result>BufferCount then
+    Result:=BufferCount;
+end;
+
+
+Procedure TDataLink.LayoutChanged;
+
+begin
+  DataSetChanged;
+end;
+
+
+Function TDataLink.MoveBy(Distance: Integer): Integer;
+
+begin
+  Result:=DataSet.MoveBy(Distance);
+end;
+
+
+Procedure TDataLink.RecordChanged(Field: TField);
+
+begin
+end;
+
+
+Procedure TDataLink.SetActiveRecord(Value: Integer);
+
+begin
+{$ifdef dsdebug}
+  Writeln('Datalink. Setting active record to ',Value,' with firstrecord ',ffirstrecord);
+{$endif}
+  Dataset.FActiveRecord:=Value + FFirstRecord;
+end;
+
+
+Procedure TDataLink.SetBufferCount(Value: Integer);
+
+begin
+  If FBufferCount<>Value then
+    begin
+      FBufferCount:=Value;
+      if Active then begin
+        DataSet.RecalcBufListSize;
+        CalcRange;
+      end;
+    end;
+end;
+
+procedure TDataLink.SetActive(AActive: Boolean);
+begin
+  if Active <> AActive then
+  begin
+    FActive := AActive;
+    // !!!: Set internal state
+    ActiveChanged;
+  end;
+end;
+
+Procedure TDataLink.SetDataSource(Value : TDatasource);
+
+begin
+  if not FDataSourceFixed then
+    begin
+    if Assigned(DataSource) then
+      Begin
+      DataSource.UnregisterDatalink(Self);
+      FDataSource := nil;
+      CheckActiveAndEditing;
+      End;
+    FDataSource := Value;
+    if Assigned(DataSource) then
+      begin
+      DataSource.RegisterDatalink(Self);
+      CheckActiveAndEditing;
+      End;
+    end;
+end;
+
+Procedure TDatalink.SetReadOnly(Value : Boolean);
+
+begin
+  If FReadOnly<>Value then
+    begin
+    FReadOnly:=Value;
+    CheckActiveAndEditing;
+    end;
+end;
+
+Procedure TDataLink.UpdateData;
+
+begin
+end;
+
+
+
+Function TDataLink.Edit: Boolean;
+
+begin
+  If Not FReadOnly then
+    DataSource.Edit;
+  // Triggered event will set FEditing
+  Result:=FEditing;
+end;
+
+
+Procedure TDataLink.UpdateRecord;
+
+begin
+  FUpdatingRecord:=True;
+  Try
+    UpdateData;
+  finally
+    FUpdatingRecord:=False;
+  end;
+end;
+
+
+
+{ ---------------------------------------------------------------------
+    TDetailDataLink
+  ---------------------------------------------------------------------}
+
+Function TDetailDataLink.GetDetailDataSet: TDataSet;
+
+begin
+  Result := nil;
+end;
+
+
+{ ---------------------------------------------------------------------
+    TMasterDataLink
+  ---------------------------------------------------------------------}
+
+constructor TMasterDataLink.Create(ADataSet: TDataSet);
+
+begin
+  inherited Create;
+  FDetailDataSet:=ADataSet;
+  FFields:=TList.Create;
+end;
+
+
+destructor TMasterDataLink.Destroy;
+
+begin
+  FFields.Free;
+  inherited Destroy;
+end;
+
+
+Procedure TMasterDataLink.ActiveChanged;
+
+begin
+  FFields.Clear;
+  if Active then
+  try
+    DataSet.GetFieldList(FFields, FFieldNames);
+  except
+    FFields.Clear;
+    raise;
+  end;
+  if FDetailDataSet.Active and not (csDestroying in FDetailDataSet.ComponentState) then
+    if Active and (FFields.Count > 0) then
+      DoMasterChange
+    else
+      DoMasterDisable;  
+end;
+
+
+Procedure TMasterDataLink.CheckBrowseMode;
+
+begin
+  if FDetailDataSet.Active then FDetailDataSet.CheckBrowseMode;
+end;
+
+
+Function TMasterDataLink.GetDetailDataSet: TDataSet;
+
+begin
+  Result := FDetailDataSet;
+end;
+
+
+Procedure TMasterDataLink.LayoutChanged;
+
+begin
+  ActiveChanged;
+end;
+
+
+Procedure TMasterDataLink.RecordChanged(Field: TField);
+
+begin
+  if (DataSource.State <> dsSetKey) and FDetailDataSet.Active and
+     (FFields.Count > 0) and ((Field = nil) or
+     (FFields.IndexOf(Field) >= 0)) then
+    DoMasterChange;  
+end;
+
+procedure TMasterDatalink.SetFieldNames(const Value: string);
+
+begin
+  if FFieldNames <> Value then
+    begin
+    FFieldNames := Value;
+    ActiveChanged;
+    end;
+end;
+
+Procedure TMasterDataLink.DoMasterDisable; 
+
+begin
+  if Assigned(FOnMasterDisable) then 
+    FOnMasterDisable(Self);
+end;
+
+Procedure TMasterDataLink.DoMasterChange; 
+
+begin
+  If Assigned(FOnMasterChange) then
+    FOnMasterChange(Self);
+end;
+
+{ ---------------------------------------------------------------------
+    TMasterDataLink
+  ---------------------------------------------------------------------}
+
+constructor TMasterParamsDataLink.Create(ADataSet: TDataSet);
+
+Var
+  P : TParams;
+
+begin
+  inherited Create(ADataset);
+  If (ADataset<>Nil) then
+    begin
+    P:=TParams(GetObjectProp(ADataset,'Params',TParams));
+    if (P<>Nil) then
+      Params:=P;
+    end;  
+end;
+
+
+Procedure TMasterParamsDataLink.SetParams(AVAlue : TParams);  
+
+begin
+  FParams:=AValue;
+  If (AValue<>Nil) then
+    RefreshParamNames;
+end;
+
+Procedure TMasterParamsDataLink.RefreshParamNames; 
+
+Var
+  FN : String;
+  DS : TDataset;
+  F  : TField;
+  I : Integer;
+
+begin
+  FN:='';
+  DS:=Dataset;
+  If Assigned(FParams) then
+    begin
+    F:=Nil;
+    For I:=0 to FParams.Count-1 do
+      begin
+      If Assigned(DS) then
+        F:=DS.FindField(FParams[i].Name);
+      If (Not Assigned(DS)) or (F<>Nil) then
+        begin
+        If (FN<>'') then
+          FN:=FN+';';
+        FN:=FN+FParams[i].Name; 
+        end;
+      end;
+    end;
+  FieldNames:=FN;  
+end;
+
+Procedure TMasterParamsDataLink.CopyParamsFromMaster(CopyBound : Boolean);
+
+begin
+  if Assigned(FParams) then
+    FParams.CopyParamValuesFromDataset(Dataset,CopyBound);
+end;
+
+Procedure TMasterParamsDataLink.DoMasterDisable; 
+
+begin
+  Inherited;
+  If Assigned(DetailDataset) and DetailDataset.Active then
+    DetailDataset.Close;
+end;
+
+Procedure TMasterParamsDataLink.DoMasterChange; 
+
+begin
+  Inherited;
+  if Assigned(Params) and Assigned(DetailDataset) and DetailDataset.Active then
+    begin
+    DetailDataSet.CheckBrowseMode;
+    DetailDataset.Close;
+    DetailDataset.Open;
+    end;
+end;
+
+{ ---------------------------------------------------------------------
+    TDatasource
+  ---------------------------------------------------------------------}
+
+Constructor TDataSource.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  FDatalinks := TList.Create;
+  FEnabled := True;
+  FAutoEdit := True;
+end;
+
+
+Destructor TDataSource.Destroy;
+
+begin
+  FOnStateCHange:=Nil;
+  Dataset:=Nil;
+  With FDataLinks do
+    While Count>0 do
+      TDatalink(Items[Count - 1]).DataSource:=Nil;
+  FDatalinks.Free;
+  inherited Destroy;
+end;
+
+
+Procedure TDatasource.Edit;
+
+begin
+  If (State=dsBrowse) and AutoEdit Then
+    Dataset.Edit;
+end;
+
+
+Function TDataSource.IsLinkedTo(ADataSet: TDataSet): Boolean;
+
+begin
+  Result:=False;
+end;
+
+
+procedure TDatasource.DistributeEvent(Event: TDataEvent; Info: Ptrint);
+
+
+Var
+  i : Longint;
+
+begin
+  With FDatalinks do
+    begin
+    For I:=0 to Count-1 do
+      With TDatalink(Items[i]) do
+        If Not VisualControl Then
+          DataEvent(Event,Info);
+    For I:=0 to Count-1 do
+      With TDatalink(Items[i]) do
+        If VisualControl Then
+          DataEvent(Event,Info);
+    end;
+end;
+
+procedure TDatasource.RegisterDataLink(DataLink: TDataLink);
+
+begin
+  FDatalinks.Add(DataLink);
+  if Assigned(DataSet) then
+    DataSet.RecalcBufListSize;
+end;
+
+
+procedure TDatasource.SetDataSet(ADataSet: TDataSet);
+begin
+  If FDataset<>Nil Then
+    Begin
+    FDataset.UnRegisterDataSource(Self);
+    FDataSet:=nil;
+    ProcessEvent(deUpdateState,0);
+    End;
+  If ADataset<>Nil Then
+    begin
+    ADataset.RegisterDatasource(Self);
+    FDataSet:=ADataset;
+    ProcessEvent(deUpdateState,0);
+    End;
+end;
+
+
+procedure TDatasource.SetEnabled(Value: Boolean);
+
+begin
+  FEnabled:=Value;
+end;
+
+
+Procedure TDatasource.DoDataChange (Info : Pointer);
+
+begin
+  If Assigned(OnDataChange) Then
+    OnDataChange(Self,TField(Info));
+end;
+
+Procedure TDatasource.DoStateChange;
+
+begin
+  If Assigned(OnStateChange) Then
+    OnStateChange(Self);
+end;
+
+
+Procedure TDatasource.DoUpdateData;
+
+begin
+  If Assigned(OnUpdateData) Then
+    OnUpdateData(Self);
+end;
+
+
+procedure TDatasource.UnregisterDataLink(DataLink: TDataLink);
+
+begin
+  FDatalinks.Remove(Datalink);
+  If Dataset<>Nil then
+    DataSet.RecalcBufListSize;
+  //Dataset.SetBufListSize(DataLink.BufferCount);
+end;
+
+
+procedure TDataSource.ProcessEvent(Event : TDataEvent; Info : Ptrint);
+
+Const
+    OnDataChangeEvents = [deRecordChange, deDataSetChange, deDataSetScroll,
+                          deLayoutChange,deUpdateState];
+
+Var
+  NeedDataChange : Boolean;
+  FLastState : TdataSetState;
+
+begin
+  // Special UpdateState handling.
+  If Event=deUpdateState then
+    begin
+    NeedDataChange:=(FState=dsInactive);
+    FLastState:=FState;
+    If Assigned(Dataset) then
+      FState:=Dataset.State
+    else
+      FState:=dsInactive;
+    // Don't do events if nothing changed.
+    If FState=FlastState then
+      exit;
+    end
+  else
+    NeedDataChange:=True;
+  DistributeEvent(Event,Info);
+  // Extra handlers
+  If Not (csDestroying in ComponentState) then
+    begin
+    If (Event=deUpdateState) then
+      DoStateChange;
+    If (Event in OnDataChangeEvents) and
+       NeedDataChange Then
+      DoDataChange(Nil);
+    If (Event = deFieldChange) Then
+      DoDataCHange(Pointer(Info));
+    If (Event=deUpdateRecord) then
+      DoUpdateData;
+    end;
+ end;

packages/fcl-db/src/base/fields.inc

@@ -0,0 +1,2903 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Michael Van Canneyt, member of the
+    Free Pascal development team
+
+    TFields and related components implementations.
+
+    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 DumpMem (P : Pointer;Size : Longint);
+
+Var i : longint;
+
+begin
+  Write ('Memory dump : ');
+  For I:=0 to Size-1 do
+    Write (Pbyte(P)[i],' ');
+  Writeln;
+end;}
+
+{ ---------------------------------------------------------------------
+    TFieldDef
+  ---------------------------------------------------------------------}
+
+Constructor TFieldDef.Create(ACollection : TCollection);
+
+begin
+  Inherited create(ACollection);
+  FFieldNo:=Index+1;
+end;
+
+Constructor TFieldDef.Create(AOwner: TFieldDefs; const AName: string;
+      ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo: Longint);
+
+begin
+{$ifdef dsdebug }
+  Writeln('TFieldDef.Create : ',Aname,'(',AFieldNo,')');
+{$endif}
+  Name:=Aname;
+  Inherited Create(AOwner);
+  FDatatype:=ADatatype;
+  FSize:=ASize;
+  FRequired:=ARequired;
+  FPrecision:=-1;
+  FFieldNo:=AFieldNo;
+end;
+
+Destructor TFieldDef.Destroy;
+
+begin
+  Inherited destroy;
+end;
+
+procedure TFieldDef.Assign(APersistent: TPersistent);
+var fd: TFieldDef;
+begin
+  fd := nil;
+  if APersistent is TFieldDef then
+    fd := APersistent as TFieldDef;
+  if Assigned(fd) then begin
+    Collection.BeginUpdate;
+    try
+      Name := fd.Name;
+      DataType := fd.DataType;
+      Size := fd.Size;
+      Precision := fd.Precision;
+      FRequired := fd.Required;
+    finally
+      Collection.EndUpdate;
+    end;
+  end else
+  inherited Assign(APersistent);
+end;
+
+Function TFieldDef.CreateField(AOwner: TComponent): TField;
+
+Var TheField : TFieldClass;
+
+begin
+{$ifdef dsdebug}
+  Writeln ('Creating field '+FNAME);
+{$endif dsdebug}
+  TheField:=GetFieldClass;
+  if TheField=Nil then
+    DatabaseErrorFmt(SUnknownFieldType,[FName]);
+  Result:=Thefield.Create(AOwner);
+  Try
+    Result.Size:=FSize;
+    Result.Required:=FRequired;
+    Result.FFieldName:=FName;
+    Result.FDisplayLabel:=DisplayName;
+    Result.FFieldNo:=Self.FieldNo;
+    Result.SetFieldType(DataType);
+    Result.FReadOnly:= (faReadOnly in Attributes);
+{$ifdef dsdebug}
+    Writeln ('TFieldDef.CReateField : Trying to set dataset');
+{$endif dsdebug}
+{$ifdef dsdebug}
+    Writeln ('TFieldDef.CReateField : Result Fieldno : ',Result.FieldNo,' Self : ',FieldNo);
+{$endif dsdebug}
+    Result.Dataset:=TFieldDefs(Collection).Dataset;
+    If Result is TFloatField then
+      TFloatField(Result).Precision:=FPrecision;
+  except
+    Result.Free;
+    Raise;
+  end;
+
+end;
+
+procedure TFieldDef.SetAttributes(AValue: TFieldAttributes);
+begin
+  FAttributes := AValue;
+  Changed(False);
+end;
+
+procedure TFieldDef.SetDataType(AValue: TFieldType);
+begin
+  FDataType := AValue;
+  Changed(False);
+end;
+
+procedure TFieldDef.SetPrecision(const AValue: Longint);
+begin
+  FPrecision := AValue;
+  Changed(False);
+end;
+
+procedure TFieldDef.SetSize(const AValue: Word);
+begin
+  FSize := AValue;
+  Changed(False);
+end;
+
+procedure TFieldDef.SetRequired(const AValue: Boolean);
+begin
+  FRequired := AValue;
+  Changed(False);
+end;
+
+Function TFieldDef.GetFieldClass : TFieldClass;
+
+begin
+  //!! Should be owner as tdataset but that doesn't work ??
+
+  If Assigned(Collection) And
+     (Collection is TFieldDefs) And
+     Assigned(TFieldDefs(Collection).Dataset) then
+    Result:=TFieldDefs(Collection).Dataset.GetFieldClass(FDataType)
+  else
+    Result:=Nil;
+end;
+
+{ ---------------------------------------------------------------------
+    TFieldDefs
+  ---------------------------------------------------------------------}
+
+{
+destructor TFieldDefs.Destroy;
+
+begin
+  FItems.Free;
+  // This will destroy all fielddefs since we own them...
+  Inherited Destroy;
+end;
+}
+
+procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType);
+
+begin
+  Add(AName,ADatatype,0,False);
+end;
+
+procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize : Word);
+
+begin
+  Add(AName,ADatatype,ASize,False);
+end;
+
+procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word;
+  ARequired: Boolean);
+
+begin
+  If Length(AName)=0 Then
+    DatabaseError(SNeedFieldName);
+  // the fielddef will register itself here as a owned component.
+  // fieldno is 1 based !
+  BeginUpdate;
+  try
+    TFieldDef.Create(Self,AName,ADataType,ASize,Arequired,Count+1);
+  finally
+    EndUpdate;
+  end;
+end;
+
+function TFieldDefs.GetItem(Index: Longint): TFieldDef;
+
+begin
+  Result := TFieldDef(inherited Items[Index]);
+end;
+
+procedure TFieldDefs.SetItem(Index: Longint; const AValue: TFieldDef);
+begin
+  inherited Items[Index] := AValue;
+end;
+
+constructor TFieldDefs.Create(ADataset: TDataset);
+begin
+  Inherited Create(ADataset, Owner, TFieldDef);
+end;
+
+procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
+
+Var I : longint;
+
+begin
+  Clear;
+  For i:=0 to FieldDefs.Count-1 do
+    With FieldDefs[i] do
+      Add(Name,DataType,Size,Required);
+end;
+
+function TFieldDefs.Find(const AName: string): TFieldDef;
+begin
+  Result := (Inherited Find(AName)) as TFieldDef;
+  if Result=nil then DatabaseErrorFmt(SFieldNotFound,[AName],FDataset);
+end;
+
+{
+procedure TFieldDefs.Clear;
+
+Var I : longint;
+
+begin
+  For I:=FItems.Count-1 downto 0 do
+    TFieldDef(Fitems[i]).Free;
+  FItems.Clear;
+end;
+}
+
+procedure TFieldDefs.Update;
+
+begin
+  if not Updated then
+    begin
+    If Assigned(Dataset) then
+      DataSet.InitFieldDefs;
+    Updated := True;
+    end;
+end;
+
+Function TFieldDefs.AddFieldDef : TFieldDef;
+
+begin
+  Result:=TFieldDef.Create(Self,'',ftUnknown,0,False,Count+1);
+end;
+
+{ ---------------------------------------------------------------------
+    TField
+  ---------------------------------------------------------------------}
+
+Const
+  SBoolean = 'Boolean';
+  SDateTime = 'TDateTime';
+  SFloat = 'Float';
+  SInteger = 'Integer';
+  SLargeInt = 'LargeInt';
+  SVariant = 'Variant';
+  SString = 'String';
+
+constructor TField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  FVisible:=True;
+  FValidChars:=[#0..#255];
+
+  FProviderFlags := [pfInUpdate,pfInWhere];
+end;
+
+destructor TField.Destroy;
+
+begin
+  IF Assigned(FDataSet) then
+    begin
+    FDataSet.Active:=False;
+    if Assigned(FFields) then
+      FFields.Remove(Self);
+    end;
+  FLookupList.Free;
+  Inherited Destroy;
+end;
+
+function TField.AccessError(const TypeName: string): EDatabaseError;
+
+begin
+  Result:=EDatabaseError.CreateFmt(SinvalidTypeConversion,[TypeName,FFieldName]);
+end;
+
+procedure TField.Assign(Source: TPersistent);
+
+begin
+  if Source = nil then Clear
+  else if Source is TField then begin
+    Value := TField(Source).Value;
+  end else
+    inherited Assign(Source);
+end;
+
+procedure TField.AssignValue(const AValue: TVarRec);
+  procedure Error;
+  begin
+    DatabaseErrorFmt(SFieldValueError, [DisplayName]);
+  end;
+
+begin
+  with AValue do
+    case VType of
+      vtInteger:
+        AsInteger := VInteger;
+      vtBoolean:
+        AsBoolean := VBoolean;
+      vtChar:
+        AsString := VChar;
+      vtExtended:
+        AsFloat := VExtended^;
+      vtString:
+        AsString := VString^;
+      vtPointer:
+        if VPointer <> nil then Error;
+      vtPChar:
+        AsString := VPChar;
+      vtObject:
+        if (VObject = nil) or (VObject is TPersistent) then
+          Assign(TPersistent(VObject))
+        else
+          Error;
+      vtAnsiString:
+        AsString := string(VAnsiString);
+      vtCurrency:
+        AsCurrency := VCurrency^;
+      vtVariant:
+        if not VarIsClear(VVariant^) then Self.Value := VVariant^;
+      vtWideString:
+        AsWideString := WideString(VWideString);
+      vtInt64:
+        Self.Value := VInt64^;
+    else
+      Error;
+    end;
+end;
+
+procedure TField.Change;
+
+begin
+  If Assigned(FOnChange) Then
+    FOnChange(Self);
+end;
+
+procedure TField.CheckInactive;
+
+begin
+  If Assigned(FDataSet) then
+    FDataset.CheckInactive;
+end;
+
+procedure TField.Clear;
+
+begin
+  if FieldKind in [fkData, fkInternalCalc] then
+    SetData(Nil);
+end;
+
+procedure TField.DataChanged;
+
+begin
+  FDataset.DataEvent(deFieldChange,ptrint(Self));
+end;
+
+procedure TField.FocusControl;
+var
+  Field1: TField;
+begin
+  Field1 := Self;
+  FDataSet.DataEvent(deFocusControl,ptrint(@Field1));
+end;
+
+procedure TField.FreeBuffers;
+
+begin
+  // Empty. Provided for backward compatibiliy;
+  // TDataset manages the buffers.
+end;
+
+function TField.GetAsBoolean: Boolean;
+
+begin
+  raise AccessError(SBoolean);
+end;
+
+function TField.GetAsDateTime: TDateTime;
+
+begin
+  raise AccessError(SdateTime);
+end;
+
+function TField.GetAsFloat: Double;
+
+begin
+  raise AccessError(SDateTime);
+end;
+
+function TField.GetAsLongint: Longint;
+
+begin
+  raise AccessError(SInteger);
+end;
+
+function TField.GetAsVariant: Variant;
+
+begin
+  raise AccessError(SVariant);
+end;
+
+
+function TField.GetAsInteger: Integer;
+
+begin
+  Result:=GetAsLongint;
+end;
+
+function TField.GetAsString: string;
+
+begin
+  Result := GetClassDesc;
+end;
+
+function TField.GetAsWideString: WideString;
+begin
+  Result := GetAsString;
+end;
+
+function TField.GetOldValue: Variant;
+
+var SaveState : TDatasetState;
+
+begin
+  SaveState := FDataset.State;
+  try
+    FDataset.SetTempState(dsOldValue);
+    Result := GetAsVariant;
+  finally
+    FDataset.RestoreState(SaveState);
+  end;
+end;
+
+function TField.GetNewValue: Variant;
+
+var SaveState : TDatasetState;
+
+begin
+  SaveState := FDataset.State;
+  try
+    FDataset.SetTempState(dsNewValue);
+    Result := GetAsVariant;
+  finally
+    FDataset.RestoreState(SaveState);
+  end;
+end;
+
+procedure TField.SetNewValue(const AValue: Variant);
+
+var SaveState : TDatasetState;
+
+begin
+  SaveState := FDataset.State;
+  try
+    FDataset.SetTempState(dsNewValue);
+    SetAsVariant(AValue);
+  finally
+    FDataset.RestoreState(SaveState);
+  end;
+end;
+
+function TField.GetCurValue: Variant;
+
+var SaveState : TDatasetState;
+
+begin
+  SaveState := FDataset.State;
+  try
+    FDataset.SetTempState(dsCurValue);
+    Result := GetAsVariant;
+  finally
+    FDataset.RestoreState(SaveState);
+  end;
+end;
+
+function TField.GetCanModify: Boolean;
+
+begin
+  Result:=Not ReadOnly;
+  If Result then
+    begin
+    Result:=Assigned(DataSet);
+    If Result then
+      Result:= DataSet.CanModify;
+    end;
+end;
+
+function TField.GetClassDesc: String;
+var ClassN : string;
+begin
+  ClassN := copy(ClassName,2,pos('Field',ClassName)-2);
+  if isNull then
+    result := '(' + LowerCase(ClassN) + ')'
+   else
+    result := '(' + UpperCase(ClassN) + ')';
+end;
+
+function TField.GetData(Buffer: Pointer): Boolean;
+
+begin
+  Result:=GetData(Buffer,True);
+end;
+
+function TField.GetData(Buffer: Pointer; NativeFormat : Boolean): Boolean;
+
+begin
+  IF FDataset=Nil then
+    DatabaseErrorFmt(SNoDataset,[FieldName]);
+  If FVAlidating then
+    begin
+    result:=Not(FValueBuffer=Nil);
+    If Result then
+      Move (FValueBuffer^,Buffer^ ,DataSize);
+    end
+  else
+    Result:=FDataset.GetFieldData(Self,Buffer,NativeFormat);
+end;
+
+function TField.GetDataSize: Word;
+
+begin
+  Result:=0;
+end;
+
+function TField.GetDefaultWidth: Longint;
+
+begin
+  Result:=10;
+end;
+
+function TField.GetDisplayName  : String;
+
+begin
+  If FDisplayLabel<>'' then
+    result:=FDisplayLabel
+  else
+    Result:=FFieldName;
+end;
+
+Function TField.IsDisplayStored : Boolean;
+
+begin
+  Result:=(DisplayLabel<>FieldName);
+end;
+
+function TField.GetLookupList: TLookupList;
+begin
+  if not Assigned(FLookupList) then
+    FLookupList := TLookupList.Create;
+  Result := FLookupList;
+end;
+
+procedure TField.CalcLookupValue;
+begin
+  if FLookupCache then
+    Value := LookupList.ValueOfKey(FDataSet.FieldValues[FKeyFields])
+  else if Assigned(FLookupDataSet) and FDataSet.Active then
+    Value := FLookupDataSet.Lookup(FLookupKeyfields, FDataSet.FieldValues[FKeyFields], FLookupresultField);
+end;
+
+function TField.getIndex : longint;
+
+begin
+  If Assigned(FDataset) then
+    Result:=FDataset.FFieldList.IndexOf(Self)
+  else
+    Result:=-1;
+end;
+
+function TField.GetAsLargeInt: LargeInt;
+begin
+  Raise AccessError(SLargeInt);
+end;
+
+function TField.GetAsCurrency: Currency;
+begin
+  Result := GetAsFloat;
+end;
+
+procedure TField.SetAlignment(const AValue: TAlignMent);
+begin
+  if FAlignment <> AValue then
+    begin
+    FAlignment := Avalue;
+    PropertyChanged(false);
+    end;
+end;
+
+procedure TField.SetIndex(const AValue: Integer);
+begin
+  if FFields <> nil then FFields.SetFieldIndex(Self, AValue)
+end;
+
+procedure TField.SetAsCurrency(AValue: Currency);
+begin
+  SetAsFloat(AValue);
+end;
+
+function TField.GetIsNull: Boolean;
+
+begin
+  Result:=Not(GetData (Nil));
+end;
+
+function TField.GetParentComponent: TComponent;
+
+begin
+  Result := DataSet;
+end;
+
+procedure TField.GetText(var AText: string; ADisplayText: Boolean);
+
+begin
+  AText:=GetAsString;
+end;
+
+function TField.HasParent: Boolean;
+
+begin
+  HasParent:=True;
+end;
+
+function TField.IsValidChar(InputChar: Char): Boolean;
+
+begin
+  // FValidChars must be set in Create.
+  Result:=InputChar in FValidChars;
+end;
+
+procedure TField.RefreshLookupList;
+var
+  tmpActive: Boolean;
+begin
+  if not Assigned(FLookupDataSet) or (Length(FLookupKeyfields) = 0)
+  or (Length(FLookupresultField) = 0) or (Length(FKeyFields) = 0) then
+    Exit;
+    
+  tmpActive := FLookupDataSet.Active;
+  try
+    FLookupDataSet.Active := True;
+    FFields.CheckFieldNames(FLookupKeyfields);
+    FLookupDataset.FieldByName(FLookupresultField); // I presume that if it doesn't exist it throws exception, and that a field with null value is still valid
+    LookupList.Clear; // have to be F-less because we might be creating it here with getter!
+
+    FLookupDataSet.DisableControls;
+    try
+      FLookupDataSet.Open;
+      repeat
+        FLookupList.Add(FLookupDataSet.FieldValues[FLookupKeyfields], FLookupDataSet.FieldValues[FLookupResultField]);
+        FLookupDataSet.Next;
+      until FLookupDataSet.EOF;
+    finally
+      FLookupDataSet.EnableControls;
+    end;
+  finally
+    FLookupDataSet.Active := tmpActive;
+  end;
+end;
+
+procedure TField.Notification(AComponent: TComponent; Operation: TOperation);
+
+begin
+  Inherited Notification(AComponent,Operation);
+  if (Operation = opRemove) and (AComponent = FLookupDataSet) then
+    FLookupDataSet := nil;
+end;
+
+procedure TField.PropertyChanged(LayoutAffected: Boolean);
+
+begin
+  If (FDataset<>Nil) and (FDataset.Active) then
+    If LayoutAffected then
+      FDataset.DataEvent(deLayoutChange,0)
+    else
+      FDataset.DataEvent(deDatasetchange,0);
+end;
+
+procedure TField.ReadState(Reader: TReader);
+
+begin
+  inherited ReadState(Reader);
+  if Reader.Parent is TDataSet then
+    DataSet := TDataSet(Reader.Parent);
+end;
+
+procedure TField.SetAsBoolean(AValue: Boolean);
+
+begin
+  Raise AccessError(SBoolean);
+end;
+
+procedure TField.SetAsDateTime(AValue: TDateTime);
+
+begin
+  Raise AccessError(SDateTime);
+end;
+
+procedure TField.SetAsFloat(AValue: Double);
+
+begin
+  Raise AccessError(SFloat);
+end;
+
+procedure TField.SetAsVariant(AValue: Variant);
+
+begin
+  if VarIsNull(AValue) then
+    Clear
+  else
+    try
+      SetVarValue(AValue);
+    except
+      on EVariantError do DatabaseErrorFmt(SFieldValueError, [DisplayName]);
+    end;
+end;
+
+
+procedure TField.SetAsLongint(AValue: Longint);
+
+begin
+  Raise AccessError(SInteger);
+end;
+
+procedure TField.SetAsInteger(AValue: Integer);
+
+begin
+  SetAsLongint(AValue);
+end;
+
+procedure TField.SetAsLargeint(AValue: Largeint);
+begin
+  Raise AccessError(SLargeInt);
+end;
+
+procedure TField.SetAsString(const AValue: string);
+
+begin
+  Raise AccessError(SString);
+end;
+
+procedure TField.SetAsWideString(const aValue: WideString);
+begin
+  SetAsString(aValue);
+end;
+
+
+procedure TField.SetData(Buffer: Pointer);
+
+begin
+ SetData(Buffer,True);
+end;
+
+procedure TField.SetData(Buffer: Pointer; NativeFormat : Boolean);
+
+begin
+  If Not Assigned(FDataset) then
+    EDatabaseError.CreateFmt(SNoDataset,[FieldName]);
+  FDataSet.SetFieldData(Self,Buffer, NativeFormat);
+end;
+
+Procedure TField.SetDataset (AValue : TDataset);
+
+begin
+{$ifdef dsdebug}
+  Writeln ('Setting dataset');
+{$endif}
+  If AValue=FDataset then exit;
+  If Assigned(FDataset) Then
+    begin
+    FDataset.CheckInactive;
+    FDataset.FFieldList.Remove(Self);
+    end;
+  If Assigned(AValue) then
+    begin
+    AValue.CheckInactive;
+    AValue.FFieldList.Add(Self);
+    end;
+  FDataset:=AValue;
+end;
+
+procedure TField.SetDataType(AValue: TFieldType);
+
+begin
+  FDataType := AValue;
+end;
+
+procedure TField.SetFieldType(AValue: TFieldType);
+
+begin
+  { empty }
+end;
+
+procedure TField.SetParentComponent(AParent: TComponent);
+
+begin
+  if not (csLoading in ComponentState) then
+    DataSet := AParent as TDataSet;
+end;
+
+procedure TField.SetSize(AValue: Word);
+
+begin
+  CheckInactive;
+  CheckTypeSize(AValue);
+  FSize:=AValue;
+end;
+
+procedure TField.SetText(const AValue: string);
+
+begin
+  AsString:=AValue;
+end;
+
+procedure TField.SetVarValue(const AValue: Variant);
+begin
+  Raise AccessError(SVariant);
+end;
+
+procedure TField.Validate(Buffer: Pointer);
+
+begin
+  If assigned(OnValidate) Then
+    begin
+    FValueBuffer:=Buffer;
+    FValidating:=True;
+    Try
+      OnValidate(Self);
+    finally
+      FValidating:=False;
+    end;
+    end;
+end;
+
+class function Tfield.IsBlob: Boolean;
+
+begin
+  Result:=False;
+end;
+
+class procedure TField.CheckTypeSize(AValue: Longint);
+
+begin
+  If (AValue<>0) and Not IsBlob Then
+    DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
+end;
+
+// TField private methods
+
+procedure TField.SetEditText(const AValue: string);
+begin
+  if Assigned(OnSetText) then
+    OnSetText(Self, AValue)
+  else
+    SetText(AValue);
+end;
+
+function TField.GetEditText: String;
+begin
+  SetLength(Result, 0);
+  if Assigned(OnGetText) then
+    OnGetText(Self, Result, False)
+  else
+    GetText(Result, False);
+end;
+
+function TField.GetDisplayText: String;
+begin
+  SetLength(Result, 0);
+  if Assigned(OnGetText) then
+    OnGetText(Self, Result, True)
+  else
+    GetText(Result, True);
+end;
+
+procedure TField.SetDisplayLabel(const AValue: string);
+begin
+  if FDisplayLabel<>Avalue then
+    begin
+    FDisplayLabel:=Avalue;
+    PropertyChanged(true);
+    end;
+end;
+
+procedure TField.SetDisplayWidth(const AValue: Longint);
+begin
+  if FDisplayWidth<>AValue then
+    begin
+    FDisplayWidth:=AValue;
+    PropertyChanged(True);
+    end;
+end;
+
+function TField.GetDisplayWidth: integer;
+begin
+  if FDisplayWidth=0 then
+    result:=GetDefaultWidth
+  else
+    result:=FDisplayWidth;
+end;
+
+procedure TField.SetReadOnly(const AValue: Boolean);
+begin
+  if (FReadOnly<>Avalue) then
+    begin
+    FReadOnly:=AValue;
+    PropertyChanged(True);
+    end;
+end;
+
+procedure TField.SetVisible(const AValue: Boolean);
+begin
+  if FVisible<>Avalue then
+    begin
+    FVisible:=AValue;
+    PropertyChanged(True);
+    end;
+end;
+
+
+{ ---------------------------------------------------------------------
+    TStringField
+  ---------------------------------------------------------------------}
+
+
+constructor TStringField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftString);
+  FFixedChar := False;
+  FTransliterate := False;
+  FSize:=20;
+end;
+
+class procedure TStringField.CheckTypeSize(AValue: Longint);
+
+begin
+// A size of 0 is allowed, since for example Firebird allows
+// a query like: 'select '' as fieldname from table' which
+// results in a string with size 0.
+  If (AValue<0) or (AValue>dsMaxStringSize) Then
+    databaseErrorFmt(SInvalidFieldSize,[AValue])
+end;
+
+function TStringField.GetAsBoolean: Boolean;
+
+Var S : String;
+
+begin
+  S:=GetAsString;
+  result := (Length(S)>0) and (Upcase(S[1]) in ['T',YesNoChars[True]]);
+end;
+
+function TStringField.GetAsDateTime: TDateTime;
+
+begin
+  Result:=StrToDateTime(GetAsString);
+end;
+
+function TStringField.GetAsFloat: Double;
+
+begin
+  Result:=StrToFloat(GetAsString);
+end;
+
+function TStringField.GetAsLongint: Longint;
+
+begin
+  Result:=StrToInt(GetAsString);
+end;
+
+function TStringField.GetAsString: string;
+
+begin
+  If Not GetValue(Result) then
+    Result:='';
+end;
+
+function TStringField.GetAsVariant: Variant;
+
+Var s : string;
+
+begin
+  If GetValue(s) then
+    Result:=s
+  else
+    Result:=Null;
+end;
+
+
+function TStringField.GetDataSize: Word;
+
+begin
+  Result:=Size+1;
+end;
+
+function TStringField.GetDefaultWidth: Longint;
+
+begin
+  result:=Size;
+end;
+
+Procedure TStringField.GetText(var AText: string; ADisplayText: Boolean);
+
+begin
+    AText:=GetAsString;
+end;
+
+function TStringField.GetValue(var AValue: string): Boolean;
+
+Var Buf, TBuf : TStringFieldBuffer;
+
+begin
+  Result:=GetData(@Buf);
+  If Result then
+    begin
+    if transliterate then
+      begin
+      DataSet.Translate(Buf,TBuf,False);
+      AValue:=TBuf;
+      end
+    else
+      AValue:=Buf
+    end
+end;
+
+procedure TStringField.SetAsBoolean(AValue: Boolean);
+
+begin
+  If AValue Then
+    SetAsString('T')
+  else
+    SetAsString('F');
+end;
+
+procedure TStringField.SetAsDateTime(AValue: TDateTime);
+
+begin
+  SetAsString(DateTimeToStr(AValue));
+end;
+
+procedure TStringField.SetAsFloat(AValue: Double);
+
+begin
+  SetAsString(FloatToStr(AValue));
+end;
+
+procedure TStringField.SetAsLongint(AValue: Longint);
+
+begin
+  SetAsString(intToStr(AValue));
+end;
+
+procedure TStringField.SetAsString(const AValue: string);
+
+var Buf      : TStringFieldBuffer;
+
+begin
+  IF Length(AValue)=0 then
+    begin
+    Buf := #0;
+    SetData(@buf);
+    end
+  else if FTransliterate then
+    begin
+    DataSet.Translate(@AValue[1],Buf,True);
+    Buf[DataSize-1] := #0;
+    SetData(@buf);
+    end
+  else
+    begin
+    // The data is copied into the buffer, since some TDataset descendents copy
+    // the whole buffer-length in SetData. (See bug 8477)
+    Buf := AValue;
+    // If length(AValue) > Datasize the buffer isn't terminated properly
+    Buf[DataSize-1] := #0;
+    SetData(@Buf);
+    end;
+end;
+
+procedure TStringField.SetVarValue(const AValue: Variant);
+begin
+  SetAsString(AValue);
+end;
+
+{ ---------------------------------------------------------------------
+    TWideStringField
+  ---------------------------------------------------------------------}
+
+class procedure TWideStringField.CheckTypeSize(aValue: Integer);
+begin
+// A size of 0 is allowed, since for example Firebird allows
+// a query like: 'select '' as fieldname from table' which
+// results in a string with size 0.
+  If (AValue<0) or (AValue>(dsMaxStringSize div 2)) Then
+    databaseErrorFmt(SInvalidFieldSize,[AValue]);
+end;
+
+constructor TWideStringField.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  SetDataType(ftWideString);
+end;
+
+function TWideStringField.GetValue(var aValue: WideString): Boolean;
+var
+  FixBuffer : array[0..dsMaxStringSize div 2] of WideChar;
+  DynBuffer : array of WideChar;
+  Buffer    : PWideChar;
+begin
+  if DataSize <= dsMaxStringSize then begin
+    Result := GetData(@FixBuffer, False);
+    aValue := FixBuffer;
+  end else begin
+    SetLength(DynBuffer, Succ(Size));
+    Buffer := PWideChar(DynBuffer);
+    Result := GetData(Buffer, False);
+    if Result then
+      aValue := Buffer;
+  end;
+end;
+
+function TWideStringField.GetAsString: string;
+begin
+  Result := GetAsWideString;
+end;
+
+procedure TWideStringField.SetAsString(const aValue: string);
+begin
+  SetAsWideString(aValue);
+end;
+
+function TWideStringField.GetAsVariant: Variant;
+var
+  ws: WideString;
+begin
+  if GetValue(ws) then
+    Result := ws
+  else
+    Result := Null;
+end;
+
+procedure TWideStringField.SetVarValue(const aValue: Variant);
+begin
+  SetAsWideString(aValue);
+end;
+
+function TWideStringField.GetAsWideString: WideString;
+begin
+  if not GetValue(Result) then
+    Result := '';
+end;
+
+procedure TWideStringField.SetAsWideString(const aValue: WideString);
+const
+  NullWideChar : WideChar = #0;
+var
+  Buffer : PWideChar;
+begin
+  if Length(aValue)>0 then
+    Buffer := PWideChar(@aValue[1])
+  else
+    Buffer := @NullWideChar;
+  SetData(Buffer, False);
+end;
+
+function TWideStringField.GetDataSize: Word;
+begin
+  Result :=
+    (Size + 1) * 2;
+end;
+
+
+{ ---------------------------------------------------------------------
+    TNumericField
+  ---------------------------------------------------------------------}
+
+
+constructor TNumericField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  AlignMent:=taRightJustify;
+end;
+
+class procedure TNumericField.CheckTypeSize(AValue: Longint);
+begin
+  // This procedure is only added because some TDataset descendents have the
+  // but that they set the Size property as if it is the DataSize property.
+  // To avoid problems with those descendents, allow values <= 16.
+  If (AValue>16) Then
+    DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
+end;
+
+procedure TNumericField.RangeError(AValue, Min, Max: Double);
+
+begin
+  DatabaseErrorFMT(SRangeError,[AValue,Min,Max,FieldName]);
+end;
+
+procedure TNumericField.SetDisplayFormat(const AValue: string);
+
+begin
+ If FDisplayFormat<>AValue then
+   begin
+   FDisplayFormat:=AValue;
+   PropertyChanged(True);
+   end;
+end;
+
+procedure TNumericField.SetEditFormat(const AValue: string);
+
+begin
+  If FEDitFormat<>AValue then
+    begin
+    FEDitFormat:=AVAlue;
+    PropertyChanged(True);
+    end;
+end;
+
+{ ---------------------------------------------------------------------
+    TLongintField
+  ---------------------------------------------------------------------}
+
+
+constructor TLongintField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDatatype(ftinteger);
+  FMinRange:=Low(LongInt);
+  FMaxRange:=High(LongInt);
+  FValidchars:=['+','-','0'..'9'];
+end;
+
+function TLongintField.GetAsFloat: Double;
+
+begin
+  Result:=GetAsLongint;
+end;
+
+function TLongintField.GetAsLongint: Longint;
+
+begin
+  If Not GetValue(Result) then
+    Result:=0;
+end;
+
+function TLongintField.GetAsVariant: Variant;
+
+Var L : Longint;
+
+begin
+  If GetValue(L) then
+    Result:=L
+  else
+    Result:=Null;
+end;
+
+function TLongintField.GetAsString: string;
+
+Var L : Longint;
+
+begin
+  If GetValue(L) then
+    Result:=IntTostr(L)
+  else
+    Result:='';
+end;
+
+function TLongintField.GetDataSize: Word;
+
+begin
+  Result:=SizeOf(Longint);
+end;
+
+procedure TLongintField.GetText(var AText: string; ADisplayText: Boolean);
+
+var l : longint;
+    fmt : string;
+
+begin
+  Atext:='';
+  If Not GetValue(l) then exit;
+  If ADisplayText or (FEditFormat='') then
+    fmt:=FDisplayFormat
+  else
+    fmt:=FEditFormat;
+  If length(fmt)<>0 then
+    AText:=FormatFloat(fmt,L)
+  else
+    Str(L,AText);
+end;
+
+function TLongintField.GetValue(var AValue: Longint): Boolean;
+
+Var L : Longint;
+    P : PLongint;
+
+begin
+  P:=@L;
+  Result:=GetData(P);
+  If Result then
+    Case Datatype of
+      ftInteger,ftautoinc  : AValue:=Plongint(P)^;
+      ftword               : Avalue:=Pword(P)^;
+      ftsmallint           : AValue:=PSmallint(P)^;
+    end;
+end;
+
+procedure TLongintField.SetAsFloat(AValue: Double);
+
+begin
+  SetAsLongint(Round(Avalue));
+end;
+
+procedure TLongintField.SetAsLongint(AValue: Longint);
+
+begin
+  If CheckRange(AValue) then
+    SetData(@AValue)
+  else
+    RangeError(Avalue,FMinrange,FMaxRange);
+end;
+
+procedure TLongintField.SetVarValue(const AValue: Variant);
+begin
+  SetAsLongint(AValue);
+end;
+
+procedure TLongintField.SetAsString(const AValue: string);
+
+Var L,Code : longint;
+
+begin
+  If length(AValue)=0 then
+    Clear
+  else
+    begin
+    Val(AVAlue,L,Code);
+    If Code=0 then
+      SetAsLongint(L)
+    else
+      DatabaseErrorFMT(SNotAnInteger,[Avalue]);
+    end;
+end;
+
+Function TLongintField.CheckRange(AValue : longint) : Boolean;
+
+begin
+  result := true;
+  if (FMaxValue=0) then
+    begin
+    if (AValue>FMaxRange) Then result := false;
+    end
+  else
+    if AValue>FMaxValue then result := false;
+
+  if (FMinValue=0) then
+    begin
+    if (AValue<FMinRange) Then result := false;
+    end
+  else
+    if AValue<FMinValue then result := false;
+end;
+
+Procedure TLongintField.SetMaxValue (AValue : longint);
+
+begin
+  If (AValue>=FMinRange) and (AValue<=FMaxRange) then
+    FMaxValue:=AValue
+  else
+    RangeError(AValue,FMinRange,FMaxRange);
+end;
+
+Procedure TLongintField.SetMinValue (AValue : longint);
+
+begin
+  If (AValue>=FMinRange) and (AValue<=FMaxRange) then
+    FMinValue:=AValue
+  else
+    RangeError(AValue,FMinRange,FMaxRange);
+end;
+
+{ ---------------------------------------------------------------------
+    TLargeintField
+  ---------------------------------------------------------------------}
+
+
+constructor TLargeintField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDatatype(ftLargeint);
+  FMinRange:=Low(Largeint);
+  FMaxRange:=High(Largeint);
+  FValidchars:=['+','-','0'..'9'];
+end;
+
+function TLargeintField.GetAsFloat: Double;
+
+begin
+  Result:=GetAsLargeint;
+end;
+
+function TLargeintField.GetAsLargeint: Largeint;
+
+begin
+  If Not GetValue(Result) then
+    Result:=0;
+end;
+
+function TLargeIntField.GetAsVariant: Variant;
+
+Var L : Largeint;
+
+begin
+  If GetValue(L) then
+    Result:=L
+  else
+    Result:=Null;
+end;
+
+function TLargeintField.GetAsLongint: Longint;
+
+begin
+  Result:=GetAsLargeint;
+end;
+
+function TLargeintField.GetAsString: string;
+
+Var L : Largeint;
+
+begin
+  If GetValue(L) then
+    Result:=IntTostr(L)
+  else
+    Result:='';
+end;
+
+function TLargeintField.GetDataSize: Word;
+
+begin
+  Result:=SizeOf(Largeint);
+end;
+
+procedure TLargeintField.GetText(var AText: string; ADisplayText: Boolean);
+
+var l : largeint;
+    fmt : string;
+
+begin
+  Atext:='';
+  If Not GetValue(l) then exit;
+  If ADisplayText or (FEditFormat='') then
+    fmt:=FDisplayFormat
+  else
+    fmt:=FEditFormat;
+  If length(fmt)<>0 then
+    AText:=FormatFloat(fmt,L)
+  else
+    Str(L,AText);
+end;
+
+function TLargeintField.GetValue(var AValue: Largeint): Boolean;
+
+type
+  PLargeint = ^Largeint;
+
+Var P : PLargeint;
+
+begin
+  P:=@AValue;
+  Result:=GetData(P);
+end;
+
+procedure TLargeintField.SetAsFloat(AValue: Double);
+
+begin
+  SetAsLargeint(Round(Avalue));
+end;
+
+procedure TLargeintField.SetAsLargeint(AValue: Largeint);
+
+begin
+  If CheckRange(AValue) then
+    SetData(@AValue)
+  else
+    RangeError(Avalue,FMinrange,FMaxRange);
+end;
+
+procedure TLargeintField.SetAsLongint(AValue: Longint);
+
+begin
+  SetAsLargeint(Avalue);
+end;
+
+procedure TLargeintField.SetAsString(const AValue: string);
+
+Var L     : largeint;
+    code  : longint;
+
+begin
+  If length(AValue)=0 then
+    Clear
+  else
+    begin
+    Val(AVAlue,L,Code);
+    If Code=0 then
+      SetAsLargeint(L)
+    else
+      DatabaseErrorFMT(SNotAnInteger,[Avalue]);
+    end;
+end;
+
+procedure TLargeintField.SetVarValue(const AValue: Variant);
+begin
+  SetAsLargeint(AValue);
+end;
+
+Function TLargeintField.CheckRange(AValue : largeint) : Boolean;
+
+begin
+  result := true;
+  if (FMaxValue=0) then
+    begin
+    if (AValue>FMaxRange) Then result := false;
+    end
+  else
+    if AValue>FMaxValue then result := false;
+
+  if (FMinValue=0) then
+    begin
+    if (AValue<FMinRange) Then result := false;
+    end
+  else
+    if AValue<FMinValue then result := false;
+end;
+
+Procedure TLargeintField.SetMaxValue (AValue : largeint);
+
+begin
+  If (AValue>=FMinRange) and (AValue<=FMaxRange) then
+    FMaxValue:=AValue
+  else
+    RangeError(AValue,FMinRange,FMaxRange);
+end;
+
+Procedure TLargeintField.SetMinValue (AValue : largeint);
+
+begin
+  If (AValue>=FMinRange) and (AValue<=FMaxRange) then
+    FMinValue:=AValue
+  else
+    RangeError(AValue,FMinRange,FMaxRange);
+end;
+
+{ TSmallintField }
+
+function TSmallintField.GetDataSize: Word;
+
+begin
+  Result:=SizeOf(SmallInt);
+end;
+
+constructor TSmallintField.Create(AOwner: TComponent);
+
+begin
+  inherited Create(AOwner);
+  SetDataType(ftSmallInt);
+  FMinRange:=-32768;
+  FMaxRange:=32767;
+end;
+
+
+{ TWordField }
+
+function TWordField.GetDataSize: Word;
+
+begin
+  Result:=SizeOf(Word);
+end;
+
+constructor TWordField.Create(AOwner: TComponent);
+
+begin
+  inherited Create(AOwner);
+  SetDataType(ftWord);
+  FMinRange:=0;
+  FMaxRange:=65535;
+  FValidchars:=['+','0'..'9'];
+end;
+
+{ TAutoIncField }
+
+constructor TAutoIncField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOWner);
+  SetDataType(ftAutoInc);
+  FReadOnly:=True;
+end;
+
+Procedure TAutoIncField.SetAsLongint(AValue : Longint);
+
+begin
+  DataBaseError(SCantSetAutoIncfields);
+end;
+
+{ TFloatField }
+
+procedure TFloatField.SetCurrency(const AValue: Boolean);
+begin
+  if FCurrency=AValue then exit;
+  FCurrency:=AValue;
+end;
+
+function TFloatField.GetAsFloat: Double;
+
+begin
+  If Not GetData(@Result) Then
+    Result:=0.0;
+end;
+
+function TFloatField.GetAsVariant: Variant;
+
+Var f : Double;
+
+begin
+  If GetData(@f) then
+    Result := f
+  else
+    Result:=Null;
+end;
+
+function TFloatField.GetAsLongint: Longint;
+
+begin
+  Result:=Round(GetAsFloat);
+end;
+
+function TFloatField.GetAsString: string;
+
+Var R : Double;
+
+begin
+  If GetData(@R) then
+    Result:=FloatToStr(R)
+  else
+    Result:='';
+end;
+
+function TFloatField.GetDataSize: Word;
+
+begin
+  Result:=SizeOf(Double);
+end;
+
+procedure TFloatField.GetText(var TheText: string; ADisplayText: Boolean);
+
+Var
+    fmt : string;
+    E : Double;
+    Digits : integer;
+    ff: TFloatFormat;
+
+begin
+  TheText:='';
+  If Not GetData(@E) then exit;
+  If ADisplayText or (Length(FEditFormat) = 0) Then
+    Fmt:=FDisplayFormat
+  else
+    Fmt:=FEditFormat;
+    
+  Digits := 0;
+  if not FCurrency then
+    ff := ffGeneral
+  else
+    begin
+    Digits := CurrencyDecimals;
+    if ADisplayText then
+      ff := ffCurrency
+    else
+      ff := ffFixed;
+    end;
+
+
+  If fmt<>'' then
+    TheText:=FormatFloat(fmt,E)
+  else
+    TheText:=FloatToStrF(E,ff,FPrecision,Digits);
+end;
+
+procedure TFloatField.SetAsFloat(AValue: Double);
+
+begin
+  If CheckRange(AValue) then
+    SetData(@Avalue)
+  else
+    RangeError(AValue,FMinValue,FMaxValue);
+end;
+
+procedure TFloatField.SetAsLongint(AValue: Longint);
+
+begin
+  SetAsFloat(Avalue);
+end;
+
+procedure TFloatField.SetAsString(const AValue: string);
+
+Var R : Double;
+
+begin
+  If (AValue='') then
+    Clear
+  else  
+    try
+      R := StrToFloat(AValue);
+      SetAsFloat(R);
+    except
+      DatabaseErrorFmt(SNotAFloat, [AValue]);
+    end;
+end;
+
+procedure TFloatField.SetVarValue(const AValue: Variant);
+begin
+  SetAsFloat(Avalue);
+end;
+
+constructor TFloatField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDatatype(ftfloat);
+  FPrecision:=15;
+  FValidChars := [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
+end;
+
+Function TFloatField.CheckRange(AValue : Double) : Boolean;
+
+begin
+  If (FMinValue<>0) or (FmaxValue<>0) then
+    Result:=(AValue>=FMinValue) and (AVAlue<=FMAxValue)
+  else
+    Result:=True;
+end;
+
+{ TCurrencyField }
+
+Constructor TCurrencyField.Create(AOwner: TComponent);
+
+begin
+  inherited Create(AOwner);
+  SetDataType(ftCurrency);
+  Currency := True;
+end;
+
+{ TBooleanField }
+
+function TBooleanField.GetAsBoolean: Boolean;
+
+var b : wordbool;
+
+begin
+  If GetData(@b) then
+    result := b
+  else
+    Result:=False;
+end;
+
+function TBooleanField.GetAsVariant: Variant;
+
+Var b : wordbool;
+
+begin
+  If GetData(@b) then
+    Result := b
+  else
+    Result:=Null;
+end;
+
+function TBooleanField.GetAsString: string;
+
+Var B : wordbool;
+
+begin
+  If Getdata(@B) then
+    Result:=FDisplays[False,B]
+  else
+    result:='';
+end;
+
+function TBooleanField.GetDataSize: Word;
+
+begin
+  Result:=SizeOf(wordBool);
+end;
+
+function TBooleanField.GetDefaultWidth: Longint;
+
+begin
+  Result:=Length(FDisplays[false,false]);
+  If Result<Length(FDisplays[false,True]) then
+    Result:=Length(FDisplays[false,True]);
+end;
+
+procedure TBooleanField.SetAsBoolean(AValue: Boolean);
+
+var b : wordbool;
+
+begin
+  b := AValue;
+  SetData(@b);
+end;
+
+procedure TBooleanField.SetAsString(const AValue: string);
+
+Var Temp : string;
+
+begin
+  Temp:=UpperCase(AValue);
+  if Temp='' then
+    Clear
+  else if pos(Temp, FDisplays[True,True])=1 then
+    SetAsBoolean(True)
+  else if pos(Temp, FDisplays[True,False])=1 then
+    SetAsBoolean(False)
+  else
+    DatabaseErrorFmt(SNotABoolean,[AValue]);
+end;
+
+procedure TBooleanField.SetVarValue(const AValue: Variant);
+begin
+  SetAsBoolean(AValue);
+end;
+
+constructor TBooleanField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftBoolean);
+  DisplayValues:='True;False';
+end;
+
+Procedure TBooleanField.SetDisplayValues(AValue : String);
+
+Var I : longint;
+
+begin
+  If FDisplayValues<>AValue then
+    begin
+    I:=Pos(';',AValue);
+    If (I<2) or (I=Length(AValue)) then
+      DatabaseErrorFmt(SInvalidDisplayValues,[AValue]);
+    FdisplayValues:=AValue;
+    // Store display values and their uppercase equivalents;
+    FDisplays[False,True]:=Copy(AValue,1,I-1);
+    FDisplays[True,True]:=UpperCase(FDisplays[False,True]);
+    FDisplays[False,False]:=Copy(AValue,I+1,Length(AValue)-i);
+    FDisplays[True,False]:=UpperCase(FDisplays[False,False]);
+    PropertyChanged(True);
+    end;
+end;
+
+{ TDateTimeField }
+
+procedure TDateTimeField.SetDisplayFormat(const AValue: string);
+begin
+  if FDisplayFormat<>AValue then begin
+    FDisplayFormat:=AValue;
+    PropertyChanged(True);
+  end;
+end;
+
+function TDateTimeField.GetAsDateTime: TDateTime;
+
+begin
+  If Not GetData(@Result,False) then
+    Result:=0;
+end;
+
+procedure TDateTimeField.SetVarValue(const AValue: Variant);
+begin
+  SetAsDateTime(AValue);
+end;
+
+function TDateTimeField.GetAsVariant: Variant;
+
+Var d : tDateTime;
+
+begin
+  If Getdata(@d,False) then
+    Result := d
+  else
+    Result:=Null;
+end;
+
+function TDateTimeField.GetAsFloat: Double;
+
+begin
+  Result:=GetAsdateTime;
+end;
+
+
+function TDateTimeField.GetAsString: string;
+
+begin
+  GetText(Result,False);
+end;
+
+
+function TDateTimeField.GetDataSize: Word;
+
+begin
+  Result:=SizeOf(TDateTime);
+end;
+
+
+procedure TDateTimeField.GetText(var TheText: string; ADisplayText: Boolean);
+
+Var R : TDateTime;
+    F : String;
+
+begin
+  If Not Getdata(@R,False) then
+    TheText:=''
+  else
+    begin
+    If (ADisplayText) and (Length(FDisplayFormat)<>0) then
+      F:=FDisplayFormat
+    else
+      Case DataType of
+       ftTime : F:=ShortTimeFormat;
+       ftDate : F:=ShortDateFormat;
+      else
+       F:='c'
+      end;
+    TheText:=FormatDateTime(F,R);
+    end;
+end;
+
+
+procedure TDateTimeField.SetAsDateTime(AValue: TDateTime);
+
+begin
+  SetData(@Avalue,False);
+end;
+
+
+procedure TDateTimeField.SetAsFloat(AValue: Double);
+
+begin
+  SetAsDateTime(AValue);
+end;
+
+
+procedure TDateTimeField.SetAsString(const AValue: string);
+
+Var R : TDateTime;
+
+begin
+  R:=StrToDateTime(AVAlue);
+  SetData(@R,False);
+end;
+
+
+constructor TDateTimeField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftDateTime);
+end;
+
+
+{ TDateField }
+
+constructor TDateField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftDate);
+end;
+
+
+{ TTimeField }
+
+constructor TTimeField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftTime);
+end;
+
+procedure TTimeField.SetAsString(const AValue: string);
+Var R : TDateTime;
+begin
+  R:=StrToTime(AVAlue);
+  SetData(@R);
+end;
+
+
+
+{ TBinaryField }
+
+class procedure TBinaryField.CheckTypeSize(AValue: Longint);
+
+begin
+  // Just check for really invalid stuff; actual size is
+  // dependent on the record...
+  If AValue<1 then
+    DatabaseErrorfmt(SInvalidFieldSize,[Avalue]);
+end;
+
+
+function TBinaryField.GetAsString: string;
+
+begin
+  Setlength(Result,DataSize);
+  GetData(Pointer(Result));
+end;
+
+
+procedure TBinaryField.GetText(var TheText: string; ADisplayText: Boolean);
+
+begin
+  TheText:=GetAsString;
+end;
+
+
+procedure TBinaryField.SetAsString(const AValue: string);
+
+Var Buf : PChar;
+    Allocated : Boolean;
+
+begin
+  Allocated:=False;
+  If Length(AVAlue)=DataSize then
+    Buf:=PChar(Avalue)
+  else
+    begin
+    GetMem(Buf,DataSize);
+    Move(Pchar(Avalue)[0],Buf^,DataSize);
+    Allocated:=True;
+    end;
+  SetData(Buf);
+  If Allocated then
+    FreeMem(Buf,DataSize);
+end;
+
+
+procedure TBinaryField.SetText(const AValue: string);
+
+begin
+  SetAsString(Avalue);
+end;
+
+procedure TBinaryField.SetVarValue(const AValue: Variant);
+begin
+  SetAsString(Avalue);
+end;
+
+
+constructor TBinaryField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+end;
+
+
+
+{ TBytesField }
+
+function TBytesField.GetDataSize: Word;
+
+begin
+  Result:=Size;
+end;
+
+
+constructor TBytesField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftBytes);
+  Size:=16;
+end;
+
+
+
+{ TVarBytesField }
+
+function TVarBytesField.GetDataSize: Word;
+
+begin
+  Result:=Size+2;
+end;
+
+
+constructor TVarBytesField.Create(AOwner: TComponent);
+
+begin
+  INherited Create(AOwner);
+  SetDataType(ftvarbytes);
+  Size:=16;
+end;
+
+{ TBCDField }
+
+class procedure TBCDField.CheckTypeSize(AValue: Longint);
+
+begin
+  If not (AValue in [1..4]) then
+    DatabaseErrorfmt(SInvalidFieldSize,[Avalue]);
+end;
+
+function TBCDField.GetAsCurrency: Currency;
+
+begin
+  if not GetData(@Result) then
+    result := 0;
+end;
+
+function TBCDField.GetAsVariant: Variant;
+
+Var c : system.Currency;
+
+begin
+  If GetData(@c) then
+    Result := c
+  else
+    Result:=Null;
+end;
+
+function TBCDField.GetAsFloat: Double;
+
+begin
+  result := GetAsCurrency;
+end;
+
+
+function TBCDField.GetAsLongint: Longint;
+
+begin
+  result := round(GetAsCurrency);
+end;
+
+
+function TBCDField.GetAsString: string;
+
+var c : system.currency;
+
+begin
+  If GetData(@C) then
+    Result:=CurrToStr(C)
+  else
+    Result:='';
+end;
+
+function TBCDField.GetValue(var AValue: Currency): Boolean;
+
+begin
+  Result := GetData(@AValue);
+end;
+
+function TBCDField.GetDataSize: Word;
+
+begin
+  result := sizeof(system.currency);
+end;
+
+function TBCDField.GetDefaultWidth: Longint;
+
+begin
+  if precision > 0 then result := precision
+    else result := 10;
+end;
+
+procedure TBCDField.GetText(var TheText: string; ADisplayText: Boolean);
+var
+  c : system.currency;
+  fmt: String;
+begin
+  if GetData(@C) then begin
+    if aDisplayText or (FEditFormat='') then
+      fmt := FDisplayFormat
+    else
+      fmt := FEditFormat;
+    if fmt<>'' then
+      TheText := FormatFloat(fmt,C)
+    else if fCurrency then begin
+      if aDisplayText then
+        TheText := FloatToStrF(C, ffCurrency, FPrecision, 2{digits?})
+      else
+        TheText := FloatToStrF(C, ffFixed, FPrecision, 2{digits?});
+    end else
+      TheText := FloatToStrF(C, ffGeneral, FPrecision, 0{digits?});
+  end else
+    TheText := '';
+end;
+
+procedure TBCDField.SetAsCurrency(AValue: Currency);
+
+begin
+  If CheckRange(AValue) then
+    setdata(@AValue)
+  else
+    RangeError(AValue,FMinValue,FMaxvalue);
+end;
+
+procedure TBCDField.SetVarValue(const AValue: Variant);
+begin
+  SetAsCurrency(AValue);
+end;
+
+Function TBCDField.CheckRange(AValue : Currency) : Boolean;
+
+begin
+  If (FMinValue<>0) or (FmaxValue<>0) then
+    Result:=(AValue>=FMinValue) and (AVAlue<=FMaxValue)
+  else
+    Result:=True;
+end;
+
+procedure TBCDField.SetAsFloat(AValue: Double);
+
+begin
+  SetAsCurrency(AValue);
+end;
+
+
+procedure TBCDField.SetAsLongint(AValue: Longint);
+
+begin
+  SetAsCurrency(AValue);
+end;
+
+
+procedure TBCDField.SetAsString(const AValue: string);
+
+begin
+  SetAsCurrency(strtocurr(AValue));
+end;
+
+constructor TBCDField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  FMaxvalue := 0;
+  FMinvalue := 0;
+  SetDataType(ftBCD);
+  FPrecision := 15;
+  Size:=4;
+end;
+
+
+{ TBlobField }
+
+
+procedure TBlobField.AssignTo(Dest: TPersistent);
+
+begin
+  //!! To be implemented
+end;
+
+Function TBlobField.GetBlobStream(Mode : TBlobStreamMode) : TStream;
+
+begin
+  Result:=FDataset.CreateBlobStream(Self,Mode);
+end;
+
+procedure TBlobField.FreeBuffers;
+
+begin
+end;
+
+
+function TBlobField.GetAsString: string;
+var
+  Stream : TStream;
+  Len    : Integer;
+begin
+  Stream := GetBlobStream(bmRead);
+  if Stream <> nil then
+    With Stream do
+      try
+        Len := Size;
+        SetLength(Result, Len);
+        if Len > 0 then
+          ReadBuffer(Result[1], Len);
+      finally
+        Free
+      end
+  else
+    Result := '';
+end;
+
+function TBlobField.GetAsWideString: WideString;
+var
+  Stream : TStream;
+  Len    : Integer;
+begin
+  Stream := GetBlobStream(bmRead);
+  if Stream <> nil then
+    With Stream do
+      try
+        Len := Size;
+        SetLength(Result,Len div 2);
+        if Len > 0 then
+          ReadBuffer(Result[1] ,Len);
+      finally
+        Free
+      end
+  else
+    Result := '';
+end;
+
+function TBlobField.GetAsVariant: Variant;
+
+Var s : string;
+
+begin
+  if not GetIsNull then
+    begin
+    s := GetAsString;
+    result := s;
+    end
+  else result := Null;
+end;
+
+
+function TBlobField.GetBlobSize: Longint;
+var
+  Stream: TStream;
+begin
+  Stream := GetBlobStream(bmread);
+  if Stream <> nil then
+    With Stream do
+      try
+        Result:=Size;
+      finally
+        Free;
+      end
+  else
+    result := 0;
+end;
+
+
+function TBlobField.GetIsNull: Boolean;
+
+begin
+  If Not Modified then
+    result:= inherited GetIsnull
+  else
+    With GetBlobStream(bmread) do
+      try
+        Result:=(Size=0);
+      Finally
+        Free;
+      end;
+end;
+
+
+procedure TBlobField.GetText(var TheText: string; ADisplayText: Boolean);
+
+begin
+  TheText:=inherited GetAsString;
+end;
+
+
+procedure TBlobField.SetAsString(const AValue: string);
+var
+  Len : Integer;
+begin
+  With GetBlobStream(bmwrite) do
+    try
+      Len := Length(Avalue);
+      if Len > 0 then
+        WriteBuffer(aValue[1], Len);
+    finally
+      Free;
+    end;
+end;
+
+
+procedure TBlobField.SetAsWideString(const AValue: WideString);
+var
+  Len : Integer;
+begin
+  With GetBlobStream(bmwrite) do
+    try
+      Len := Length(Avalue) * 2;
+      if Len > 0 then
+        WriteBuffer(aValue[1], Len);
+    finally
+      Free;
+    end;
+end;
+
+
+procedure TBlobField.SetText(const AValue: string);
+
+begin
+  SetAsString(AValue);
+end;
+
+procedure TBlobField.SetVarValue(const AValue: Variant);
+begin
+  SetAsString(AValue);
+end;
+
+
+constructor TBlobField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOWner);
+  SetDataType(ftBlob);
+end;
+
+
+procedure TBlobField.Assign(Source: TPersistent);
+
+begin
+  //!! To be implemented
+end;
+
+
+procedure TBlobField.Clear;
+
+begin
+  GetBlobStream(bmWrite).free;
+end;
+
+
+class function TBlobField.IsBlob: Boolean;
+
+begin
+  Result:=True;
+end;
+
+
+procedure TBlobField.LoadFromFile(const FileName: string);
+
+Var S : TFileStream;
+
+begin
+  S:=TFileStream.Create(FileName,fmOpenRead);
+  try
+    LoadFromStream(S);
+  finally
+    S.Free;
+  end;
+end;
+
+
+procedure TBlobField.LoadFromStream(Stream: TStream);
+
+begin
+  With GetBlobStream(bmWrite) do
+    Try
+      CopyFrom(Stream,0);
+    finally
+      Free;
+    end;
+end;
+
+
+procedure TBlobField.SaveToFile(const FileName: string);
+
+Var S : TFileStream;
+
+begin
+  S:=TFileStream.Create(FileName,fmCreate);
+  try
+    SaveToStream(S);
+  finally
+    S.Free;
+  end;
+end;
+
+
+procedure TBlobField.SaveToStream(Stream: TStream);
+
+Var S : TStream;
+
+begin
+  S:=GetBlobStream(bmRead);
+  Try
+    Stream.CopyFrom(S,0);
+  finally
+    S.Free;
+  end;
+end;
+
+procedure TBlobField.SetFieldType(AValue: TFieldType);
+
+begin
+  If AValue in [Low(TBlobType)..High(TBlobType)] then
+    SetDatatype(Avalue);
+end;
+
+{ TMemoField }
+
+constructor TMemoField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftMemo);
+end;
+
+function TMemoField.GetAsWideString: WideString;
+begin
+  Result := GetAsString;
+end;
+
+procedure TMemoField.SetAsWideString(const aValue: WideString);
+begin
+  SetAsString(aValue);
+end;
+
+{ TWideMemoField }
+
+constructor TWideMemoField.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  SetDataType(ftWideMemo);
+end;
+
+function TWideMemoField.GetAsString: string;
+begin
+  Result := GetAsWideString;
+end;
+
+procedure TWideMemoField.SetAsString(const aValue: string);
+begin
+  SetAsWideString(aValue);
+end;
+
+function TWideMemoField.GetAsVariant: Variant;
+
+Var s : string;
+
+begin
+  if not GetIsNull then
+    begin
+    s := GetAsWideString;
+    result := s;
+    end
+  else result := Null;
+end;
+
+procedure TWideMemoField.SetVarValue(const AValue: Variant);
+begin
+  SetAsWideString(AValue);
+end;
+
+{ TGraphicField }
+
+constructor TGraphicField.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftGraphic);
+end;
+
+{ TGuidField }
+
+constructor TGuidField.Create(AOwner: TComponent);
+begin
+  Size := 38;
+  inherited Create(AOwner);
+  SetDataType(ftGuid);
+end;
+
+class procedure TGuidField.CheckTypeSize(AValue: LongInt);
+begin
+  if aValue <> 38 then
+    DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
+end;
+
+function TGuidField.GetAsGuid: TGUID;
+const
+  nullguid: TGUID = '{00000000-0000-0000-0000-000000000000}';
+var
+  S: string;
+begin
+  S := GetAsString;
+  if S = '' then
+    Result := nullguid
+  else
+    Result := StringToGuid(S);
+end;
+
+function TGuidField.GetDefaultWidth: LongInt;
+begin
+  Result := 38;
+end;
+
+procedure TGuidField.SetAsGuid(const aValue: TGUID);
+begin
+  SetAsString(GuidToString(aValue));
+end;
+
+function TVariantField.GetDefaultWidth: Integer;
+begin
+  Result := 15;
+end;
+
+{ TVariantField }
+
+constructor TVariantField.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  SetDataType(ftVariant);
+end;
+
+class procedure TVariantField.CheckTypeSize(aValue: Integer);
+begin
+  { empty }
+end;
+
+function TVariantField.GetAsBoolean: Boolean;
+begin
+  Result := GetAsVariant;
+end;
+
+function TVariantField.GetAsDateTime: TDateTime;
+begin
+  Result := GetAsVariant;
+end;
+
+function TVariantField.GetAsFloat: Double;
+begin
+  Result := GetAsVariant;
+end;
+
+function TVariantField.GetAsInteger: Longint;
+begin
+  Result := GetAsVariant;
+end;
+
+function TVariantField.GetAsString: string;
+begin
+  Result := VarToStr(GetAsVariant);
+end;
+
+function TVariantField.GetAsWideString: WideString;
+begin
+  Result := VarToWideStr(GetAsVariant);
+end;
+
+function TVariantField.GetAsVariant: Variant;
+begin
+  if not GetData(@Result) then
+    Result := Null;
+end;
+
+procedure TVariantField.SetAsBoolean(aValue: Boolean);
+begin
+  SetVarValue(aValue);
+end;
+
+procedure TVariantField.SetAsDateTime(aValue: TDateTime);
+begin
+  SetVarValue(aValue);
+end;
+
+procedure TVariantField.SetAsFloat(aValue: Double);
+begin
+  SetVarValue(aValue);
+end;
+
+procedure TVariantField.SetAsInteger(aValue: Longint);
+begin
+  SetVarValue(aValue);
+end;
+
+procedure TVariantField.SetAsString(const aValue: string);
+begin
+  SetVarValue(aValue);
+end;
+
+procedure TVariantField.SetAsWideString(const aValue: WideString);
+begin
+  SetVarValue(aValue);
+end;
+
+procedure TVariantField.SetVarValue(const aValue: Variant);
+begin
+  SetData(@aValue);
+end;
+
+
+{ TFields }
+
+Constructor TFields.Create(ADataset : TDataset);
+
+begin
+  FDataSet:=ADataset;
+  FFieldList:=TList.Create;
+  FValidFieldKinds:=[fkData..fkInternalcalc];
+end;
+
+Destructor TFields.Destroy;
+
+begin
+  if FFieldList <> nil then Clear;
+  FFieldList.Free;
+  inherited Destroy;
+end;
+
+Procedure Tfields.Changed;
+
+begin
+  if (FDataSet <> nil) and not (csDestroying in FDataSet.ComponentState) and FDataset.Active then
+    FDataSet.DataEvent(deFieldListChange, 0);
+  If Assigned(FOnChange) then
+    FOnChange(Self);
+end;
+
+Procedure TFields.CheckfieldKind(Fieldkind : TFieldKind; Field : TField);
+
+begin
+  If Not (FieldKind in ValidFieldKinds) Then
+    DatabaseErrorFmt(SInvalidFieldKind,[Field.FieldName]);
+end;
+
+Function Tfields.GetCount : Longint;
+
+begin
+  Result:=FFieldList.Count;
+end;
+
+
+Function TFields.GetField (Index : longint) : TField;
+
+begin
+  Result:=Tfield(FFieldList[Index]);
+end;
+
+procedure Tfields.SetField(Index: Integer; Value: TField);
+begin
+  Fields[Index].Assign(Value);
+end;
+
+Procedure TFields.SetFieldIndex (Field : TField;Value : Integer);
+
+Var Old : Longint;
+
+begin
+  Old := FFieldList.indexOf(Field);
+  If Old=-1 then
+    Exit;
+  // Check value
+  If Value<0 Then Value:=0;
+  If Value>=Count then Value:=Count-1;
+  If Value<>Old then
+    begin
+    FFieldList.Delete(Old);
+    FFieldList.Insert(Value,Field);
+    Field.PropertyChanged(True);
+    Changed;
+    end;
+end;
+
+Procedure TFields.Add(Field : TField);
+
+begin
+  CheckFieldName(Field.FieldName);
+  FFieldList.Add(Field);
+  Field.FFields:=Self;
+  Changed;
+end;
+
+Procedure TFields.CheckFieldName (Const Value : String);
+
+begin
+  If FindField(Value)<>Nil then
+    DataBaseErrorFmt(SDuplicateFieldName,[Value],FDataset);
+end;
+
+Procedure TFields.CheckFieldNames (Const Value : String);
+
+
+Var I : longint;
+    S,T : String;
+begin
+  T:=Value;
+  Repeat
+    I:=Pos(';',T);
+    If I=0 Then I:=Length(T)+1;
+    S:=Copy(T,1,I-1);
+    Delete(T,1,I);
+    // Will raise an error if no such field...
+    FieldByName(S);
+  Until (T='');
+end;
+
+Procedure TFields.Clear;
+
+begin
+  with FFieldList do
+    while Count > 0 do begin
+      TField(Last).FDataSet := Nil;
+      TField(Last).Free;
+      FFieldList.Delete(Count - 1);
+    end;
+  Changed;
+end;
+
+Function TFields.FindField (Const Value : String) : TField;
+
+Var S : String;
+    I : longint;
+
+begin
+  Result:=Nil;
+  S:=UpperCase(Value);
+  For I:=0 To FFieldList.Count-1 do
+    If S=UpperCase(TField(FFieldList[i]).FieldName) Then
+      Begin
+      {$ifdef dsdebug}
+      Writeln ('Found field ',Value);
+      {$endif}
+      Result:=TField(FFieldList[I]);
+      Exit;
+      end;
+end;
+
+Function TFields.FieldByName (Const Value : String) : TField;
+
+begin
+  Result:=FindField(Value);
+  If result=Nil then
+    DatabaseErrorFmt(SFieldNotFound,[Value],FDataset);
+end;
+
+Function TFields.FieldByNumber(FieldNo : Integer) : TField;
+
+Var i : Longint;
+
+begin
+  Result:=Nil;
+  For I:=0 to FFieldList.Count-1 do
+    If FieldNo=TField(FFieldList[I]).FieldNo then
+      begin
+      Result:=TField(FFieldList[i]);
+      Exit;
+      end;
+end;
+
+Procedure TFields.GetFieldNames (Values : TStrings);
+
+Var i : longint;
+
+begin
+  Values.Clear;
+  For I:=0 to FFieldList.Count-1 do
+    Values.Add(Tfield(FFieldList[I]).FieldName);
+end;
+
+Function TFields.IndexOf(Field : TField) : Longint;
+
+begin
+  Result:=FFieldList.IndexOf(Field);
+end;
+
+procedure TFields.Remove(Value : TField);
+
+begin
+  FFieldList.Remove(Value);
+  Value.FFields := nil;
+  Changed;
+end;
+

packages/fcl-db/tests/dbtestframework.pas

@@ -0,0 +1,44 @@
+program dbtestframework;
+
+{$IFDEF FPC}
+  {$mode objfpc}{$H+}
+{$ENDIF}
+
+{$APPTYPE CONSOLE}
+
+uses
+  SysUtils,
+  fpcunit,  testreport, testregistry,
+  DigestTestReport,
+  toolsunit,
+// Units wich contains the tests
+  testbasics, testfieldtypes, TestDatasources, testdbbasics;
+  
+var
+  FXMLResultsWriter: TXMLResultsWriter;
+  FDigestResultsWriter: TDigestResultsWriter;
+  testResult: TTestResult;
+begin
+  InitialiseDBConnector;
+  testResult := TTestResult.Create;
+  FXMLResultsWriter := TXMLResultsWriter.Create;
+  FDigestResultsWriter := TDigestResultsWriter.Create(nil);
+  try
+    testResult.AddListener(FXMLResultsWriter);
+    testResult.AddListener(FDigestResultsWriter);
+    FDigestResultsWriter.Comment:=dbtype;
+    FDigestResultsWriter.Category:='DB';
+    FDigestResultsWriter.RelSrcDir:='fcl-db';
+    FDigestResultsWriter.Comment:=dbtype;
+    FDigestResultsWriter.Category:='db';
+    FDigestResultsWriter.RelSrcDir:='fcl-db';
+    FXMLResultsWriter.WriteHeader;
+//    FdiDBResultsWriter.OpenConnection(dbconnectorname+';'+dbconnectorparams);
+    GetTestRegistry.Run(testResult);
+    FXMLResultsWriter.WriteResult(testResult);
+  finally
+    testResult.Free;
+    FXMLResultsWriter.Free;
+    FDigestResultsWriter.Free;
+  end;
+end.

packages/fcl-fpcunit/Makefile

@@ -1,8 +1,8 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2008/03/24]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2008/03/20]
 #
 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-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded
+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-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded
 BSDs = freebsd netbsd openbsd darwin
 UNIXs = linux $(BSDs) solaris qnx
 LIMIT83fs = go32v2 os2 emx watcom
@@ -167,17 +167,6 @@ OS_TARGET:=$(word 5,$(FPC_COMPILERINFO))
 endif
 FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
 FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
-ifeq ($(CPU_TARGET),armeb)
-ARCH=arm
-override FPCOPT+=-Cb
-else
-ifeq ($(CPU_TARGET),armel)
-ARCH=arm
-override FPCOPT+=-CaEABI
-else
-ARCH=$(CPU_TARGET)
-endif
-endif
 ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
 TARGETSUFFIX=$(OS_TARGET)
 SOURCESUFFIX=$(OS_SOURCE)
@@ -199,7 +188,7 @@ endif
 ifeq ($(OS_TARGET),linux)
 linuxHier=1
 endif
-export OS_TARGET OS_SOURCE ARCH CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE TARGETSUFFIX SOURCESUFFIX CROSSCOMPILE
+export OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE TARGETSUFFIX SOURCESUFFIX CROSSCOMPILE
 ifdef FPCDIR
 override FPCDIR:=$(subst \,/,$(FPCDIR))
 ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
@@ -415,12 +404,6 @@ endif
 ifeq ($(FULL_TARGET),avr-embedded)
 override TARGET_UNITS+=testregistry testreport testdecorator ubmockobject xmlreporter fpcunitreport latextestreport xmltestreport plaintestreport fpcunit testutils digesttestreport
 endif
-ifeq ($(FULL_TARGET),armeb-linux)
-override TARGET_UNITS+=testregistry testreport testdecorator ubmockobject xmlreporter fpcunitreport latextestreport xmltestreport plaintestreport fpcunit testutils digesttestreport
-endif
-ifeq ($(FULL_TARGET),armeb-embedded)
-override TARGET_UNITS+=testregistry testreport testdecorator ubmockobject xmlreporter fpcunitreport latextestreport xmltestreport plaintestreport fpcunit testutils digesttestreport
-endif
 override INSTALL_FPCPACKAGE=y
 ifeq ($(FULL_TARGET),i386-linux)
 override COMPILER_OPTIONS+=-S2h
@@ -584,12 +567,6 @@ endif
 ifeq ($(FULL_TARGET),avr-embedded)
 override COMPILER_OPTIONS+=-S2h
 endif
-ifeq ($(FULL_TARGET),armeb-linux)
-override COMPILER_OPTIONS+=-S2h
-endif
-ifeq ($(FULL_TARGET),armeb-embedded)
-override COMPILER_OPTIONS+=-S2h
-endif
 ifeq ($(FULL_TARGET),i386-linux)
 override COMPILER_SOURCEDIR+=src
 endif
@@ -752,12 +729,6 @@ endif
 ifeq ($(FULL_TARGET),avr-embedded)
 override COMPILER_SOURCEDIR+=src
 endif
-ifeq ($(FULL_TARGET),armeb-linux)
-override COMPILER_SOURCEDIR+=src
-endif
-ifeq ($(FULL_TARGET),armeb-embedded)
-override COMPILER_SOURCEDIR+=src
-endif
 ifdef REQUIRE_UNITSDIR
 override UNITSDIR+=$(REQUIRE_UNITSDIR)
 endif
@@ -1888,20 +1859,6 @@ REQUIRE_PACKAGES_PASZLIB=1
 REQUIRE_PACKAGES_FCL-BASE=1
 REQUIRE_PACKAGES_FCL-XML=1
 endif
-ifeq ($(FULL_TARGET),armeb-linux)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-BASE=1
-REQUIRE_PACKAGES_FCL-XML=1
-endif
-ifeq ($(FULL_TARGET),armeb-embedded)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_HASH=1
-REQUIRE_PACKAGES_PASZLIB=1
-REQUIRE_PACKAGES_FCL-BASE=1
-REQUIRE_PACKAGES_FCL-XML=1
-endif
 ifdef REQUIRE_PACKAGES_RTL
 PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/Makefile.fpc,$(PACKAGESDIR))))))
 ifneq ($(PACKAGEDIR_RTL),)
@@ -2085,13 +2042,13 @@ override COMPILER_UNITDIR+=$(UNITDIR_WINUNITS-JEDI)
 endif
 endif
 ifndef NOCPUDEF
-override FPCOPTDEF=$(ARCH)
+override FPCOPTDEF=$(CPU_TARGET)
 endif
 ifneq ($(OS_TARGET),$(OS_SOURCE))
 override FPCOPT+=-T$(OS_TARGET)
 endif
 ifneq ($(CPU_TARGET),$(CPU_SOURCE))
-override FPCOPT+=-P$(ARCH)
+override FPCOPT+=-P$(CPU_TARGET)
 endif
 ifeq ($(OS_SOURCE),openbsd)
 override FPCOPT+=-FD$(NEW_BINUTILS_PATH)

rtl/inc/variants.pp

@@ -0,0 +1,4343 @@
+{
+    This include file contains the variants
+    support for FPC
+
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2001-2005 by the Free Pascal development team
+
+    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.
+
+ **********************************************************************}
+
+{$IFDEF fpc}
+{$mode objfpc}
+{$ENDIF}
+{$h+}
+
+{ Using inlining for small system functions/wrappers }
+{$inline on}
+{$define VARIANTINLINE}
+
+unit variants;
+
+interface
+
+  uses
+    sysutils,sysconst,rtlconsts,typinfo;
+
+type
+  EVariantParamNotFoundError = class(EVariantError);
+  EVariantInvalidOpError = class(EVariantError);
+  EVariantTypeCastError = class(EVariantError);
+  EVariantOverflowError = class(EVariantError);
+  EVariantInvalidArgError = class(EVariantError);
+  EVariantBadVarTypeError = class(EVariantError);
+  EVariantBadIndexError = class(EVariantError);
+  EVariantArrayLockedError = class(EVariantError);
+  EVariantNotAnArrayError = class(EVariantError);
+  EVariantArrayCreateError = class(EVariantError);
+  EVariantNotImplError = class(EVariantError);
+  EVariantOutOfMemoryError = class(EVariantError);
+  EVariantUnexpectedError = class(EVariantError);
+  EVariantDispatchError = class(EVariantError);
+  EVariantRangeCheckError = class(EVariantOverflowError);
+  EVariantInvalidNullOpError = class(EVariantInvalidOpError);
+
+  TVariantRelationship = (vrEqual, vrLessThan, vrGreaterThan, vrNotEqual);
+  TNullCompareRule = (ncrError, ncrStrict, ncrLoose);
+  TBooleanToStringRule = (bsrAsIs, bsrLower, bsrUpper);
+
+Const
+  OrdinalVarTypes = [varSmallInt, varInteger, varBoolean, varShortInt,
+                     varByte, varWord,varLongWord,varInt64];
+  FloatVarTypes = [
+{$ifndef FPUNONE}
+    varSingle, varDouble,
+{$endif}
+    varCurrency];
+
+{ Variant support procedures and functions }
+
+function VarType(const V: Variant): TVarType; inline;
+function VarTypeDeRef(const V: Variant): TVarType; overload;
+function VarTypeDeRef(const V: TVarData): TVarType; overload; inline;
+function VarAsType(const V: Variant; aVarType: TVarType): Variant;
+function VarIsType(const V: Variant; aVarType: TVarType): Boolean; overload; inline;
+function VarIsType(const V: Variant; const AVarTypes: array of TVarType): Boolean; overload;
+function VarIsByRef(const V: Variant): Boolean; inline;
+
+function VarIsEmpty(const V: Variant): Boolean; inline;
+procedure VarCheckEmpty(const V: Variant); inline;
+function VarIsNull(const V: Variant): Boolean; inline;
+function VarIsClear(const V: Variant): Boolean; inline;
+
+function VarIsCustom(const V: Variant): Boolean; inline;
+function VarIsOrdinal(const V: Variant): Boolean; inline;
+function VarIsFloat(const V: Variant): Boolean; inline;
+function VarIsNumeric(const V: Variant): Boolean; inline;
+function VarIsStr(const V: Variant): Boolean;
+
+function VarToStr(const V: Variant): string;
+function VarToStrDef(const V: Variant; const ADefault: string): string;
+function VarToWideStr(const V: Variant): WideString;
+function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;
+
+{$ifndef FPUNONE}
+function VarToDateTime(const V: Variant): TDateTime;
+function VarFromDateTime(const DateTime: TDateTime): Variant;
+{$endif}
+
+function VarInRange(const AValue, AMin, AMax: Variant): Boolean;
+function VarEnsureRange(const AValue, AMin, AMax: Variant): Variant;
+
+function VarSameValue(const A, B: Variant): Boolean;
+function VarCompareValue(const A, B: Variant): TVariantRelationship;
+
+function VarIsEmptyParam(const V: Variant): Boolean; inline;
+
+procedure VarClear(var V: Variant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
+procedure VarClear(var V: OleVariant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
+
+procedure SetClearVarToEmptyParam(var V: TVarData);
+
+function VarIsError(const V: Variant; out AResult: HRESULT): Boolean;
+function VarIsError(const V: Variant): Boolean; inline;
+function VarAsError(AResult: HRESULT): Variant;
+
+function VarSupports(const V: Variant; const IID: TGUID; out Intf): Boolean;
+function VarSupports(const V: Variant; const IID: TGUID): Boolean;
+
+{ Variant copy support }
+procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);
+
+{ Variant array support procedures and functions }
+
+function VarArrayCreate(const Bounds: array of SizeInt; aVarType: TVarType): Variant;
+function VarArrayCreate(const Bounds: PVarArrayBoundArray; Dims : SizeInt; aVarType: TVarType): Variant;
+function VarArrayOf(const Values: array of Variant): Variant;
+
+function VarArrayAsPSafeArray(const A: Variant): PVarArray;
+
+function VarArrayDimCount(const A: Variant) : LongInt;
+function VarArrayLowBound(const A: Variant; Dim : LongInt) : LongInt;
+function VarArrayHighBound(const A: Variant; Dim : LongInt) : LongInt;
+
+function VarArrayLock(const A: Variant): Pointer;
+procedure VarArrayUnlock(const A: Variant);
+
+function VarArrayRef(const A: Variant): Variant;
+
+function VarIsArray(const A: Variant): Boolean; inline;
+function VarIsArray(const A: Variant; AResolveByRef: Boolean): Boolean;
+
+function VarTypeIsValidArrayType(const aVarType: TVarType): Boolean;
+function VarTypeIsValidElementType(const aVarType: TVarType): Boolean;
+
+{ Variant <--> Dynamic Arrays }
+
+procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
+procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
+
+{ Global constants }
+
+function Unassigned: Variant; // Unassigned standard constant
+function Null: Variant;       // Null standard constant
+
+var
+  EmptyParam: OleVariant;
+
+{ Custom Variant base class }
+
+type
+  TVarCompareResult = (crLessThan, crEqual, crGreaterThan);
+  TCustomVariantType = class(TObject, IInterface)
+  private
+    FVarType: TVarType;
+  protected
+    function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
+    function _AddRef: Integer; stdcall;
+    function _Release: Integer; stdcall;
+    procedure SimplisticClear(var V: TVarData);
+    procedure SimplisticCopy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean = False);
+    procedure RaiseInvalidOp;
+    procedure RaiseCastError;
+    procedure RaiseDispError;
+    function LeftPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean; virtual;
+    function RightPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean; virtual;
+    function OlePromotion(const V: TVarData; out RequiredVarType: TVarType): Boolean; virtual;
+    procedure DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer); virtual;
+    procedure VarDataInit(var Dest: TVarData);
+    procedure VarDataClear(var Dest: TVarData);
+    procedure VarDataCopy(var Dest: TVarData; const Source: TVarData);
+    procedure VarDataCopyNoInd(var Dest: TVarData; const Source: TVarData);
+    procedure VarDataCast(var Dest: TVarData; const Source: TVarData);
+    procedure VarDataCastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); overload;
+    procedure VarDataCastTo(var Dest: TVarData; const aVarType: TVarType); overload;
+    procedure VarDataCastToOleStr(var Dest: TVarData);
+    procedure VarDataFromStr(var V: TVarData; const Value: string);
+    procedure VarDataFromOleStr(var V: TVarData; const Value: WideString);
+    function VarDataToStr(const V: TVarData): string;
+    function VarDataIsEmptyParam(const V: TVarData): Boolean;
+    function VarDataIsByRef(const V: TVarData): Boolean;
+    function VarDataIsArray(const V: TVarData): Boolean;
+    function VarDataIsOrdinal(const V: TVarData): Boolean;
+    function VarDataIsFloat(const V: TVarData): Boolean;
+    function VarDataIsNumeric(const V: TVarData): Boolean;
+    function VarDataIsStr(const V: TVarData): Boolean;
+  public
+    constructor Create; overload;
+    constructor Create(RequestedVarType: TVarType); overload;
+    destructor Destroy; override;
+    function IsClear(const V: TVarData): Boolean; virtual;
+    procedure Cast(var Dest: TVarData; const Source: TVarData); virtual;
+    procedure CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); virtual;
+    procedure CastToOle(var Dest: TVarData; const Source: TVarData); virtual;
+    procedure Clear(var V: TVarData); virtual; abstract;
+    procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); virtual; abstract;
+    procedure BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp); virtual;
+    procedure UnaryOp(var Right: TVarData; const Operation: TVarOp); virtual;
+    function CompareOp(const Left, Right: TVarData; const Operation: TVarOp): Boolean; virtual;
+    procedure Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); virtual;
+    property VarType: TVarType read FVarType;
+  end;
+  TCustomVariantTypeClass = class of TCustomVariantType;
+
+  TVarDataArray = array of TVarData;
+  IVarInvokeable = interface
+    ['{1CB65C52-BBCB-41A6-9E58-7FB916BEEB2D}']
+    function DoFunction(var Dest: TVarData; const V: TVarData;
+      const Name: string; const Arguments: TVarDataArray): Boolean;
+    function DoProcedure(const V: TVarData; const Name: string;
+      const Arguments: TVarDataArray): Boolean;
+    function GetProperty(var Dest: TVarData; const V: TVarData;
+      const Name: string): Boolean;
+    function SetProperty(const V: TVarData; const Name: string;
+      const Value: TVarData): Boolean;
+  end;
+
+  TInvokeableVariantType = class(TCustomVariantType, IVarInvokeable)
+  protected
+    procedure DispInvoke(Dest: PVarData; const Source: TVarData;
+      CallDesc: PCallDesc; Params: Pointer); override;
+  public
+    { IVarInvokeable }
+    function DoFunction(var Dest: TVarData; const V: TVarData;
+      const Name: string; const Arguments: TVarDataArray): Boolean; virtual;
+    function DoProcedure(const V: TVarData; const Name: string;
+      const Arguments: TVarDataArray): Boolean; virtual;
+    function GetProperty(var Dest: TVarData; const V: TVarData;
+      const Name: string): Boolean; virtual;
+    function SetProperty(const V: TVarData; const Name: string;
+      const Value: TVarData): Boolean; virtual;
+  end;
+
+  IVarInstanceReference = interface
+    ['{5C176802-3F89-428D-850E-9F54F50C2293}']
+    function GetInstance(const V: TVarData): TObject;
+  end;
+
+  TPublishableVariantType = class(TInvokeableVariantType, IVarInstanceReference)
+  protected
+    { IVarInstanceReference }
+    function GetInstance(const V: TVarData): TObject; virtual; abstract;
+  public
+    function GetProperty(var Dest: TVarData; const V: TVarData;
+      const Name: string): Boolean; override;
+    function SetProperty(const V: TVarData; const Name: string;
+      const Value: TVarData): Boolean; override;
+  end;
+
+  function FindCustomVariantType(const aVarType: TVarType;
+    out CustomVariantType: TCustomVariantType): Boolean; overload;
+  function FindCustomVariantType(const TypeName: string;
+    out CustomVariantType: TCustomVariantType): Boolean; overload;
+
+type
+  TAnyProc = procedure (var V: TVarData);
+  TVarDispProc = procedure (Dest: PVariant; const Source: Variant;
+      CallDesc: PCallDesc; Params: Pointer); cdecl;
+
+Const
+  CMaxNumberOfCustomVarTypes = $06FF;
+  CMinVarType = $0100;
+  CMaxVarType = CMinVarType + CMaxNumberOfCustomVarTypes;
+  CIncVarType = $000F;
+  CFirstUserType = CMinVarType + CIncVarType;
+
+var
+  NullEqualityRule: TNullCompareRule = ncrLoose;
+  NullMagnitudeRule: TNullCompareRule = ncrLoose;
+  NullStrictConvert: Boolean = true;
+  NullAsStringValue: string = '';
+  PackVarCreation: Boolean = True;
+{$ifndef FPUNONE}
+  OleVariantInt64AsDouble: Boolean = False;
+{$endif}
+
+
+  VarDispProc: TVarDispProc;
+  ClearAnyProc: TAnyProc;  { Handler clearing a varAny }
+  ChangeAnyProc: TAnyProc; { Handler to change any to Variant }
+  RefAnyProc: TAnyProc;    { Handler to add a reference to an varAny }
+  InvalidCustomVariantType : TCustomVariantType;
+
+procedure VarCastError;
+procedure VarCastError(const ASourceType, ADestType: TVarType);
+procedure VarCastErrorOle(const ASourceType: TVarType);
+procedure VarInvalidOp;
+procedure VarInvalidOp(const aLeft, aRight: TVarType; aOpCode: TVarOp);
+procedure VarInvalidOp(const aRight: TVarType; aOpCode: TVarOp);
+procedure VarInvalidNullOp;
+procedure VarBadTypeError;
+procedure VarOverflowError;
+procedure VarOverflowError(const ASourceType, ADestType: TVarType);
+procedure VarBadIndexError;
+procedure VarArrayLockedError;
+procedure VarNotImplError;
+procedure VarOutOfMemoryError;
+procedure VarInvalidArgError;
+procedure VarInvalidArgError(AType: TVarType);
+procedure VarUnexpectedError;
+procedure VarRangeCheckError(const AType: TVarType);
+procedure VarRangeCheckError(const ASourceType, ADestType: TVarType);
+procedure VarArrayCreateError;
+procedure VarResultCheck(AResult: HRESULT);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
+procedure VarResultCheck(AResult: HRESULT; ASourceType, ADestType: TVarType);
+procedure HandleConversionException(const ASourceType, ADestType: TVarType);
+function VarTypeAsText(const AType: TVarType): string;
+function FindVarData(const V: Variant): PVarData;
+
+const
+  VarOpAsText : array[TVarOp] of string = (
+    '+',   {opAdd}
+    '-',   {opSubtract}
+    '*',   {opMultiply}
+    '/',   {opDivide}
+    'div', {opIntDivide}
+    'mod', {opModulus}
+    'shl', {opShiftLeft}
+    'shr', {opShiftRight}
+    'and', {opAnd}
+    'or',  {opOr}
+    'xor', {opXor}
+    '',    {opCompare}
+    '-',   {opNegate}
+    'not', {opNot}
+    '=',   {opCmpEq}
+    '<>',  {opCmpNe}
+    '<',   {opCmpLt}
+    '<=',  {opCmpLe}
+    '>',   {opCmpGt}
+    '>=',  {opCmpGe}
+    '**'   {opPower}
+  );
+
+{ Typinfo unit Variant routines have been moved here, so as not to make TypInfo dependent on variants }
+
+Function GetPropValue(Instance: TObject; const PropName: string): Variant;
+Function GetPropValue(Instance: TObject; const PropName: string; PreferStrings: Boolean): Variant;
+Procedure SetPropValue(Instance: TObject; const PropName: string; const Value: Variant);
+Function  GetVariantProp(Instance: TObject; PropInfo : PPropInfo): Variant;
+Function  GetVariantProp(Instance: TObject; const PropName: string): Variant;
+Procedure SetVariantProp(Instance: TObject; const PropName: string; const Value: Variant);
+Procedure SetVariantProp(Instance: TObject; PropInfo : PPropInfo; const Value: Variant);
+
+
+{$IFDEF DEBUG_VARIANTS}
+var
+  __DEBUG_VARIANTS: Boolean = False;
+{$ENDIF}
+
+implementation
+
+uses
+  Math,
+  VarUtils;
+
+{$IFOPT R-} {$DEFINE RANGECHECKINGOFF} {$ENDIF}
+{$IFOPT Q-} {$DEFINE OVERFLOWCHECKINGOFF} {$ENDIF}
+
+var
+  customvarianttypes    : array of TCustomVariantType;
+  customvarianttypelock : trtlcriticalsection;
+
+const
+  { all variants for which vType and varComplexType = 0 do not require
+    finalization. }
+  varComplexType = $BFE8;
+
+procedure DoVarClearComplex(var v : TVarData); forward;
+procedure DoVarCopy(var Dest : TVarData; const Source : TVarData); forward;
+procedure DoVarCast(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt); forward;
+
+procedure DoVarClear(var v : TVarData); inline;
+begin
+  if v.vType and varComplexType <> 0 then
+    DoVarClearComplex(v)
+  else
+    v.vType := varEmpty;
+end;
+
+procedure DoVarClearIfComplex(var v : TVarData); inline;
+begin
+  if v.vType and varComplexType <> 0 then
+    DoVarClearComplex(v);
+end;
+
+function AlignToPtr(p : Pointer) : Pointer;inline;
+begin
+  {$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT}
+  Result:=align(p,SizeOf(p));
+  {$ELSE FPC_REQUIRES_PROPER_ALIGNMENT}
+  Result:=p;
+  {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT}
+end;
+
+
+{ ---------------------------------------------------------------------
+    String Messages
+  ---------------------------------------------------------------------}
+
+ResourceString
+  SErrVarIsEmpty = 'Variant is empty';
+  SErrInvalidIntegerRange = 'Invalid Integer range: %d';
+
+{ ---------------------------------------------------------------------
+    Auxiliary routines
+  ---------------------------------------------------------------------}
+
+Procedure VariantError (Const Msg : String); inline;
+begin
+  Raise EVariantError.Create(Msg);
+end;
+
+Procedure NotSupported(Meth: String);
+begin
+  Raise EVariantError.CreateFmt('Method %s not yet supported.',[Meth]);
+end;
+
+type
+  TVariantArrayIterator = object
+    Bounds : PVarArrayBoundArray;
+    Coords : PVarArrayCoorArray;
+    Dims   : SizeInt;
+    constructor Init(aDims: SizeInt; aBounds : PVarArrayBoundArray);
+    destructor Done;
+
+    function Next : Boolean;
+    { returns true if the iterator reached the end of the variant array }
+    function AtEnd: Boolean;
+  end;
+
+
+{$r-}
+
+constructor TVariantArrayIterator.Init(aDims: SizeInt; aBounds : PVarArrayBoundArray);
+var
+  i : sizeint;
+begin
+  Dims := aDims;
+  Bounds := aBounds;
+
+  GetMem(Coords, SizeOf(SizeInt) * Dims);
+  { initialize coordinate counter }
+  for i:= 0 to Pred(Dims) do
+    Coords^[i] := Bounds^[i].LowBound;
+end;
+
+
+function TVariantArrayIterator.Next: Boolean;
+var
+  Finished : Boolean;
+
+  procedure IncDim(Dim : SizeInt);
+  begin
+    if Finished then
+      Exit;
+
+    Inc(Coords^[Dim]);
+    if Coords^[Dim] >= Bounds^[Dim].LowBound + Bounds^[Dim].ElementCount then begin
+      Coords^[Dim]:=Bounds^[Dim].LowBound;
+      if Dim > 0 then
+        IncDim(Pred(Dim))
+      else
+        Finished := True;
+    end;
+  end;
+
+
+begin
+  Finished := False;
+  IncDim(Pred(Dims));
+  Result := not Finished;
+end;
+
+
+function TVariantArrayIterator.AtEnd: Boolean;
+var
+  i : sizeint;
+begin
+  result:=true;
+  for i:=0 to Pred(Dims) do
+    if Coords^[i] < Bounds^[i].LowBound + Bounds^[i].ElementCount then
+      begin
+        result:=false;
+        exit;
+      end;
+end;
+
+{$ifndef RANGECHECKINGOFF}
+{$r+}
+{$endif}
+
+destructor TVariantArrayIterator.done;
+  begin
+    FreeMem(Coords);
+  end;
+
+
+type
+  tdynarraybounds = array of SizeInt;
+  tdynarraycoords = tdynarraybounds;
+  tdynarrayelesize = tdynarraybounds;
+  tdynarraypositions = array of Pointer;
+  tdynarrayiter = object
+    Bounds : tdynarraybounds;
+    Coords : tdynarraycoords;
+    elesize : tdynarrayelesize;
+    positions : tdynarraypositions;
+    Dims : SizeInt;
+    data : Pointer;
+    constructor init(d : Pointer;p : pdynarraytypeinfo;_dims: SizeInt;b : tdynarraybounds);
+    function next : Boolean;
+    destructor done;
+  end;
+
+
+constructor tdynarrayiter.init(d : Pointer;p : pdynarraytypeinfo;_dims: SizeInt;b : tdynarraybounds);
+  var
+    i : sizeint;
+  begin
+    Bounds:=b;
+    Dims:=_dims;
+    SetLength(Coords,Dims);
+    SetLength(elesize,Dims);
+    SetLength(positions,Dims);
+    positions[0]:=d;
+    { initialize coordinate counter and elesize }
+    for i:=0 to Dims-1 do
+      begin
+        Coords[i]:=0;
+        if i>0 then
+          positions[i]:=Pointer(positions[i-1]^);
+        { skip kind and name }
+        inc(Pointer(p),ord(pdynarraytypeinfo(p)^.namelen)+2);
+
+        p:=AlignToPtr(p);
+
+        elesize[i]:=psizeint(p)^;
+
+        { skip elesize }
+        inc(Pointer(p),SizeOf(sizeint));
+
+        p:=pdynarraytypeinfo(ppointer(p)^);
+      end;
+    data:=positions[Dims-1];
+  end;
+
+
+function tdynarrayiter.next : Boolean;
+  var
+    Finished : Boolean;
+
+  procedure incdim(d : SizeInt);
+    begin
+      if Finished then
+        exit;
+      inc(Coords[d]);
+      inc(Pointer(positions[d]),elesize[d]);
+
+      if Coords[d]>=Bounds[d] then
+        begin
+          Coords[d]:=0;
+          if d>0 then
+            begin
+              incdim(d-1);
+              positions[d]:=Pointer(positions[d-1]^);
+            end
+          else
+            Finished:=true;
+        end;
+    end;
+
+  begin
+    Finished:=False;
+    incdim(Dims-1);
+    data:=positions[Dims-1];
+    Result:=not(Finished);
+  end;
+
+
+destructor tdynarrayiter.done;
+  begin
+    Bounds:=nil;
+    Coords:=nil;
+    elesize:=nil;
+    positions:=nil;
+  end;
+
+{ ---------------------------------------------------------------------
+    VariantManager support
+  ---------------------------------------------------------------------}
+
+procedure sysvarinit(var v : Variant);
+begin
+  TVarData(V).vType := varEmpty;
+end;
+
+
+procedure sysvarclear(var v : Variant);
+begin
+  if TVarData(v).vType and varComplexType <> 0 then
+    VarClearProc(TVarData(V))
+  else
+    TVarData(v).vType := varEmpty;
+end;
+
+
+function Sysvartoint (const v : Variant) : Integer;
+begin
+  if VarType(v) = varNull then
+    if NullStrictConvert then
+      VarCastError(varNull, varInt64)
+    else
+      Result := 0
+  else
+    Result := VariantToLongInt(TVarData(V));
+end;
+
+function Sysvartoint64 (const v : Variant) : Int64;
+begin
+  if VarType(v) = varNull then
+    if NullStrictConvert then
+      VarCastError(varNull, varInt64)
+    else
+      Result := 0
+  else
+    Result := VariantToInt64(TVarData(V));
+end;
+
+
+function sysvartoword64 (const v : Variant) : QWord;
+begin
+  if VarType(v) = varNull then
+    if NullStrictConvert then
+      VarCastError(varNull, varQWord)
+    else
+      Result := 0
+  else
+    Result := VariantToQWord (TVarData(V));
+end;
+
+
+function sysvartobool (const v : Variant) : Boolean;
+begin
+  if VarType(v) = varNull then
+    if NullStrictConvert then
+      VarCastError(varNull, varBoolean)
+    else
+      Result := False
+  else
+    Result := VariantToBoolean(TVarData(V));
+end;
+
+
+{$ifndef FPUNONE}
+function sysvartoreal (const v : Variant) : Extended;
+begin
+  if VarType(v) = varNull then
+    if NullStrictConvert then
+      VarCastError(varNull, varDouble)
+    else
+      Result := 0
+  else
+    Result := VariantToDouble(TVarData(V));
+end;
+{$endif}
+
+
+function sysvartocurr (const v : Variant) : Currency;
+begin
+  if VarType(v) = varNull then
+    if NullStrictConvert then
+      VarCastError(varNull, varCurrency)
+    else
+      Result := 0
+  else
+    Result := VariantToCurrency(TVarData(V));
+end;
+
+
+procedure sysvartolstr (var s : AnsiString; const v : Variant);
+begin
+  if VarType(v) = varNull then
+    if NullStrictConvert then
+      VarCastError(varNull, varString)
+    else
+      s := NullAsStringValue
+  else
+    S := VariantToAnsiString(TVarData(V));
+end;
+
+
+procedure sysvartopstr (var s; const v : Variant);
+begin
+  if VarType(v) = varNull then
+    if NullStrictConvert then
+      VarCastError(varNull, varString)
+    else
+      ShortString(s) := NullAsStringValue
+  else
+    ShortString(s) := VariantToShortString(TVarData(V));
+end;
+
+
+procedure sysvartowstr (var s : WideString; const v : Variant);
+begin
+  if VarType(v) = varNull then
+    if NullStrictConvert then
+      VarCastError(varNull, varOleStr)
+    else
+      s := NullAsStringValue
+  else
+    S := VariantToWideString(TVarData(V));
+end;
+
+
+procedure sysvartointf (var Intf : IInterface; const v : Variant);
+begin
+  case TVarData(v).vType of
+    varEmpty:
+      Intf := nil;
+    varNull:
+      if NullStrictConvert then
+        VarCastError(varNull, varUnknown)
+      else
+        Intf := nil;
+    varUnknown:
+      Intf := IInterface(TVarData(v).vUnknown);
+    varUnknown or varByRef:
+      Intf := IInterface(TVarData(v).vPointer^);
+    varDispatch:
+      Intf := IInterface(TVarData(v).vDispatch);
+    varDispatch or varByRef:
+      Intf := IInterface(TVarData(v).vPointer^);
+    varVariant, varVariant or varByRef: begin
+      if not Assigned(TVarData(v).vPointer) then
+        VarBadTypeError;
+      sysvartointf(Intf, Variant(PVarData(TVarData(v).vPointer)^) );
+    end;
+  else
+    VarCastError(TVarData(v).vType, varUnknown);
+  end;
+end;
+
+
+procedure sysvartodisp (var Disp : IDispatch; const v : Variant);
+begin
+  case TVarData(v).vType of
+    varEmpty:
+      Disp := nil;
+    varNull:
+      if NullStrictConvert then
+        VarCastError(varNull, varDispatch)
+      else
+        Disp := nil;
+    varUnknown:
+      if IInterface(TVarData(v).vUnknown).QueryInterface(IDispatch, Disp) <> S_OK then
+        VarCastError(varUnknown, varDispatch);
+    varUnknown or varByRef:
+      if IInterface(TVarData(v).vPointer^).QueryInterface(IDispatch, Disp) <> S_OK then
+        VarCastError(varUnknown or varByRef, varDispatch);
+    varDispatch:
+      Disp := IDispatch(TVarData(v).vDispatch);
+    varDispatch or varByRef:
+      Disp := IDispatch(TVarData(v).vPointer^);
+    varVariant, varVariant or varByRef: begin
+      if not Assigned(TVarData(v).vPointer) then
+        VarBadTypeError;
+      sysvartodisp(Disp, Variant(PVarData(TVarData(v).vPointer)^) );
+    end;
+  else
+    VarCastError(TVarData(v).vType, varDispatch);
+  end;
+end;
+
+{$ifndef FPUNONE}
+function sysvartotdatetime (const v : Variant) : TDateTime;
+begin
+  if VarType(v) = varNull then
+    if NullStrictConvert then
+      VarCastError(varNull, varDate)
+    else
+      Result := 0
+  else
+    Result:=VariantToDate(TVarData(v));
+end;
+{$endif}
+
+function DynamicArrayIsRectangular(p : Pointer;TypeInfo : Pointer) : Boolean;
+var
+  arraysize,i : sizeint;
+begin
+  Result := False;
+
+  { get TypeInfo of second level }
+  { skip kind and name }
+  inc(Pointer(TypeInfo),ord(pdynarraytypeinfo(TypeInfo)^.namelen)+2);
+  TypeInfo:=AlignToPtr(TypeInfo);
+  TypeInfo:=ppointer(TypeInfo+SizeOf(sizeint))^;
+
+  { check recursively? }
+  if assigned(pdynarraytypeinfo(TypeInfo)) and (pdynarraytypeinfo(TypeInfo)^.kind=byte(tkDynArray)) then
+    begin
+      { set to dimension of first element }
+      arraysize:=psizeint(ppointer(p)^-SizeOf(sizeint))^;
+      { walk through all elements }
+      for i:=1 to psizeint(p-SizeOf(sizeint))^ do
+        begin
+          { ... and check dimension }
+          if psizeint(ppointer(p)^-SizeOf(sizeint))^<>arraysize then
+            exit;
+          if not(DynamicArrayIsRectangular(ppointer(p)^,TypeInfo)) then
+            exit;
+          inc(p,SizeOf(Pointer));
+        end;
+    end;
+    Result:=true;
+end;
+
+procedure sysvartodynarray (var dynarr : Pointer; const v : Variant; TypeInfo : Pointer);
+begin
+  DynArrayFromVariant(dynarr, v, TypeInfo);
+end;
+
+procedure sysvarfrombool (var Dest : Variant; const Source : Boolean);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varBoolean;
+    vBoolean := Source;
+  end;
+end;
+
+procedure VariantErrorInvalidIntegerRange(Range: LongInt);
+begin
+  VariantError(Format(SErrInvalidIntegerRange,[Range]));
+end;
+
+procedure sysvarfromint (var Dest : Variant; const Source, Range : LongInt);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do
+    if PackVarCreation then
+      case Range of
+        -4 : begin
+          vType := varInteger;
+          vInteger := Source;
+        end;
+        -2 : begin
+          vType := varSmallInt;
+          vSmallInt := Source;
+        end;
+        -1 : Begin
+          vType := varShortInt;
+          vshortint := Source;
+        end;
+        1 : begin
+          vType := varByte;
+          vByte := Source;
+        end;
+        2 : begin
+          vType := varWord;
+          vWord := Source;
+        end;
+        4 : Begin
+          vType := varLongWord;
+          {use vInteger, not vLongWord as the value came passed in as an Integer }
+          vInteger := Source;
+        end;
+      else
+        VariantErrorInvalidIntegerRange(Range);
+      end
+    else begin
+      vType := varInteger;
+      vInteger := Source;
+    end;
+end;
+
+procedure sysvarfromint64 (var Dest : Variant; const Source : Int64);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varInt64;
+    vInt64 := Source;
+  end;
+end;
+
+procedure sysvarfromword64 (var Dest : Variant; const Source : QWord);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varQWord;
+    vQWord := Source;
+  end;
+end;
+
+{$ifndef FPUNONE}
+procedure sysvarfromreal (var Dest : Variant; const Source : Extended);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varDouble;
+    vDouble := Source;
+  end;
+end;
+
+procedure sysvarfromsingle (var Dest : Variant; const Source : single);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varSingle;
+    vSingle := Source;
+  end;
+end;
+
+procedure sysvarfromdouble (var Dest : Variant; const Source : double);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varDouble;
+    vDouble := Source;
+  end;
+end;
+{$endif}
+
+procedure sysvarfromcurr (var Dest : Variant; const Source : Currency);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varCurrency;
+    vCurrency := Source;
+  end;
+end;
+
+
+{$ifndef FPUNONE}
+procedure sysvarfromtdatetime (var Dest : Variant; const Source : TDateTime);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varDate;
+    vDate := Source;
+  end;
+end;
+{$endif}
+
+
+procedure sysvarfrompstr (var Dest : Variant; const Source : ShortString);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varString;
+    vString := nil;
+    AnsiString(vString) := Source;
+  end;
+end;
+
+procedure sysvarfromlstr (var Dest : Variant; const Source : AnsiString);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varString;
+    vString := nil;
+    AnsiString(vString) := Source;
+  end;
+end;
+
+
+procedure sysvarfromwstr (var Dest : Variant; const Source : WideString);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vType := varOleStr;
+    vOleStr := nil;
+    WideString(Pointer(vOleStr)) := Source;
+  end;
+end;
+
+procedure sysvarfromintf(var Dest : Variant; const Source : IInterface);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vUnknown := nil;
+    IInterface(vUnknown) := Source;
+    vType := varUnknown;
+  end;
+end;
+
+
+procedure sysvarfromdisp(var Dest : Variant; const Source : IDispatch);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vUnknown := nil;
+    IDispatch(vDispatch) := Source;
+    vType := varDispatch;
+  end;
+end;
+
+type
+  TCommonType = (ctEmpty,ctAny,ctError,ctLongInt,ctBoolean,
+{$ifndef FPUNONE}
+    ctFloat,ctDate,ctCurrency,
+{$endif}
+    ctInt64,ctNull,ctWideStr,ctString);
+
+  TCommonVarType = varEmpty..varQWord;
+
+const
+{$ifdef FPUNONE}
+  ctFloat = ctError;
+  ctDate = ctError;
+  ctCurrency = ctError;
+{$endif}
+
+  { get the basic type for a Variant type }
+  VarTypeToCommonType : array[TCommonVarType] of TCommonType =
+    (ctEmpty,           // varEmpty = 0;
+     ctNull,            // varNull = 1;
+     ctLongInt,         // varSmallInt = 2;
+     ctLongInt,         // varInteger = 3;
+     ctFloat,           // varSingle = 4;
+     ctFloat,           // varDouble = 5;
+     ctCurrency,        // varCurrency = 6;
+     ctDate,            // varDate = 7;
+     ctWideStr,         // varOleStr = 8;
+     ctError,           // varDispatch = 9;
+     ctError,           // varError = 10;
+     ctBoolean,         // varBoolean = 11;
+     ctError,           // varVariant = 12;
+     ctError,           // varUnknown = 13;
+     ctError,           // ??? 15
+     ctError,           // varDecimal = 14;
+     ctLongInt,         // varShortInt = 16;
+     ctLongInt,         // varByte = 17;
+     ctLongInt,         // varWord = 18;
+     ctInt64,           // varLongWord = 19;
+     ctInt64,           // varInt64 = 20;
+     ctInt64            // varQWord = 21;
+    );
+
+  { map a basic type back to a Variant type }
+{ Not used yet
+  CommonTypeToVarType : array[TCommonType] of TVarType =
+    (
+      varEmpty,
+      varany,
+      varError,
+      varInteger,
+      varDouble,
+      varBoolean,
+      varInt64,
+      varNull,
+      varOleStr,
+      varDate,
+      varCurrency,
+      varString
+    );
+}
+function MapToCommonType(const vType : TVarType) : TCommonType;
+begin
+  case vType of
+    Low(TCommonVarType)..High(TCommonVarType):
+      Result := VarTypeToCommonType[vType];
+    varString:
+      Result:=ctString;
+    varAny:
+      Result:=ctAny;
+  else
+    Result:=ctError;
+  end;
+end;
+
+const
+  FindCmpCommonType : array[TCommonType, TCommonType] of TCommonType = (
+     {              ctEmpty    ctAny    ctError  ctLongInt   ctBoolean                         ctFloat    ctDate   ctCurrency           ctInt64     ctNull   ctWideStr   ctString  }
+    ({ ctEmpty }    ctEmpty,   ctEmpty, ctError, ctEmpty,    ctEmpty,    {$ifndef FPUNONE}ctEmpty,   ctEmpty, ctEmpty,    {$endif}ctEmpty,    ctEmpty, ctEmpty,    ctEmpty   ),
+    ({ ctAny }      ctEmpty,   ctAny,   ctError, ctAny,      ctAny,      {$ifndef FPUNONE}ctAny,     ctAny,   ctAny,      {$endif}ctAny,      ctAny,   ctAny,      ctAny      ),
+    ({ ctError }    ctError,   ctError, ctError, ctError,    ctError,    {$ifndef FPUNONE}ctError,   ctError, ctError,    {$endif}ctError,    ctError, ctError,    ctError    ),
+    ({ ctLongInt }  ctEmpty,   ctAny,   ctError, ctLongInt,  ctBoolean,  {$ifndef FPUNONE}ctFloat,   ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,  ctFloat,    ctFloat    ),
+    ({ ctBoolean }  ctEmpty,   ctAny,   ctError, ctLongInt,  ctBoolean,  {$ifndef FPUNONE}ctFloat,   ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,  ctWideStr,  ctString   ),
+{$ifndef FPUNONE}
+    ({ ctFloat }    ctEmpty,   ctAny,   ctError, ctFloat,    ctFloat,    ctFloat,   ctDate,  ctCurrency, ctFloat,    ctNull,  ctFloat,    ctFloat    ),
+    ({ ctDate }     ctEmpty,   ctAny,   ctError, ctDate,     ctDate,     ctDate,    ctDate,  ctDate,     ctDate,     ctNull,  ctDate,     ctDate     ),
+    ({ ctCurrency } ctEmpty,   ctAny,   ctError, ctCurrency, ctCurrency, ctCurrency,ctDate,  ctCurrency, ctCurrency, ctNull,  ctCurrency, ctCurrency ),
+{$endif}
+    ({ ctInt64 }    ctEmpty,   ctAny,   ctError, ctInt64,    ctInt64,    {$ifndef FPUNONE}ctFloat,   ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,  ctFloat,    ctFloat    ),
+    ({ ctNull }     ctEmpty,   ctAny,   ctError, ctNull,     ctNull,     {$ifndef FPUNONE}ctNull,    ctNull,  ctNull,     {$endif}ctNull,     ctNull,  ctNull,     ctNull     ),
+    ({ ctWideStr }  ctEmpty,   ctAny,   ctError, ctFloat,    ctWideStr,  {$ifndef FPUNONE}ctFloat,   ctDate,  ctCurrency, {$endif}ctFloat,    ctNull,  ctWideStr,  ctWideStr  ),
+    ({ ctString }   ctEmpty,   ctAny,   ctError, ctFloat,    ctString,   {$ifndef FPUNONE}ctFloat,   ctDate,  ctCurrency, {$endif}ctFloat,    ctNull,  ctWideStr,  ctString   )
+    );
+
+function DoVarCmpSimple (const Left, Right, Common: TCommonType) : ShortInt; inline;
+begin
+  if Left = Common then
+    if Right = Common then
+      Result := 0
+    else
+      Result := -1
+  else
+    Result := 1;
+end;
+
+function DoVarCmpAny(const Left, Right: TVarData; const OpCode: TVarOp) : ShortInt;
+begin
+  VarInvalidOp(Left.vType, Right.vType, OpCode);
+  Result:=0;
+end;
+
+function DoVarCmpLongInt(const Left, Right: LongInt): ShortInt; inline;
+begin
+  if Left < Right then
+    Result := -1
+  else if Left > Right then
+    Result := 1
+  else
+    Result := 0;
+end;
+
+{$ifndef FPUNONE}
+function DoVarCmpFloat(const Left, Right: Double; const OpCode: TVarOp): ShortInt;
+begin
+  if SameValue(Left, Right) then
+    Result := 0
+  else if (OpCode in [opCmpEq, opCmpNe]) or (Left < Right) then
+    Result := -1
+  else
+    Result := 1;
+end;
+{$endif}
+
+function DoVarCmpInt64(const Left, Right: Int64): ShortInt;
+begin
+  if Left < Right then
+    Result := -1
+  else if Left > Right then
+    Result := 1
+  else
+    Result := 0;
+end;
+
+function DoVarCmpNull(const Left, Right: TCommonType; const OpCode: TVarOp) : ShortInt;
+const
+  ResultMap: array [Boolean, opCmpEq..opCmpGe] of ShortInt =
+    ( ( -1, 0, 0, 1, 0, -1 ), ( 0, -1, -1, -1, 1, 1 ) );
+begin
+  if OpCode in [opCmpEq, opCmpNe] then
+    case NullEqualityRule of
+      ncrError:  VarInvalidNullOp;
+      ncrStrict: Result := ResultMap[False, OpCode];
+      ncrLoose:  Result := ResultMap[(Left = Right) xor (OpCode = opCmpNe), OpCode];
+    end
+  else
+    case NullMagnitudeRule of
+      ncrError:  VarInvalidNullOp;
+      ncrStrict: Result := ResultMap[False, OpCode];
+      ncrLoose:  Result := DoVarCmpSimple(Left, Right, ctNull);
+    end;
+end;
+
+function DoVarCmpCurr(const Left, Right: Currency): ShortInt;
+begin
+  if Left < Right then
+    Result := -1
+  else if Left > Right then
+    Result := 1
+  else
+    Result := 0;
+end;
+
+function DoVarCmpWStrDirect(const Left, Right: Pointer; const OpCode: TVarOp): ShortInt; inline;
+begin
+  { we can do this without ever copying the string }
+  if OpCode in [opCmpEq, opCmpNe] then
+    if Length(WideString(Left)) <> Length(WideString(Right)) then
+      Exit(-1);
+  Result := WideCompareStr(
+    WideString(Left),
+    WideString(Right)
+  );
+end;
+
+
+function DoVarCmpWStr(const Left, Right: TVarData; const OpCode: TVarOp): ShortInt;
+begin
+  { keep the temps away from the main proc }
+  Result := DoVarCmpWStrDirect(Pointer(VariantToWideString(Left)),
+    Pointer(VariantToWideString(Right)), OpCode);
+end;
+
+
+function DoVarCmpLStrDirect(const Left, Right: Pointer; const OpCode: TVarOp): ShortInt; inline;
+begin
+  { we can do this without ever copying the string }
+  if OpCode in [opCmpEq, opCmpNe] then
+    if Length(AnsiString(Left)) <> Length(AnsiString(Right)) then
+      Exit(-1);
+  Result := CompareStr(
+    AnsiString(Left),
+    AnsiString(Right)
+  );
+end;
+
+
+function DoVarCmpLStr(const Left, Right: TVarData; const OpCode: TVarOp): ShortInt;
+begin
+  { keep the temps away from the main proc }
+  Result := DoVarCmpLStrDirect(Pointer(VariantToAnsiString(Left)),
+    Pointer(VariantToAnsiString(Right)), OpCode);
+end;
+
+function DoVarCmpComplex(const Left, Right: TVarData; const OpCode: TVarOp): ShortInt;
+begin
+  {!! custom variants? }
+  VarInvalidOp(Left.vType, Right.vType, OpCode);
+  Result:=0;
+end;
+
+
+function DoVarCmp(const vl, vr : TVarData; const OpCode : TVarOp) : ShortInt;
+var
+  lct: TCommonType;
+  rct: TCommonType;
+begin
+  { as the function in cvarutil.inc can handle varByRef correctly we simply
+    resolve the final type }
+  lct := MapToCommonType(VarTypeDeRef(vl));
+  rct := MapToCommonType(VarTypeDeRef(vr));
+
+  {$IFDEF DEBUG_VARIANTS}
+  if __DEBUG_VARIANTS then begin
+    WriteLn('DoVarCmp $', IntToHex(Cardinal(@vl),8), ' ', GetEnumName(TypeInfo(TVarOp), Ord(OpCode)) ,' $', IntToHex(Cardinal(@vr),8));
+    DumpVariant('DoVarCmp/vl', vl);
+    WriteLn('lct ', GetEnumName(TypeInfo(TCommonType), Ord(lct)));
+
+    DumpVariant('DoVarCmp/vr', vr);
+    WriteLn('rct ', GetEnumName(TypeInfo(TCommonType), Ord(rct)));
+
+    WriteLn('common ', GetEnumName(TypeInfo(TCommonType), Ord(FindCmpCommonType[lct, rct])));
+  end;
+  {$ENDIF}
+
+  case FindCmpCommonType[lct, rct] of
+    ctEmpty:    Result := DoVarCmpSimple(lct, rct, ctEmpty);
+    ctAny:      Result := DoVarCmpAny(vl, vr, OpCode);
+    ctLongInt:  Result := DoVarCmpLongInt(VariantToLongInt(vl), VariantToLongInt(vr));
+{$ifndef FPUNONE}
+    ctFloat:    Result := DoVarCmpFloat(VariantToDouble(vl), VariantToDouble(vr), OpCode);
+{$endif}
+    ctBoolean:  Result := DoVarCmpLongInt(LongInt(VariantToBoolean(vl)), LongInt(VariantToBoolean(vr)));
+    ctInt64:    Result := DoVarCmpInt64(VariantToInt64(vl), VariantToInt64(vr));
+    ctNull:     Result := DoVarCmpNull(lct, rct, OpCode);
+    ctWideStr:
+      if (vl.vType = varOleStr) and (vr.vType = varOleStr) then
+        Result := DoVarCmpWStrDirect(Pointer(vl.vOleStr), Pointer(vr.vOleStr), OpCode)
+      else
+        Result := DoVarCmpWStr(vl, vr, OpCode);
+{$ifndef FPUNONE}
+    ctDate:     Result := DoVarCmpFloat(VariantToDate(vl), VariantToDate(vr), OpCode);
+    ctCurrency: Result := DoVarCmpCurr(VariantToCurrency(vl), VariantToCurrency(vr));
+{$endif}
+    ctString:
+      if (vl.vType = varString) and (vr.vType = varString) then
+        Result := DoVarCmpLStrDirect(Pointer(vl.vString), Pointer(vr.vString), OpCode)
+      else
+        Result := DoVarCmpLStr(vl, vr, OpCode);
+  else
+    Result := DoVarCmpComplex(vl, vr, OpCode);
+  end;
+end;
+
+function syscmpop (const Left, Right : Variant; const OpCode : TVarOp) : Boolean;
+var
+  CmpRes : ShortInt;
+begin
+  CmpRes:=DoVarCmp(TVarData(Left),TVarData(Right),OpCode);
+  case OpCode of
+    opCmpEq:
+      Result:=CmpRes=0;
+    opCmpNe:
+      Result:=CmpRes<>0;
+    opCmpLt:
+      Result:=CmpRes<0;
+    opCmpLe:
+      Result:=CmpRes<=0;
+    opCmpGt:
+      Result:=CmpRes>0;
+    opCmpGe:
+      Result:=CmpRes>=0;
+   else
+     VarInvalidOp;
+  end;
+end;
+
+
+const
+  FindOpCommonType : array[TCommonType,TCommonType] of TCommonType = (
+     {              ctEmpty  ctAny    ctError  ctLongInt   ctBoolean   ctFloat     ctDate   ctCurrency  ctInt64     ctNull    ctWideStr   ctString  }
+    ({ ctEmpty }    ctEmpty, ctAny,   ctError, ctEmpty,    ctEmpty,    {$ifndef FPUNONE}ctEmpty,    ctEmpty, ctEmpty,    {$endif}ctEmpty,    ctEmpty,  ctEmpty,    ctEmpty    ),
+    ({ ctAny }      ctAny,   ctAny,   ctError, ctAny,      ctAny,      {$ifndef FPUNONE}ctAny,      ctAny,   ctAny,      {$endif}ctAny,      ctAny,    ctAny,      ctAny      ),
+    ({ ctError }    ctError, ctError, ctError, ctError,    ctError,    {$ifndef FPUNONE}ctError,    ctError, ctError,    {$endif}ctError,    ctError,  ctError,    ctError    ),
+    ({ ctLongInt }  ctEmpty, ctAny,   ctError, ctLongInt,  ctBoolean,  {$ifndef FPUNONE}ctFloat,    ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,   ctFloat,    ctFloat    ),
+    ({ ctBoolean }  ctEmpty, ctAny,   ctError, ctLongInt,  ctBoolean,  {$ifndef FPUNONE}ctFloat,    ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,   ctBoolean,  ctBoolean  ),
+{$ifndef FPUNONE}
+    ({ ctFloat }    ctEmpty, ctAny,   ctError, ctFloat,    ctFloat,    ctFloat,    ctDate,  ctCurrency, ctFloat,    ctNull,   ctFloat,    ctFloat    ),
+    ({ ctDate }     ctEmpty, ctAny,   ctError, ctDate,     ctDate,     ctDate,     ctDate,  ctDate,     ctDate,     ctNull,   ctDate,     ctDate     ),
+    ({ ctCurrency } ctEmpty, ctAny,   ctError, ctCurrency, ctCurrency, ctCurrency, ctDate,  ctCurrency, ctCurrency, ctNull,   ctCurrency, ctCurrency ),
+{$endif}
+    ({ ctInt64 }    ctEmpty, ctAny,   ctError, ctInt64,    ctInt64,    {$ifndef FPUNONE}ctFloat,    ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,   ctFloat,    ctFloat    ),
+    ({ ctNull }     ctEmpty, ctAny,   ctError, ctNull,     ctNull,     {$ifndef FPUNONE}ctNull,     ctNull,  ctNull,     {$endif}ctNull,     ctNull,   ctNull,     ctNull     ),
+    ({ ctWideStr }  ctEmpty, ctAny,   ctError, ctFloat,    ctBoolean,  {$ifndef FPUNONE}ctFloat,    ctDate,  ctCurrency, {$endif}ctFloat,    ctNull,   ctWideStr,  ctWideStr  ),
+    ({ ctString }   ctEmpty, ctAny,   ctError, ctFloat,    ctBoolean,  {$ifndef FPUNONE}ctFloat,    ctDate,  ctCurrency, {$endif}ctFloat,    ctNull,   ctWideStr,  ctString   )
+    );
+
+procedure DoVarOpFloat(var vl :TVarData; const vr : TVarData; const OpCode : TVarOp);
+{$ifndef FPUNONE}
+var
+  l, r : Double;
+begin
+  l := VariantToDouble(vl);
+  r := VariantToDouble(vr);
+  case OpCode of
+    opAdd      :  l := l  + r;
+    opSubtract :  l := l  - r;
+    opMultiply :  l := l  * r;
+    opDivide   :  l := l  / r;
+    opPower    :  l := l ** r;
+  else
+    VarInvalidOp(vl.vType, vr.vType, OpCode);
+  end;
+  DoVarClearIfComplex(vl);
+  vl.vType := varDouble;
+  vl.vDouble := l;
+{$else}
+begin
+   VarInvalidOp(vl.vType, vr.vType, OpCode);
+{$endif}
+end;
+
+procedure DoVarOpAny(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
+begin
+  VarInvalidOp(vl.vType, vr.vType, OpCode);
+end;
+
+procedure DoVarOpLongInt(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
+var
+  l, r: LongInt;
+begin
+  l := VariantToLongint(vl);
+  r := VariantToLongint(vr);
+  case OpCode of
+    opIntDivide  : l := l div r;
+    opModulus    : l := l mod r;
+    opShiftLeft  : l := l shl r;
+    opShiftRight : l := l shr r;
+    opAnd        : l := l and r;
+    opOr         : l := l  or r;
+    opXor        : l := l xor r;
+  else
+    VarInvalidOp(vl.vType, vr.vType, OpCode);
+  end;
+  DoVarClearIfComplex(vl);
+  vl.vType := varInteger;
+  vl.vInteger := l;
+end;
+
+procedure DoVarOpInt64(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
+var
+  l, r     : Int64;
+  Overflow : Boolean;
+begin
+  l := VariantToInt64(vl);
+  r := VariantToInt64(vr);
+  Overflow := False;
+  case OpCode of
+    {$R+}{$Q+}
+    opAdd..opMultiply,opPower: try
+      case OpCode of
+        opAdd      :  l := l  + r;
+        opSubtract :  l := l  - r;
+        opMultiply :  l := l  * r;
+{$ifndef FPUNONE}
+        opPower    :  l := l ** r;
+{$endif}
+      end;
+    except
+      on E: SysUtils.ERangeError do
+        Overflow := True;
+      on E: SysUtils.EIntOverflow do
+        Overflow := True;
+    end;
+    {$IFDEF RANGECHECKINGOFF} {$R-} {$ENDIF} {$IFDEF OVERFLOWCHECKINGOFF} {$Q+} {$ENDIF}
+    opIntDivide  : l := l div r;
+    opModulus    : l := l mod r;
+    opShiftLeft  : l := l shl r;
+    opShiftRight : l := l shr r;
+    opAnd        : l := l and r;
+    opOr         : l := l  or r;
+    opXor        : l := l xor r;
+  else
+    VarInvalidOp(vl.vType, vr.vType, OpCode);
+  end;
+  if Overflow then
+    DoVarOpFloat(vl,vr,OpCode)
+  else begin
+    DoVarClearIfComplex(vl);
+    vl.vType := varInt64;
+    vl.vInt64 := l;
+  end;
+end;
+
+procedure DoVarOpInt64to32(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
+begin
+  { can't do this well without an efficent way to check for overflows,
+    let the Int64 version handle it and check the Result if we can downgrade it
+    to integer }
+  DoVarOpInt64(vl, vr, OpCode);
+  with vl do
+    if (vType = varInt64) and (vInt64 >= Low(LongInt)) and (vInt64 <= High(LongInt)) then begin
+      vInteger := vInt64;
+      vType := varInteger;
+    end;
+end;
+
+
+procedure DoVarOpBool(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
+var
+  l,r: Boolean;
+begin
+  l := VariantToBoolean(vl);
+  r := VariantToBoolean(vr);
+  case OpCode of
+    opAnd : l := l and r;
+    opOr  : l := l  or r;
+    opXor : l := l xor r;
+  else
+    VarInvalidOp(vl.vType, vr.vType, OpCode);
+  end;
+  DoVarClearIfComplex(vl);
+  vl.vType := varBoolean;
+  vl.vBoolean := l;
+end;
+
+procedure DoVarOpNull(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
+begin
+  if (OpCode = opAnd) or (OpCode = opOr) then
+    if vl.vType = varNull then begin
+      if vr.vType = varNull then begin
+        {both null, do nothing }
+      end else begin
+        {Left null, Right not}
+        if OpCode = opAnd then begin
+          if not VariantToBoolean(vr) then
+            VarCopyProc(vl, vr);
+        end else {OpCode = opOr} begin
+          if VariantToBoolean(vr) then
+            VarCopyProc(vl, vr);
+        end;
+      end;
+    end else begin
+      if vr.vType = varNull then begin
+        {Right null, Left not}
+        if OpCode = opAnd then begin
+          if VariantToBoolean(vl) then begin
+            DoVarClearIfComplex(vl);
+            vl.vType := varNull;
+          end;
+        end else {OpCode = opOr} begin
+          if not VariantToBoolean(vl) then begin
+            DoVarClearIfComplex(vl);
+            vl.vType := varNull;
+          end;
+        end;
+      end else begin
+        { both not null, shouldn't happen }
+        VarInvalidOp(vl.vType, vr.vType, OpCode);
+      end;
+    end
+  else begin
+    DoVarClearIfComplex(vl);
+    vl.vType := varNull;
+  end;
+end;
+
+procedure DoVarOpWStrCat(var vl : TVarData; const vr : TVarData);
+var
+  ws: WideString;
+begin
+  ws := VariantToWideString(vl) + VariantToWideString(vr);
+  DoVarClearIfComplex(vl);
+  vl.vType := varOleStr;
+  { transfer the WideString without making a copy }
+  Pointer(vl.vOleStr) := Pointer(ws);
+  { prevent the WideString from being freed, the reference has been transfered
+    from the local to the variant and will be correctly finalized when the
+    variant is finalized. }
+  Pointer(ws) := nil;
+end;
+
+procedure DoVarOpLStrCat(var vl: TVarData; const vr : TVarData);
+var
+  s: AnsiString;
+begin
+  s := VariantToAnsiString(vl) + VariantToAnsiString(vr);
+  DoVarClearIfComplex(vl);
+  vl.vType := varString;
+  { transfer the AnsiString without making a copy }
+  Pointer(vl.vString) := Pointer(s);
+  { prevent the AnsiString from being freed, the reference has been transfered
+    from the local to the variant and will be correctly finalized when the
+    variant is finalized. }
+  Pointer(s) := nil;
+end;
+
+procedure DoVarOpDate(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
+{$ifndef FPUNONE}
+var
+  l, r : TDateTime;
+begin
+  l := VariantToDate(vl);
+  r := VariantToDate(vr);
+  case OpCode of
+    opAdd      : l := l + r;
+    opSubtract : l := l - r;
+  else
+    VarInvalidOp(vl.vType, vr.vType, OpCode);
+  end;
+  DoVarClearIfComplex(vl);
+  vl.vType := varDate;
+  vl.vDate := l;
+{$else}
+begin
+   VarInvalidOp(vl.vType, vr.vType, OpCode);
+{$endif}
+end;
+
+procedure DoVarOpCurr(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp; const lct, rct : TCommonType);
+{$ifndef FPUNONE}
+var
+  c  : Currency;
+  d  : Double;
+begin
+  case OpCode of
+    opAdd:
+      c := VariantToCurrency(vl) + VariantToCurrency(vr);
+    opSubtract:
+      c := VariantToCurrency(vl) - VariantToCurrency(vr);
+    opMultiply:
+      if lct = ctCurrency then
+        if rct = ctCurrency then {both Currency}
+          c := VariantToCurrency(vl) * VariantToCurrency(vr)
+        else {Left Currency}
+          c := VariantToCurrency(vl) * VariantToDouble(vr)
+      else
+        if rct = ctCurrency then {rigth Currency}
+          c := VariantToDouble(vl) * VariantToCurrency(vr)
+        else {non Currency, error}
+          VarInvalidOp(vl.vType, vr.vType, OpCode);
+    opDivide:
+      if lct = ctCurrency then
+        if rct = ctCurrency then {both Currency}
+          c := VariantToCurrency(vl) / VariantToCurrency(vr)
+        else {Left Currency}
+          c := VariantToCurrency(vl) / VariantToDouble(vr)
+      else
+        if rct = ctCurrency then begin {rigth Currency}
+          d := VariantToCurrency(vl) / VariantToCurrency(vr);
+          DoVarClearIfComplex(vl);
+          vl.vType := varDouble;
+          vl.vDouble := d;
+          Exit;
+        end else {non Currency, error}
+          VarInvalidOp(vl.vType, vr.vType, OpCode);
+    opPower:
+      if lct = ctCurrency then
+        if rct = ctCurrency then {both Currency}
+          c := VariantToCurrency(vl) ** VariantToCurrency(vr)
+        else {Left Currency}
+          c := VariantToCurrency(vl) ** VariantToDouble(vr)
+      else
+        if rct = ctCurrency then {rigth Currency}
+          c := VariantToDouble(vl) ** VariantToCurrency(vr)
+        else {non Currency, error}
+          VarInvalidOp(vl.vType, vr.vType, OpCode);
+  else
+    VarInvalidOp(vl.vType, vr.vType, OpCode);
+  end;
+  DoVarClearIfComplex(vl);
+  vl.vType := varCurrency;
+  vl.vCurrency := c;
+{$else}
+begin
+   VarInvalidOp(vl.vType, vr.vType, OpCode);
+{$endif}
+end;
+
+procedure DoVarOpComplex(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
+begin
+  {custom Variant support? }
+   VarInvalidOp(vl.vType, vr.vType, OpCode);
+end;
+
+procedure SysVarOp(var Left : Variant; const Right : Variant; OpCode : TVarOp);
+var
+  lct: TCommonType;
+  rct: TCommonType;
+  {$IFDEF DEBUG_VARIANTS}
+  i: Integer;
+  {$ENDIF}
+begin
+  { as the function in cvarutil.inc can handle varByRef correctly we simply
+    resolve the final type }
+  lct := MapToCommonType(VarTypeDeRef(Left));
+  rct := MapToCommonType(VarTypeDeRef(Right));
+
+  {$IFDEF DEBUG_VARIANTS}
+  if __DEBUG_VARIANTS then begin
+    WriteLn('SysVarOp $', IntToHex(Cardinal(@TVarData(Left)),8), ' ', GetEnumName(TypeInfo(TVarOp), Ord(OpCode)) ,' $', IntToHex(Cardinal(@TVarData(Right)),8));
+    DumpVariant('SysVarOp/TVarData(Left)', TVarData(Left));
+    WriteLn('lct ', GetEnumName(TypeInfo(TCommonType), Ord(lct)));
+
+    DumpVariant('SysVarOp/TVarData(Right)', TVarData(Right));
+    WriteLn('rct ', GetEnumName(TypeInfo(TCommonType), Ord(rct)));
+
+    WriteLn('common ', GetEnumName(TypeInfo(TCommonType), Ord(FindOpCommonType[lct, rct])));
+  end;
+  {$ENDIF}
+
+  case FindOpCommonType[lct, rct] of
+    ctEmpty:
+      case OpCode of
+        opDivide:
+          Error(reZeroDivide);
+        opIntDivide, opModulus:
+          Error(reDivByZero);
+      else
+        DoVarClear(TVarData(Left));
+      end;
+    ctAny:
+      DoVarOpAny(TVarData(Left),TVarData(Right),OpCode);
+    ctLongInt:
+      case OpCode of
+        opAdd..opMultiply,opPower:
+          DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
+        opDivide:
+          DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
+      else
+        DoVarOpLongInt(TVarData(Left),TVarData(Right),OpCode);
+      end;
+{$ifndef FPUNONE}
+    ctFloat:
+      if OpCode in [opAdd,opSubtract,opMultiply,opDivide] then
+        DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode)
+      else
+        DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
+{$endif}
+    ctBoolean:
+      case OpCode of
+        opAdd..opMultiply, opPower:
+          DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
+        opIntDivide..opShiftRight:
+          DoVarOpLongInt(TVarData(Left),TVarData(Right),OpCode);
+        opAnd..opXor:
+          DoVarOpBool(TVarData(Left),TVarData(Right),OpCode);
+      else
+        VarInvalidOp(TVarData(Left).vType, TVarData(Right).vType, OpCode);
+      end;
+    ctInt64:
+      if OpCode <> opDivide then
+        DoVarOpInt64(TVarData(Left),TVarData(Right),OpCode)
+      else
+        DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
+    ctNull:
+      DoVarOpNull(TVarData(Left),TVarData(Right),OpCode);
+    ctWideStr:
+      case OpCode of
+        opAdd:
+          DoVarOpWStrCat(TVarData(Left),TVarData(Right));
+        opSubtract..opDivide,opPower:
+          DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
+        opIntDivide..opXor:
+          DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
+      else
+        VarInvalidOp(TVarData(Left).vType, TVarData(Right).vType, OpCode);
+      end;
+{$ifndef FPUNONE}
+    ctDate:
+      case OpCode of
+        opAdd:
+          DoVarOpDate(TVarData(Left),TVarData(Right),OpCode);
+        opSubtract: begin
+          DoVarOpDate(TVarData(Left),TVarData(Right),OpCode);
+            if lct = rct then {both are date}
+              TVarData(Left).vType := varDouble;
+        end;
+        opMultiply, opDivide:
+          DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
+      else
+        DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
+      end;
+    ctCurrency:
+      if OpCode in [opAdd..opDivide, opPower] then
+        DoVarOpCurr(TVarData(Left),TVarData(Right),OpCode, lct, rct)
+      else
+        DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
+{$endif}
+    ctString:
+      case OpCode of
+        opAdd:
+          DoVarOpLStrCat(TVarData(Left),TVarData(Right));
+        opSubtract..opDivide,opPower:
+          DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
+        opIntDivide..opXor:
+          DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
+      else
+        VarInvalidOp(TVarData(Left).vType, TVarData(Right).vType, OpCode);
+      end;
+  else
+    { more complex case }
+    DoVarOpComplex(TVarData(Left),TVarData(Right),OpCode);
+  end;
+end;
+
+procedure DoVarNegAny(var v: TVarData);
+begin
+  VarInvalidOp(v.vType, opNegate);
+end;
+
+procedure DoVarNegComplex(var v: TVarData);
+begin
+  { custom variants? }
+  VarInvalidOp(v.vType, opNegate);
+end;
+
+procedure sysvarneg(var v: Variant);
+const
+  BoolMap: array [Boolean] of SmallInt = (0, -1);
+begin
+  with TVarData(v) do case vType of
+    varEmpty: begin
+      vSmallInt := 0;
+      vType := varSmallInt;
+    end;
+    varNull:;
+    varSmallint: vSmallInt := -vSmallInt;
+    varInteger:  vInteger  := -vInteger;
+{$ifndef FPUNONE}
+    varSingle:   vSingle   := -vSingle;
+    varDouble:   vDouble   := -vDouble;
+    varCurrency: vCurrency := -vCurrency;
+    varDate:     vDate     := -vDate;
+    varOleStr:   sysvarfromreal(v, -VariantToDouble(TVarData(v)));
+{$else}
+    varOleStr:   sysvarfromint64(v, -VariantToInt64(TVarData(v)));
+{$endif}
+    varBoolean: begin
+      vSmallInt := BoolMap[vBoolean];
+      vType := varSmallInt;
+    end;
+    varShortInt: vShortInt := -vShortInt;
+    varByte: begin
+      vSmallInt := -vByte;
+      vType := varSmallInt;
+    end;
+    varWord: begin
+      vInteger := -vWord;
+      vType := varInteger;
+    end;
+    varLongWord:
+      if vLongWord and $80000000 <> 0 then begin
+        vInt64 := -vLongWord;
+        vType := varInt64;
+      end else begin
+        vInteger := -vLongWord;
+        vType := varInteger;
+      end;
+    varInt64:    vInt64    := -vInt64;
+    varQWord: begin
+      if vQWord and $8000000000000000 <> 0 then
+        VarRangeCheckError(varQWord, varInt64);
+      vInt64 := -vQWord;
+      vType := varInt64;
+    end;
+    varVariant:  v         := -Variant(PVarData(vPointer)^);
+  else {with TVarData(v) do case vType of}
+    case vType of
+{$ifndef FPUNONE}
+      varString:   sysvarfromreal(v, -VariantToDouble(TVarData(v)));
+{$else}
+      varString:   sysvarfromint64(v, -VariantToInt64(TVarData(v)));
+{$endif}
+      varAny:      DoVarNegAny(TVarData(v));
+    else {case vType of}
+      if (vType and not varTypeMask) = varByRef then
+        case vType and varTypeMask of
+          varSmallInt: begin
+            vSmallInt := -PSmallInt(vPointer)^;
+            vType := varSmallInt;
+          end;
+          varInteger: begin
+            vInteger := -PInteger(vPointer)^;
+            vType := varInteger;
+          end;
+{$ifndef FPUNONE}
+          varSingle: begin
+            vSingle := -PSingle(vPointer)^;
+            vType := varSingle;
+          end;
+          varDouble: begin
+            vDouble := -PDouble(vPointer)^;
+            vType := varDouble;
+          end;
+          varCurrency: begin
+            vCurrency := -PCurrency(vPointer)^;
+            vType := varCurrency;
+          end;
+          varDate: begin
+            vDate := -PDate(vPointer)^;
+            vType := varDate;
+          end;
+          varOleStr: sysvarfromreal(v, -VariantToDouble(TVarData(v)));
+{$else}
+          varOleStr: sysvarfromint64(v, -VariantToInt64(TVarData(v)));
+{$endif}
+          varBoolean: begin
+            vSmallInt := BoolMap[PWordBool(vPointer)^];
+            vType := varSmallInt;
+          end;
+          varShortInt: begin
+            vShortInt := -PShortInt(vPointer)^;
+            vType := varShortInt;
+          end;
+          varByte: begin
+            vSmallInt := -PByte(vPointer)^;
+            vType := varSmallInt;
+          end;
+          varWord: begin
+            vInteger := -PWord(vPointer)^;
+            vType := varInteger;
+          end;
+          varLongWord:
+            if PLongWord(vPointer)^ and $80000000 <> 0 then begin
+              vInt64 := -PLongWord(vPointer)^;
+              vType := varInt64;
+            end else begin
+              vInteger := -PLongWord(vPointer)^;
+              vType := varInteger;
+            end;
+          varInt64: begin
+            vInt64 := -PInt64(vPointer)^;
+            vType := varInt64;
+          end;
+          varQWord: begin
+            if PQWord(vPointer)^ and $8000000000000000 <> 0 then
+              VarRangeCheckError(varQWord, varInt64);
+            vInt64 := -PQWord(vPointer)^;
+            vType := varInt64;
+          end;
+          varVariant:
+            v := -Variant(PVarData(vPointer)^);
+        else {case vType and varTypeMask of}
+          DoVarNegComplex(TVarData(v));
+        end {case vType and varTypeMask of}
+      else {if (vType and not varTypeMask) = varByRef}
+        DoVarNegComplex(TVarData(v));
+    end; {case vType of}
+  end; {with TVarData(v) do case vType of}
+end;
+
+procedure DoVarNotAny(var v: TVarData);
+begin
+  VarInvalidOp(v.vType, opNot);
+end;
+
+procedure DoVarNotOrdinal(var v: TVarData);
+var
+  i: Int64;
+begin
+  { only called for types that do no require finalization }
+  i := VariantToInt64(v);
+  with v do
+    if (i < Low(Integer)) or (i > High(Integer)) then begin
+      vInt64 := not i;
+      vType := varInt64;
+    end else begin
+      vInteger := not Integer(i);
+      vType := varInteger;
+    end
+end;
+
+procedure DoVarNotWStr(var v: TVarData; const p: Pointer);
+var
+  i: Int64;
+  e: Word;
+  b: Boolean;
+begin
+  Val(WideString(p), i, e);
+  with v do
+    if e = 0 then begin
+      DoVarClearIfComplex(v);
+      if (i < Low(Integer)) or (i > High(Integer)) then begin
+        vInt64 := not i;
+        vType := varInt64;
+      end else begin
+        vInteger := not Integer(i);
+        vType := varInteger;
+      end
+    end else begin
+      if not TryStrToBool(WideString(p), b) then
+        VarInvalidOp(vType, opNot);
+      DoVarClearIfComplex(v);
+      vBoolean := not b;
+      vType := varBoolean;
+    end;
+end;
+
+procedure DoVarNotLStr(var v: TVarData; const p: Pointer);
+var
+  i: Int64;
+  e: Word;
+  b: Boolean;
+begin
+  Val(AnsiString(p), i, e);
+  with v do
+    if e = 0 then begin
+      DoVarClearIfComplex(v);
+      if (i < Low(Integer)) or (i > High(Integer)) then begin
+        vInt64 := not i;
+        vType := varInt64;
+      end else begin
+        vInteger := not Integer(i);
+        vType := varInteger;
+      end
+    end else begin
+      if not TryStrToBool(AnsiString(p), b) then
+        VarInvalidOp(v.vType, opNot);
+      DoVarClearIfComplex(v);
+      vBoolean := not b;
+      vType := varBoolean;
+    end;
+end;
+
+procedure DoVarNotComplex(var v: TVarData);
+begin
+  { custom variant support ?}
+  VarInvalidOp(v.vType, opNot);
+end;
+
+procedure sysvarnot(var v: Variant);
+begin
+  with TVarData(v) do case vType of
+    varEmpty:    v := -1;
+    varNull:;
+    varSmallint: vSmallInt := not vSmallInt;
+    varInteger:  vInteger  := not vInteger;
+{$ifndef FPUNONE}
+    varSingle,
+    varDouble,
+    varCurrency,
+    varDate:     DoVarNotOrdinal(TVarData(v));
+{$endif}
+    varOleStr:   DoVarNotWStr(TVarData(v), Pointer(vOleStr));
+    varBoolean:  vBoolean := not vBoolean;
+    varShortInt: vShortInt := not vShortInt;
+    varByte:     vByte := not vByte;
+    varWord:     vWord := not vWord;
+    varLongWord: vLongWord := not vLongWord;
+    varInt64:    vInt64    := not vInt64;
+    varQWord:    vQWord    := not vQWord;
+    varVariant:  v         := not Variant(PVarData(vPointer)^);
+  else {with TVarData(v) do case vType of}
+    case vType of
+      varString:   DoVarNotLStr(TVarData(v), Pointer(vString));
+      varAny:      DoVarNotAny(TVarData(v));
+    else {case vType of}
+      if (vType and not varTypeMask) = varByRef then
+        case vType and varTypeMask of
+          varSmallInt: begin
+            vSmallInt := not PSmallInt(vPointer)^;
+            vType := varSmallInt;
+          end;
+          varInteger: begin
+            vInteger := not PInteger(vPointer)^;
+            vType := varInteger;
+          end;
+{$ifndef FPUNONE}
+          varSingle,
+          varDouble,
+          varCurrency,
+          varDate: DoVarNotOrdinal(TVarData(v));
+{$endif}
+          varOleStr: DoVarNotWStr(TVarData(v), PPointer(vPointer)^);
+          varBoolean: begin
+            vBoolean := not PWordBool(vPointer)^;
+            vType := varBoolean;
+          end;
+          varShortInt: begin
+            vShortInt := not PShortInt(vPointer)^;
+            vType := varShortInt;
+          end;
+          varByte: begin
+            vByte := not PByte(vPointer)^;
+            vType := varByte;
+          end;
+          varWord: begin
+            vWord := not PWord(vPointer)^;
+            vType := varWord;
+          end;
+          varLongWord: begin
+            vLongWord := not PLongWord(vPointer)^;
+            vType := varLongWord;
+          end;
+          varInt64: begin
+            vInt64 := not PInt64(vPointer)^;
+            vType := varInt64;
+          end;
+          varQWord: begin
+            vQWord := not PQWord(vPointer)^;
+            vType := varQWord;
+          end;
+          varVariant:
+            v := not Variant(PVarData(vPointer)^);
+        else {case vType and varTypeMask of}
+          DoVarNotComplex(TVarData(v));
+        end {case vType and varTypeMask of}
+      else {if (vType and not varTypeMask) = varByRef}
+        DoVarNotComplex(TVarData(v));
+    end; {case vType of}
+  end; {with TVarData(v) do case vType of}
+end;
+
+{
+  Clears variant array. If array element type is varVariant, then
+  clear each element individually first.
+}
+procedure DoVarClearArray(var VArray: TVarData);
+var
+  arr: pvararray;
+  i, cnt: cardinal;
+  data: pvardata;
+begin
+  if VArray.vtype and varTypeMask = varVariant then begin
+    if WordBool(VArray.vType and varByRef) then
+      arr:=PVarArray(VArray.vPointer^)
+    else
+      arr:=VArray.vArray;
+    VarResultCheck(SafeArrayAccessData(arr, data));
+    try
+      { Calculation total number of elements in the array }
+      cnt:=1;
+      for i:=0 to arr^.dimcount - 1 do
+        cnt:=cnt*cardinal(arr^.Bounds[i].ElementCount);
+      { Clearing each element }
+      for i:=1 to cnt do begin
+        DoVarClear(data^);
+        Inc(data);
+      end;
+    finally
+      VarResultCheck(SafeArrayUnaccessData(arr));
+    end;
+  end;
+  VariantClear(VArray);
+end;
+
+procedure DoVarClearComplex(var v : TVarData);
+var
+  Handler : TCustomVariantType;
+begin
+  with v do
+    if vType < varInt64 then
+      VarResultCheck(VariantClear(v))
+    else if vType = varString then begin
+      AnsiString(vString) := '';
+      vType := varEmpty
+    end else if vType = varAny then
+      ClearAnyProc(v)
+    else if vType and varArray <> 0 then
+      DoVarClearArray(v)
+    else if FindCustomVariantType(vType, Handler) then
+      Handler.Clear(v)
+    else begin
+      { ignore errors, if the OS doesn't know how to free it, we don't either }
+      VariantClear(v);
+      vType := varEmpty;
+    end;
+end;
+
+type
+  TVarArrayCopyCallback = procedure(var aDest: TVarData; const aSource: TVarData);
+
+procedure DoVarCopyArray(var aDest: TVarData; const aSource: TVarData; aCallback: TVarArrayCopyCallback);
+var
+  SourceArray : PVarArray;
+  SourcePtr   : Pointer;
+  DestArray   : PVarArray;
+  DestPtr     : Pointer;
+
+  Bounds      : array[0..63] of TVarArrayBound;
+  Iterator    : TVariantArrayIterator;
+
+  Dims        : Integer;
+  HighBound   : Integer;
+  i           : Integer;
+begin
+  with aSource do begin
+    if vType and varArray = 0 then
+      VarResultCheck(VAR_INVALIDARG);
+
+    if (vType and varTypeMask) = varVariant then begin
+
+      if (vType and varByRef) <> 0 then
+        SourceArray := PVarArray(vPointer^)
+      else
+        SourceArray := vArray;
+
+      Dims := SourceArray^.DimCount;
+      for i := 0 to Pred(Dims) do
+        with Bounds[i] do begin
+          VarResultCheck(SafeArrayGetLBound(SourceArray, Succ(i), LowBound));
+          VarResultCheck(SafeArrayGetUBound(SourceArray, Succ(i), HighBound));
+          ElementCount := HighBound - LowBound + 1;
+        end;
+
+      DestArray := SafeArrayCreate(varVariant, Dims, PVarArrayBoundArray(@Bounds)^);
+      if not Assigned(DestArray) then
+        VarArrayCreateError;
+
+      DoVarClearIfComplex(aDest);
+      with aDest do begin
+        vType := varVariant or varArray;
+        vArray := DestArray;
+      end;
+
+      Iterator.Init(Dims, @Bounds);
+      try
+        if not(Iterator.AtEnd) then
+          repeat
+            VarResultCheck(SafeArrayPtrOfIndex(SourceArray, Iterator.Coords, SourcePtr));
+            VarResultCheck(SafeArrayPtrOfIndex(DestArray, Iterator.Coords, DestPtr));
+            aCallback(PVarData(DestPtr)^, PVarData(SourcePtr)^);
+          until not Iterator.Next;
+      finally
+        Iterator.Done;
+      end;
+
+    end else
+      VarResultCheck(VariantCopy(aDest, aSource));
+  end;
+end;
+
+procedure DoVarCopyComplex(var Dest: TVarData; const Source: TVarData);
+var
+  Handler: TCustomVariantType;
+begin
+  DoVarClearIfComplex(Dest);
+
+  with Source do
+    if vType < varInt64 then
+      VarResultCheck(VariantCopy(Dest, Source))
+    else if vType = varString then begin
+      Dest.vType := varString;
+      Dest.vString := nil;
+      AnsiString(Dest.vString) := AnsiString(vString);
+    end else if vType = varAny then begin
+      Dest := Source;
+      RefAnyProc(Dest);
+    end else if vType and varArray <> 0 then
+      DoVarCopyArray(Dest, Source, @DoVarCopy)
+    else if FindCustomVariantType(vType, Handler) then
+      Handler.Copy(Dest, Source, False)
+    else
+      VarResultCheck(VariantCopy(Dest, Source));
+end;
+
+procedure DoVarCopy(var Dest : TVarData; const Source : TVarData);
+begin
+  if @Dest <> @Source then
+    if (Source.vType and varComplexType) = 0 then begin
+      DoVarClearIfComplex(Dest);
+      Dest := Source;
+    end else
+      DoVarCopyComplex(Dest, Source);
+end;
+
+procedure sysvarcopy (var Dest : Variant; const Source : Variant);
+begin
+  DoVarCopy(TVarData(Dest),TVarData(Source));
+end;
+
+procedure DoVarAddRef(var v : TVarData); inline;
+var
+  Dummy : TVarData;
+begin
+  Dummy := v;
+  v.vType := varEmpty;
+  DoVarCopy(v, Dummy);
+end;
+
+procedure sysvaraddref(var v : Variant);
+begin
+  DoVarAddRef(TVarData(v));
+end;
+
+procedure DoVarCastWStr(var aDest : TVarData; const aSource : TVarData);
+begin
+  SysVarFromWStr(Variant(aDest), VariantToWideString(aSource));
+end;
+
+procedure DoVarCastLStr(var aDest : TVarData; const aSource : TVarData);
+begin
+  SysVarFromLStr(Variant(aDest), VariantToAnsiString(aSource));
+end;
+
+procedure DoVarCastDispatch(var aDest : TVarData; const aSource : TVarData);
+var
+  Disp: IDispatch;
+begin
+  SysVarToDisp(Disp, Variant(aSource));
+  SysVarFromDisp(Variant(aDest), Disp);
+end;
+
+procedure DoVarCastInterface(var aDest : TVarData; const aSource : TVarData);
+var
+  Intf: IInterface;
+begin
+  SysVarToIntf(Intf, Variant(aSource));
+  SysVarFromIntf(Variant(aDest), Intf);
+end;
+
+procedure DoVarCastAny(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
+begin
+  VarCastError(aSource.vType, aVarType)
+end;
+
+procedure DoVarCastFallback(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
+begin
+  if aSource.vType and varTypeMask >= varInt64 then begin
+    DoVarCast(aDest, aSource, varOleStr);
+    VarResultCheck(VariantChangeTypeEx(aDest, aDest, VAR_LOCALE_USER_DEFAULT,
+      0, aVarType), aSource.vType, aVarType);
+  end else if aVarType and varTypeMask < varInt64 then
+    VarResultCheck(VariantChangeTypeEx(aDest, aSource, VAR_LOCALE_USER_DEFAULT,
+      0, aVarType), aSource.vType, aVarType)
+  else
+    VarCastError(aSource.vType, aVarType);
+end;
+
+procedure DoVarCastComplex(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
+var
+  Handler: TCustomVariantType;
+begin
+  if aSource.vType = varAny then
+    DoVarCastAny(aDest, aSource, aVarType)
+  else if FindCustomVariantType(aSource.vType, Handler) then
+    Handler.CastTo(aDest, aSource, aVarType)
+  else if FindCustomVariantType(aVarType, Handler) then
+    Handler.Cast(aDest, aSource)
+  else
+    DoVarCastFallback(aDest, aSource, aVarType);
+end;
+
+procedure DoVarCast(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
+begin
+  with aSource do
+    if vType = aVarType then
+      DoVarCopy(aDest, aSource)
+    else begin
+      if (vType = varNull) and NullStrictConvert then
+        VarCastError(varNull, aVarType);
+
+      case aVarType of
+        varEmpty, varNull: begin
+          DoVarClearIfComplex(aDest);
+          aDest.vType := aVarType;
+        end;
+        varSmallInt: SysVarFromInt(Variant(aDest), VariantToSmallInt(aSource), -2);
+        varInteger:  SysVarFromInt(Variant(aDest), VariantToLongInt(aSource), -4);
+{$ifndef FPUNONE}
+        varSingle:   SysVarFromSingle(Variant(aDest), VariantToSingle(aSource));
+        varDouble:   SysVarFromDouble(Variant(aDest), VariantToDouble(aSource));
+        varCurrency: SysVarFromCurr(Variant(aDest), VariantToCurrency(aSource));
+        varDate:     SysVarFromTDateTime(Variant(aDest), VariantToDate(aSource));
+{$endif}
+        varOleStr:   DoVarCastWStr(aDest, aSource);
+        varBoolean:  SysVarFromBool(Variant(aDest), VariantToBoolean(aSource));
+        varShortInt: SysVarFromInt(Variant(aDest), VariantToShortInt(aSource), -1);
+        varByte:     SysVarFromInt(Variant(aDest), VariantToByte(aSource), 1);
+        varWord:     SysVarFromInt(Variant(aDest), VariantToLongInt(aSource), 2);
+        varLongWord: SysVarFromInt(Variant(aDest), Integer(VariantToCardinal(aSource)), 4);
+        varInt64:    SysVarFromInt64(Variant(aDest), VariantToInt64(aSource));
+        varQWord:    SysVarFromWord64(Variant(aDest), VariantToQWord(aSource));
+
+        varDispatch: DoVarCastDispatch(aDest, aSource);
+        varUnknown:  DoVarCastInterface(aDest, aSource);
+      else
+        case aVarType of
+          varString: DoVarCastLStr(aDest, aSource);
+          varAny:    VarCastError(vType, varAny);
+        else
+          DoVarCastComplex(aDest, aSource, aVarType);
+        end;
+      end;
+    end;
+
+end;
+
+procedure sysvarcast (var aDest : Variant; const aSource : Variant; aVarType : LongInt);
+begin
+  DoVarCast(TVarData(aDest), TVarData(aSource), aVarType);
+end;
+
+
+procedure sysvarfromdynarray(var Dest : Variant; const Source : Pointer; TypeInfo: Pointer);
+begin
+  DynArrayToVariant(Dest,Source,TypeInfo);
+  if VarIsEmpty(Dest) then
+    VarCastError;
+end;
+
+
+procedure sysolevarfrompstr(var Dest : olevariant; const Source : ShortString);
+begin
+  sysvarfromwstr(Variant(TVarData(Dest)), Source);
+end;
+
+
+procedure sysolevarfromlstr(var Dest : olevariant; const Source : AnsiString);
+begin
+  sysvarfromwstr(Variant(TVarData(Dest)), Source);
+end;
+
+procedure DoOleVarFromAny(var aDest : TVarData; const aSource : TVarData);
+begin
+  VarCastErrorOle(aSource.vType);
+end;
+
+procedure DoOleVarFromVar(var aDest : TVarData; const aSource : TVarData);
+var
+  Handler: TCustomVariantType;
+begin
+  with aSource do
+    if vType = varByRef or varVariant then
+      DoOleVarFromVar(aDest, PVarData(vPointer)^)
+    else begin
+      case vType of
+        varShortInt, varByte, varWord:
+          DoVarCast(aDest, aSource, varInteger);
+        varLongWord:
+          if vLongWord and $80000000 = 0 then
+            DoVarCast(aDest, aSource, varInteger)
+          else
+{$ifndef FPUNONE}
+            if OleVariantInt64AsDouble then
+              DoVarCast(aDest, aSource, varDouble)
+            else
+{$endif}
+              DoVarCast(aDest, aSource, varInt64);
+        varInt64:
+          if (vInt64 < Low(Integer)) or (vInt64 > High(Integer)) then
+{$ifndef FPUNONE}
+            if OleVariantInt64AsDouble then
+              DoVarCast(aDest, aSource, varDouble)
+            else
+{$endif}
+              DoVarCast(aDest, aSource, varInt64)
+          else
+            DoVarCast(aDest, aSource, varInteger);
+        varQWord:
+          if vQWord > High(Integer) then
+{$ifndef FPUNONE}
+            if OleVariantInt64AsDouble or (vQWord and $8000000000000000 <> 0) then
+              DoVarCast(aDest, aSource, varDouble)
+            else
+{$endif}
+              DoVarCast(aDest, aSource, varInt64)
+          else
+            DoVarCast(aDest, aSource, varInteger);
+        varString:
+          DoVarCast(aDest, aSource, varOleStr);
+        varAny:
+          DoOleVarFromAny(aDest, aSource);
+      else
+        if (vType and varArray) <> 0 then
+          DoVarCopyArray(aDest, aSource, @DoOleVarFromVar)
+        else if (vType and varTypeMask) < CFirstUserType then
+          DoVarCopy(aDest, aSource)
+        else if FindCustomVariantType(vType, Handler) then
+          Handler.CastToOle(aDest, aSource)
+        else
+          VarCastErrorOle(vType);
+      end;
+    end;
+end;
+
+procedure sysolevarfromvar(var aDest : OleVariant; const aSource : Variant);
+begin
+  DoOleVarFromVar(TVarData(aDest), TVarData(aSource));
+end;
+
+procedure sysolevarfromint(var Dest : olevariant; const Source : LongInt; const range : ShortInt);
+begin
+  DoVarClearIfComplex(TVarData(Dest));
+  with TVarData(Dest) do begin
+    vInteger := Source;
+    vType := varInteger;
+  end;
+end;
+
+procedure DoVarCastOle(var aDest: TVarData; const aSource: TVarData; aVarType: LongInt);
+var
+  Handler: TCustomVariantType;
+begin
+  with aSource do
+  if vType = varByRef or varVariant then
+    DoVarCastOle(aDest, PVarData(VPointer)^, aVarType)
+  else
+    if (aVarType = varString) or (aVarType = varAny) then
+      VarCastError(vType, aVarType)
+    else if FindCustomVariantType(vType, Handler) then
+      Handler.CastTo(aDest, aSource, aVarType)
+    else
+      DoVarCast(aDest, aSource, aVarType);
+end;
+
+procedure sysvarcastole(var Dest : Variant; const Source : Variant; aVarType : LongInt);
+begin
+  DoVarCastOle(TVarData(Dest), TVarData(Source), aVarType);
+end;
+
+
+procedure sysdispinvoke(Dest : PVarData; const Source : TVarData;calldesc : pcalldesc;params : Pointer);cdecl;
+var
+  temp  : TVarData;
+  tempp : ^TVarData;
+  customvarianttype : TCustomVariantType;
+begin
+  if Source.vType=(varByRef or varVariant) then
+    sysdispinvoke(Dest,PVarData(Source.vPointer)^,calldesc,params)
+  else
+    begin
+      try
+        { get a defined Result }
+        if not(assigned(Dest)) then
+          tempp:=nil
+        else
+          begin
+            fillchar(temp,SizeOf(temp),0);
+            tempp:=@temp;
+          end;
+        case Source.vType of
+          varDispatch,
+          varAny,
+          varUnknown,
+          varDispatch or varByRef,
+          varAny or varByRef,
+          varUnknown or varByRef:
+            VarDispProc(pvariant(tempp),Variant(Source),calldesc,params);
+          else
+            begin
+              if FindCustomVariantType(Source.vType,customvarianttype) then
+                customvarianttype.DispInvoke(tempp,Source,calldesc,params)
+              else
+                VarInvalidOp;
+            end;
+        end;
+      finally
+        if assigned(tempp) then
+          begin
+            DoVarCopy(Dest^,tempp^);
+            DoVarClear(temp);
+          end;
+      end;
+    end;
+end;
+
+
+procedure sysvararrayredim(var a : Variant;highbound : SizeInt);
+var
+  src : TVarData;
+  p : pvararray;
+  newbounds : tvararraybound;
+begin
+  src:=TVarData(a);
+  { get final Variant }
+  while src.vType=varByRef or varVariant do
+    src:=TVarData(src.vPointer^);
+
+  if (src.vType and varArray)<>0 then
+    begin
+      { get Pointer to the array }
+      if (src.vType and varByRef)<>0 then
+        p:=pvararray(src.vPointer^)
+      else
+        p:=src.vArray;
+
+      if highbound<p^.Bounds[p^.dimcount-1].LowBound-1 then
+        VarInvalidArgError;
+
+      newbounds.LowBound:=p^.Bounds[p^.dimcount-1].LowBound;
+      newbounds.ElementCount:=highbound-newbounds.LowBound+1;
+
+      VarResultCheck(SafeArrayRedim(p,newbounds));
+    end
+  else
+    VarInvalidArgError(src.vType);
+end;
+
+
+function getfinalvartype(const v : TVarData) : TVarType;{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
+var
+  p: PVarData;
+begin
+  p := @v;
+  while p^.vType = varByRef or varVariant do
+    p := PVarData(p^.vPointer);
+  Result := p^.vType;
+end;
+
+
+function sysvararrayget(const a : Variant;indexcount : SizeInt;indices : psizeint) : Variant;cdecl;
+var
+  src : TVarData;
+  p : pvararray;
+  arraysrc : pvariant;
+  arrayelementtype : TVarType;
+begin
+  src:=TVarData(a);
+  { get final Variant }
+  while src.vType=varByRef or varVariant do
+    src:=TVarData(src.vPointer^);
+
+  if (src.vType and varArray)<>0 then
+    begin
+      { get Pointer to the array }
+      if (src.vType and varByRef)<>0 then
+        p:=pvararray(src.vPointer^)
+      else
+        p:=src.vArray;
+
+      { number of indices ok? }
+      if p^.DimCount<>indexcount then
+        VarInvalidArgError;
+
+      arrayelementtype:=src.vType and varTypeMask;
+      if arrayelementtype=varVariant then
+        begin
+          VarResultCheck(SafeArrayPtrOfIndex(p,PVarArrayCoorArray(indices),arraysrc));
+          Result:=arraysrc^;
+        end
+      else
+        begin
+          TVarData(Result).vType:=arrayelementtype;
+          VarResultCheck(SafeArrayGetElement(p,PVarArrayCoorArray(indices),@TVarData(Result).vPointer));
+        end;
+    end
+  else
+    VarInvalidArgError(src.vType);
+end;
+
+
+procedure sysvararrayput(var a : Variant; const value : Variant;indexcount : SizeInt;indices : psizeint);cdecl;
+var
+  Dest : TVarData;
+  p : pvararray;
+  arraydest : pvariant;
+  valuevtype,
+  arrayelementtype : TVarType;
+  tempvar : Variant;
+  variantmanager : tvariantmanager;
+begin
+  Dest:=TVarData(a);
+  { get final Variant }
+  while Dest.vType=varByRef or varVariant do
+    Dest:=TVarData(Dest.vPointer^);
+
+  valuevtype:=getfinalvartype(TVarData(value));
+
+  if not(VarTypeIsValidElementType(valuevtype)) and
+    { varString isn't a valid varArray type but it is converted
+      later }
+    (valuevtype<>varString) then
+    VarCastError(valuevtype,Dest.vType);
+
+  if (Dest.vType and varArray)<>0 then
+    begin
+      { get Pointer to the array }
+      if (Dest.vType and varByRef)<>0 then
+        p:=pvararray(Dest.vPointer^)
+      else
+        p:=Dest.vArray;
+
+      { number of indices ok? }
+      if p^.DimCount<>indexcount then
+        VarInvalidArgError;
+
+      arrayelementtype:=Dest.vType and varTypeMask;
+      if arrayelementtype=varVariant then
+        begin
+          VarResultCheck(SafeArrayPtrOfIndex(p,PVarArrayCoorArray(indices),arraydest));
+          { we can't store ansistrings in Variant arrays so we convert the string to
+            an olestring }
+          if valuevtype=varString then
+            begin
+              tempvar:=VarToWideStr(value);
+              arraydest^:=tempvar;
+            end
+          else
+            arraydest^:=value;
+        end
+      else
+        begin
+          GetVariantManager(variantmanager);
+          variantmanager.varcast(tempvar,value,arrayelementtype);
+          if arrayelementtype in [varOleStr,varDispatch,varUnknown] then
+            VarResultCheck(SafeArrayPutElement(p,PVarArrayCoorArray(indices),TVarData(tempvar).vPointer))
+          else
+            VarResultCheck(SafeArrayPutElement(p,PVarArrayCoorArray(indices),@TVarData(tempvar).vPointer));
+        end;
+    end
+  else
+    VarInvalidArgError(Dest.vType);
+end;
+
+
+{ import from system unit }
+Procedure fpc_Write_Text_AnsiStr (Len : LongInt; Var f : Text; S : AnsiString); external name 'FPC_WRITE_TEXT_ANSISTR';
+
+
+function syswritevariant(var t : text; const v : Variant;width : LongInt) : Pointer;
+var
+  s : AnsiString;
+  variantmanager : tvariantmanager;
+begin
+  GetVariantManager(variantmanager);
+  variantmanager.vartolstr(s,v);
+  fpc_write_text_ansistr(width,t,s);
+  Result:=nil; // Pointer to what should be returned?
+end;
+
+
+function syswrite0Variant(var t : text; const v : Variant) : Pointer;
+var
+  s : AnsiString;
+  variantmanager : tvariantmanager;
+begin
+  getVariantManager(variantmanager);
+  variantmanager.vartolstr(s,v);
+  fpc_write_text_ansistr(-1,t,s);
+  Result:=nil; // Pointer to what should be returned?
+end;
+
+Const
+  SysVariantManager : TVariantManager = (
+    vartoint      : @sysvartoint;
+    vartoint64    : @sysvartoint64;
+    vartoword64   : @sysvartoword64;
+    vartobool     : @sysvartobool;
+{$ifndef FPUNONE}
+    vartoreal     : @sysvartoreal;
+    vartotdatetime: @sysvartotdatetime;
+{$endif}
+    vartocurr     : @sysvartocurr;
+    vartopstr     : @sysvartopstr;
+    vartolstr     : @sysvartolstr;
+    vartowstr     : @sysvartowstr;
+    vartointf     : @sysvartointf;
+    vartodisp     : @sysvartodisp;
+    vartodynarray : @sysvartodynarray;
+    varfrombool   : @sysvarfromBool;
+    varfromint    : @sysvarfromint;
+    varfromint64  : @sysvarfromint64;
+    varfromword64 : @sysvarfromword64;
+{$ifndef FPUNONE}
+    varfromreal   : @sysvarfromreal;
+    varfromtdatetime: @sysvarfromtdatetime;
+{$endif}
+    varfromcurr   : @sysvarfromcurr;
+    varfrompstr   : @sysvarfrompstr;
+    varfromlstr   : @sysvarfromlstr;
+    varfromwstr   : @sysvarfromwstr;
+    varfromintf   : @sysvarfromintf;
+    varfromdisp   : @sysvarfromdisp;
+    varfromdynarray: @sysvarfromdynarray;
+    olevarfrompstr: @sysolevarfrompstr;
+    olevarfromlstr: @sysolevarfromlstr;
+    olevarfromvar : @sysolevarfromvar;
+    olevarfromint : @sysolevarfromint;
+    varop         : @SysVarOp;
+    cmpop         : @syscmpop;
+    varneg        : @sysvarneg;
+    varnot        : @sysvarnot;
+    varinit       : @sysvarinit;
+    varclear      : @sysvarclear;
+    varaddref     : @sysvaraddref;
+    varcopy       : @sysvarcopy;
+    varcast       : @sysvarcast;
+    varcastole    : @sysvarcastole;
+    dispinvoke    : @sysdispinvoke;
+    vararrayredim : @sysvararrayredim;
+    vararrayget   : @sysvararrayget;
+    vararrayput   : @sysvararrayput;
+    writevariant  : @syswritevariant;
+    write0Variant : @syswrite0variant;
+  );
+
+Var
+  PrevVariantManager : TVariantManager;
+
+Procedure SetSysVariantManager;
+
+begin
+  GetVariantManager(PrevVariantManager);
+  SetVariantManager(SysVariantManager);
+end;
+
+Procedure UnsetSysVariantManager;
+
+begin
+  SetVariantManager(PrevVariantManager);
+end;
+
+
+{ ---------------------------------------------------------------------
+   Variant support procedures and functions
+  ---------------------------------------------------------------------}
+
+
+function VarType(const V: Variant): TVarType;
+
+begin
+  Result:=TVarData(V).vType;
+end;
+
+
+function VarTypeDeRef(const V: Variant): TVarType;
+var
+  p: PVarData;
+begin
+  p := @TVarData(V);
+  Result := p^.vType and not varByRef;
+  while Result = varVariant do begin
+    p := p^.vPointer;
+    if not Assigned(p) then
+      VarBadTypeError;
+    Result := p^.vType and not varByRef;
+  end;
+end;
+
+function VarTypeDeRef(const V: TVarData): TVarType;
+begin
+  Result := VarTypeDeRef(Variant(v));
+end;
+
+function VarAsType(const V: Variant; aVarType: TVarType): Variant;
+
+begin
+  sysvarcast(Result,V,aVarType);
+end;
+
+
+
+function VarIsType(const V: Variant; aVarType: TVarType): Boolean; overload;
+
+begin
+  Result:=((TVarData(V).vType and varTypeMask)=aVarType);
+end;
+
+
+function VarIsType(const V: Variant; const AVarTypes: array of TVarType): Boolean; overload;
+
+Var
+  I : Integer;
+
+begin
+  I:=Low(AVarTypes);
+  Result:=False;
+  While Not Result and (I<=High(AVarTypes)) do
+    Result:=((TVarData(V).vType and varTypeMask)=AVarTypes[I]);
+end;
+
+
+function VarIsByRef(const V: Variant): Boolean;
+begin
+  Result:=(TVarData(V).vType and varByRef)<>0;
+end;
+
+
+function VarIsEmpty(const V: Variant): Boolean;
+begin
+  Result:=TVarData(V).vType=varEmpty;
+end;
+
+
+procedure VarCheckEmpty(const V: Variant);
+begin
+  If VarIsEmpty(V) Then
+    VariantError(SErrVarIsEmpty);
+end;
+
+
+procedure VarClear(var V: Variant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
+begin
+  sysvarclear(v);
+end;
+
+
+procedure VarClear(var V: OleVariant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
+begin
+  { strange casting using TVarData to avoid call of helper olevariant->Variant }
+  sysvarclear(Variant(TVarData(v)));
+end;
+
+
+function VarIsNull(const V: Variant): Boolean;
+begin
+  Result:=TVarData(V).vType=varNull;
+end;
+
+
+function VarIsClear(const V: Variant): Boolean;
+
+Var
+  VT : TVarType;
+
+begin
+  VT:=TVarData(V).vType and varTypeMask;
+  Result:=(VT=varEmpty) or
+          (((VT=varDispatch) or (VT=varUnknown))
+           and (TVarData(V).vDispatch=Nil));
+end;
+
+
+function VarIsCustom(const V: Variant): Boolean;
+
+begin
+  Result:=TVarData(V).vType>=CFirstUserType;
+end;
+
+
+function VarIsOrdinal(const V: Variant): Boolean;
+begin
+  Result:=(TVarData(V).vType and varTypeMask) in OrdinalVarTypes;
+end;
+
+
+
+function VarIsFloat(const V: Variant): Boolean;
+
+begin
+  Result:=(TVarData(V).vType and varTypeMask) in FloatVarTypes;
+end;
+
+
+function VarIsNumeric(const V: Variant): Boolean;
+begin
+  Result:=(TVarData(V).vType and varTypeMask) in (OrdinalVarTypes + FloatVarTypes);
+end;
+
+
+
+function VarIsStr(const V: Variant): Boolean;
+
+begin
+  case (TVarData(V).vType and varTypeMask) of
+    varOleStr,
+    varString :
+      Result:=True;
+    else
+      Result:=False;
+  end;
+end;
+
+
+function VarToStr(const V: Variant): string;
+
+begin
+  Result:=VarToStrDef(V,'');
+end;
+
+
+function VarToStrDef(const V: Variant; const ADefault: string): string;
+
+begin
+  If TVarData(V).vType<>varNull then
+    Result:=V
+  else
+    Result:=ADefault;
+end;
+
+
+function VarToWideStr(const V: Variant): WideString;
+
+begin
+  Result:=VarToWideStrDef(V,'');
+end;
+
+
+function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;
+
+begin
+  If TVarData(V).vType<>varNull then
+    Result:=V
+  else
+    Result:=ADefault;
+end;
+
+
+{$ifndef FPUNONE}
+
+function VarToDateTime(const V: Variant): TDateTime;
+begin
+  Result:=VariantToDate(TVarData(V));
+end;
+
+
+function VarFromDateTime(const DateTime: TDateTime): Variant;
+
+begin
+  SysVarClear(Result);
+  with TVarData(Result) do
+    begin
+      vType:=varDate;
+      vdate:=DateTime;
+    end;
+end;
+
+{$endif}
+
+
+function VarInRange(const AValue, AMin, AMax: Variant): Boolean;
+begin
+  Result:=(AValue>=AMin) and (AValue<=AMax);
+end;
+
+
+function VarEnsureRange(const AValue, AMin, AMax: Variant): Variant;
+begin
+  If Result>AMAx then
+    Result:=AMax
+  else If Result<AMin Then
+    Result:=AMin
+  else
+    Result:=AValue;
+end;
+
+
+function VarSameValue(const A, B: Variant): Boolean;
+  var
+    v1,v2 : TVarData;
+  begin
+    v1:=FindVarData(a)^;
+    v2:=FindVarData(b)^;
+    if v1.vType in [varEmpty,varNull] then
+      Result:=v1.vType=v2.vType
+    else if v2.vType in [varEmpty,varNull] then
+      Result:=False
+    else
+      Result:=A=B;
+  end;
+
+
+function VarCompareValue(const A, B: Variant): TVariantRelationship;
+  var
+    v1,v2 : TVarData;
+  begin
+    Result:=vrNotEqual;
+    v1:=FindVarData(a)^;
+    v2:=FindVarData(b)^;
+    if (v1.vType in [varEmpty,varNull]) and (v1.vType=v2.vType) then
+      Result:=vrEqual
+    else if not(v2.vType in [varEmpty,varNull]) and
+            not(v1.vType in [varEmpty,varNull]) then
+      begin
+        if a=b then
+          Result:=vrEqual
+        else if a>b then
+          Result:=vrGreaterThan
+        else
+          Result:=vrLessThan;
+      end;
+  end;
+
+
+function VarIsEmptyParam(const V: Variant): Boolean;
+begin
+  Result:=(TVarData(V).vType = varError) and
+          (TVarData(V).vError=VAR_PARAMNOTFOUND);
+end;
+
+
+procedure SetClearVarToEmptyParam(var V: TVarData);
+begin
+  VariantClear(V);
+  V.vType := varError;
+  V.vError := VAR_PARAMNOTFOUND;
+end;
+
+
+function VarIsError(const V: Variant; out aResult: HRESULT): Boolean;
+begin
+  Result := TVarData(V).vType = varError;
+  if Result then
+    aResult := TVarData(v).vError;
+end;
+
+
+function VarIsError(const V: Variant): Boolean;
+begin
+  Result := TVarData(V).vType = varError;
+end;
+
+
+function VarAsError(AResult: HRESULT): Variant;
+  begin
+    TVarData(Result).vType:=varError;
+    TVarData(Result).vError:=AResult;
+  end;
+
+
+{$warnings off}
+function VarSupports(const V: Variant; const IID: TGUID; out Intf): Boolean;
+begin
+  NotSupported('VarSupports');
+end;
+
+
+function VarSupports(const V: Variant; const IID: TGUID): Boolean;
+begin
+  NotSupported('VarSupports');
+end;
+
+
+{ Variant copy support }
+procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);
+
+begin
+  NotSupported('VarCopyNoInd');
+end;
+{$warnings on}
+
+{****************************************************************************
+              Variant array support procedures and functions
+ ****************************************************************************}
+
+{$r-}
+
+function VarArrayCreate(const Bounds: array of SizeInt; aVarType: TVarType): Variant;
+  var
+    hp : PVarArrayBoundArray;
+    p : pvararray;
+    i,lengthb : SizeInt;
+  begin
+    if not(VarTypeIsValidArrayType(aVarType)) or odd(length(Bounds)) then
+      VarArrayCreateError;
+    lengthb:=length(Bounds) div 2;
+    try
+      GetMem(hp,lengthb*SizeOf(TVarArrayBound));
+      for i:=0 to lengthb-1 do
+        begin
+          hp^[i].LowBound:=Bounds[i*2];
+          hp^[i].ElementCount:=Bounds[i*2+1]-Bounds[i*2]+1;
+        end;
+      SysVarClear(Result);
+
+      p:=SafeArrayCreate(aVarType,lengthb,hp^);
+
+      if not(assigned(p)) then
+        VarArrayCreateError;
+
+      TVarData(Result).vType:=aVarType or varArray;
+      TVarData(Result).vArray:=p;
+    finally
+      FreeMem(hp);
+    end;
+  end;
+
+{$ifndef RANGECHECKINGOFF}
+{$r+}
+{$endif}
+
+function VarArrayCreate(const Bounds: PVarArrayBoundArray; Dims : SizeInt; aVarType: TVarType): Variant;
+  var
+    p : pvararray;
+  begin
+    if not(VarTypeIsValidArrayType(aVarType)) then
+      VarArrayCreateError;
+    SysVarClear(Result);
+
+    p:=SafeArrayCreate(aVarType,Dims,Bounds^);
+
+    if not(assigned(p)) then
+      VarArrayCreateError;
+
+    TVarData(Result).vType:=aVarType or varArray;
+    TVarData(Result).vArray:=p;
+  end;
+
+function VarArrayOf(const Values: array of Variant): Variant;
+  var
+    i : SizeInt;
+  begin
+    Result:=VarArrayCreate([0,high(Values)],varVariant);
+    for i:=0 to high(Values) do
+      Result[i]:=Values[i];
+  end;
+
+
+function VarArrayAsPSafeArray(const A: Variant): PVarArray;
+  var
+    v : TVarData;
+  begin
+    v:=TVarData(a);
+    while v.vType=varByRef or varVariant do
+      v:=TVarData(v.vPointer^);
+
+    if (v.vType and varArray)=varArray then
+      begin
+        if (v.vType and varByRef)<>0 then
+          Result:=pvararray(v.vPointer^)
+        else
+          Result:=v.vArray;
+      end
+    else
+      VarResultCheck(VAR_INVALIDARG);
+  end;
+
+
+function VarArrayDimCount(const A: Variant) : LongInt;
+  var
+    hv : TVarData;
+  begin
+    hv:=TVarData(a);
+
+    { get final Variant }
+    while hv.vType=varByRef or varVariant do
+      hv:=TVarData(hv.vPointer^);
+
+    if (hv.vType and varArray)<>0 then
+      Result:=hv.vArray^.DimCount
+    else
+      Result:=0;
+  end;
+
+
+function VarArrayLowBound(const A: Variant; Dim: LongInt) : LongInt;
+  begin
+    VarResultCheck(SafeArrayGetLBound(VarArrayAsPSafeArray(A),Dim,Result));
+  end;
+
+
+function VarArrayHighBound(const A: Variant; Dim: LongInt) : LongInt;
+  begin
+    VarResultCheck(SafeArrayGetUBound(VarArrayAsPSafeArray(A),Dim,Result));
+  end;
+
+
+function VarArrayLock(const A: Variant): Pointer;
+  begin
+    VarResultCheck(SafeArrayAccessData(VarArrayAsPSafeArray(A),Result));
+  end;
+
+
+procedure VarArrayUnlock(const A: Variant);
+  begin
+    VarResultCheck(SafeArrayUnaccessData(VarArrayAsPSafeArray(A)));
+  end;
+
+
+function VarArrayRef(const A: Variant): Variant;
+  begin
+    if (TVarData(a).vType and varArray)=0 then
+      VarInvalidArgError(TVarData(a).vType);
+    TVarData(Result).vType:=TVarData(a).vType or varByRef;
+    if (TVarData(a).vType and varByRef)=0 then
+      TVarData(Result).vPointer:=@TVarData(a).vArray
+    else
+      TVarData(Result).vPointer:=@TVarData(a).vPointer;
+  end;
+
+
+function VarIsArray(const A: Variant; AResolveByRef: Boolean): Boolean;
+  var
+    v : TVarData;
+  begin
+    v:=TVarData(a);
+    if AResolveByRef then
+      while v.vType=varByRef or varVariant do
+        v:=TVarData(v.vPointer^);
+
+    Result:=(v.vType and varArray)=varArray;
+  end;
+
+
+function VarIsArray(const A: Variant): Boolean;
+  begin
+    VarIsArray:=VarIsArray(A,true);
+  end;
+
+
+function VarTypeIsValidArrayType(const aVarType: TVarType): Boolean;
+  begin
+    Result:=aVarType in [varSmallInt,varInteger,
+{$ifndef FPUNONE}
+      varSingle,varDouble,varDate,
+{$endif}
+      varCurrency,varOleStr,varDispatch,varError,varBoolean,
+      varVariant,varUnknown,varShortInt,varByte,varWord,varLongWord];
+  end;
+
+
+function VarTypeIsValidElementType(const aVarType: TVarType): Boolean;
+  var
+    customvarianttype : TCustomVariantType;
+  begin
+    if FindCustomVariantType(aVarType,customvarianttype) then
+      Result:=true
+    else
+      begin
+        Result:=(aVarType and not(varByRef)) in [varEmpty,varNull,varSmallInt,varInteger,
+{$ifndef FPUNONE}
+          varSingle,varDouble,varDate,
+{$endif}
+          varCurrency,varOleStr,varDispatch,varError,varBoolean,
+          varVariant,varUnknown,varShortInt,varByte,varWord,varLongWord,varInt64];
+      end;
+  end;
+
+
+{ ---------------------------------------------------------------------
+    Variant <-> Dynamic arrays support
+  ---------------------------------------------------------------------}
+
+function DynArrayGetVariantInfo(p : Pointer; var Dims : sizeint) : sizeint;
+  begin
+    Result:=varNull;
+    { skip kind and name }
+    inc(Pointer(p),ord(pdynarraytypeinfo(p)^.namelen)+2);
+
+    p:=AlignToPtr(p);
+
+    { skip elesize }
+    inc(p,SizeOf(sizeint));
+
+    { search recursive? }
+    if pdynarraytypeinfo(ppointer(p)^)^.kind=21{tkDynArr} then
+      Result:=DynArrayGetVariantInfo(ppointer(p)^,Dims)
+    else
+      begin
+        { skip dynarraytypeinfo }
+        inc(p,SizeOf(pdynarraytypeinfo));
+        Result:=plongint(p)^;
+      end;
+    inc(Dims);
+  end;
+
+
+{$r-}
+
+procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
+  var
+    i,
+    Dims           : sizeint;
+    vararrtype,
+    dynarrvartype  : LongInt;
+    vararraybounds : PVarArrayBoundArray;
+    iter : TVariantArrayIterator;
+    dynarriter : tdynarrayiter;
+    p : Pointer;
+    temp : Variant;
+    variantmanager : tvariantmanager;
+    dynarraybounds : tdynarraybounds;
+  type
+    TDynArray = array of Pointer;
+  begin
+    DoVarClear(TVarData(v));
+
+    Dims:=0;
+    dynarrvartype:=DynArrayGetVariantInfo(TypeInfo,Dims);
+
+    vararrtype:=dynarrvartype;
+
+    if (Dims>1) and not(DynamicArrayIsRectangular(DynArray,TypeInfo)) then
+      exit;
+
+    GetVariantManager(variantmanager);
+
+    { retrieve Bounds array }
+    Setlength(dynarraybounds,Dims);
+    GetMem(vararraybounds,Dims*SizeOf(TVarArrayBound));
+    try
+      p:=DynArray;
+      for i:=0 to Dims-1 do
+        begin
+          vararraybounds^[i].LowBound:=0;
+          vararraybounds^[i].ElementCount:=length(TDynArray(p));
+          dynarraybounds[i]:=length(TDynArray(p));
+          if dynarraybounds[i]>0 then
+            { we checked that the array is rectangular }
+            p:=TDynArray(p)[0];
+        end;
+      { .. create Variant array }
+      V:=VarArrayCreate(vararraybounds,Dims,vararrtype);
+
+      VarArrayLock(V);
+      try
+        iter.init(Dims,PVarArrayBoundArray(vararraybounds));
+        dynarriter.init(DynArray,TypeInfo,Dims,dynarraybounds);
+        if not iter.AtEnd then
+        repeat
+          case vararrtype of
+            varSmallInt:
+              temp:=PSmallInt(dynarriter.data)^;
+            varInteger:
+              temp:=PInteger(dynarriter.data)^;
+{$ifndef FPUNONE}
+            varSingle:
+              temp:=PSingle(dynarriter.data)^;
+            varDouble:
+              temp:=PDouble(dynarriter.data)^;
+            varDate:
+              temp:=PDouble(dynarriter.data)^;
+{$endif}
+            varCurrency:
+              temp:=PCurrency(dynarriter.data)^;
+            varOleStr:
+              temp:=PWideString(dynarriter.data)^;
+            varDispatch:
+              temp:=PDispatch(dynarriter.data)^;
+            varError:
+              temp:=PError(dynarriter.data)^;
+            varBoolean:
+              temp:=PBoolean(dynarriter.data)^;
+            varVariant:
+              temp:=PVariant(dynarriter.data)^;
+            varUnknown:
+              temp:=PUnknown(dynarriter.data)^;
+            varShortInt:
+              temp:=PShortInt(dynarriter.data)^;
+            varByte:
+              temp:=PByte(dynarriter.data)^;
+            varWord:
+              temp:=PWord(dynarriter.data)^;
+            varLongWord:
+              temp:=PLongWord(dynarriter.data)^;
+            varInt64:
+              temp:=PInt64(dynarriter.data)^;
+            varQWord:
+              temp:=PQWord(dynarriter.data)^;
+            else
+              VarClear(temp);
+          end;
+          dynarriter.next;
+          variantmanager.VarArrayPut(V,temp,Dims,PSizeInt(iter.Coords));
+        until not(iter.next);
+      finally
+        iter.done;
+        dynarriter.done;
+        VarArrayUnlock(V);
+      end;
+    finally
+      FreeMem(vararraybounds);
+    end;
+  end;
+
+
+procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
+  var
+    DynArrayDims,
+    VarArrayDims : SizeInt;
+    iter : TVariantArrayIterator;
+    dynarriter : tdynarrayiter;
+    temp : Variant;
+    dynarrvartype : LongInt;
+    variantmanager : tvariantmanager;
+    vararraybounds : PVarArrayBoundArray;
+    dynarraybounds : tdynarraybounds;
+    i : SizeInt;
+  type
+    TDynArray = array of Pointer;
+  begin
+    VarArrayDims:=VarArrayDimCount(V);
+
+    DynArrayDims:=0;
+    dynarrvartype:=DynArrayGetVariantInfo(TypeInfo,DynArrayDims);
+
+    if (VarArrayDims=0) or (VarArrayDims<>DynArrayDims) then
+      VarResultCheck(VAR_INVALIDARG);
+
+    { retrieve Bounds array }
+    Setlength(dynarraybounds,VarArrayDims);
+    GetMem(vararraybounds,VarArrayDims*SizeOf(TVarArrayBound));
+    try
+      for i:=0 to VarArrayDims-1 do
+        begin
+          vararraybounds^[i].LowBound:=VarArrayLowBound(V,i+1);
+          vararraybounds^[i].ElementCount:=VarArrayHighBound(V,i+1)-vararraybounds^[i].LowBound+1;
+          dynarraybounds[i]:=vararraybounds^[i].ElementCount;
+        end;
+      DynArraySetLength(DynArray,TypeInfo,VarArrayDims,PSizeInt(dynarraybounds));
+      GetVariantManager(variantmanager);
+      VarArrayLock(V);
+      try
+        iter.init(VarArrayDims,PVarArrayBoundArray(vararraybounds));
+        dynarriter.init(DynArray,TypeInfo,VarArrayDims,dynarraybounds);
+        if not iter.AtEnd then
+        repeat
+          temp:=variantmanager.VarArrayGet(V,VarArrayDims,PSizeInt(iter.Coords));
+          case dynarrvartype of
+            varSmallInt:
+              PSmallInt(dynarriter.data)^:=temp;
+            varInteger:
+              PInteger(dynarriter.data)^:=temp;
+{$ifndef FPUNONE}
+            varSingle:
+              PSingle(dynarriter.data)^:=temp;
+            varDouble:
+              PDouble(dynarriter.data)^:=temp;
+            varDate:
+              PDouble(dynarriter.data)^:=temp;
+{$endif}
+            varCurrency:
+              PCurrency(dynarriter.data)^:=temp;
+            varOleStr:
+              PWideString(dynarriter.data)^:=temp;
+            varDispatch:
+              PDispatch(dynarriter.data)^:=temp;
+            varError:
+              PError(dynarriter.data)^:=temp;
+            varBoolean:
+              PBoolean(dynarriter.data)^:=temp;
+            varVariant:
+              PVariant(dynarriter.data)^:=temp;
+            varUnknown:
+              PUnknown(dynarriter.data)^:=temp;
+            varShortInt:
+              PShortInt(dynarriter.data)^:=temp;
+            varByte:
+              PByte(dynarriter.data)^:=temp;
+            varWord:
+              PWord(dynarriter.data)^:=temp;
+            varLongWord:
+              PLongWord(dynarriter.data)^:=temp;
+            varInt64:
+              PInt64(dynarriter.data)^:=temp;
+            varQWord:
+              PQWord(dynarriter.data)^:=temp;
+            else
+              VarCastError;
+          end;
+          dynarriter.next;
+        until not(iter.next);
+      finally
+        iter.done;
+        dynarriter.done;
+        VarArrayUnlock(V);
+      end;
+    finally
+      FreeMem(vararraybounds);
+    end;
+  end;
+{$ifndef RANGECHECKINGOFF}
+{$r+}
+{$endif}
+
+
+function FindCustomVariantType(const aVarType: TVarType; out CustomVariantType: TCustomVariantType): Boolean; overload;
+  begin
+    Result:=(aVarType>=CMinVarType);
+    if Result then
+      begin
+        EnterCriticalSection(customvarianttypelock);
+        try
+          Result:=(aVarType-CMinVarType)<=high(customvarianttypes);
+          if Result then
+            begin
+              CustomVariantType:=customvarianttypes[aVarType-CMinVarType];
+              Result:=assigned(CustomVariantType) and
+               (CustomVariantType<>InvalidCustomVariantType);
+            end;
+        finally
+          LeaveCriticalSection(customvarianttypelock);
+        end;
+      end;
+  end;
+
+
+{$warnings off}
+function FindCustomVariantType(const TypeName: string;  out CustomVariantType: TCustomVariantType): Boolean; overload;
+
+begin
+  NotSupported('FindCustomVariantType');
+end;
+{$warnings on}
+
+function Unassigned: Variant; // Unassigned standard constant
+begin
+  SysVarClear(Result);
+  TVarData(Result).vType := varEmpty;
+end;
+
+
+function Null: Variant;       // Null standard constant
+  begin
+    SysVarClear(Result);
+    TVarData(Result).vType := varNull;
+  end;
+
+
+{ ---------------------------------------------------------------------
+    TCustomVariantType Class.
+  ---------------------------------------------------------------------}
+
+{$warnings off}
+function TCustomVariantType.QueryInterface(const IID: TGUID; out Obj): HResult;  stdcall;
+  begin
+    NotSupported('TCustomVariantType.QueryInterface');
+  end;
+
+
+function TCustomVariantType._AddRef: Integer; stdcall;
+  begin
+    NotSupported('TCustomVariantType._AddRef');
+  end;
+
+
+function TCustomVariantType._Release: Integer; stdcall;
+  begin
+    NotSupported('TCustomVariantType._Release');
+  end;
+
+
+procedure TCustomVariantType.SimplisticClear(var V: TVarData);
+  begin
+    NotSupported('TCustomVariantType.SimplisticClear');
+  end;
+
+
+procedure TCustomVariantType.SimplisticCopy(var Dest: TVarData; const Source: TVarData;  const Indirect: Boolean = False);
+begin
+  NotSupported('TCustomVariantType.SimplisticCopy');
+end;
+
+
+procedure TCustomVariantType.RaiseInvalidOp;
+begin
+  NotSupported('TCustomVariantType.RaiseInvalidOp');
+end;
+
+
+procedure TCustomVariantType.RaiseCastError;
+begin
+  NotSupported('TCustomVariantType.RaiseCastError');
+end;
+
+
+procedure TCustomVariantType.RaiseDispError;
+
+begin
+  NotSupported('TCustomVariantType.RaiseDispError');
+end;
+
+
+
+function TCustomVariantType.LeftPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.LeftPromotion');
+end;
+
+
+function TCustomVariantType.RightPromotion(const V: TVarData; const Operation: TVarOp;  out RequiredVarType: TVarType): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.RightPromotion');
+end;
+
+
+function TCustomVariantType.OlePromotion(const V: TVarData;  out RequiredVarType: TVarType): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.OlePromotion');
+end;
+
+
+procedure TCustomVariantType.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
+
+begin
+  NotSupported('TCustomVariantType.DispInvoke');
+end;
+
+
+
+procedure TCustomVariantType.VarDataInit(var Dest: TVarData);
+
+begin
+  NotSupported('TCustomVariantType.VarDataInit');
+end;
+
+
+procedure TCustomVariantType.VarDataClear(var Dest: TVarData);
+
+begin
+  NotSupported('TCustomVariantType.VarDataClear');
+end;
+
+
+
+procedure TCustomVariantType.VarDataCopy(var Dest: TVarData; const Source: TVarData);
+
+begin
+  NotSupported('TCustomVariantType.VarDataCopy');
+end;
+
+
+procedure TCustomVariantType.VarDataCopyNoInd(var Dest: TVarData; const Source: TVarData);
+
+begin
+  NotSupported('TCustomVariantType.VarDataCopyNoInd');
+end;
+
+
+
+procedure TCustomVariantType.VarDataCast(var Dest: TVarData; const Source: TVarData);
+
+begin
+  NotSupported('TCustomVariantType.VarDataCast');
+end;
+
+
+procedure TCustomVariantType.VarDataCastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
+
+begin
+  NotSupported('TCustomVariantType.VarDataCastTo');
+end;
+
+
+procedure TCustomVariantType.VarDataCastTo(var Dest: TVarData; const aVarType: TVarType);
+
+begin
+  NotSupported('TCustomVariantType.VarDataCastTo');
+end;
+
+
+procedure TCustomVariantType.VarDataCastToOleStr(var Dest: TVarData);
+
+begin
+  NotSupported('TCustomVariantType.VarDataCastToOleStr');
+end;
+
+
+
+procedure TCustomVariantType.VarDataFromStr(var V: TVarData; const Value: string);
+
+begin
+  NotSupported('TCustomVariantType.VarDataFromStr');
+end;
+
+
+procedure TCustomVariantType.VarDataFromOleStr(var V: TVarData; const Value: WideString);
+
+begin
+  NotSupported('TCustomVariantType.VarDataFromOleStr');
+end;
+
+
+function TCustomVariantType.VarDataToStr(const V: TVarData): string;
+
+begin
+  NotSupported('TCustomVariantType.VarDataToStr');
+end;
+
+
+
+function TCustomVariantType.VarDataIsEmptyParam(const V: TVarData): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.VarDataIsEmptyParam');
+end;
+
+
+function TCustomVariantType.VarDataIsByRef(const V: TVarData): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.VarDataIsByRef');
+end;
+
+
+function TCustomVariantType.VarDataIsArray(const V: TVarData): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.VarDataIsArray');
+end;
+
+
+
+function TCustomVariantType.VarDataIsOrdinal(const V: TVarData): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.VarDataIsOrdinal');
+end;
+
+
+function TCustomVariantType.VarDataIsFloat(const V: TVarData): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.VarDataIsFloat');
+end;
+
+
+function TCustomVariantType.VarDataIsNumeric(const V: TVarData): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.VarDataIsNumeric');
+end;
+
+
+function TCustomVariantType.VarDataIsStr(const V: TVarData): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.VarDataIsStr');
+end;
+
+
+constructor TCustomVariantType.Create;
+begin
+  inherited Create;
+  EnterCriticalSection(customvarianttypelock);
+  try
+    SetLength(customvarianttypes,Length(customvarianttypes)+1);
+    customvarianttypes[High(customvarianttypes)]:=self;
+    FVarType:=CMinVarType+High(customvarianttypes);
+  finally
+    LeaveCriticalSection(customvarianttypelock);
+  end;
+end;
+
+
+constructor TCustomVariantType.Create(RequestedVarType: TVarType);
+
+begin
+  NotSupported('TCustomVariantType.Create');
+end;
+
+
+destructor TCustomVariantType.Destroy;
+begin
+  EnterCriticalSection(customvarianttypelock);
+  try
+    if FVarType<>0 then
+      customvarianttypes[FVarType-CMinVarType]:=InvalidCustomVariantType;
+  finally
+    LeaveCriticalSection(customvarianttypelock);
+  end;
+
+  inherited Destroy;
+end;
+
+
+
+function TCustomVariantType.IsClear(const V: TVarData): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.IsClear');
+end;
+
+
+procedure TCustomVariantType.Cast(var Dest: TVarData; const Source: TVarData);
+
+begin
+  NotSupported('TCustomVariantType.Cast');
+end;
+
+
+procedure TCustomVariantType.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
+
+begin
+  NotSupported('TCustomVariantType.CastTo');
+end;
+
+
+procedure TCustomVariantType.CastToOle(var Dest: TVarData; const Source: TVarData);
+
+begin
+  NotSupported('TCustomVariantType.CastToOle');
+end;
+
+
+
+procedure TCustomVariantType.BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp);
+
+begin
+  NotSupported('TCustomVariantType.BinaryOp');
+end;
+
+
+procedure TCustomVariantType.UnaryOp(var Right: TVarData; const Operation: TVarOp);
+
+begin
+  NotSupported('TCustomVariantType.UnaryOp');
+end;
+
+
+function TCustomVariantType.CompareOp(const Left, Right: TVarData; const Operation: TVarOp): Boolean;
+
+begin
+  NotSupported('TCustomVariantType.CompareOp');
+end;
+
+
+procedure TCustomVariantType.Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult);
+
+begin
+  NotSupported('TCustomVariantType.Compare');
+end;
+{$warnings on}
+
+{ ---------------------------------------------------------------------
+    TInvokeableVariantType implementation
+  ---------------------------------------------------------------------}
+
+{$warnings off}
+procedure TInvokeableVariantType.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
+
+begin
+  NotSupported('TInvokeableVariantType.DispInvoke');
+end;
+
+function TInvokeableVariantType.DoFunction(var Dest: TVarData; const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;
+
+begin
+  NotSupported('TInvokeableVariantType.DoFunction');
+end;
+
+function TInvokeableVariantType.DoProcedure(const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;
+begin
+  NotSupported('TInvokeableVariantType.DoProcedure');
+end;
+
+
+function TInvokeableVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean;
+  begin
+    NotSupported('TInvokeableVariantType.GetProperty');
+  end;
+
+
+function TInvokeableVariantType.SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean;
+  begin
+    NotSupported('TInvokeableVariantType.SetProperty');
+  end;
+{$warnings on}
+
+
+function TPublishableVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean;
+  begin
+    Result:=true;
+    Variant(Dest):=GetPropValue(getinstance(v),name);
+  end;
+
+
+function TPublishableVariantType.SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean;
+  begin
+    Result:=true;
+    SetPropValue(getinstance(v),name,Variant(value));
+  end;
+
+
+procedure VarCastError;
+  begin
+    raise EVariantTypeCastError.Create(SInvalidVarCast);
+  end;
+
+
+procedure VarCastError(const ASourceType, ADestType: TVarType);
+  begin
+    raise EVariantTypeCastError.CreateFmt(SVarTypeCouldNotConvert,
+      [VarTypeAsText(ASourceType),VarTypeAsText(ADestType)]);
+  end;
+
+
+procedure VarCastErrorOle(const ASourceType: TVarType);
+  begin
+    raise EVariantTypeCastError.CreateFmt(SVarTypeCouldNotConvert,
+      [VarTypeAsText(ASourceType),'(OleVariant)']);
+  end;
+
+
+procedure VarInvalidOp;
+  begin
+    raise EVariantInvalidOpError.Create(SInvalidVarOp);
+  end;
+
+procedure VarInvalidOp(const aLeft, aRight: TVarType; aOpCode: TVarOp);
+  begin
+    raise EVariantInvalidOpError.CreateFmt(SInvalidBinaryVarOp,
+      [VarTypeAsText(aLeft),VarOpAsText[aOpCode],VarTypeAsText(aRight)]);
+  end;
+
+
+procedure VarInvalidOp(const aRight: TVarType; aOpCode: TVarOp);
+  begin
+    raise EVariantInvalidOpError.CreateFmt(SInvalidUnaryVarOp,
+      [VarOpAsText[aOpCode],VarTypeAsText(aRight)]);
+  end;
+
+
+procedure VarInvalidNullOp;
+  begin
+    raise EVariantInvalidOpError.Create(SInvalidvarNullOp);
+  end;
+
+
+procedure VarParamNotFoundError;
+  begin
+    raise EVariantParamNotFoundError.Create(SVarParamNotFound);
+  end;
+
+
+procedure VarBadTypeError;
+  begin
+    raise EVariantBadVarTypeError.Create(SVarBadType);
+  end;
+
+
+procedure VarOverflowError;
+  begin
+    raise EVariantOverflowError.Create(SVarOverflow);
+  end;
+
+
+procedure VarOverflowError(const ASourceType, ADestType: TVarType);
+  begin
+    raise EVariantOverflowError.CreateFmt(SVarTypeConvertOverflow,
+      [VarTypeAsText(ASourceType),VarTypeAsText(ADestType)]);
+  end;
+
+
+procedure VarRangeCheckError(const AType: TVarType);
+  begin
+    raise EVariantOverflowError.CreateFmt(SVarTypeRangeCheck1,
+      [VarTypeAsText(AType)])
+  end;
+
+
+procedure VarRangeCheckError(const ASourceType, ADestType: TVarType);
+  begin
+    if ASourceType<>ADestType then
+      raise EVariantOverflowError.CreateFmt(SVarTypeRangeCheck2,
+        [VarTypeAsText(ASourceType),VarTypeAsText(ADestType)])
+    else
+      VarRangeCheckError(ASourceType);
+  end;
+
+
+procedure VarBadIndexError;
+  begin
+    raise EVariantBadIndexError.Create(SVarArrayBounds);
+  end;
+
+
+procedure VarArrayLockedError;
+  begin
+    raise EVariantArrayLockedError.Create(SVarArrayLocked);
+  end;
+
+
+procedure VarNotImplError;
+  begin
+    raise EVariantNotImplError.Create(SVarNotImplemented);
+  end;
+
+
+procedure VarOutOfMemoryError;
+  begin
+    raise EVariantOutOfMemoryError.Create(SOutOfMemory);
+  end;
+
+
+procedure VarInvalidArgError;
+  begin
+    raise EVariantInvalidArgError.Create(SVarInvalid);
+  end;
+
+
+procedure VarInvalidArgError(AType: TVarType);
+  begin
+    raise EVariantInvalidArgError.CreateFmt(SVarInvalid1,
+      [VarTypeAsText(AType)])
+  end;
+
+
+procedure VarUnexpectedError;
+  begin
+    raise EVariantUnexpectedError.Create(SVarUnexpected);
+  end;
+
+
+procedure VarArrayCreateError;
+  begin
+    raise EVariantArrayCreateError.Create(SVarArrayCreate);
+  end;
+
+
+procedure RaiseVarException(res : HRESULT);
+  begin
+    case res of
+      VAR_PARAMNOTFOUND:
+        VarParamNotFoundError;
+      VAR_TYPEMISMATCH:
+        VarCastError;
+      VAR_BADVARTYPE:
+        VarBadTypeError;
+      VAR_EXCEPTION:
+        VarInvalidOp;
+      VAR_OVERFLOW:
+        VarOverflowError;
+      VAR_BADINDEX:
+        VarBadIndexError;
+      VAR_ARRAYISLOCKED:
+        VarArrayLockedError;
+      VAR_NOTIMPL:
+        VarNotImplError;
+      VAR_OUTOFMEMORY:
+        VarOutOfMemoryError;
+      VAR_INVALIDARG:
+        VarInvalidArgError;
+      VAR_UNEXPECTED:
+        VarUnexpectedError;
+      else
+        raise EVariantError.CreateFmt(SInvalidVarOpWithHResultWithPrefix,
+          ['$',res,'']);
+    end;
+  end;
+
+
+procedure VarResultCheck(AResult: HRESULT);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
+  begin
+    if AResult<>VAR_OK then
+      RaiseVarException(AResult);
+  end;
+
+
+procedure VarResultCheck(AResult: HRESULT; ASourceType, ADestType: TVarType);
+  begin
+    case AResult of
+      VAR_OK:
+        ;
+      VAR_OVERFLOW:
+        VarOverflowError(ASourceType,ADestType);
+      VAR_TYPEMISMATCH:
+        VarCastError(ASourceType,ADestType);
+    else
+      RaiseVarException(AResult);
+    end;
+  end;
+
+
+procedure HandleConversionException(const ASourceType, ADestType: TVarType);
+  begin
+    if exceptobject is econverterror then
+      VarCastError(asourcetype,adesttype)
+    else if (exceptobject is eoverflow) or
+      (exceptobject is erangeerror) then
+      varoverflowerror(asourcetype,adesttype)
+    else
+      raise exception(acquireexceptionobject);
+  end;
+
+
+function VarTypeAsText(const AType: TVarType): string;
+  var
+    customvarianttype : TCustomVariantType;
+  const
+    names : array[varEmpty..varQWord] of string[8] = (
+    'Empty','Null','Smallint','Integer','Single','Double','Currency','Date','OleStr','Dispatch','Error','Boolean','Variant',
+    'Unknown','Decimal','???','ShortInt','Byte','Word','DWord','Int64','QWord');
+  begin
+    if ((AType and varTypeMask)>=low(names)) and ((AType and varTypeMask)<=high(names)) then
+      Result:=names[AType]
+    else
+      case AType and varTypeMask of
+        varString:
+          Result:='String';
+        varAny:
+          Result:='Any';
+        else
+          begin
+            if FindCustomVariantType(AType and varTypeMask,customvarianttype) then
+              Result:=customvarianttype.classname
+            else
+              Result:='$'+IntToHex(AType and varTypeMask,4)
+          end;
+      end;
+    if (AType and vararray)<>0 then
+      Result:='Array of '+Result;
+    if (AType and varByRef)<>0 then
+      Result:='Ref to '+Result;
+  end;
+
+
+function FindVarData(const V: Variant): PVarData;
+  begin
+    Result:=PVarData(@V);
+    while Result^.vType=varVariant or varByRef do
+      Result:=PVarData(Result^.vPointer);
+  end;
+
+{ ---------------------------------------------------------------------
+    Variant properties from typinfo
+  ---------------------------------------------------------------------}
+
+function GetVariantProp(Instance : TObject;PropInfo : PPropInfo) : Variant;
+type
+  TGetVariantProc = function:Variant of object;
+  TGetVariantProcIndex = function(Index: integer): Variant of object;
+var
+  AMethod : TMethod;
+begin
+  Result:=Null;
+  case PropInfo^.PropProcs and 3 of
+    ptField:
+      Result:=PVariant(Pointer(Instance)+PtrUInt(PropInfo^.GetProc))^;
+    ptStatic,
+    ptVirtual:
+      begin
+        if (PropInfo^.PropProcs and 3)=ptStatic then
+          AMethod.Code:=PropInfo^.GetProc
+        else
+          AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^;
+        AMethod.Data:=Instance;
+
+        if ((PropInfo^.PropProcs shr 6) and 1)=0 then
+          Result:=TGetVariantProc(AMethod)()
+        else
+          Result:=TGetVariantProcIndex(AMethod)(PropInfo^.Index);
+      end;
+  end;
+end;
+
+
+Procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo; const Value : Variant);
+type
+  TSetVariantProc = procedure(const AValue: Variant) of object;
+  TSetVariantProcIndex = procedure(Index: integer; AValue: Variant) of object;
+Var
+  AMethod : TMethod;
+begin
+  case (PropInfo^.PropProcs shr 2) and 3 of
+    ptfield:
+      PVariant(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;	
+    ptVirtual,ptStatic:
+      begin
+        if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
+          AMethod.Code:=PropInfo^.SetProc
+        else
+          AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
+        AMethod.Data:=Instance;
+
+	      if ((PropInfo^.PropProcs shr 6) and 1)=0 then
+          TSetVariantProc(AMethod)(Value)
+        else
+          TSetVariantProcIndex(AMethod)(PropInfo^.Index,Value);
+      end;
+  end;
+end;
+
+
+Function GetVariantProp(Instance: TObject; const PropName: string): Variant;
+begin
+  Result:=GetVariantProp(Instance,FindPropInfo(Instance,PropName));
+end;
+
+
+Procedure SetVariantProp(Instance: TObject; const PropName: string;  const Value: Variant);
+begin
+  SetVariantprop(instance,FindpropInfo(Instance,PropName),Value);
+end;
+
+{ ---------------------------------------------------------------------
+  All properties through Variant.
+  ---------------------------------------------------------------------}
+
+Function GetPropValue(Instance: TObject; const PropName: string): Variant;
+begin
+  Result:=GetPropValue(Instance,PropName,True);
+end;
+
+
+Function GetPropValue(Instance: TObject; const PropName: string; PreferStrings: Boolean): Variant;
+
+var
+  PropInfo: PPropInfo;
+
+begin
+  // find the property
+  PropInfo := GetPropInfo(Instance, PropName);
+  if PropInfo = nil then
+    raise EPropertyError.CreateFmt(SErrPropertyNotFound, [PropName])
+ else
+   begin
+   Result := Null; //at worst
+   // call the Right GetxxxProp
+   case PropInfo^.PropType^.Kind of
+     tkInteger, tkChar, tkWChar, tkClass, tkBool:
+        Result := GetOrdProp(Instance, PropInfo);
+     tkEnumeration:
+       if PreferStrings then
+         Result := GetEnumProp(Instance, PropInfo)
+       else
+         Result := GetOrdProp(Instance, PropInfo);
+     tkSet:
+       if PreferStrings then
+         Result := GetSetProp(Instance, PropInfo, False)
+       else
+         Result := GetOrdProp(Instance, PropInfo);
+{$ifndef FPUNONE}
+     tkFloat:
+       Result := GetFloatProp(Instance, PropInfo);
+{$endif}
+     tkMethod:
+       Result := PropInfo^.PropType^.Name;
+     tkString, tkLString, tkAString:
+       Result := GetStrProp(Instance, PropInfo);
+     tkWString:
+       Result := GetWideStrProp(Instance, PropInfo);
+     tkVariant:
+       Result := GetVariantProp(Instance, PropInfo);
+     tkInt64:
+       Result := GetInt64Prop(Instance, PropInfo);
+   else
+     raise EPropertyConvertError.CreateFmt('Invalid Property Type: %s',[PropInfo^.PropType^.Name]);
+   end;
+   end;
+end;
+
+Procedure SetPropValue(Instance: TObject; const PropName: string;  const Value: Variant);
+
+var
+ PropInfo: PPropInfo;
+// TypeData: PTypeData;
+ O : Integer;
+ S : String;
+ B : Boolean;
+
+begin
+   // find the property
+   PropInfo := GetPropInfo(Instance, PropName);
+   if PropInfo = nil then
+     raise EPropertyError.CreateFmt(SErrPropertyNotFound, [PropName])
+   else
+     begin
+//     TypeData := GetTypeData(PropInfo^.PropType);
+     // call Right SetxxxProp
+     case PropInfo^.PropType^.Kind of
+       tkBool:
+         begin
+         { to support the strings 'true' and 'false' }
+         B:=Value;
+         SetOrdProp(Instance, PropInfo, ord(B));
+         end;
+       tkInteger, tkChar, tkWChar:
+         begin
+         O:=Value;
+         SetOrdProp(Instance, PropInfo, O);
+         end;
+       tkEnumeration :
+         begin
+         if (VarType(Value)=varOleStr) or  (VarType(Value)=varString) then
+           begin
+           S:=Value;
+           SetEnumProp(Instance,PropInfo,S);
+           end
+         else
+           begin
+           O:=Value;
+           SetOrdProp(Instance, PropInfo, O);
+           end;
+         end;
+       tkSet :
+         begin
+         if (VarType(Value)=varOleStr) or  (VarType(Value)=varString) then
+           begin
+           S:=Value;
+           SetSetProp(Instance,PropInfo,S);
+           end
+         else
+           begin
+           O:=Value;
+           SetOrdProp(Instance, PropInfo, O);
+           end;
+         end;
+{$ifndef FPUNONE}
+       tkFloat:
+         SetFloatProp(Instance, PropInfo, Value);
+{$endif}
+       tkString, tkLString, tkAString:
+         SetStrProp(Instance, PropInfo, VarToStr(Value));
+       tkWString:
+         SetWideStrProp(Instance, PropInfo, VarToWideStr(Value));
+       tkVariant:
+         SetVariantProp(Instance, PropInfo, Value);
+       tkInt64:
+         SetInt64Prop(Instance, PropInfo, Value);
+     else
+       raise EPropertyConvertError.CreateFmt('SetPropValue: Invalid Property Type %s',
+                                      [PropInfo^.PropType^.Name]);
+     end;
+   end;
+end;
+
+var
+  i : LongInt;
+
+Initialization
+  InitCriticalSection(customvarianttypelock);
+  SetSysVariantManager;
+  SetClearVarToEmptyParam(TVarData(EmptyParam));
+  VarClearProc:=@DoVarClear;
+  VarAddRefProc:=@DoVarAddRef;
+  VarCopyProc:=@DoVarCopy;
+  // Typinfo Variant support
+  OnGetVariantProp:=@GetVariantprop;
+  OnSetVariantProp:=@SetVariantprop;
+  OnSetPropValue:=@SetPropValue;
+  OnGetPropValue:=@GetPropValue;
+  InvalidCustomVariantType:=TCustomVariantType(-1);
+  SetLength(customvarianttypes,CFirstUserType);
+Finalization
+  EnterCriticalSection(customvarianttypelock);
+  try
+    for i:=0 to high(customvarianttypes) do
+      if customvarianttypes[i]<>InvalidCustomVariantType then
+        customvarianttypes[i].Free;
+  finally
+    LeaveCriticalSection(customvarianttypelock);
+  end;
+  UnSetSysVariantManager;
+  DoneCriticalSection(customvarianttypelock);
+end.

rtl/objpas/classes/classes.inc

@@ -0,0 +1,1705 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
+
+    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.
+
+ **********************************************************************}
+
+{**********************************************************************
+ *       Class implementations are in separate files.                 *
+ **********************************************************************}
+
+var
+  ClassList : TThreadlist;
+  ClassAliasList : TStringList;
+
+{
+ Include all message strings
+
+ Add a language with IFDEF LANG_NAME
+ just befor the final ELSE. This way English will always be the default.
+}
+
+{$IFDEF LANG_GERMAN}
+{$i constsg.inc}
+{$ELSE}
+{$IFDEF LANG_SPANISH}
+{$i constss.inc}
+{$ENDIF}
+{$ENDIF}
+
+{ Utility routines }
+{$i util.inc}
+
+{ TBits implementation }
+{$i bits.inc}
+
+{ All streams implementations: }
+{ Tstreams THandleStream TFileStream TResourcseStreams TStringStream }
+{ TCustomMemoryStream TMemoryStream }
+{$i streams.inc}
+
+{ TParser implementation}
+{$i parser.inc}
+
+{ TCollection and TCollectionItem implementations }
+{$i collect.inc}
+
+{ TList and TThreadList implementations }
+{$i lists.inc}
+
+{ TStrings and TStringList implementations }
+{$i stringl.inc}
+
+{ TThread implementation }
+
+{ system independend threading code }
+var
+  { event that happens when gui thread is done executing the method}
+  ExecuteEvent: PRtlEvent;
+  { event executed by synchronize to wake main thread if it sleeps in CheckSynchronize }
+  SynchronizeTimeoutEvent: PRtlEvent;
+  { guard for synchronization variables }
+  SynchronizeCritSect: TRtlCriticalSection;
+  { method to execute }
+  SynchronizeMethod: TThreadMethod;
+  { should we execute the method? }
+  DoSynchronizeMethod: boolean;
+  { caught exception in gui thread, to be raised in calling thread }
+  SynchronizeException: Exception;
+
+
+function ThreadProc(ThreadObjPtr: Pointer): PtrInt;
+  var
+    FreeThread: Boolean;
+    Thread: TThread absolute ThreadObjPtr;
+  begin
+    { if Suspend checks FSuspended before doing anything, make sure it }
+    { knows we're currently not suspended (this flag may have been set }
+    { to true if CreateSuspended was true)                             }
+//    Thread.FSuspended:=false;
+    // wait until AfterConstruction has been called, so we cannot
+    // free ourselves before TThread.Create has finished
+    // (since that one may check our VTM in case of $R+, and
+    //  will call the AfterConstruction method in all cases)
+//    Thread.Suspend;
+    try
+      Thread.Execute;
+    except
+      Thread.FFatalException := TObject(AcquireExceptionObject);
+    end;
+    FreeThread := Thread.FFreeOnTerminate;
+    Result := Thread.FReturnValue;
+    Thread.FFinished := True;
+    Thread.DoTerminate;
+    if FreeThread then
+      Thread.Free;
+    EndThread(Result);
+  end;
+
+{ system-dependent code }
+{$i tthread.inc}
+
+
+function TThread.GetSuspended: Boolean;
+begin
+  GetSuspended:=FSuspended;
+end;
+
+
+procedure TThread.AfterConstruction;
+begin
+  inherited AfterConstruction;
+//  Resume;
+end;
+
+
+class procedure TThread.Synchronize(AThread: TThread; AMethod: TThreadMethod);
+  var
+    LocalSyncException: Exception;
+  begin
+    { do we really need a synchronized call? }
+    if GetCurrentThreadID=MainThreadID then
+      AMethod()
+    else
+      begin
+        System.EnterCriticalSection(SynchronizeCritSect);
+        SynchronizeException:=nil;
+        SynchronizeMethod:=AMethod;
+
+        { be careful, after this assignment Method could be already executed }
+        DoSynchronizeMethod:=true;
+
+        RtlEventSetEvent(SynchronizeTimeoutEvent);
+
+        if assigned(WakeMainThread) then
+          WakeMainThread(AThread);
+
+        { wait infinitely }
+        RtlEventWaitFor(ExecuteEvent);
+        LocalSyncException:=SynchronizeException;
+        System.LeaveCriticalSection(SynchronizeCritSect);
+        if assigned(LocalSyncException) then
+          raise LocalSyncException;
+      end;
+  end;
+
+
+procedure TThread.Synchronize(AMethod: TThreadMethod);
+  begin
+    TThread.Synchronize(self,AMethod);
+  end;
+
+
+function CheckSynchronize(timeout : longint=0) : boolean;
+  { assumes being called from GUI thread }
+  begin
+    result:=false;
+    { first sanity check }
+    if Not IsMultiThread then
+      Exit
+    { second sanity check }
+    else if GetCurrentThreadID<>MainThreadID then
+      raise EThread.CreateFmt(SCheckSynchronizeError,[GetCurrentThreadID])
+    else
+      begin
+        if timeout>0 then
+          begin
+            RtlEventWaitFor(SynchronizeTimeoutEvent,timeout);
+          end
+         else
+           RtlEventResetEvent(SynchronizeTimeoutEvent);
+
+        if DoSynchronizeMethod then
+          begin
+            DoSynchronizeMethod:=false;
+            try
+              SynchronizeMethod;
+              result:=true;
+            except
+              SynchronizeException:=Exception(AcquireExceptionObject);
+            end;
+            RtlEventSetEvent(ExecuteEvent);
+          end;
+      end;
+  end;
+
+{ TPersistent implementation }
+{$i persist.inc }
+
+{$i sllist.inc}
+{$i resref.inc}
+
+{ TComponent implementation }
+{$i compon.inc}
+
+{ TBasicAction implementation }
+{$i action.inc}
+
+{ TDataModule implementation }
+{$i dm.inc}
+
+{ Class and component registration routines }
+{$I cregist.inc}
+
+
+
+{ Interface related stuff }
+{$I intf.inc}
+
+{**********************************************************************
+ *       Miscellaneous procedures and functions                       *
+ **********************************************************************}
+
+function ExtractStrings(Separators, WhiteSpace: TSysCharSet; Content: PChar; Strings: TStrings): Integer;
+var
+  b, c : pchar;
+
+  procedure SkipWhitespace;
+    begin
+      while (c^ in Whitespace) do
+        inc (c);
+    end;
+
+  procedure AddString;
+    var
+      l : integer;
+      s : string;
+    begin
+      l := c-b;
+      if l > 0 then
+        begin
+          if assigned(Strings) then
+            begin
+              setlength(s, l);
+              move (b^, s[1],l);
+              Strings.Add (s);
+            end;
+          inc (result);
+        end;
+    end;
+
+var
+  quoted : char;
+begin
+  result := 0;
+  c := Content;
+  Quoted := #0;
+  Separators := Separators + [#13, #10] - ['''','"'];
+  SkipWhitespace;
+  b := c;
+  while (c^ <> #0) do
+    begin
+      if (c^ = Quoted) then
+        begin
+          if ((c+1)^ = Quoted) then
+            inc (c)
+          else
+            Quoted := #0
+        end
+      else if (Quoted = #0) and (c^ in ['''','"']) then
+        Quoted := c^;
+      if (Quoted = #0) and (c^ in Separators) then
+        begin
+          AddString;
+          inc (c);
+          SkipWhitespace;
+          b := c;
+        end
+      else
+        inc (c);
+    end;
+  if (c <> b) then
+    AddString;
+end;
+
+
+
+{ Point and rectangle constructors }
+
+function Point(AX, AY: Integer): TPoint;
+
+begin
+  with Result do
+  begin
+    X := AX;
+    Y := AY;
+  end;
+end;
+
+
+function SmallPoint(AX, AY: SmallInt): TSmallPoint;
+
+begin
+  with Result do
+  begin
+    X := AX;
+    Y := AY;
+  end;
+end;
+
+
+function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
+
+begin
+  with Result do
+  begin
+    Left := ALeft;
+    Top := ATop;
+    Right := ARight;
+    Bottom := ABottom;
+  end;
+end;
+
+
+function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
+
+begin
+  with Result do
+  begin
+    Left := ALeft;
+    Top := ATop;
+    Right := ALeft + AWidth;
+    Bottom :=  ATop + AHeight;
+  end;
+end;
+
+
+function PointsEqual(const P1, P2: TPoint): Boolean; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+  begin
+    { lazy, but should work }
+    result:=QWord(P1)=QWord(P2);
+  end;
+
+
+function PointsEqual(const P1, P2: TSmallPoint): Boolean; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+  begin
+    { lazy, but should work }
+    result:=DWord(P1)=DWord(P2);
+  end;
+
+function InvalidPoint(X, Y: Integer): Boolean;
+  begin
+    result:=(X=-1) and (Y=-1);
+  end;
+
+
+function InvalidPoint(const At: TPoint): Boolean;
+  begin
+    result:=(At.x=-1) and (At.y=-1);
+  end;
+
+
+function InvalidPoint(const At: TSmallPoint): Boolean;
+  begin
+    result:=(At.x=-1) and (At.y=-1);
+  end;
+
+
+{ Object filing routines }
+
+var
+  IntConstList: TThreadList;
+
+type
+  TIntConst = class
+    IntegerType: PTypeInfo;             // The integer type RTTI pointer
+    IdentToIntFn: TIdentToInt;          // Identifier to Integer conversion
+    IntToIdentFn: TIntToIdent;          // Integer to Identifier conversion
+    constructor Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
+      AIntToIdent: TIntToIdent);
+  end;
+
+constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
+  AIntToIdent: TIntToIdent);
+begin
+  IntegerType := AIntegerType;
+  IdentToIntFn := AIdentToInt;
+  IntToIdentFn := AIntToIdent;
+end;
+
+procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToIntFn: TIdentToInt;
+  IntToIdentFn: TIntToIdent);
+begin
+  IntConstList.Add(TIntConst.Create(IntegerType, IdentToIntFn, IntToIdentFn));
+end;
+
+function FindIntToIdent(AIntegerType: Pointer): TIntToIdent;
+var
+  i: Integer;
+begin
+  with IntConstList.LockList do
+  try
+    for i := 0 to Count - 1 do
+      if TIntConst(Items[i]).IntegerType = AIntegerType then
+        exit(TIntConst(Items[i]).IntToIdentFn);
+    Result := nil;
+  finally
+    IntConstList.UnlockList;
+  end;
+end;
+
+function FindIdentToInt(AIntegerType: Pointer): TIdentToInt;
+var
+  i: Integer;
+begin
+  with IntConstList.LockList do
+  try
+    for i := 0 to Count - 1 do
+      with TIntConst(Items[I]) do
+        if TIntConst(Items[I]).IntegerType = AIntegerType then
+          exit(IdentToIntFn);
+    Result := nil;
+  finally
+    IntConstList.UnlockList;
+  end;
+end;
+
+function IdentToInt(const Ident: String; var Int: LongInt;
+  const Map: array of TIdentMapEntry): Boolean;
+var
+  i: Integer;
+begin
+  for i := Low(Map) to High(Map) do
+    if CompareText(Map[i].Name, Ident) = 0 then
+    begin
+      Int := Map[i].Value;
+      exit(True);
+    end;
+  Result := False;
+end;
+
+function IntToIdent(Int: LongInt; var Ident: String;
+  const Map: array of TIdentMapEntry): Boolean;
+var
+  i: Integer;
+begin
+  for i := Low(Map) to High(Map) do
+    if Map[i].Value = Int then
+    begin
+      Ident := Map[i].Name;
+      exit(True);
+    end;
+  Result := False;
+end;
+
+function GlobalIdentToInt(const Ident: String; var Int: LongInt):boolean;
+var
+  i : Integer;
+begin
+  with IntConstList.LockList do
+    try
+      for i := 0 to Count - 1 do
+        if TIntConst(Items[I]).IdentToIntFn(Ident, Int) then
+          Exit(True);
+      Result := false;
+    finally
+      IntConstList.UnlockList;
+    end;
+end;
+
+{ TPropFixup }
+// Tainted. TPropFixup is being removed.
+ 
+Type
+  TInitHandler = Class(TObject)
+    AHandler : TInitComponentHandler;
+    AClass : TComponentClass;
+  end;
+
+Var
+  InitHandlerList : TList;
+  FindGlobalComponentList : TList;
+
+procedure RegisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent);
+  begin
+    if not(assigned(FindGlobalComponentList)) then
+      FindGlobalComponentList:=TList.Create;
+    if FindGlobalComponentList.IndexOf(Pointer(AFindGlobalComponent))<0 then
+      FindGlobalComponentList.Add(Pointer(AFindGlobalComponent));
+  end;
+
+
+procedure UnregisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent);
+  begin
+    if assigned(FindGlobalComponentList) then
+      FindGlobalComponentList.Remove(Pointer(AFindGlobalComponent));
+  end;
+
+
+function FindGlobalComponent(const Name: string): TComponent;
+  var
+  	i : sizeint;
+  begin
+    FindGlobalComponent:=nil;
+    if assigned(FindGlobalComponentList) then
+      begin
+      	for i:=FindGlobalComponentList.Count-1 downto 0 do
+      	  begin
+      	    FindGlobalComponent:=TFindGlobalComponent(FindGlobalComponentList[i])(name);
+      	    if assigned(FindGlobalComponent) then
+      	      break;
+      	  end;
+      end;
+  end;
+
+
+procedure RegisterInitComponentHandler(ComponentClass: TComponentClass;   Handler: TInitComponentHandler);
+Var
+  I : Integer;
+  H: TInitHandler;
+begin
+  If (InitHandlerList=Nil) then
+    InitHandlerList:=TList.Create;
+  H:=TInitHandler.Create;
+  H.Aclass:=ComponentClass;
+  H.AHandler:=Handler;
+  try
+    With InitHandlerList do
+      begin
+        I:=0;
+        While (I<Count) and not H.AClass.InheritsFrom(TInitHandler(Items[I]).AClass) do
+          Inc(I);
+        { override? }
+        if (I<Count) and (TInitHandler(Items[I]).AClass=H.AClass) then
+          begin
+            TInitHandler(Items[I]).AHandler:=Handler;
+            H.Free;
+          end
+        else
+          InitHandlerList.Insert(I,H);
+      end;
+   except
+     H.Free;
+     raise;
+  end;
+end;
+
+
+{ all targets should at least include the sysres.inc dummy in the system unit to compile this }
+function CreateComponentfromRes(const res : string;Inst : THandle;var Component : TComponent) : Boolean;
+  var
+    ResStream : TResourceStream;
+  begin
+    result:=true;
+
+    if Inst=0 then
+      Inst:=HInstance;
+
+    try
+      ResStream:=TResourceStream.Create(Inst,res,RT_RCDATA);
+      try
+        Component:=ResStream.ReadComponent(Component);
+      finally
+        ResStream.Free;
+      end;
+    except
+      on EResNotFound do
+        result:=false;
+    end;
+  end;
+
+
+function DefaultInitHandler(Instance: TComponent; RootAncestor: TClass): Boolean;
+
+  function doinit(_class : TClass) : boolean;
+    begin
+      result:=false;
+      if (_class.ClassType=TComponent) or (_class.ClassType=RootAncestor) then
+        exit;
+      result:=doinit(_class.ClassParent);
+      result:=CreateComponentfromRes(_class.ClassName,0,Instance) or result;
+    end;
+
+  begin
+    GlobalNameSpace.BeginWrite;
+    try
+      result:=doinit(Instance.ClassType);
+    finally
+      GlobalNameSpace.EndWrite;
+    end;
+  end;
+
+
+function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
+Var
+  I : Integer;
+begin
+  I:=0;
+  if not Assigned(InitHandlerList) then begin
+    Result := True;
+    Exit;
+  end;
+  Result:=False;
+  With InitHandlerList do
+    begin
+    I:=0;
+    // Instance is the normally the lowest one, so that one should be used when searching.
+    While Not result and (I<Count) do
+      begin
+      If (Instance.InheritsFrom(TInitHandler(Items[i]).AClass)) then
+        Result:=TInitHandler(Items[i]).AHandler(Instance,RootAncestor);
+      Inc(I);
+      end;
+    end;
+end;
+
+
+function InitComponentRes(const ResName: String; Instance: TComponent): Boolean;
+
+begin
+  { !!!: Too Win32-specific }
+  InitComponentRes := False;
+end;
+
+
+function ReadComponentRes(const ResName: String; Instance: TComponent): TComponent;
+
+begin
+  { !!!: Too Win32-specific }
+  ReadComponentRes := nil;
+end;
+
+
+function ReadComponentResEx(HInstance: THandle; const ResName: String): TComponent;
+
+begin
+  { !!!: Too Win32-specific in VCL }
+  ReadComponentResEx := nil;
+end;
+
+
+function ReadComponentResFile(const FileName: String; Instance: TComponent): TComponent;
+var
+  FileStream: TStream;
+begin
+  FileStream := TFileStream.Create(FileName, fmOpenRead {!!!:or fmShareDenyWrite});
+  try
+    Result := FileStream.ReadComponentRes(Instance);
+  finally
+    FileStream.Free;
+  end;
+end;
+
+
+procedure WriteComponentResFile(const FileName: String; Instance: TComponent);
+var
+  FileStream: TStream;
+begin
+  FileStream := TFileStream.Create(FileName, fmCreate);
+  try
+    FileStream.WriteComponentRes(Instance.ClassName, Instance);
+  finally
+    FileStream.Free;
+  end;
+end;
+
+
+Function FindNestedComponent(Root : TComponent; APath : String; CStyle : Boolean = True) : TComponent;
+
+  Function GetNextName : String; inline;
+  
+  Var
+    P : Integer;
+    CM : Boolean;
+    
+  begin
+    P:=Pos('.',APath);
+    CM:=False;
+    If (P=0) then
+      begin
+      If CStyle then
+        begin
+        P:=Pos('->',APath);
+        CM:=P<>0;
+        end;
+      If (P=0) Then
+        P:=Length(APath)+1;
+      end;
+    Result:=Copy(APath,1,P-1);
+    Delete(APath,1,P+Ord(CM));
+  end;
+
+Var
+  C : TComponent;
+  S : String;
+begin
+  If (APath='') then
+    Result:=Nil
+  else
+    begin
+    Result:=Root;
+    While (APath<>'') And (Result<>Nil) do
+      begin
+      C:=Result;
+      S:=Uppercase(GetNextName);
+      Result:=C.FindComponent(S);
+      If (Result=Nil) And (S='OWNER') then
+        Result:=C;
+      end;
+    end;
+end;
+
+threadvar
+  GlobalLoaded, GlobalLists: TList;
+
+procedure BeginGlobalLoading;
+
+begin
+  if not Assigned(GlobalLists) then
+    GlobalLists := TList.Create;
+  GlobalLists.Add(GlobalLoaded);
+  GlobalLoaded := TList.Create;
+end;
+
+
+{ Notify all global components that they have been loaded completely }
+procedure NotifyGlobalLoading;
+var
+  i: Integer;
+begin
+  for i := 0 to GlobalLoaded.Count - 1 do
+    TComponent(GlobalLoaded[i]).Loaded;
+end;
+
+
+procedure EndGlobalLoading;
+begin
+  { Free the memory occupied by BeginGlobalLoading }
+  GlobalLoaded.Free;
+  GlobalLoaded := TList(GlobalLists.Last);
+  GlobalLists.Delete(GlobalLists.Count - 1);
+  if GlobalLists.Count = 0 then
+  begin
+    GlobalLists.Free;
+    GlobalLists := nil;
+  end;
+end;
+
+
+function CollectionsEqual(C1, C2: TCollection): Boolean;
+begin
+  // !!!: Implement this
+  CollectionsEqual:=false;
+end;
+
+function CollectionsEqual(C1, C2: TCollection; Owner1, Owner2: TComponent): Boolean;
+
+  procedure stream_collection(s : tstream;c : tcollection;o : tcomponent);
+    var
+      w : twriter;
+    begin
+      w:=twriter.create(s,4096);
+      try
+        w.root:=o;
+        w.flookuproot:=o;
+        w.writecollection(c);
+      finally
+        w.free;
+      end;
+    end;
+
+  var
+    s1,s2 : tmemorystream;
+  begin
+    result:=false;
+    if (c1.classtype<>c2.classtype) or
+      (c1.count<>c2.count) then
+      exit;
+
+    s1:=tmemorystream.create;
+    try
+      s2:=tmemorystream.create;
+      try
+        stream_collection(s1,c1,owner1);
+        stream_collection(s2,c2,owner2);
+        result:=(s1.size=s2.size) and (CompareChar(s1.memory,s2.memory,s1.size)=0);
+      finally
+        s2.free;
+      end;
+    finally
+      s1.free;
+    end;
+  end;
+
+
+{ Object conversion routines }
+
+type
+  CharToOrdFuncty = Function(var charpo: Pointer): Cardinal;
+
+function CharToOrd(var P: Pointer): Cardinal;
+begin
+  result:= ord(pchar(P)^);
+  inc(pchar(P));
+end;
+
+function WideCharToOrd(var P: Pointer): Cardinal;
+begin
+  result:= ord(pwidechar(P)^);
+  inc(pwidechar(P));
+end;
+
+function Utf8ToOrd(var P:Pointer): Cardinal;
+begin
+  // Should also check for illegal utf8 combinations
+  Result := Ord(PChar(P)^);
+  Inc(P);
+  if (Result and $80) <> 0 then
+    if (Ord(Result) and %11100000) = %11000000 then begin
+      Result := ((Result and %00011111) shl 6)
+                or (ord(PChar(P)^) and %00111111);
+      Inc(P);
+    end else if (Ord(Result) and %11110000) = %11100000 then begin
+      Result := ((Result and %00011111) shl 12)
+                or ((ord(PChar(P)^) and %00111111) shl 6)
+                or (ord((PChar(P)+1)^) and %00111111);
+      Inc(P,2);
+    end else begin
+      Result := ((ord(Result) and %00011111) shl 18)
+                or ((ord(PChar(P)^) and %00111111) shl 12)
+                or ((ord((PChar(P)+1)^) and %00111111) shl 6)
+                or (ord((PChar(P)+2)^) and %00111111);
+      Inc(P,3);
+    end;
+end;
+
+procedure ObjectBinaryToText(Input, Output: TStream);
+
+  procedure OutStr(s: String);
+  begin
+    if Length(s) > 0 then
+      Output.Write(s[1], Length(s));
+  end;
+
+  procedure OutLn(s: String);
+  begin
+    OutStr(s + LineEnding);
+  end;
+
+  procedure Outchars(P, LastP : Pointer; CharToOrdFunc: CharToOrdFuncty);
+
+  var
+    res, NewStr: String;
+    w: Cardinal;
+    InString, NewInString: Boolean;
+  begin
+   if p = nil then begin
+    res:= '''''';
+   end
+   else 
+    begin
+    res := '';
+    InString := False;
+    while P < LastP do 
+      begin
+      NewInString := InString;
+      w := CharToOrdfunc(P);
+      if w = ord('''') then 
+        begin //quote char
+        if not InString then
+          NewInString := True;
+        NewStr := '''''';
+        end 
+      else if (Ord(w) >= 32) and (Ord(w) < 127) then 
+        begin //printable ascii
+        if not InString then
+          NewInString := True;
+        NewStr := char(w);
+        end 
+      else 
+        begin //ascii control chars, non ascii
+        if InString then
+          NewInString := False;
+        NewStr := '#' + IntToStr(w);
+        end;
+      if NewInString <> InString then 
+        begin
+        NewStr := '''' + NewStr;
+        InString := NewInString;
+        end;
+      res := res + NewStr;
+      end;
+    if InString then 
+      res := res + '''';
+    end;
+   OutStr(res);
+  end;
+
+  procedure OutString(s: String);
+
+  begin
+    OutChars(Pointer(S),PChar(S)+Length(S),@CharToOrd);
+  end;
+
+  procedure OutWString(W: WideString);
+
+  begin
+    OutChars(Pointer(W),pwidechar(W)+Length(W),@WideCharToOrd);
+  end;
+
+  procedure OutUtf8Str(s: String);
+  begin
+    OutChars(Pointer(S),PChar(S)+Length(S),@Utf8ToOrd);
+  end;
+
+  function ReadWord : word; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+  begin
+    Result:=Input.ReadWord;
+    Result:=LEtoN(Result);
+  end;
+
+  function ReadDWord : longword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+  begin
+    Result:=Input.ReadDWord;
+    Result:=LEtoN(Result);
+  end;
+
+  function ReadQWord : qword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+  begin
+    Input.ReadBuffer(Result,sizeof(Result));
+    Result:=LEtoN(Result);
+  end;
+
+{$ifndef FPUNONE}
+  {$IFNDEF FPC_HAS_TYPE_EXTENDED}
+  function ExtendedToDouble(e : pointer) : double;
+  var mant : qword;
+      exp : smallint;
+      sign : boolean;
+      d : qword;
+  begin
+    move(pbyte(e)[0],mant,8); //mantissa         : bytes 0..7
+    move(pbyte(e)[8],exp,2);  //exponent and sign: bytes 8..9
+    mant:=LEtoN(mant);
+    exp:=LetoN(word(exp));
+    sign:=(exp and $8000)<>0;
+    if sign then exp:=exp and $7FFF;
+    case exp of
+          0 : mant:=0;  //if denormalized, value is too small for double,
+                        //so it's always zero
+      $7FFF : exp:=2047 //either infinity or NaN
+      else
+      begin
+        dec(exp,16383-1023);
+        if (exp>=-51) and (exp<=0) then //can be denormalized
+        begin
+          mant:=mant shr (-exp);
+          exp:=0;
+        end
+        else
+        if (exp<-51) or (exp>2046) then //exponent too large.
+        begin
+          Result:=0;
+          exit;
+        end
+        else //normalized value
+          mant:=mant shl 1; //hide most significant bit
+      end;
+    end;
+    d:=word(exp);
+    d:=d shl 52;
+
+    mant:=mant shr 12;
+    d:=d or mant;
+    if sign then d:=d or $8000000000000000;
+    Result:=pdouble(@d)^;
+  end;
+  {$ENDIF}
+{$endif}
+
+  function ReadInt(ValueType: TValueType): Int64;
+  begin
+    case ValueType of
+      vaInt8: Result := ShortInt(Input.ReadByte);
+      vaInt16: Result := SmallInt(ReadWord);
+      vaInt32: Result := LongInt(ReadDWord);
+      vaInt64: Result := Int64(ReadQWord);
+    end;
+  end;
+
+  function ReadInt: Int64;
+  begin
+    Result := ReadInt(TValueType(Input.ReadByte));
+  end;
+
+{$ifndef FPUNONE}
+  function ReadExtended : extended;
+  {$IFNDEF FPC_HAS_TYPE_EXTENDED}
+  var ext : array[0..9] of byte;
+  {$ENDIF}
+  begin
+    {$IFNDEF FPC_HAS_TYPE_EXTENDED}
+    Input.ReadBuffer(ext[0],10);
+    Result:=ExtendedToDouble(@(ext[0]));
+    {$ELSE}
+    Input.ReadBuffer(Result,sizeof(Result));
+    {$ENDIF}
+  end;
+{$endif}
+
+  function ReadSStr: String;
+  var
+    len: Byte;
+  begin
+    len := Input.ReadByte;
+    SetLength(Result, len);
+    if (len > 0) then
+      Input.ReadBuffer(Result[1], len);
+  end;
+
+  function ReadLStr: String;
+  var
+    len: DWord;
+  begin
+    len := ReadDWord;
+    SetLength(Result, len);
+    if (len > 0) then
+      Input.ReadBuffer(Result[1], len);
+  end;
+
+  function ReadWStr: WideString;
+  var
+    len: DWord;
+  {$IFDEF ENDIAN_BIG}
+    i : integer;
+  {$ENDIF}
+  begin
+    len := ReadDWord;
+    SetLength(Result, len);
+    if (len > 0) then
+    begin
+      Input.ReadBuffer(Pointer(@Result[1])^, len*2);
+      {$IFDEF ENDIAN_BIG}
+      for i:=1 to len do
+        Result[i]:=widechar(SwapEndian(word(Result[i])));
+      {$ENDIF}
+    end;
+  end;
+
+  procedure ReadPropList(indent: String);
+
+    procedure ProcessValue(ValueType: TValueType; Indent: String);
+
+      procedure ProcessBinary;
+      var
+        ToDo, DoNow, i: LongInt;
+        lbuf: array[0..31] of Byte;
+        s: String;
+      begin
+        ToDo := ReadDWord;
+        OutLn('{');
+        while ToDo > 0 do begin
+          DoNow := ToDo;
+          if DoNow > 32 then DoNow := 32;
+          Dec(ToDo, DoNow);
+          s := Indent + '  ';
+          Input.ReadBuffer(lbuf, DoNow);
+          for i := 0 to DoNow - 1 do
+            s := s + IntToHex(lbuf[i], 2);
+          OutLn(s);
+        end;
+        OutLn(indent + '}');
+      end;
+
+    var
+      s: String;
+{      len: LongInt; }
+      IsFirst: Boolean;
+{$ifndef FPUNONE}
+      ext: Extended;
+{$endif}
+
+    begin
+      case ValueType of
+        vaList: begin
+            OutStr('(');
+            IsFirst := True;
+            while True do begin
+              ValueType := TValueType(Input.ReadByte);
+              if ValueType = vaNull then break;
+              if IsFirst then begin
+                OutLn('');
+                IsFirst := False;
+              end;
+              OutStr(Indent + '  ');
+              ProcessValue(ValueType, Indent + '  ');
+            end;
+            OutLn(Indent + ')');
+          end;
+        vaInt8: OutLn(IntToStr(ShortInt(Input.ReadByte)));
+        vaInt16: OutLn( IntToStr(SmallInt(ReadWord)));
+        vaInt32: OutLn(IntToStr(LongInt(ReadDWord)));
+        vaInt64: OutLn(IntToStr(Int64(ReadQWord)));
+{$ifndef FPUNONE}
+        vaExtended: begin
+            ext:=ReadExtended;
+            Str(ext,S);// Do not use localized strings.
+            OutLn(S);
+          end;
+{$endif}
+        vaString: begin
+            OutString(ReadSStr);
+            OutLn('');
+          end;
+        vaIdent: OutLn(ReadSStr);
+        vaFalse: OutLn('False');
+        vaTrue: OutLn('True');
+        vaBinary: ProcessBinary;
+        vaSet: begin
+            OutStr('[');
+            IsFirst := True;
+            while True do begin
+              s := ReadSStr;
+              if Length(s) = 0 then break;
+              if not IsFirst then OutStr(', ');
+              IsFirst := False;
+              OutStr(s);
+            end;
+            OutLn(']');
+          end;
+        vaLString:
+          begin
+          OutString(ReadLStr);
+          OutLn('');
+          end;
+        vaWString:
+          begin
+          OutWString(ReadWStr);
+          OutLn('');
+          end;
+        vaNil:
+          OutLn('nil');
+        vaCollection: begin
+            OutStr('<');
+            while Input.ReadByte <> 0 do begin
+              OutLn(Indent);
+              Input.Seek(-1, soFromCurrent);
+              OutStr(indent + '  item');
+              ValueType := TValueType(Input.ReadByte);
+              if ValueType <> vaList then
+                OutStr('[' + IntToStr(ReadInt(ValueType)) + ']');
+              OutLn('');
+              ReadPropList(indent + '    ');
+              OutStr(indent + '  end');
+            end;
+            OutLn('>');
+          end;
+        {vaSingle: begin OutLn('!!Single!!'); exit end;
+        vaCurrency: begin OutLn('!!Currency!!'); exit end;
+        vaDate: begin OutLn('!!Date!!'); exit end;}
+        vaUTF8String: begin
+            OutUtf8Str(ReadLStr);
+            OutLn('');
+          end;
+        else
+          Raise EReadError.CreateFmt(SErrInvalidPropertyType,[Ord(ValueType)]);
+      end;
+    end;
+
+  begin
+    while Input.ReadByte <> 0 do begin
+      Input.Seek(-1, soFromCurrent);
+      OutStr(indent + ReadSStr + ' = ');
+      ProcessValue(TValueType(Input.ReadByte), Indent);
+    end;
+  end;
+
+  procedure ReadObject(indent: String);
+  var
+    b: Byte;
+    ObjClassName, ObjName: String;
+    ChildPos: LongInt;
+  begin
+    // Check for FilerFlags
+    b := Input.ReadByte;
+    if (b and $f0) = $f0 then begin
+      if (b and 2) <> 0 then ChildPos := ReadInt;
+    end else begin
+      b := 0;
+      Input.Seek(-1, soFromCurrent);
+    end;
+
+    ObjClassName := ReadSStr;
+    ObjName := ReadSStr;
+
+    OutStr(Indent);
+    if (b and 1) <> 0 then OutStr('inherited')
+    else
+     if (b and 4) <> 0 then OutStr('inline')
+     else OutStr('object');
+    OutStr(' ');
+    if ObjName <> '' then
+      OutStr(ObjName + ': ');
+    OutStr(ObjClassName);
+    if (b and 2) <> 0 then OutStr('[' + IntToStr(ChildPos) + ']');
+    OutLn('');
+
+    ReadPropList(indent + '  ');
+
+    while Input.ReadByte <> 0 do begin
+      Input.Seek(-1, soFromCurrent);
+      ReadObject(indent + '  ');
+    end;
+    OutLn(indent + 'end');
+  end;
+
+type
+  PLongWord = ^LongWord;
+const
+  signature: PChar = 'TPF0';
+  
+begin
+  if Input.ReadDWord <> PLongWord(Pointer(signature))^ then
+    raise EReadError.Create('Illegal stream image' {###SInvalidImage});
+  ReadObject('');
+end;
+
+
+procedure ObjectTextToBinary(Input, Output: TStream);
+var
+  parser: TParser;
+
+  procedure WriteWord(w : word); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+  begin
+    w:=NtoLE(w);
+    Output.WriteWord(w);
+  end;
+
+  procedure WriteDWord(lw : longword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+  begin
+    lw:=NtoLE(lw);
+    Output.WriteDWord(lw);
+  end;
+
+  procedure WriteQWord(qw : qword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+  begin
+    qw:=NtoLE(qw);
+    Output.WriteBuffer(qw,sizeof(qword));
+  end;
+
+{$ifndef FPUNONE}
+  {$IFNDEF FPC_HAS_TYPE_EXTENDED}
+  procedure DoubleToExtended(d : double; e : pointer);
+  var mant : qword;
+      exp : smallint;
+      sign : boolean;
+  begin
+    mant:=(qword(d) and $000FFFFFFFFFFFFF) shl 12;
+    exp :=(qword(d) shr 52) and $7FF;
+    sign:=(qword(d) and $8000000000000000)<>0;
+    case exp of
+         0 : begin
+               if mant<>0 then  //denormalized value: hidden bit is 0. normalize it
+               begin
+                 exp:=16383-1022;
+                 while (mant and $8000000000000000)=0 do
+                 begin
+                   dec(exp);
+                   mant:=mant shl 1;
+                 end;
+                 dec(exp); //don't shift, most significant bit is not hidden in extended
+               end;
+             end;
+      2047 : exp:=$7FFF //either infinity or NaN
+      else
+      begin
+        inc(exp,16383-1023);
+        mant:=(mant shr 1) or $8000000000000000; //unhide hidden bit
+      end;
+    end;
+    if sign then exp:=exp or $8000;
+    mant:=NtoLE(mant);
+    exp:=NtoLE(word(exp));
+    move(mant,pbyte(e)[0],8); //mantissa         : bytes 0..7
+    move(exp,pbyte(e)[8],2);  //exponent and sign: bytes 8..9
+  end;
+  {$ENDIF}
+
+  procedure WriteExtended(e : extended);
+  {$IFNDEF FPC_HAS_TYPE_EXTENDED}
+  var ext : array[0..9] of byte;
+  {$ENDIF}
+  begin
+    {$IFNDEF FPC_HAS_TYPE_EXTENDED}
+    DoubleToExtended(e,@(ext[0]));
+    Output.WriteBuffer(ext[0],10);
+    {$ELSE}
+    Output.WriteBuffer(e,sizeof(e));
+    {$ENDIF}
+  end;
+{$endif}
+
+  procedure WriteString(s: String);
+  var size : byte;
+  begin
+    if length(s)>255 then size:=255
+    else size:=length(s);
+    Output.WriteByte(size);
+    if Length(s) > 0 then
+      Output.WriteBuffer(s[1], size);
+  end;
+
+  procedure WriteLString(Const s: String);
+  begin
+    WriteDWord(Length(s));
+    if Length(s) > 0 then
+      Output.WriteBuffer(s[1], Length(s));
+  end;
+
+  procedure WriteWString(Const s: WideString);
+  var len : longword;
+  {$IFDEF ENDIAN_BIG}
+      i : integer;
+      ws : widestring;
+  {$ENDIF}
+  begin
+    len:=Length(s);
+    WriteDWord(len);
+    if len > 0 then
+    begin
+      {$IFDEF ENDIAN_BIG}
+      setlength(ws,len);
+      for i:=1 to len do
+        ws[i]:=widechar(SwapEndian(word(s[i])));
+      Output.WriteBuffer(ws[1], len*sizeof(widechar));
+      {$ELSE}
+      Output.WriteBuffer(s[1], len*sizeof(widechar));
+      {$ENDIF}
+    end;
+  end;
+
+  procedure WriteInteger(value: Int64);
+  begin
+    if (value >= -128) and (value <= 127) then begin
+      Output.WriteByte(Ord(vaInt8));
+      Output.WriteByte(byte(value));
+    end else if (value >= -32768) and (value <= 32767) then begin
+      Output.WriteByte(Ord(vaInt16));
+      WriteWord(word(value));
+    end else if (value >= -2147483648) and (value <= 2147483647) then begin
+      Output.WriteByte(Ord(vaInt32));
+      WriteDWord(longword(value));
+    end else begin
+      Output.WriteByte(ord(vaInt64));
+      WriteQWord(qword(value));
+    end;
+  end;
+  
+  procedure ProcessProperty; forward;
+
+  procedure ProcessValue;
+  var
+{$ifndef FPUNONE}
+    flt: Extended;
+{$endif}
+    s: String;
+    ws: WideString;
+    stream: TMemoryStream;
+    i: Integer;
+    b: Boolean;
+  begin
+    case parser.Token of
+      toInteger:
+        begin
+          WriteInteger(parser.TokenInt);
+          parser.NextToken;
+        end;
+{$ifndef FPUNONE}
+      toFloat:
+        begin
+          Output.WriteByte(Ord(vaExtended));
+          flt := Parser.TokenFloat;
+          WriteExtended(flt);
+          parser.NextToken;
+        end;
+{$endif}
+      toString:
+        begin
+          ws := parser.TokenWideString;
+          while parser.NextToken = '+' do
+          begin
+            parser.NextToken;   // Get next string fragment
+            parser.CheckToken(toString);
+            ws := ws + parser.TokenWideString;
+          end;
+          b:= false;
+          for i:= 1 to length(ws) do begin
+            if ord(ws[i]) and $ff00 <> 0 then begin
+              b:= true;
+              break;
+            end;
+          end;
+          if b then begin
+            Output.WriteByte(Ord(vaWstring));
+            WriteWString(ws);
+            end
+          else
+	    begin
+            setlength(s,length(ws));
+            for i:= 1 to length(s) do begin
+              s[i]:= chr(ord(ws[i])); //cut msb
+            end;
+            if (length(S)>255) then begin
+            Output.WriteByte(Ord(vaLString));
+            WriteLString(S);
+            end
+            else begin
+            Output.WriteByte(Ord(vaString));
+            WriteString(s);
+            end;
+          end;
+        end;
+      toSymbol:
+        begin
+          if CompareText(parser.TokenString, 'True') = 0 then
+            Output.WriteByte(Ord(vaTrue))
+          else if CompareText(parser.TokenString, 'False') = 0 then
+            Output.WriteByte(Ord(vaFalse))
+          else if CompareText(parser.TokenString, 'nil') = 0 then
+            Output.WriteByte(Ord(vaNil))
+          else
+          begin
+            Output.WriteByte(Ord(vaIdent));
+            WriteString(parser.TokenComponentIdent);
+          end;
+          Parser.NextToken;
+        end;
+      // Set
+      '[':
+        begin
+          parser.NextToken;
+          Output.WriteByte(Ord(vaSet));
+          if parser.Token <> ']' then
+            while True do
+            begin
+              parser.CheckToken(toSymbol);
+              WriteString(parser.TokenString);
+              parser.NextToken;
+              if parser.Token = ']' then
+                break;
+              parser.CheckToken(',');
+              parser.NextToken;
+            end;
+          Output.WriteByte(0);
+          parser.NextToken;
+        end;
+      // List
+      '(':
+        begin
+          parser.NextToken;
+          Output.WriteByte(Ord(vaList));
+          while parser.Token <> ')' do
+            ProcessValue;
+          Output.WriteByte(0);
+          parser.NextToken;
+        end;
+      // Collection
+      '<':
+        begin
+          parser.NextToken;
+          Output.WriteByte(Ord(vaCollection));
+          while parser.Token <> '>' do
+          begin
+            parser.CheckTokenSymbol('item');
+            parser.NextToken;
+            // ConvertOrder
+            Output.WriteByte(Ord(vaList));
+            while not parser.TokenSymbolIs('end') do
+              ProcessProperty;
+            parser.NextToken;   // Skip 'end'
+            Output.WriteByte(0);
+          end;
+          Output.WriteByte(0);
+          parser.NextToken;
+        end;
+      // Binary data
+      '{':
+        begin
+          Output.WriteByte(Ord(vaBinary));
+          stream := TMemoryStream.Create;
+          try
+            parser.HexToBinary(stream);
+            WriteDWord(stream.Size);
+            Output.WriteBuffer(Stream.Memory^, stream.Size);
+          finally
+            stream.Free;
+          end;
+          parser.NextToken;
+        end;
+      else
+        parser.Error(SInvalidProperty);
+    end;
+  end;
+
+  procedure ProcessProperty;
+  var
+    name: String;
+  begin
+    // Get name of property
+    parser.CheckToken(toSymbol);
+    name := parser.TokenString;
+    while True do begin
+      parser.NextToken;
+      if parser.Token <> '.' then break;
+      parser.NextToken;
+      parser.CheckToken(toSymbol);
+      name := name + '.' + parser.TokenString;
+    end;
+    WriteString(name);
+    parser.CheckToken('=');
+    parser.NextToken;
+    ProcessValue;
+  end;
+
+  procedure ProcessObject;
+  var
+    Flags: Byte;
+    ObjectName, ObjectType: String;
+    ChildPos: Integer;
+  begin
+    if parser.TokenSymbolIs('OBJECT') then
+      Flags :=0  { IsInherited := False }
+    else begin
+      if parser.TokenSymbolIs('INHERITED') then
+        Flags := 1 { IsInherited := True; }
+      else begin
+        parser.CheckTokenSymbol('INLINE');
+        Flags := 4;
+      end;
+    end;
+    parser.NextToken;
+    parser.CheckToken(toSymbol);
+    ObjectName := '';
+    ObjectType := parser.TokenString;
+    parser.NextToken;
+    if parser.Token = ':' then begin
+      parser.NextToken;
+      parser.CheckToken(toSymbol);
+      ObjectName := ObjectType;
+      ObjectType := parser.TokenString;
+      parser.NextToken;
+      if parser.Token = '[' then begin
+        parser.NextToken;
+        ChildPos := parser.TokenInt;
+        parser.NextToken;
+        parser.CheckToken(']');
+        parser.NextToken;
+        Flags := Flags or 2;
+      end;
+    end;
+    if Flags <> 0 then begin
+      Output.WriteByte($f0 or Flags);
+      if (Flags and 2) <> 0 then
+        WriteInteger(ChildPos);
+    end;
+    WriteString(ObjectType);
+    WriteString(ObjectName);
+
+    // Convert property list
+    while not (parser.TokenSymbolIs('END') or
+      parser.TokenSymbolIs('OBJECT') or
+      parser.TokenSymbolIs('INHERITED') or
+      parser.TokenSymbolIs('INLINE')) do
+      ProcessProperty;
+    Output.WriteByte(0);        // Terminate property list
+
+    // Convert child objects
+    while not parser.TokenSymbolIs('END') do ProcessObject;
+    parser.NextToken;           // Skip end token
+    Output.WriteByte(0);        // Terminate property list
+  end;
+
+const
+  signature: PChar = 'TPF0';
+begin
+  parser := TParser.Create(Input);
+  try
+    Output.WriteBuffer(signature[0], 4);
+    ProcessObject;
+  finally
+    parser.Free;
+  end;
+end;
+
+
+procedure ObjectResourceToText(Input, Output: TStream);
+begin
+  Input.ReadResHeader;
+  ObjectBinaryToText(Input, Output);
+end;
+
+
+procedure ObjectTextToResource(Input, Output: TStream);
+var
+  StartPos, FixupInfo: LongInt;
+  parser: TParser;
+  name: String;
+begin
+  // Get form type name
+  StartPos := Input.Position;
+  parser := TParser.Create(Input);
+  try
+    if not parser.TokenSymbolIs('OBJECT') then parser.CheckTokenSymbol('INHERITED');
+    parser.NextToken;
+    parser.CheckToken(toSymbol);
+    parser.NextToken;
+    parser.CheckToken(':');
+    parser.NextToken;
+    parser.CheckToken(toSymbol);
+    name := parser.TokenString;
+  finally
+    parser.Free;
+    Input.Position := StartPos;
+  end;
+
+  name := UpperCase(name);
+  Output.WriteResourceHeader(name,FixupInfo); // Write resource header
+  ObjectTextToBinary(Input, Output);          // Convert the stuff!
+  Output.FixupResourceHeader(FixupInfo);      // Insert real resource data size
+end;
+
+
+
+{ Utility routines }
+
+function LineStart(Buffer, BufPos: PChar): PChar;
+
+begin
+  Result := BufPos;
+  while Result > Buffer do begin
+    Dec(Result);
+    if Result[0] = #10 then break;
+  end;
+end;
+
+procedure CommonInit;
+begin
+  InitCriticalSection(SynchronizeCritSect);
+  ExecuteEvent:=RtlEventCreate;
+  SynchronizeTimeoutEvent:=RtlEventCreate;
+  DoSynchronizeMethod:=false;
+  MainThreadID:=GetCurrentThreadID;
+  InitCriticalsection(ResolveSection);
+  InitHandlerList:=Nil;
+  FindGlobalComponentList:=nil;
+  IntConstList := TThreadList.Create;
+  ClassList := TThreadList.Create;
+  ClassAliasList := TStringList.Create;
+  { on unix this maps to a simple rw synchornizer }
+  GlobalNameSpace := TMultiReadExclusiveWriteSynchronizer.Create;
+  RegisterInitComponentHandler(TComponent,@DefaultInitHandler);
+end;
+
+procedure CommonCleanup;
+var
+  i: Integer;
+begin
+  GlobalNameSpace.BeginWrite;
+  with IntConstList.LockList do
+    try
+      for i := 0 to Count - 1 do
+        TIntConst(Items[I]).Free;
+    finally
+      IntConstList.UnlockList;
+    end;
+    IntConstList.Free;
+  ClassList.Free;
+  ClassAliasList.Free;
+  RemoveFixupReferences(nil, '');
+  DoneCriticalsection(ResolveSection);
+  GlobalLists.Free;
+  ComponentPages.Free;
+
+  { GlobalNameSpace is an interface so this is enough }
+  GlobalNameSpace:=nil;
+
+  if (InitHandlerList<>Nil) then
+    for i := 0 to InitHandlerList.Count - 1 do
+      TInitHandler(InitHandlerList.Items[I]).Free;
+  InitHandlerList.Free;
+  InitHandlerList:=Nil;
+  FindGlobalComponentList.Free;
+  FindGlobalComponentList:=nil;
+  DoneCriticalSection(SynchronizeCritSect);
+  RtlEventDestroy(ExecuteEvent);
+  RtlEventDestroy(SynchronizeTimeoutEvent);
+end;
+
+{ TFiler implementation }
+{$i filer.inc}
+
+{ TReader implementation }
+{$i reader.inc}
+
+{ TWriter implementations }
+{$i writer.inc}
+{$i twriter.inc}
+
+

rtl/objpas/classes/classesh.inc

@@ -0,0 +1,1867 @@
+{
+    This file is part of the Free Pascal Run Time Library (rtl)
+    Copyright (c) 1999-2008 by Michael Van Canneyt, Florian Klaempfl,
+    and Micha Nelissen
+
+    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.
+
+ **********************************************************************}
+
+{$H+}
+
+
+{$IFDEF VER2_0}
+// Sanity check
+{$UNDEF FPC_TESTGENERICS}
+{$ENDIF}
+
+{$ifdef CLASSESINLINE}{$inline on}{$endif}
+
+
+type
+   { extra types to compile with FPC }
+   HRSRC = longint;
+   TComponentName = string;
+   THandle = System.THandle;
+
+   TPoint=Types.TPoint;
+   TRect=Types.TRect;
+
+{$ifndef windows}
+   TSmallPoint = record
+      x,y : smallint;
+   end;
+   HMODULE = longint;
+{$else}
+   TSmallPoint = Windows.TSmallPoint;
+   HModule = System.HModule;
+{$endif}
+
+const
+
+{ Maximum TList size }
+
+  MaxListSize = Maxint div 16;
+
+{ values for TShortCut }
+
+  scShift = $2000;
+  scCtrl = $4000;
+  scAlt = $8000;
+  scNone = 0;
+
+{ TStream seek origins }
+const
+  soFromBeginning = 0;
+  soFromCurrent = 1;
+  soFromEnd = 2;
+
+type
+  TSeekOrigin = (soBeginning, soCurrent, soEnd);
+  TDuplicates = Types.TDuplicates;
+
+// For Delphi and backwards compatibility.
+const
+  dupIgnore = Types.dupIgnore;
+  dupAccept = Types.dupAccept;
+  dupError  = Types.dupError;
+
+{ TFileStream create mode }
+const
+  fmCreate        = $FFFF;
+  fmOpenRead      = 0;
+  fmOpenWrite     = 1;
+  fmOpenReadWrite = 2;
+
+{ TParser special tokens }
+
+  toEOF     = Char(0);
+  toSymbol  = Char(1);
+  toString  = Char(2);
+  toInteger = Char(3);
+  toFloat   = Char(4);
+  toWString = Char(5);
+
+Const
+  FilerSignature : Array[1..4] of char = 'TPF0';
+
+type
+{ Text alignment types }
+  TAlignment = (taLeftJustify, taRightJustify, taCenter);
+
+  TLeftRight = taLeftJustify..taRightJustify;
+
+  TBiDiMode = (bdLeftToRight,bdRightToLeft,bdRightToLeftNoAlign,bdRightToLeftReadingOnly);
+
+
+{ Types used by standard events }
+  TShiftStateEnum = (ssShift, ssAlt, ssCtrl,
+    ssLeft, ssRight, ssMiddle, ssDouble,
+    // Extra additions
+    ssMeta, ssSuper, ssHyper, ssAltGr, ssCaps, ssNum,
+    ssScroll,ssTriple,ssQuad,ssExtra1,ssExtra2);
+
+{$packset 1}
+  TShiftState = set of TShiftStateEnum;
+{$packset default}
+
+  THelpContext = -MaxLongint..MaxLongint;
+  THelpType = (htKeyword, htContext);
+
+  TShortCut = Low(Word)..High(Word);
+
+{ Standard events }
+
+  TNotifyEvent = procedure(Sender: TObject) of object;
+  THelpEvent = function (Command: Word; Data: Longint;
+    var CallHelp: Boolean): Boolean of object;
+  TGetStrProc = procedure(const S: string) of object;
+
+{ Exception classes }
+
+  EStreamError = class(Exception);
+  EFCreateError = class(EStreamError);
+  EFOpenError = class(EStreamError);
+  EFilerError = class(EStreamError);
+  EReadError = class(EFilerError);
+  EWriteError = class(EFilerError);
+  EClassNotFound = class(EFilerError);
+  EMethodNotFound = class(EFilerError);
+  EInvalidImage = class(EFilerError);
+  EResNotFound = class(Exception);
+{$ifdef FPC_TESTGENERICS}
+  EListError = fgl.EListError;
+{$else}
+  EListError = class(Exception);
+{$endif}
+  EBitsError = class(Exception);
+  EStringListError = class(Exception);
+  EComponentError = class(Exception);
+  EParserError = class(Exception);
+  EOutOfResources = class(EOutOfMemory);
+  EInvalidOperation = class(Exception);
+
+{ Forward class declarations }
+
+  TStream = class;
+  TFiler = class;
+  TReader = class;
+  TWriter = class;
+  TComponent = class;
+
+{ TFPList class }
+
+  PPointerList = ^TPointerList;
+  TPointerList = array[0..MaxListSize - 1] of Pointer;
+  TListSortCompare = function (Item1, Item2: Pointer): Integer;
+  TListCallback = Types.TListCallback;
+  TListStaticCallback = Types.TListStaticCallback;
+
+
+{$IFNDEF FPC_TESTGENERICS}
+
+  TListAssignOp = (laCopy, laAnd, laOr, laXor, laSrcUnique, laDestUnique);
+
+  TFPList = class(TObject)
+  private
+    FList: PPointerList;
+    FCount: Integer;
+    FCapacity: Integer;
+    procedure CopyMove (aList : TFPList);
+    procedure MergeMove (aList : TFPList);
+    procedure DoCopy(ListA, ListB : TFPList);
+    procedure DoSrcUnique(ListA, ListB : TFPList);
+    procedure DoAnd(ListA, ListB : TFPList);
+    procedure DoDestUnique(ListA, ListB : TFPList);
+    procedure DoOr(ListA, ListB : TFPList);
+    procedure DoXOr(ListA, ListB : TFPList);
+  protected
+    function Get(Index: Integer): Pointer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
+    procedure Put(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
+    procedure SetCapacity(NewCapacity: Integer);
+    procedure SetCount(NewCount: Integer);
+    Procedure RaiseIndexError(Index: Integer);
+  public
+    destructor Destroy; override;
+    Procedure AddList(AList : TFPList);
+    function Add(Item: Pointer): Integer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
+    procedure Clear;
+    procedure Delete(Index: Integer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
+    class procedure Error(const Msg: string; Data: PtrInt);
+    procedure Exchange(Index1, Index2: Integer);
+    function Expand: TFPList; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
+    function Extract(Item: Pointer): Pointer;
+    function First: Pointer;
+    function IndexOf(Item: Pointer): Integer;
+    procedure Insert(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
+    function Last: Pointer;
+    procedure Move(CurIndex, NewIndex: Integer);
+    procedure Assign (ListA: TFPList; AOperator: TListAssignOp=laCopy; ListB: TFPList=nil);
+    function Remove(Item: Pointer): Integer;
+    procedure Pack;
+    procedure Sort(Compare: TListSortCompare);
+    procedure ForEachCall(proc2call:TListCallback;arg:pointer);
+    procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer);
+    property Capacity: Integer read FCapacity write SetCapacity;
+    property Count: Integer read FCount write SetCount;
+    property Items[Index: Integer]: Pointer read Get write Put; default;
+    property List: PPointerList read FList;
+  end;
+
+{$else}
+
+  TFPPtrList = specialize TFPGList<Pointer>;
+
+  TFPList = class(TFPPtrList)
+  public
+    procedure Assign(Source: TFPList);
+    procedure Sort(Compare: TListSortCompare);
+    procedure ForEachCall(Proc2call: TListCallback; Arg: Pointer);
+    procedure ForEachCall(Proc2call: TListStaticCallback; Arg: Pointer);
+  end;
+
+{$endif}
+
+{ TList class}
+  TListNotification = (lnAdded, lnExtracted, lnDeleted);
+
+
+  TList = class(TObject)
+  private
+    FList: TFPList;
+    procedure CopyMove (aList : TList);
+    procedure MergeMove (aList : TList);
+    procedure DoCopy(ListA, ListB : TList);
+    procedure DoSrcUnique(ListA, ListB : TList);
+    procedure DoAnd(ListA, ListB : TList);
+    procedure DoDestUnique(ListA, ListB : TList);
+    procedure DoOr(ListA, ListB : TList);
+    procedure DoXOr(ListA, ListB : TList);
+  protected
+    function Get(Index: Integer): Pointer;
+    procedure Grow; virtual;
+    procedure Put(Index: Integer; Item: Pointer);
+    procedure Notify(Ptr: Pointer; Action: TListNotification); virtual;
+    procedure SetCapacity(NewCapacity: Integer);
+    function GetCapacity: integer;
+    procedure SetCount(NewCount: Integer);
+    function GetCount: integer;
+    function GetList: PPointerList;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    Procedure AddList(AList : TList);
+    function Add(Item: Pointer): Integer;
+    procedure Clear; virtual;
+    procedure Delete(Index: Integer);
+    class procedure Error(const Msg: string; Data: PtrInt); virtual;
+    procedure Exchange(Index1, Index2: Integer);
+    function Expand: TList;
+    function Extract(item: Pointer): Pointer;
+    function First: Pointer;
+    function IndexOf(Item: Pointer): Integer;
+    procedure Insert(Index: Integer; Item: Pointer);
+    function Last: Pointer;
+    procedure Move(CurIndex, NewIndex: Integer);
+    procedure Assign (ListA: TList; AOperator: TListAssignOp=laCopy; ListB: TList=nil);
+    function Remove(Item: Pointer): Integer;
+    procedure Pack;
+    procedure Sort(Compare: TListSortCompare);
+    property Capacity: Integer read GetCapacity write SetCapacity;
+    property Count: Integer read GetCount write SetCount;
+    property Items[Index: Integer]: Pointer read Get write Put; default;
+    property List: PPointerList read GetList;
+  end;
+
+{ TThreadList class }
+
+  TThreadList = class
+  private
+    FList: TList;
+    FDuplicates: TDuplicates;
+    FLock: TRTLCriticalSection;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure Add(Item: Pointer);
+    procedure Clear;
+    function  LockList: TList;
+    procedure Remove(Item: Pointer);
+    procedure UnlockList;
+    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
+  end;
+
+{TBits Class}
+
+const
+   BITSHIFT = 5;
+   MASK = 31; {for longs that are 32-bit in size}
+   MaxBitRec = $FFFF Div (SizeOf(longint));
+   MaxBitFlags = MaxBitRec * 32;
+
+type
+   TBitArray = array[0..MaxBitRec - 1] of cardinal;
+
+   TBits = class(TObject)
+   private
+      { Private declarations }
+      FBits : ^TBitArray;
+      FSize : longint;  { total longints currently allocated }
+      FBSize: longint;  {total bits currently allocated}
+      findIndex : longint;
+      findState : boolean;
+
+      { functions and properties to match TBits class }
+      procedure SetBit(bit : longint; value : Boolean);
+      function GetSize : longint;
+      procedure SetSize(value : longint);
+      procedure CheckBitIndex (Bit : longint;CurrentSize : Boolean);
+      procedure Resize(Nbit : longint);
+   public
+      { Public declarations }
+      constructor Create(TheSize : longint = 0); virtual;
+      destructor Destroy; override;
+      function  GetFSize : longint;
+      procedure SetOn(Bit : longint);
+      procedure Clear(Bit : longint);
+      procedure Clearall;
+      procedure AndBits(BitSet : TBits);
+      procedure OrBits(BitSet : TBits);
+      procedure XorBits(BitSet : TBits);
+      procedure NotBits(BitSet : TBits);
+      function  Get(Bit : longint) : boolean;
+      procedure Grow(NBit : longint);
+      function  Equals(BitSet : TBits) : Boolean;
+      procedure SetIndex(Index : longint);
+      function  FindFirstBit(State : boolean) : longint;
+      function  FindNextBit : longint;
+      function  FindPrevBit : longint;
+
+      { functions and properties to match TBits class }
+      function OpenBit: longint;
+      property Bits[Bit: longint]: Boolean read get write SetBit; default;
+      property Size: longint read getSize write setSize;
+   end;
+
+{ TPersistent abstract class }
+
+{$M+}
+
+  TPersistent = class(TObject)
+  private
+    procedure AssignError(Source: TPersistent);
+  protected
+    procedure AssignTo(Dest: TPersistent); virtual;
+    procedure DefineProperties(Filer: TFiler); virtual;
+    function  GetOwner: TPersistent; dynamic;
+  public
+    destructor Destroy; override;
+    procedure Assign(Source: TPersistent); virtual;
+    function  GetNamePath: string; virtual; {dynamic;}
+  end;
+
+{$M-}
+
+{ TPersistent class reference type }
+
+  TPersistentClass = class of TPersistent;
+
+{ TInterfaced Persistent }
+
+  TInterfacedPersistent = class(TPersistent, IInterface)
+  private
+    FOwnerInterface: IInterface;
+  protected
+    { IInterface }
+    function _AddRef: Integer; stdcall;
+    function _Release: Integer; stdcall;
+  public
+    function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
+    procedure AfterConstruction; override;
+  end;
+
+{ TRecall class }
+
+  TRecall = class(TObject)
+  private
+    FStorage, FReference: TPersistent;
+  public
+    constructor Create(AStorage, AReference: TPersistent);
+    destructor Destroy; override;
+    procedure Store;
+    procedure Forget;
+    property Reference: TPersistent read FReference;
+  end;
+
+{ TCollection class }
+
+  TCollection = class;
+
+  TCollectionItem = class(TPersistent)
+  private
+    FCollection: TCollection;
+    FID: Integer;
+    FUpdateCount: Integer;
+    function GetIndex: Integer;
+  protected
+    procedure SetCollection(Value: TCollection);virtual;
+    procedure Changed(AllItems: Boolean);
+    function GetNamePath: string; override;
+    function GetOwner: TPersistent; override;
+    function GetDisplayName: string; virtual;
+    procedure SetIndex(Value: Integer); virtual;
+    procedure SetDisplayName(const Value: string); virtual;
+    property UpdateCount: Integer read FUpdateCount;
+  public
+    constructor Create(ACollection: TCollection); virtual;
+    destructor Destroy; override;
+    property Collection: TCollection read FCollection write SetCollection;
+    property ID: Integer read FID;
+    property Index: Integer read GetIndex write SetIndex;
+    property DisplayName: string read GetDisplayName write SetDisplayName;
+  end;
+
+  TCollectionItemClass = class of TCollectionItem;
+  TCollectionNotification = (cnAdded, cnExtracting, cnDeleting);
+
+  TCollection = class(TPersistent)
+  private
+    FItemClass: TCollectionItemClass;
+    FItems: TList;
+    FUpdateCount: Integer;
+    FNextID: Integer;
+    FPropName: string;
+    function GetCount: Integer;
+    function GetPropName: string;
+    procedure InsertItem(Item: TCollectionItem);
+    procedure RemoveItem(Item: TCollectionItem);
+  protected
+    { Design-time editor support }
+    function GetAttrCount: Integer; dynamic;
+    function GetAttr(Index: Integer): string; dynamic;
+    function GetItemAttr(Index, ItemIndex: Integer): string; dynamic;
+    function GetNamePath: string; override;
+    procedure Changed;
+    function GetItem(Index: Integer): TCollectionItem;
+    procedure SetItem(Index: Integer; Value: TCollectionItem);
+    procedure SetItemName(Item: TCollectionItem); virtual;
+    procedure SetPropName; virtual;
+    procedure Update(Item: TCollectionItem); virtual;
+    procedure Notify(Item: TCollectionItem;Action: TCollectionNotification); virtual;
+    property PropName: string read GetPropName write FPropName;
+    property UpdateCount: Integer read FUpdateCount;
+  public
+    constructor Create(AItemClass: TCollectionItemClass);
+    destructor Destroy; override;
+    function Owner: TPersistent;
+    function Add: TCollectionItem;
+    procedure Assign(Source: TPersistent); override;
+    procedure BeginUpdate; virtual;
+    procedure Clear;
+    procedure EndUpdate; virtual;
+    procedure Delete(Index: Integer);
+    function Insert(Index: Integer): TCollectionItem;
+    function FindItemID(ID: Integer): TCollectionItem;
+    property Count: Integer read GetCount;
+    property ItemClass: TCollectionItemClass read FItemClass;
+    property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
+  end;
+
+  TOwnedCollection = class(TCollection)
+  private
+    FOwner: TPersistent;
+  protected
+    Function GetOwner: TPersistent; override;
+  public
+    Constructor Create(AOwner: TPersistent;AItemClass: TCollectionItemClass);
+  end;
+
+
+  TStrings = class;
+
+{ IStringsAdapter interface }
+
+  { Maintains link between TStrings and IStrings implementations }
+  IStringsAdapter = interface ['{739C2F34-52EC-11D0-9EA6-0020AF3D82DA}']
+    procedure ReferenceStrings(S: TStrings);
+    procedure ReleaseStrings;
+  end;
+
+{ TStrings class }
+
+  TStrings = class(TPersistent)
+  private
+    FSpecialCharsInited : boolean;
+    FQuoteChar : Char;
+    FDelimiter : Char;
+    FNameValueSeparator : Char;
+    FUpdateCount: Integer;
+    FAdapter: IStringsAdapter;
+    FLBS : TTextLineBreakStyle;
+    function GetCommaText: string;
+    function GetName(Index: Integer): string;
+    function GetValue(const Name: string): string;
+    Function GetLBS : TTextLineBreakStyle;
+    Procedure SetLBS (AValue : TTextLineBreakStyle); 
+    procedure ReadData(Reader: TReader);
+    procedure SetCommaText(const Value: string);
+    procedure SetStringsAdapter(const Value: IStringsAdapter);
+    procedure SetValue(const Name, Value: string);
+    procedure SetDelimiter(c:Char);
+    procedure SetQuoteChar(c:Char);
+    procedure SetNameValueSeparator(c:Char);
+    procedure WriteData(Writer: TWriter);
+  protected
+    procedure DefineProperties(Filer: TFiler); override;
+    procedure Error(const Msg: string; Data: Integer);
+    procedure Error(const Msg: pstring; Data: Integer);
+    function Get(Index: Integer): string; virtual; abstract;
+    function GetCapacity: Integer; virtual;
+    function GetCount: Integer; virtual; abstract;
+    function GetObject(Index: Integer): TObject; virtual;
+    function GetTextStr: string; virtual;
+    procedure Put(Index: Integer; const S: string); virtual;
+    procedure PutObject(Index: Integer; AObject: TObject); virtual;
+    procedure SetCapacity(NewCapacity: Integer); virtual;
+    procedure SetTextStr(const Value: string); virtual;
+    procedure SetUpdateState(Updating: Boolean); virtual;
+    property UpdateCount: Integer read FUpdateCount;
+    Function DoCompareText(const s1,s2 : string) : PtrInt; virtual;
+    Function GetDelimitedText: string;
+    Procedure SetDelimitedText(Const AValue: string);
+    Function GetValueFromIndex(Index: Integer): string;
+    Procedure SetValueFromIndex(Index: Integer; const Value: string);
+    Procedure CheckSpecialChars;
+  public
+    destructor Destroy; override;
+    function Add(const S: string): Integer; virtual;
+    function AddObject(const S: string; AObject: TObject): Integer; virtual;
+    procedure Append(const S: string);
+    procedure AddStrings(TheStrings: TStrings); virtual;
+    procedure Assign(Source: TPersistent); override;
+    procedure BeginUpdate;
+    procedure Clear; virtual; abstract;
+    procedure Delete(Index: Integer); virtual; abstract;
+    procedure EndUpdate;
+    function Equals(TheStrings: TStrings): Boolean;
+    procedure Exchange(Index1, Index2: Integer); virtual;
+    function GetText: PChar; virtual;
+    function IndexOf(const S: string): Integer; virtual;
+    function IndexOfName(const Name: string): Integer; virtual;
+    function IndexOfObject(AObject: TObject): Integer; virtual;
+    procedure Insert(Index: Integer; const S: string); virtual; abstract;
+    procedure InsertObject(Index: Integer; const S: string;
+      AObject: TObject);
+    procedure LoadFromFile(const FileName: string); virtual;
+    procedure LoadFromStream(Stream: TStream); virtual;
+    procedure Move(CurIndex, NewIndex: Integer); virtual;
+    procedure SaveToFile(const FileName: string); virtual;
+    procedure SaveToStream(Stream: TStream); virtual;
+    procedure SetText(TheText: PChar); virtual;
+    procedure GetNameValue(Index : Integer; Var AName,AValue : String);
+    function  ExtractName(Const S:String):String;
+    Property TextLineBreakStyle : TTextLineBreakStyle Read GetLBS Write SetLBS;
+    property Delimiter: Char read FDelimiter write SetDelimiter;
+    property DelimitedText: string read GetDelimitedText write SetDelimitedText;
+    property QuoteChar: Char read FQuoteChar write SetQuoteChar;
+    Property NameValueSeparator : Char Read FNameValueSeparator Write SetNameValueSeparator;
+    property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex;
+    property Capacity: Integer read GetCapacity write SetCapacity;
+    property CommaText: string read GetCommaText write SetCommaText;
+    property Count: Integer read GetCount;
+    property Names[Index: Integer]: string read GetName;
+    property Objects[Index: Integer]: TObject read GetObject write PutObject;
+    property Values[const Name: string]: string read GetValue write SetValue;
+    property Strings[Index: Integer]: string read Get write Put; default;
+    property Text: string read GetTextStr write SetTextStr;
+    property StringsAdapter: IStringsAdapter read FAdapter write SetStringsAdapter;
+  end;
+
+{ TStringList class }
+
+  TStringList = class;
+
+  TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer;
+
+{$IFNDEF FPC_TESTGENERICS}
+
+  PStringItem = ^TStringItem;
+  TStringItem = record
+    FString: string;
+    FObject: TObject;
+  end;
+
+  PStringItemList = ^TStringItemList;
+  TStringItemList = array[0..MaxListSize] of TStringItem;
+
+  TStringList = class(TStrings)
+  private
+    FList: PStringItemList;
+    FCount: Integer;
+    FCapacity: Integer;
+    FOnChange: TNotifyEvent;
+    FOnChanging: TNotifyEvent;
+    FDuplicates: TDuplicates;
+    FCaseSensitive : Boolean;
+    FSorted: Boolean;
+    procedure ExchangeItems(Index1, Index2: Integer);
+    procedure Grow;
+    procedure QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
+    procedure SetSorted(Value: Boolean);
+    procedure SetCaseSensitive(b : boolean);
+  protected
+    procedure Changed; virtual;
+    procedure Changing; virtual;
+    function Get(Index: Integer): string; override;
+    function GetCapacity: Integer; override;
+    function GetCount: Integer; override;
+    function GetObject(Index: Integer): TObject; override;
+    procedure Put(Index: Integer; const S: string); override;
+    procedure PutObject(Index: Integer; AObject: TObject); override;
+    procedure SetCapacity(NewCapacity: Integer); override;
+    procedure SetUpdateState(Updating: Boolean); override;
+    procedure InsertItem(Index: Integer; const S: string); virtual;
+    procedure InsertItem(Index: Integer; const S: string; O: TObject); virtual;
+    Function DoCompareText(const s1,s2 : string) : PtrInt; override;
+
+  public
+    destructor Destroy; override;
+    function Add(const S: string): Integer; override;
+    procedure Clear; override;
+    procedure Delete(Index: Integer); override;
+    procedure Exchange(Index1, Index2: Integer); override;
+    function Find(const S: string; var Index: Integer): Boolean; virtual;
+    function IndexOf(const S: string): Integer; override;
+    procedure Insert(Index: Integer; const S: string); override;
+    procedure Sort; virtual;
+    procedure CustomSort(CompareFn: TStringListSortCompare); virtual;
+    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
+    property Sorted: Boolean read FSorted write SetSorted;
+    property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;
+    property OnChange: TNotifyEvent read FOnChange write FOnChange;
+    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
+  end;
+
+{$else}
+
+  TFPStrObjMap = specialize TFPGMap<string, TObject>;
+
+  TStringListTextCompare = function(const s1, s2: string): PtrInt of object;
+
+  TStringList = class(TStrings)
+  private
+    FMap: TFPStrObjMap;
+    FCaseSensitive: Boolean;
+    FOnChange: TNotifyEvent;
+    FOnChanging: TNotifyEvent;
+    FOnCompareText: TStringListTextCompare;
+    procedure SetCaseSensitive(NewSensitive: Boolean);
+  protected
+    procedure Changed; virtual;
+    procedure Changing; virtual;
+    function DefaultCompareText(const s1, s2: string): PtrInt;
+    function DoCompareText(const s1, s2: string): PtrInt; override;
+    function Get(Index: Integer): string; override;
+    function GetCapacity: Integer; override;
+    function GetDuplicates: TDuplicates;
+    function GetCount: Integer; override;
+    function GetObject(Index: Integer): TObject; override;
+    function GetSorted: Boolean; {$ifdef CLASSESINLINE} inline; {$endif}
+    function MapPtrCompare(Key1, Key2: Pointer): Integer;
+    procedure Put(Index: Integer; const S: string); override;
+    procedure PutObject(Index: Integer; AObject: TObject); override;
+    procedure QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
+    procedure SetCapacity(NewCapacity: Integer); override;
+    procedure SetDuplicates(NewDuplicates: TDuplicates);
+    procedure SetSorted(NewSorted: Boolean); {$ifdef CLASSESINLINE} inline; {$endif}
+    procedure SetUpdateState(Updating: Boolean); override;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    function Add(const S: string): Integer; override;
+    procedure Clear; override;
+    procedure Delete(Index: Integer); override;
+    procedure Exchange(Index1, Index2: Integer); override;
+    function Find(const S: string; var Index: Integer): Boolean; virtual;
+    function IndexOf(const S: string): Integer; override;
+    procedure Insert(Index: Integer; const S: string); override;
+    procedure Sort; virtual;
+    procedure CustomSort(CompareFn: TStringListSortCompare);
+    property Duplicates: TDuplicates read GetDuplicates write SetDuplicates;
+    property Sorted: Boolean read GetSorted write SetSorted;
+    property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;
+    property OnChange: TNotifyEvent read FOnChange write FOnChange;
+    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
+    property OnCompareText: TStringListTextCompare read FOnCompareText write FOnCompareText;
+  end;
+
+{$endif}
+
+{ TStream abstract class }
+
+  TStream = class(TObject)
+  protected
+    function  GetPosition: Int64; virtual;
+    procedure SetPosition(const Pos: Int64); virtual;
+    function  GetSize: Int64; virtual;
+    procedure SetSize64(const NewSize: Int64); virtual;
+    procedure SetSize(NewSize: Longint); virtual;overload;
+    procedure SetSize(const NewSize: Int64); virtual;overload;
+	procedure ReadNotImplemented;
+	procedure WriteNotImplemented;
+  public
+    function Read(var Buffer; Count: Longint): Longint; virtual;
+    function Write(const Buffer; Count: Longint): Longint; virtual;
+    function Seek(Offset: Longint; Origin: Word): Longint; virtual; overload;
+    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; virtual; overload;
+    procedure ReadBuffer(var Buffer; Count: Longint);
+    procedure WriteBuffer(const Buffer; Count: Longint);
+    function CopyFrom(Source: TStream; Count: Int64): Int64;
+    function ReadComponent(Instance: TComponent): TComponent;
+    function ReadComponentRes(Instance: TComponent): TComponent;
+    procedure WriteComponent(Instance: TComponent);
+    procedure WriteComponentRes(const ResName: string; Instance: TComponent);
+    procedure WriteDescendent(Instance, Ancestor: TComponent);
+    procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
+    procedure WriteResourceHeader(const ResName: string; {!!!:out} var FixupInfo: Integer);
+    procedure FixupResourceHeader(FixupInfo: Integer);
+    procedure ReadResHeader;
+    function ReadByte : Byte;
+    function ReadWord : Word;
+    function ReadDWord : Cardinal;
+    function ReadAnsiString : String;
+    procedure WriteByte(b : Byte);
+    procedure WriteWord(w : Word);
+    procedure WriteDWord(d : Cardinal);
+    Procedure WriteAnsiString (const S : String);
+    property Position: Int64 read GetPosition write SetPosition;
+    property Size: Int64 read GetSize write SetSize64;
+  end;
+
+  { TOwnerStream }
+  TOwnerStream = Class(TStream)
+  Protected
+    FOwner : Boolean;
+    FSource : TStream;
+  Public
+    Constructor Create(ASource : TStream);
+    Destructor Destroy; override;
+    Property Source : TStream Read FSource;
+    Property SourceOwner : Boolean Read Fowner Write FOwner;
+  end;
+
+
+  IStreamPersist = interface ['{B8CD12A3-267A-11D4-83DA-00C04F60B2DD}']
+    procedure LoadFromStream(Stream: TStream);
+    procedure SaveToStream(Stream: TStream);
+  end;
+
+{ THandleStream class }
+
+  THandleStream = class(TStream)
+  private
+    FHandle: Integer;
+  protected
+    procedure SetSize(NewSize: Longint); override;
+    procedure SetSize(const NewSize: Int64); override;
+  public
+    constructor Create(AHandle: Integer);
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
+    property Handle: Integer read FHandle;
+  end;
+
+{ TFileStream class }
+
+  TFileStream = class(THandleStream)
+  Private
+    FFileName : String;
+  public
+    constructor Create(const AFileName: string; Mode: Word);
+    constructor Create(const AFileName: string; Mode: Word; Rights: Cardinal);
+    destructor Destroy; override;
+    property FileName : String Read FFilename;
+  end;
+
+{ TCustomMemoryStream abstract class }
+
+  TCustomMemoryStream = class(TStream)
+  private
+    FMemory: Pointer;
+    FSize, FPosition: Longint;
+  protected
+    procedure SetPointer(Ptr: Pointer; ASize: Longint);
+  public
+    Function GetSize : Int64; Override;
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+    procedure SaveToStream(Stream: TStream);
+    procedure SaveToFile(const FileName: string);
+    property Memory: Pointer read FMemory;
+  end;
+
+{ TMemoryStream }
+
+  TMemoryStream = class(TCustomMemoryStream)
+  private
+    FCapacity: Longint;
+    procedure SetCapacity(NewCapacity: Longint);
+  protected
+    function Realloc(var NewCapacity: Longint): Pointer; virtual;
+    property Capacity: Longint read FCapacity write SetCapacity;
+  public
+    destructor Destroy; override;
+    procedure Clear;
+    procedure LoadFromStream(Stream: TStream);
+    procedure LoadFromFile(const FileName: string);
+    procedure SetSize(NewSize: Longint); override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+  end;
+
+{ TStringStream }
+
+  TStringStream = class(TStream)
+  private
+    FDataString: string;
+    FPosition: Integer;
+  protected
+    procedure SetSize(NewSize: Longint); override;
+  public
+    constructor Create(const AString: string);
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function ReadString(Count: Longint): string;
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+    procedure WriteString(const AString: string);
+    property DataString: string read FDataString;
+  end;
+
+{ TResourceStream }
+
+{$ifdef UNICODE}
+  TResourceStream = class(TCustomMemoryStream)
+  private
+    Res: HRSRC;
+    Handle: THandle;
+    procedure Initialize(Instance: THandle; Name, ResType: PWideChar);
+  public
+    constructor Create(Instance: THandle; const ResName: WideString; ResType: PWideChar);
+    constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PWideChar);
+    destructor Destroy; override;
+  end;
+{$else}
+  TResourceStream = class(TCustomMemoryStream)
+  private
+    Res: HRSRC;
+    Handle: THandle;
+    procedure Initialize(Instance: THandle; Name, ResType: PChar);
+  public
+    constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
+    constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
+    destructor Destroy; override;
+  end;
+{$endif UNICODE}
+
+{ TStreamAdapter }
+
+  TStreamOwnership = (soReference, soOwned);
+
+{ Implements OLE IStream on TStream }
+  TStreamAdapter = class(TInterfacedObject, IStream)
+  private
+    FStream: TStream;
+    FOwnership: TStreamOwnership;
+  public
+    constructor Create(Stream: TStream; Ownership: TStreamOwnership = soReference);
+    destructor Destroy; override;
+    function Read(pv: Pointer; cb: DWORD; pcbRead: PDWORD): HResult; virtual; stdcall;
+    function Write(pv: Pointer; cb: DWORD; pcbWritten: PDWORD): HResult; virtual; stdcall;
+    function Seek(dlibMove: Largeint; dwOrigin: Longint; out libNewPosition: Largeint): HResult; virtual; stdcall;
+    function SetSize(libNewSize: Largeint): HResult; virtual; stdcall;
+    function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint; out cbWritten: Largeint): HResult; virtual; stdcall;
+    function Commit(grfCommitFlags: Longint): HResult; virtual; stdcall;
+    function Revert: HResult; virtual; stdcall;
+    function LockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; virtual; stdcall;
+    function UnlockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; virtual; stdcall;
+    function Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult; virtual; stdcall;
+    function Clone(out stm: IStream): HResult; virtual; stdcall;
+    property Stream: TStream read FStream;
+    property StreamOwnership: TStreamOwnership read FOwnership write FOwnership;
+  end;
+
+{ TFiler }
+
+  TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
+    vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
+    vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64, vaUTF8String);
+
+  TFilerFlag = (ffInherited, ffChildPos, ffInline);
+  TFilerFlags = set of TFilerFlag;
+
+  TReaderProc = procedure(Reader: TReader) of object;
+  TWriterProc = procedure(Writer: TWriter) of object;
+  TStreamProc = procedure(Stream: TStream) of object;
+
+  TFiler = class(TObject)
+  private
+    FRoot: TComponent;
+    FLookupRoot: TComponent;
+    FAncestor: TPersistent;
+    FIgnoreChildren: Boolean;
+  protected
+    procedure SetRoot(ARoot: TComponent); virtual;
+  public
+    procedure DefineProperty(const Name: string;
+      ReadData: TReaderProc; WriteData: TWriterProc;
+      HasData: Boolean); virtual; abstract;
+    procedure DefineBinaryProperty(const Name: string;
+      ReadData, WriteData: TStreamProc;
+      HasData: Boolean); virtual; abstract;
+    property Root: TComponent read FRoot write SetRoot;
+    property LookupRoot: TComponent read FLookupRoot;
+    property Ancestor: TPersistent read FAncestor write FAncestor;
+    property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren;
+  end;
+
+
+{ TComponent class reference type }
+
+  TComponentClass = class of TComponent;
+
+
+{ TReader }
+
+  TAbstractObjectReader = class
+  public
+    function NextValue: TValueType; virtual; abstract;
+    function ReadValue: TValueType; virtual; abstract;
+    procedure BeginRootComponent; virtual; abstract;
+    procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
+      var CompClassName, CompName: String); virtual; abstract;
+    function BeginProperty: String; virtual; abstract;
+
+    //Please don't use read, better use ReadBinary whenever possible
+    procedure Read(var Buf; Count: LongInt); virtual; abstract;
+    { All ReadXXX methods are called _after_ the value type has been read! }
+    procedure ReadBinary(const DestData: TMemoryStream); virtual; abstract;
+{$ifndef FPUNONE}
+    function ReadFloat: Extended; virtual; abstract;
+    function ReadSingle: Single; virtual; abstract;
+    function ReadDate: TDateTime; virtual; abstract;
+{$endif}
+    function ReadCurrency: Currency; virtual; abstract;
+    function ReadIdent(ValueType: TValueType): String; virtual; abstract;
+    function ReadInt8: ShortInt; virtual; abstract;
+    function ReadInt16: SmallInt; virtual; abstract;
+    function ReadInt32: LongInt; virtual; abstract;
+    function ReadInt64: Int64; virtual; abstract;
+    function ReadSet(EnumType: Pointer): Integer; virtual; abstract;
+    function ReadStr: String; virtual; abstract;
+    function ReadString(StringType: TValueType): String; virtual; abstract;
+    function ReadWideString: WideString;virtual;abstract;
+    procedure SkipComponent(SkipComponentInfos: Boolean); virtual; abstract;
+    procedure SkipValue; virtual; abstract;
+  end;
+
+  { TBinaryObjectReader }
+
+  TBinaryObjectReader = class(TAbstractObjectReader)
+  protected
+    FStream: TStream;
+    FBuffer: Pointer;
+    FBufSize: Integer;
+    FBufPos: Integer;
+    FBufEnd: Integer;
+
+    function ReadWord : word; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+    function ReadDWord : longword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+    function ReadQWord : qword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+{$ifndef FPUNONE}
+    function ReadExtended : extended; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+{$endif}
+    procedure SkipProperty;
+    procedure SkipSetBody;
+  public
+    constructor Create(Stream: TStream; BufSize: Integer);
+    destructor Destroy; override;
+
+    function NextValue: TValueType; override;
+    function ReadValue: TValueType; override;
+    procedure BeginRootComponent; override;
+    procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
+      var CompClassName, CompName: String); override;
+    function BeginProperty: String; override;
+
+    //Please don't use read, better use ReadBinary whenever possible
+    procedure Read(var Buf; Count: LongInt); override;
+    procedure ReadBinary(const DestData: TMemoryStream); override;
+{$ifndef FPUNONE}
+    function ReadFloat: Extended; override;
+    function ReadSingle: Single; override;
+    function ReadDate: TDateTime; override;
+{$endif}
+    function ReadCurrency: Currency; override;
+    function ReadIdent(ValueType: TValueType): String; override;
+    function ReadInt8: ShortInt; override;
+    function ReadInt16: SmallInt; override;
+    function ReadInt32: LongInt; override;
+    function ReadInt64: Int64; override;
+    function ReadSet(EnumType: Pointer): Integer; override;
+    function ReadStr: String; override;
+    function ReadString(StringType: TValueType): String; override;
+    function ReadWideString: WideString;override;
+    procedure SkipComponent(SkipComponentInfos: Boolean); override;
+    procedure SkipValue; override;
+  end;
+
+
+  TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
+    var Address: Pointer; var Error: Boolean) of object;
+  TSetMethodPropertyEvent = procedure(Reader: TReader; Instance: TPersistent;
+    PropInfo: PPropInfo; const TheMethodName: string;
+    var Handled: boolean) of object;
+  TSetNameEvent = procedure(Reader: TReader; Component: TComponent;
+    var Name: string) of object;
+  TReferenceNameEvent = procedure(Reader: TReader; var Name: string) of object;
+  TAncestorNotFoundEvent = procedure(Reader: TReader; const ComponentName: string;
+    ComponentClass: TPersistentClass; var Component: TComponent) of object;
+  TReadComponentsProc = procedure(Component: TComponent) of object;
+  TReaderError = procedure(Reader: TReader; const Message: string;
+    var Handled: Boolean) of object;
+  TPropertyNotFoundEvent = procedure(Reader: TReader; Instance: TPersistent;
+    var PropName: string; IsPath: boolean; var Handled, Skip: Boolean) of object;
+  TFindComponentClassEvent = procedure(Reader: TReader; const ClassName: string;
+    var ComponentClass: TComponentClass) of object;
+  TCreateComponentEvent = procedure(Reader: TReader;
+    ComponentClass: TComponentClass; var Component: TComponent) of object;
+
+  TReadWriteStringPropertyEvent = procedure(Sender:TObject;
+    const Instance: TPersistent; PropInfo: PPropInfo;
+    var Content:string) of object;
+
+
+  { TReader }
+
+  TReader = class(TFiler)
+  private
+    FDriver: TAbstractObjectReader;
+    FOwner: TComponent;
+    FParent: TComponent;
+    FFixups: TObject;
+    FLoaded: TList;
+    FOnFindMethod: TFindMethodEvent;
+    FOnSetMethodProperty: TSetMethodPropertyEvent;
+    FOnSetName: TSetNameEvent;
+    FOnReferenceName: TReferenceNameEvent;
+    FOnAncestorNotFound: TAncestorNotFoundEvent;
+    FOnError: TReaderError;
+    FOnPropertyNotFound: TPropertyNotFoundEvent;
+    FOnFindComponentClass: TFindComponentClassEvent;
+    FOnCreateComponent: TCreateComponentEvent;
+    FPropName: string;
+    FCanHandleExcepts: Boolean;
+    FOnReadStringProperty:TReadWriteStringPropertyEvent;
+    procedure DoFixupReferences;
+    function FindComponentClass(const AClassName: string): TComponentClass;
+  protected
+    function Error(const Message: string): Boolean; virtual;
+    function FindMethod(ARoot: TComponent; const AMethodName: string): Pointer; virtual;
+    procedure ReadProperty(AInstance: TPersistent);
+    procedure ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
+    procedure PropertyError;
+    procedure ReadData(Instance: TComponent);
+    property PropName: string read FPropName;
+    property CanHandleExceptions: Boolean read FCanHandleExcepts;
+    function CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectReader; virtual;
+  public
+    constructor Create(Stream: TStream; BufSize: Integer);
+    destructor Destroy; override;
+    procedure BeginReferences;
+    procedure CheckValue(Value: TValueType);
+    procedure DefineProperty(const Name: string;
+      AReadData: TReaderProc; WriteData: TWriterProc;
+      HasData: Boolean); override;
+    procedure DefineBinaryProperty(const Name: string;
+      AReadData, WriteData: TStreamProc;
+      HasData: Boolean); override;
+    function EndOfList: Boolean;
+    procedure EndReferences;
+    procedure FixupReferences;
+    function NextValue: TValueType;
+    //Please don't use read, better use ReadBinary whenever possible
+    //uuups, ReadBinary is protected ..
+    procedure Read(var Buf; Count: LongInt); virtual;
+
+    function ReadBoolean: Boolean;
+    function ReadChar: Char;
+    function ReadWideChar: WideChar;
+    procedure ReadCollection(Collection: TCollection);
+    function ReadComponent(Component: TComponent): TComponent;
+    procedure ReadComponents(AOwner, AParent: TComponent;
+      Proc: TReadComponentsProc);
+{$ifndef FPUNONE}
+    function ReadFloat: Extended;
+    function ReadSingle: Single;
+    function ReadDate: TDateTime;
+{$endif}
+    function ReadCurrency: Currency;
+    function ReadIdent: string;
+    function ReadInteger: Longint;
+    function ReadInt64: Int64;
+    procedure ReadListBegin;
+    procedure ReadListEnd;
+    function ReadRootComponent(ARoot: TComponent): TComponent;
+    function ReadString: string;
+    function ReadWideString: WideString;
+    function ReadValue: TValueType;
+    procedure CopyValue(Writer: TWriter);
+    property Driver: TAbstractObjectReader read FDriver;
+    property Owner: TComponent read FOwner write FOwner;
+    property Parent: TComponent read FParent write FParent;
+    property OnError: TReaderError read FOnError write FOnError;
+    property OnPropertyNotFound: TPropertyNotFoundEvent read FOnPropertyNotFound write FOnPropertyNotFound;
+    property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod;
+    property OnSetMethodProperty: TSetMethodPropertyEvent read FOnSetMethodProperty write FOnSetMethodProperty;
+    property OnSetName: TSetNameEvent read FOnSetName write FOnSetName;
+    property OnReferenceName: TReferenceNameEvent read FOnReferenceName write FOnReferenceName;
+    property OnAncestorNotFound: TAncestorNotFoundEvent read FOnAncestorNotFound write FOnAncestorNotFound;
+    property OnCreateComponent: TCreateComponentEvent read FOnCreateComponent write FOnCreateComponent;
+    property OnFindComponentClass: TFindComponentClassEvent read FOnFindComponentClass write FOnFindComponentClass;
+    property OnReadStringProperty: TReadWriteStringPropertyEvent read FOnReadStringProperty write FOnReadStringProperty;
+  end;
+
+
+{ TWriter }
+
+  TAbstractObjectWriter = class
+  public
+    { Begin/End markers. Those ones who don't have an end indicator, use
+      "EndList", after the occurrence named in the comment. Note that this
+      only counts for "EndList" calls on the same level; each BeginXXX call
+      increases the current level. }
+    procedure BeginCollection; virtual; abstract;  { Ends with the next "EndList" }
+    procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
+      ChildPos: Integer); virtual; abstract;  { Ends after the second "EndList" }
+    procedure BeginList; virtual; abstract;
+    procedure EndList; virtual; abstract;
+    procedure BeginProperty(const PropName: String); virtual; abstract;
+    procedure EndProperty; virtual; abstract;
+    //Please don't use write, better use WriteBinary whenever possible
+    procedure Write(const Buffer; Count: Longint); virtual;abstract;
+
+    procedure WriteBinary(const Buffer; Count: Longint); virtual; abstract;
+    procedure WriteBoolean(Value: Boolean); virtual; abstract;
+    // procedure WriteChar(Value: Char);
+{$ifndef FPUNONE}
+    procedure WriteFloat(const Value: Extended); virtual; abstract;
+    procedure WriteSingle(const Value: Single); virtual; abstract;
+    procedure WriteDate(const Value: TDateTime); virtual; abstract;
+{$endif}
+    procedure WriteCurrency(const Value: Currency); virtual; abstract;
+    procedure WriteIdent(const Ident: string); virtual; abstract;
+    procedure WriteInteger(Value: Int64); virtual; abstract;
+    procedure WriteMethodName(const Name: String); virtual; abstract;
+    procedure WriteSet(Value: LongInt; SetType: Pointer); virtual; abstract;
+    procedure WriteString(const Value: String); virtual; abstract;
+    procedure WriteWideString(const Value: WideString);virtual;abstract;
+  end;
+
+  { TBinaryObjectWriter }
+
+  TBinaryObjectWriter = class(TAbstractObjectWriter)
+  protected
+    FStream: TStream;
+    FBuffer: Pointer;
+    FBufSize: Integer;
+    FBufPos: Integer;
+    FBufEnd: Integer;
+    FSignatureWritten: Boolean;
+
+    procedure WriteWord(w : word); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+    procedure WriteDWord(lw : longword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+    procedure WriteQWord(qw : qword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+{$ifndef FPUNONE}
+    procedure WriteExtended(e : extended); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+{$endif}
+    procedure FlushBuffer;
+    procedure WriteValue(Value: TValueType);
+    procedure WriteStr(const Value: String);
+  public
+    constructor Create(Stream: TStream; BufSize: Integer);
+    destructor Destroy; override;
+
+    procedure BeginCollection; override;
+    procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
+      ChildPos: Integer); override;
+    procedure BeginList; override;
+    procedure EndList; override;
+    procedure BeginProperty(const PropName: String); override;
+    procedure EndProperty; override;
+
+    //Please don't use write, better use WriteBinary whenever possible
+    procedure Write(const Buffer; Count: Longint); override;
+    procedure WriteBinary(const Buffer; Count: LongInt); override;
+    procedure WriteBoolean(Value: Boolean); override;
+{$ifndef FPUNONE}
+    procedure WriteFloat(const Value: Extended); override;
+    procedure WriteSingle(const Value: Single); override;
+    procedure WriteDate(const Value: TDateTime); override;
+{$endif}
+    procedure WriteCurrency(const Value: Currency); override;
+    procedure WriteIdent(const Ident: string); override;
+    procedure WriteInteger(Value: Int64); override;
+    procedure WriteMethodName(const Name: String); override;
+    procedure WriteSet(Value: LongInt; SetType: Pointer); override;
+    procedure WriteString(const Value: String); override;
+    procedure WriteWideString(const Value: WideString); override;
+  end;
+
+  TTextObjectWriter = class(TAbstractObjectWriter)
+  end;
+
+
+  TFindAncestorEvent = procedure (Writer: TWriter; Component: TComponent;
+    const Name: string; var Ancestor, RootAncestor: TComponent) of object;
+  TWriteMethodPropertyEvent = procedure (Writer: TWriter; Instance: TPersistent;
+    PropInfo: PPropInfo;
+    const MethodValue, DefMethodValue: TMethod;
+    var Handled: boolean) of object;
+
+  TWriter = class(TFiler)
+  private
+    FDriver: TAbstractObjectWriter;
+    FDestroyDriver: Boolean;
+    FRootAncestor: TComponent;
+    FPropPath: String;
+    FAncestorList: TList;
+    FAncestorPos: Integer;
+    FChildPos: Integer;
+    FOnFindAncestor: TFindAncestorEvent;
+    FOnWriteMethodProperty: TWriteMethodPropertyEvent;
+    FOnWriteStringProperty:TReadWriteStringPropertyEvent;
+    procedure AddToAncestorList(Component: TComponent);
+    procedure WriteComponentData(Instance: TComponent);
+  protected
+    procedure SetRoot(ARoot: TComponent); override;
+    procedure WriteBinary(AWriteData: TStreamProc);
+    procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
+    procedure WriteProperties(Instance: TPersistent);
+    function CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectWriter; virtual;
+  public
+    constructor Create(ADriver: TAbstractObjectWriter);
+    constructor Create(Stream: TStream; BufSize: Integer);
+    destructor Destroy; override;
+    procedure DefineProperty(const Name: string;
+      ReadData: TReaderProc; AWriteData: TWriterProc;
+      HasData: Boolean); override;
+    procedure DefineBinaryProperty(const Name: string;
+      ReadData, AWriteData: TStreamProc;
+      HasData: Boolean); override;
+    //Please don't use write, better use WriteBinary whenever possible
+    //uuups, WriteBinary is protected ..
+    procedure Write(const Buffer; Count: Longint); virtual;
+    procedure WriteBoolean(Value: Boolean);
+    procedure WriteCollection(Value: TCollection);
+    procedure WriteComponent(Component: TComponent);
+    procedure WriteChar(Value: Char);
+    procedure WriteWideChar(Value: WideChar);
+    procedure WriteDescendent(ARoot: TComponent; AAncestor: TComponent);
+{$ifndef FPUNONE}
+    procedure WriteFloat(const Value: Extended);
+    procedure WriteSingle(const Value: Single);
+    procedure WriteDate(const Value: TDateTime);
+{$endif}
+    procedure WriteCurrency(const Value: Currency);
+    procedure WriteIdent(const Ident: string);
+    procedure WriteInteger(Value: Longint); overload;
+    procedure WriteInteger(Value: Int64); overload;
+    procedure WriteListBegin;
+    procedure WriteListEnd;
+    procedure WriteRootComponent(ARoot: TComponent);
+    procedure WriteString(const Value: string);
+    procedure WriteWideString(const Value: WideString);
+    property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
+    property OnFindAncestor: TFindAncestorEvent read FOnFindAncestor write FOnFindAncestor;
+    property OnWriteMethodProperty: TWriteMethodPropertyEvent read FOnWriteMethodProperty write FOnWriteMethodProperty;
+    property OnWriteStringProperty: TReadWriteStringPropertyEvent read FOnWriteStringProperty write FOnWriteStringProperty;
+
+    property Driver: TAbstractObjectWriter read FDriver;
+    property PropertyPath: string read FPropPath;
+  end;
+
+
+{ TParser }
+
+  TParser = class(TObject)
+  private
+    fStream : TStream;
+    fBuf : pchar;
+    fBufLen : integer;
+    fPos : integer;
+    fDeltaPos : integer;
+    fFloatType : char;
+    fSourceLine : integer;
+    fToken : char;
+    fEofReached : boolean;
+    fLastTokenStr : string;
+    fLastTokenWStr : widestring;
+    function GetTokenName(aTok : char) : string;
+    procedure LoadBuffer;
+    procedure CheckLoadBuffer; inline;
+    procedure ProcessChar; inline;
+    function IsNumber : boolean; inline;
+    function IsHexNum : boolean; inline;
+    function IsAlpha : boolean; inline;
+    function IsAlphaNum : boolean; inline;
+    function GetHexValue(c : char) : byte; inline;
+    function GetAlphaNum : string;
+    procedure HandleNewLine;
+    procedure SkipSpaces;
+    procedure SkipWhitespace;
+    procedure HandleEof;
+    procedure HandleAlphaNum;
+    procedure HandleNumber;
+    procedure HandleHexNumber;
+    function HandleQuotedString : string;
+    function HandleDecimalString(var ascii : boolean) : widestring;
+    procedure HandleString;
+    procedure HandleMinus;
+    procedure HandleUnknown;
+  public
+    constructor Create(Stream: TStream);
+    destructor Destroy; override;
+    procedure CheckToken(T: Char);
+    procedure CheckTokenSymbol(const S: string);
+    procedure Error(const Ident: string);
+    procedure ErrorFmt(const Ident: string; const Args: array of const);
+    procedure ErrorStr(const Message: string);
+    procedure HexToBinary(Stream: TStream);
+    function NextToken: Char;
+    function SourcePos: Longint;
+    function TokenComponentIdent: string;
+{$ifndef FPUNONE}
+    function TokenFloat: Extended;
+{$endif}
+    function TokenInt: Int64;
+    function TokenString: string;
+    function TokenWideString: WideString;
+    function TokenSymbolIs(const S: string): Boolean;
+    property FloatType: Char read fFloatType;
+    property SourceLine: Integer read fSourceLine;
+    property Token: Char read fToken;
+  end;
+
+{ TThread }
+
+  EThread = class(Exception);
+  EThreadDestroyCalled = class(EThread);
+  TSynchronizeProcVar = procedure;
+  TThreadMethod = procedure of object;
+
+  TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
+    tpTimeCritical);
+
+  TThread = class
+  private
+    FHandle: TThreadID;
+    FTerminated: Boolean;
+    FFreeOnTerminate: Boolean;
+    FFinished: Boolean;
+    FSuspended: LongBool;
+    FReturnValue: Integer;
+    FOnTerminate: TNotifyEvent;
+    FMethod: TThreadMethod;
+    FSynchronizeException: TObject;
+    FFatalException: TObject;
+    procedure CallOnTerminate;
+    function GetPriority: TThreadPriority;
+    procedure SetPriority(Value: TThreadPriority);
+    procedure SetSuspended(Value: Boolean);
+    function GetSuspended: Boolean;
+  protected
+    FThreadID: TThreadID; // someone might need it for pthread_* calls
+    procedure DoTerminate; virtual;
+    procedure Execute; virtual; abstract;
+    procedure Synchronize(AMethod: TThreadMethod);
+    property ReturnValue: Integer read FReturnValue write FReturnValue;
+    property Terminated: Boolean read FTerminated;
+{$ifdef Unix}
+  private
+    // see tthread.inc, ThreadFunc and TThread.Resume
+    FSem: Pointer;
+    FInitialSuspended: boolean;
+    FSuspendedExternal: boolean;
+    FThreadReaped: boolean;
+{$endif}
+{$ifdef netwlibc}
+  private
+    // see tthread.inc, ThreadFunc and TThread.Resume
+    FSem: Pointer;
+    FInitialSuspended: boolean;
+    FSuspendedExternal: boolean;
+    FPid: LongInt;
+{$endif}
+  public
+    constructor Create(CreateSuspended: Boolean;
+                       const StackSize: SizeUInt = DefaultStackSize);
+    destructor Destroy; override;
+    procedure AfterConstruction; override;
+    procedure Resume;
+    procedure Suspend;
+    procedure Terminate;
+    function WaitFor: Integer;
+    class procedure Synchronize(AThread: TThread; AMethod: TThreadMethod);
+    property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
+    property Handle: TThreadID read FHandle;
+    property Priority: TThreadPriority read GetPriority write SetPriority;
+    property Suspended: Boolean read GetSuspended write SetSuspended;
+    property ThreadID: TThreadID read FThreadID;
+    property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
+    property FatalException: TObject read FFatalException;
+  end;
+
+
+{ TComponent class }
+
+  TOperation = (opInsert, opRemove);
+  TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
+    csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification,
+    csInline, csDesignInstance);
+  TComponentStyle = set of (csInheritable, csCheckPropAvail, csSubComponent,
+    csTransient);
+  TGetChildProc = procedure (Child: TComponent) of object;
+
+  {
+  TComponentName = type string;
+
+  IVCLComObject = interface
+    function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
+    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
+    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+      NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
+    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
+    function SafeCallException(ExceptObject: TObject;
+      ExceptAddr: Pointer): Integer;
+    procedure FreeOnRelease;
+  end;
+  }
+
+  IInterfaceComponentReference = interface 
+    ['{3FEEC8E1-E400-4A24-BCAC-1F01476439B1}']
+    function GetComponent:TComponent;
+   end;
+
+  IDesignerNotify = interface
+    ['{B971E807-E3A6-11D1-AAB1-00C04FB16FBC}']
+    procedure Modified;
+    procedure Notification(AnObject: TPersistent; Operation: TOperation);
+  end;
+
+  TBasicAction = class;
+
+  { TComponent }
+
+  TComponent = class(TPersistent,IUnknown,IInterfaceComponentReference)
+  private
+    FOwner: TComponent;
+    FName: TComponentName;
+    FTag: Longint;
+    FComponents: TList;
+    FFreeNotifies: TList;
+    FDesignInfo: Longint;
+    FVCLComObject: Pointer;
+    FComponentState: TComponentState;
+    // function GetComObject: IUnknown;
+    function GetComponent(AIndex: Integer): TComponent;
+    function GetComponentCount: Integer;
+    function GetComponentIndex: Integer;
+    procedure Insert(AComponent: TComponent);
+    procedure ReadLeft(Reader: TReader);
+    procedure ReadTop(Reader: TReader);
+    procedure Remove(AComponent: TComponent);
+    procedure RemoveNotification(AComponent: TComponent);
+    procedure SetComponentIndex(Value: Integer);
+    procedure SetReference(Enable: Boolean);
+    procedure WriteLeft(Writer: TWriter);
+    procedure WriteTop(Writer: TWriter);
+  protected
+    FComponentStyle: TComponentStyle;
+    procedure ChangeName(const NewName: TComponentName);
+    procedure DefineProperties(Filer: TFiler); override;
+    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); dynamic;
+    function GetChildOwner: TComponent; dynamic;
+    function GetChildParent: TComponent; dynamic;
+    function GetNamePath: string; override;
+    function GetOwner: TPersistent; override;
+    procedure Loaded; virtual;
+    procedure Loading; virtual;
+    procedure Notification(AComponent: TComponent;
+      Operation: TOperation); virtual;
+    procedure PaletteCreated; dynamic;
+    procedure ReadState(Reader: TReader); virtual;
+    procedure SetAncestor(Value: Boolean);
+    procedure SetDesigning(Value: Boolean);
+    procedure SetName(const NewName: TComponentName); virtual;
+    procedure SetChildOrder(Child: TComponent; Order: Integer); dynamic;
+    procedure SetParentComponent(Value: TComponent); dynamic;
+    procedure Updating; dynamic;
+    procedure Updated; dynamic;
+    class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); dynamic;
+    procedure ValidateRename(AComponent: TComponent;
+      const CurName, NewName: string); virtual;
+    procedure ValidateContainer(AComponent: TComponent); dynamic;
+    procedure ValidateInsert(AComponent: TComponent); dynamic;
+    { IUnknown }
+    function QueryInterface(const IID: TGUID; out Obj): Hresult; virtual; stdcall;
+    function _AddRef: Integer; stdcall;
+    function _Release: Integer; stdcall;
+    function iicrGetComponent: TComponent;
+    { IDispatch }
+    //!!!! function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
+    //!!!! function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
+    //!!!! function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+    //!!!!   NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
+    //!!!! function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+    //!!!!   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
+  public
+    //!! Moved temporary
+    function IInterfaceComponentReference.GetComponent=iicrgetcomponent;
+    procedure WriteState(Writer: TWriter); virtual;
+    constructor Create(AOwner: TComponent); virtual;
+    procedure BeforeDestruction; override;
+    destructor Destroy; override;
+    procedure DestroyComponents;
+    procedure Destroying;
+    function ExecuteAction(Action: TBasicAction): Boolean; dynamic;
+    function FindComponent(const AName: string): TComponent;
+    procedure FreeNotification(AComponent: TComponent);
+    procedure RemoveFreeNotification(AComponent: TComponent);
+    procedure FreeOnRelease;
+    function GetParentComponent: TComponent; dynamic;
+    function HasParent: Boolean; dynamic;
+    procedure InsertComponent(AComponent: TComponent);
+    procedure RemoveComponent(AComponent: TComponent);
+    function SafeCallException(ExceptObject: TObject;
+      ExceptAddr: Pointer): Integer; override;
+    procedure SetSubComponent(ASubComponent: Boolean);
+    function UpdateAction(Action: TBasicAction): Boolean; dynamic;
+    // property ComObject: IUnknown read GetComObject;
+    function IsImplementorOf (const Intf:IInterface):boolean;
+    procedure ReferenceInterface(const intf:IInterface;op:TOperation);
+    property Components[Index: Integer]: TComponent read GetComponent;
+    property ComponentCount: Integer read GetComponentCount;
+    property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex;
+    property ComponentState: TComponentState read FComponentState;
+    property ComponentStyle: TComponentStyle read FComponentStyle;
+    property DesignInfo: Longint read FDesignInfo write FDesignInfo;
+    property Owner: TComponent read FOwner;
+    property VCLComObject: Pointer read FVCLComObject write FVCLComObject;
+  published
+    property Name: TComponentName read FName write SetName stored False;
+    property Tag: Longint read FTag write FTag default 0;
+  end;
+
+{ TBasicActionLink }
+
+  TBasicActionLink = class(TObject)
+  private
+    FOnChange: TNotifyEvent;
+  protected
+    FAction: TBasicAction;
+    procedure AssignClient(AClient: TObject); virtual;
+    procedure Change; virtual;
+    function IsOnExecuteLinked: Boolean; virtual;
+    procedure SetAction(Value: TBasicAction); virtual;
+    procedure SetOnExecute(Value: TNotifyEvent); virtual;
+  public
+    constructor Create(AClient: TObject); virtual;
+    destructor Destroy; override;
+    function Execute(AComponent: TComponent = nil): Boolean; virtual;
+    function Update: Boolean; virtual;
+    property Action: TBasicAction read FAction write SetAction;
+    property OnChange: TNotifyEvent read FOnChange write FOnChange;
+  end;
+
+  TBasicActionLinkClass = class of TBasicActionLink;
+
+{ TBasicAction }
+
+  TBasicAction = class(TComponent)
+  private
+    FActionComponent: TComponent;
+    FOnChange: TNotifyEvent;
+    FOnExecute: TNotifyEvent;
+    FOnUpdate: TNotifyEvent;
+  protected
+    FClients: TList;
+    procedure Change; virtual;
+    procedure SetOnExecute(Value: TNotifyEvent); virtual;
+    property OnChange: TNotifyEvent read FOnChange write FOnChange;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    function HandlesTarget(Target: TObject): Boolean; virtual;
+    procedure UpdateTarget(Target: TObject); virtual;
+    procedure ExecuteTarget(Target: TObject); virtual;
+    function Execute: Boolean; dynamic;
+    procedure RegisterChanges(Value: TBasicActionLink);
+    procedure UnRegisterChanges(Value: TBasicActionLink);
+    function Update: Boolean; virtual;
+    property ActionComponent: TComponent read FActionComponent write FActionComponent;
+    property OnExecute: TNotifyEvent read FOnExecute write SetOnExecute;
+    property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate;
+  end;
+
+{ TBasicAction class reference type }
+
+  TBasicActionClass = class of TBasicAction;
+
+{ Component registration handlers }
+
+  TActiveXRegType = (axrComponentOnly, axrIncludeDescendants);
+
+  IInterfaceList = interface ['{285DEA8A-B865-11D1-AAA7-00C04FB17A72}']
+    function Get(i : Integer) : IUnknown;
+    function GetCapacity : Integer;
+    function GetCount : Integer;
+    procedure Put(i : Integer;item : IUnknown);
+    procedure SetCapacity(NewCapacity : Integer);
+    procedure SetCount(NewCount : Integer);
+    procedure Clear;
+    procedure Delete(index : Integer);
+    procedure Exchange(index1,index2 : Integer);
+    function First : IUnknown;
+    function IndexOf(item : IUnknown) : Integer;
+    function Add(item : IUnknown) : Integer;
+    procedure Insert(i : Integer;item : IUnknown);
+    function Last : IUnknown;
+    function Remove(item : IUnknown): Integer;
+    procedure Lock;
+    procedure Unlock;
+    property Capacity : Integer read GetCapacity write SetCapacity;
+    property Count : Integer read GetCount write SetCount;
+    property Items[index : Integer] : IUnknown read Get write Put;default;
+  end;
+
+  TInterfaceList = class(TInterfacedObject,IInterfaceList)
+  private
+    FList : TThreadList;
+  protected
+    function Get(i : Integer) : IUnknown;
+    function GetCapacity : Integer;
+    function GetCount : Integer;
+    procedure Put(i : Integer;item : IUnknown);
+    procedure SetCapacity(NewCapacity : Integer);
+    procedure SetCount(NewCount : Integer);
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    procedure Clear;
+    procedure Delete(index : Integer);
+    procedure Exchange(index1,index2 : Integer);
+    function First : IUnknown;
+    function IndexOf(item : IUnknown) : Integer;
+    function Add(item : IUnknown) : Integer;
+    procedure Insert(i : Integer;item : IUnknown);
+    function Last : IUnknown;
+    function Remove(item : IUnknown): Integer;
+    procedure Lock;
+    procedure Unlock;
+
+    function Expand : TInterfaceList;
+
+    property Capacity : Integer read GetCapacity write SetCapacity;
+    property Count : Integer read GetCount write SetCount;
+    property Items[Index : Integer] : IUnknown read Get write Put;default;
+  end;
+
+{ ---------------------------------------------------------------------
+    TDatamodule support
+  ---------------------------------------------------------------------}
+  TDataModule = class(TComponent)
+  private
+    FDPos: TPoint;
+    FDSize: TPoint;
+    FOnCreate: TNotifyEvent;
+    FOnDestroy: TNotifyEvent;
+    FOldOrder : Boolean;
+    Procedure ReadT(Reader: TReader);
+    Procedure WriteT(Writer: TWriter);
+    Procedure ReadL(Reader: TReader);
+    Procedure WriteL(Writer: TWriter);
+    Procedure ReadW(Reader: TReader);
+    Procedure WriteW(Writer: TWriter);
+    Procedure ReadH(Reader: TReader);
+    Procedure WriteH(Writer: TWriter);
+  protected
+    Procedure DoCreate; virtual;
+    Procedure DoDestroy; virtual;
+    Procedure DefineProperties(Filer: TFiler); override;
+    Procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
+    Function HandleCreateException: Boolean; virtual;
+    Procedure ReadState(Reader: TReader); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    Constructor CreateNew(AOwner: TComponent);
+    Constructor CreateNew(AOwner: TComponent; CreateMode: Integer); virtual;
+    destructor Destroy; override;
+    Procedure AfterConstruction; override;
+    Procedure BeforeDestruction; override;
+    property DesignOffset: TPoint read FDPos write FDPos;
+    property DesignSize: TPoint read FDSize write FDSize;
+  published
+    property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
+    property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
+    property OldCreateOrder: Boolean read FOldOrder write FOldOrder;
+  end;
+
+var
+  // IDE hooks for TDatamodule support.
+  AddDataModule              : procedure (DataModule: TDataModule) of object;
+  RemoveDataModule           : procedure (DataModule: TDataModule) of object;
+  ApplicationHandleException : procedure (Sender: TObject) of object;
+  ApplicationShowException   : procedure (E: Exception) of object;
+
+{ ---------------------------------------------------------------------
+    tthread helpers
+  ---------------------------------------------------------------------}
+
+{ function to be called when gui thread is ready to execute method
+  result is true if a method has been executed
+}
+function CheckSynchronize(timeout : longint=0) : boolean;
+
+var
+  { method proc that is called to trigger gui thread to execute a
+method }
+  WakeMainThread : TNotifyEvent = nil;
+
+{ ---------------------------------------------------------------------
+    General streaming and registration routines
+  ---------------------------------------------------------------------}
+
+
+var
+  RegisterComponentsProc: procedure(const Page: string;
+    ComponentClasses: array of TComponentClass);
+  RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass);
+{!!!!  RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass;
+    AxRegType: TActiveXRegType) = nil;
+  CurrentGroup: Integer = -1;
+  CreateVCLComObjectProc: procedure(Component: TComponent) = nil;}
+
+{ Point and rectangle constructors }
+
+function Point(AX, AY: Integer): TPoint;
+function SmallPoint(AX, AY: SmallInt): TSmallPoint;
+function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
+function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
+
+function PointsEqual(const P1, P2: TPoint): Boolean; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+function PointsEqual(const P1, P2: TSmallPoint): Boolean; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+function InvalidPoint(X, Y: Integer): Boolean;
+function InvalidPoint(const At: TPoint): Boolean;
+function InvalidPoint(const At: TSmallPoint): Boolean;
+
+{ Class registration routines }
+
+procedure RegisterClass(AClass: TPersistentClass);
+procedure RegisterClasses(AClasses: array of TPersistentClass);
+procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
+procedure UnRegisterClass(AClass: TPersistentClass);
+procedure UnRegisterClasses(AClasses: array of TPersistentClass);
+procedure UnRegisterModuleClasses(Module: HMODULE);
+function FindClass(const AClassName: string): TPersistentClass;
+function GetClass(const AClassName: string): TPersistentClass;
+procedure StartClassGroup(AClass: TPersistentClass);
+procedure GroupDescendentsWith(AClass, AClassGroup: TPersistentClass);
+function ActivateClassGroup(AClass: TPersistentClass): TPersistentClass;
+function ClassGroupOf(AClass: TPersistentClass): TPersistentClass;
+function ClassGroupOf(Instance: TPersistent): TPersistentClass;
+
+{ Component registration routines }
+
+procedure RegisterComponents(const Page: string;
+  ComponentClasses: array of TComponentClass);
+procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
+procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass;
+  AxRegType: TActiveXRegType);
+
+var
+  GlobalNameSpace: IReadWriteSync;
+
+{ Object filing routines }
+
+type
+  TIdentMapEntry = record
+    Value: Integer;
+    Name: String;
+  end;
+
+  TIdentToInt = function(const Ident: string; var Int: Longint): Boolean;
+  TIntToIdent = function(Int: Longint; var Ident: string): Boolean;
+  TFindGlobalComponent = function(const Name: string): TComponent;
+  TInitComponentHandler = function(Instance: TComponent; RootAncestor : TClass): boolean;
+
+var
+  MainThreadID: TThreadID;
+
+procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToIntFn: TIdentToInt;
+  IntToIdentFn: TIntToIdent);
+function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
+function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
+function FindIntToIdent(AIntegerType: Pointer): TIntToIdent;
+function FindIdentToInt(AIntegerType: Pointer): TIdentToInt;
+
+procedure RegisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent);
+procedure UnregisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent);
+function FindGlobalComponent(const Name: string): TComponent;
+
+function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
+function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
+function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
+function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
+function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
+procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
+procedure RegisterInitComponentHandler(ComponentClass: TComponentClass;   Handler: TInitComponentHandler);
+
+procedure GlobalFixupReferences;
+procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
+procedure GetFixupInstanceNames(Root: TComponent;
+  const ReferenceRootName: string; Names: TStrings);
+procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
+  NewRootName: string);
+procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
+procedure RemoveFixups(Instance: TPersistent);
+Function FindNestedComponent(Root : TComponent; APath : String; CStyle : Boolean = True) : TComponent;
+
+procedure BeginGlobalLoading;
+procedure NotifyGlobalLoading;
+procedure EndGlobalLoading;
+
+function CollectionsEqual(C1, C2: TCollection): Boolean;
+function CollectionsEqual(C1, C2: TCollection; Owner1, Owner2: TComponent): Boolean;
+
+{ Object conversion routines }
+
+procedure ObjectBinaryToText(Input, Output: TStream);
+procedure ObjectTextToBinary(Input, Output: TStream);
+
+procedure ObjectResourceToText(Input, Output: TStream);
+procedure ObjectTextToResource(Input, Output: TStream);
+
+{ Utility routines }
+
+function LineStart(Buffer, BufPos: PChar): PChar;
+procedure BinToHex(BinValue, HexValue: PChar; BinBufSize: Integer);
+function HexToBin(HexValue, BinValue: PChar; BinBufSize: Integer): Integer;
+function ExtractStrings(Separators, WhiteSpace: TSysCharSet; Content: PChar; Strings: TStrings): Integer;
+

rtl/objpas/classes/collect.inc

@@ -0,0 +1,355 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by the Free Pascal development team
+
+    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.
+
+ **********************************************************************}
+{****************************************************************************}
+{*                             TCollectionItem                              *}
+{****************************************************************************}
+
+
+function TCollectionItem.GetIndex: Integer;
+
+begin
+  if FCollection<>nil then
+    Result:=FCollection.FItems.IndexOf(Pointer(Self))
+  else
+    Result:=-1;
+end;
+
+
+
+procedure TCollectionItem.SetCollection(Value: TCollection);
+
+begin
+  IF Value<>FCollection then
+    begin
+    If FCollection<>Nil then FCollection.RemoveItem(Self);
+    if Value<>Nil then Value.InsertItem(Self);
+    FCollection:=Value;
+    end;
+end;
+
+
+
+procedure TCollectionItem.Changed(AllItems: Boolean);
+
+begin
+ If (FCollection<>Nil) then
+  begin
+  If AllItems then
+    FCollection.Update(Nil)
+  else
+    FCollection.Update(Self);
+  end;
+end;
+
+
+
+function TCollectionItem.GetNamePath: string;
+
+begin
+  If FCollection<>Nil then
+    Result:=FCollection.GetNamePath+'['+IntToStr(Index)+']'
+  else
+    Result:=ClassName;
+end;
+
+
+function TCollectionItem.GetOwner: TPersistent;
+
+begin
+  Result:=FCollection;
+end;
+
+
+
+function TCollectionItem.GetDisplayName: string;
+
+begin
+  Result:=ClassName;
+end;
+
+
+
+procedure TCollectionItem.SetIndex(Value: Integer);
+
+Var Temp : Longint;
+
+begin
+  Temp:=GetIndex;
+  If (Temp>-1) and (Temp<>Value) then
+    begin
+    FCollection.FItems.Move(Temp,Value);
+    Changed(True);
+    end;
+end;
+
+
+procedure TCollectionItem.SetDisplayName(const Value: string);
+
+begin
+  Changed(False);
+end;
+
+
+
+constructor TCollectionItem.Create(ACollection: TCollection);
+
+begin
+  Inherited Create;
+  SetCollection(ACollection);
+end;
+
+
+
+destructor TCollectionItem.Destroy;
+
+begin
+  SetCollection(Nil);
+  Inherited Destroy;
+end;
+
+{****************************************************************************}
+{*                             TCollection                                  *}
+{****************************************************************************}
+
+function TCollection.Owner: TPersistent;
+begin
+        result:=getowner;
+end;
+
+
+function TCollection.GetCount: Integer;
+
+begin
+  If Assigned(FItems) Then
+    Result:=FItems.Count
+  else
+    Result:=0;
+end;
+
+
+Procedure TCollection.SetPropName;
+
+begin
+  //!! Should be replaced by the proper routines.
+  FPropName:='';
+end;
+
+
+function TCollection.GetPropName: string;
+
+Var TheOWner : TPersistent;
+
+begin
+  Result:=FPropNAme;
+  TheOWner:=GetOwner;
+  If (Result<>'') or (TheOwner=Nil) Or (TheOwner.Classinfo=Nil) then exit;
+  SetPropName;
+  Result:=FPropName;
+end;
+
+
+procedure TCollection.InsertItem(Item: TCollectionItem);
+begin
+  If Not(Item Is FitemClass) then
+    exit;
+  FItems.add(Pointer(Item));
+  Item.FID:=FNextID;
+  inc(FNextID);
+  SetItemName(Item);
+  Notify(Item,cnAdded);
+  Changed;
+end;
+
+
+procedure TCollection.RemoveItem(Item: TCollectionItem);
+begin
+        Notify(Item,cnExtracting);
+  FItems.Remove(Pointer(Item));
+  Item.FCollection:=Nil;
+  Changed;
+end;
+
+
+function TCollection.GetAttrCount: Integer;
+begin
+  Result:=0;
+end;
+
+
+function TCollection.GetAttr(Index: Integer): string;
+begin
+  Result:='';
+end;
+
+
+function TCollection.GetItemAttr(Index, ItemIndex: Integer): string;
+begin
+  Result:=TCollectionItem(FItems.Items[ItemIndex]).DisplayName;
+end;
+
+
+function TCollection.GetNamePath: string;
+var o : TObject;
+begin
+  o:=getowner;
+  if assigned(o) and (propname<>'') and (o IS TPersistent) then 
+     result:=TPersistent(o).getnamepath+'.'+propname
+   else
+     result:=classname;
+end;
+
+
+procedure TCollection.Changed;
+begin
+  if FUpdateCount=0 then
+    Update(Nil);
+end;
+
+
+function TCollection.GetItem(Index: Integer): TCollectionItem;
+begin
+  Result:=TCollectionItem(FItems.Items[Index]);
+end;
+
+
+procedure TCollection.SetItem(Index: Integer; Value: TCollectionItem);
+begin
+  TCollectionItem(FItems.items[Index]).Assign(Value);
+end;
+
+
+procedure TCollection.SetItemName(Item: TCollectionItem);
+begin
+end;
+
+
+
+procedure TCollection.Update(Item: TCollectionItem);
+begin
+end;
+
+
+constructor TCollection.Create(AItemClass: TCollectionItemClass);
+begin
+  inherited create;
+  FItemClass:=AItemClass;
+  FItems:=TList.Create;
+end;
+
+
+destructor TCollection.Destroy;
+begin
+  If Assigned(FItems) Then Clear;
+  FItems.Free;
+  Inherited Destroy;
+end;
+
+
+function TCollection.Add: TCollectionItem;
+begin
+  Result:=FItemClass.Create(Self);
+end;
+
+
+procedure TCollection.Assign(Source: TPersistent);
+Var I : Longint;
+begin
+  If Source is TCollection then
+    begin
+    Clear;
+    For I:=0 To TCollection(Source).Count-1 do
+     Add.Assign(TCollection(Source).Items[I]);
+    exit;
+    end
+  else
+    Inherited Assign(Source);
+end;
+
+
+procedure TCollection.BeginUpdate;
+begin
+        inc(FUpdateCount);
+end;
+
+
+procedure TCollection.Clear;
+begin
+  If Assigned(FItems) then
+    While FItems.Count>0 do TCollectionItem(FItems.Last).Free;
+end;
+
+
+procedure TCollection.EndUpdate;
+begin
+        dec(FUpdateCount);
+        if FUpdateCount=0 then
+          Changed;
+end;
+
+
+function TCollection.FindItemID(ID: Integer): TCollectionItem;
+Var
+          I : Longint;
+begin
+  Result:=Nil;
+  For I:=0 to Fitems.Count-1 do
+   begin
+     Result:=TCollectionItem(FItems.items[I]);
+     If Result.Id=Id then
+       exit;
+   end;
+end;
+
+
+procedure TCollection.Delete(Index: Integer);
+begin
+  Notify(TCollectionItem(FItems[Index]),cnDeleting);
+  TCollectionItem(FItems[Index]).Free;
+end;
+
+
+function TCollection.Insert(Index: Integer): TCollectionItem;
+begin
+  Result:=Add;
+  Result.Index:=Index;
+end;
+
+
+procedure TCollection.Notify(Item: TCollectionItem;Action: TCollectionNotification);
+begin
+end;
+
+
+{****************************************************************************}
+{*                             TOwnedCollection                             *}
+{****************************************************************************}
+
+
+
+Constructor TOwnedCollection.Create(AOwner: TPersistent; AItemClass: TCollectionItemClass);
+
+Begin
+  FOwner := AOwner;
+  inherited Create(AItemClass);
+end;
+
+
+
+Function TOwnedCollection.GetOwner: TPersistent;
+
+begin
+  Result:=FOwner;
+end;
+
+
+

rtl/objpas/classes/lists.inc

@@ -0,0 +1,880 @@
+{
+    This file is part of the Free Pascal Run Time Library (rtl)
+    Copyright (c) 1999-2005 by the Free Pascal development team
+
+    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.
+
+ **********************************************************************}
+
+{$if defined(VER2_0) or not defined(FPC_TESTGENERICS)}
+
+{****************************************************************************}
+{*                           TFPList                                        *}
+{****************************************************************************}
+
+Const
+  // Ratio of Pointer and Word Size.
+  WordRatio = SizeOf(Pointer) Div SizeOf(Word);
+
+procedure TFPList.RaiseIndexError(Index : Integer);
+begin
+  Error(SListIndexError, Index);
+end;
+
+function TFPList.Get(Index: Integer): Pointer;
+begin
+  If (Index < 0) or (Index >= FCount) then
+    RaiseIndexError(Index);
+  Result:=FList^[Index];
+end;
+
+procedure TFPList.Put(Index: Integer; Item: Pointer);
+begin
+  if (Index < 0) or (Index >= FCount) then
+    RaiseIndexError(Index);
+  Flist^[Index] := Item;
+end;
+
+function TFPList.Extract(Item: Pointer): Pointer;
+var
+  i : Integer;
+begin
+  i := IndexOf(item);
+  if i >= 0 then
+   begin
+     Result := item;
+     Delete(i);
+   end
+  else
+    result := nil;
+end;
+
+procedure TFPList.SetCapacity(NewCapacity: Integer);
+begin
+  If (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
+     Error (SListCapacityError, NewCapacity);
+  if NewCapacity = FCapacity then
+    exit;
+  ReallocMem(FList, SizeOf(Pointer)*NewCapacity);
+  FCapacity := NewCapacity;
+end;
+
+procedure TFPList.SetCount(NewCount: Integer);
+begin
+  if (NewCount < 0) or (NewCount > MaxListSize)then
+    Error(SListCountError, NewCount);
+  If NewCount > FCount then
+    begin
+    If NewCount > FCapacity then
+      SetCapacity(NewCount);
+    If FCount < NewCount then
+      FillWord(Flist^[FCount], (NewCount-FCount) *  WordRatio, 0);
+    end;
+  FCount := Newcount;
+end;
+
+destructor TFPList.Destroy;
+begin
+  Self.Clear;
+  inherited Destroy;
+end;
+
+Procedure TFPList.AddList(AList : TFPList);
+
+Var
+  I : Integer;
+
+begin
+  If (Capacity<Count+AList.Count) then
+    Capacity:=Count+AList.Count;
+  For I:=0 to AList.Count-1 do
+    Add(AList[i]);
+end;
+
+
+function TFPList.Add(Item: Pointer): Integer;
+begin
+  if FCount = FCapacity then
+    Self.Expand;
+  FList^[FCount] := Item;
+  Result := FCount;
+  FCount := FCount + 1;
+end;
+
+procedure TFPList.Clear;
+begin
+  if Assigned(FList) then
+  begin
+    SetCount(0);
+    SetCapacity(0);
+    FList := nil;
+  end;
+end;
+
+procedure TFPList.Delete(Index: Integer);
+begin
+  If (Index<0) or (Index>=FCount) then
+    Error (SListIndexError, Index);
+  FCount := FCount-1;
+  System.Move (FList^[Index+1], FList^[Index], (FCount - Index) * SizeOf(Pointer));
+  // Shrink the list if appropriate
+  if (FCapacity > 256) and (FCount < FCapacity shr 2) then
+  begin
+    FCapacity := FCapacity shr 1;
+    ReallocMem(FList, SizeOf(Pointer) * FCapacity);
+  end;
+end;
+
+class procedure TFPList.Error(const Msg: string; Data: PtrInt);
+begin
+  Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
+end;
+
+procedure TFPList.Exchange(Index1, Index2: Integer);
+var
+  Temp : Pointer;
+begin
+  If ((Index1 >= FCount) or (Index1 < 0)) then
+    Error(SListIndexError, Index1);
+  If ((Index2 >= FCount) or (Index2 < 0)) then
+    Error(SListIndexError, Index2);
+  Temp := FList^[Index1];
+  FList^[Index1] := FList^[Index2];
+  FList^[Index2] := Temp;
+end;
+
+function TFPList.Expand: TFPList;
+var
+  IncSize : Longint;
+begin
+  if FCount < FCapacity then exit;
+  IncSize := 4;
+  if FCapacity > 3 then IncSize := IncSize + 4;
+  if FCapacity > 8 then IncSize := IncSize+8;
+  if FCapacity > 127 then Inc(IncSize, FCapacity shr 2);
+  SetCapacity(FCapacity + IncSize);
+  Result := Self;
+end;
+
+function TFPList.First: Pointer;
+begin
+  If FCount = 0 then
+    Result := Nil
+  else
+    Result := Items[0];
+end;
+
+function TFPList.IndexOf(Item: Pointer): Integer;
+begin
+  Result := 0;
+  while(Result < FCount) and (Flist^[Result] <> Item) do Result := Result + 1;
+  If Result = FCount  then Result := -1;
+end;
+
+procedure TFPList.Insert(Index: Integer; Item: Pointer);
+begin
+  if (Index < 0) or (Index > FCount )then
+    Error(SlistIndexError, Index);
+  iF FCount = FCapacity then Self.Expand;
+  if Index<FCount then
+    System.Move(Flist^[Index], Flist^[Index+1], (FCount - Index) * SizeOf(Pointer));
+  FList^[Index] := Item;
+  FCount := FCount + 1;
+end;
+
+function TFPList.Last: Pointer;
+begin
+{ Wouldn't it be better to return nil if the count is zero ?}
+  If FCount = 0 then
+    Result := nil
+  else
+    Result := Items[FCount - 1];
+end;
+
+procedure TFPList.Move(CurIndex, NewIndex: Integer);
+var
+  Temp : Pointer;
+begin
+  if ((CurIndex < 0) or (CurIndex > Count - 1)) then
+    Error(SListIndexError, CurIndex);
+  if ((NewIndex < 0) or (NewIndex > Count -1)) then
+    Error(SlistIndexError, NewIndex);
+  Temp := FList^[CurIndex];
+  FList^[CurIndex] := nil;
+  Self.Delete(CurIndex);
+  Self.Insert(NewIndex, nil);
+  FList^[NewIndex] := Temp;
+end;
+
+function TFPList.Remove(Item: Pointer): Integer;
+begin
+  Result := IndexOf(Item);
+  If Result <> -1 then
+    Self.Delete(Result);
+end;
+
+procedure TFPList.Pack;
+var
+  NewCount,
+  i : integer;
+  pdest,
+  psrc : PPointer;
+begin
+  NewCount:=0;
+  psrc:=@FList^[0];
+  pdest:=psrc;
+  For I:=0 To FCount-1 Do
+    begin
+      if assigned(psrc^) then
+        begin
+          pdest^:=psrc^;
+          inc(pdest);
+          inc(NewCount);
+        end;
+      inc(psrc);
+    end;
+  FCount:=NewCount;
+end;
+
+// Needed by Sort method.
+
+Procedure QuickSort(FList: PPointerList; L, R : Longint;
+                     Compare: TListSortCompare);
+var
+  I, J : Longint;
+  P, Q : Pointer;
+begin
+ repeat
+   I := L;
+   J := R;
+   P := FList^[ (L + R) div 2 ];
+   repeat
+     while Compare(P, FList^[i]) > 0 do
+       I := I + 1;
+     while Compare(P, FList^[J]) < 0 do
+       J := J - 1;
+     If I <= J then
+     begin
+       Q := FList^[I];
+       Flist^[I] := FList^[J];
+       FList^[J] := Q;
+       I := I + 1;
+       J := J - 1;
+     end;
+   until I > J;
+   if L < J then
+     QuickSort(FList, L, J, Compare);
+   L := I;
+ until I >= R;
+end;
+
+procedure TFPList.Sort(Compare: TListSortCompare);
+begin
+  if Not Assigned(FList) or (FCount < 2) then exit;
+  QuickSort(Flist, 0, FCount-1, Compare);
+end;
+
+
+procedure TFPList.ForEachCall(proc2call:TListCallback;arg:pointer);
+var
+  i : integer;
+  p : pointer;
+begin
+  For I:=0 To Count-1 Do
+    begin
+      p:=FList^[i];
+      if assigned(p) then
+        proc2call(p,arg);
+    end;
+end;
+
+
+procedure TFPList.ForEachCall(proc2call:TListStaticCallback;arg:pointer);
+var
+  i : integer;
+  p : pointer;
+begin
+  For I:=0 To Count-1 Do
+    begin
+      p:=FList^[i];
+      if assigned(p) then
+        proc2call(p,arg);
+    end;
+end;
+
+procedure TFPList.CopyMove (aList : TFPList);
+var r : integer;
+begin
+  Clear;
+  for r := 0 to aList.count-1 do
+    Add (aList[r]);
+end;
+
+procedure TFPList.MergeMove (aList : TFPList);
+var r : integer;
+begin
+  For r := 0 to aList.count-1 do
+    if self.indexof(aList[r]) < 0 then
+      self.Add (aList[r]);
+end;
+
+procedure TFPList.DoCopy(ListA, ListB : TFPList);
+var l : TFPList;
+begin
+  if assigned (ListB) then
+    CopyMove (ListB)
+  else
+    CopyMove (ListA);
+end;
+
+procedure TFPList.DoDestUnique(ListA, ListB : TFPList);
+  procedure MoveElements (src, dest : TFPList);
+  var r : integer;
+  begin
+    self.clear;
+    for r := 0 to src.count-1 do
+      if dest.indexof(src[r]) < 0 then
+        self.Add (src[r]);
+  end;
+  
+var dest : TFPList;
+begin
+  if assigned (ListB) then
+    MoveElements (ListB, ListA)
+  else
+    try
+      dest := TFPList.Create;
+      dest.CopyMove (self);
+      MoveElements (ListA, dest)
+    finally
+      dest.Free;
+    end;
+end;
+
+procedure TFPList.DoAnd(ListA, ListB : TFPList);
+var r : integer;
+begin
+  if assigned (ListB) then
+    begin
+    self.clear;
+    for r := 0 to ListA.count-1 do
+      if ListB.indexOf (ListA[r]) >= 0 then
+        self.Add (ListA[r]);
+    end
+  else
+    begin
+    for r := self.Count-1 downto 0 do
+      if ListA.indexof (Self[r]) < 0 then
+        self.delete (r);
+    end;
+end;
+
+procedure TFPList.DoSrcUnique(ListA, ListB : TFPList);
+var r : integer;
+begin
+  if assigned (ListB) then
+    begin
+    self.Clear;
+    for r := 0 to ListA.Count-1 do
+      if ListB.indexof (ListA[r]) < 0 then
+        self.Add (ListA[r]);
+    end
+  else
+    begin
+    for r := self.count-1 downto 0 do
+      if ListA.indexof (self[r]) >= 0 then
+        self.delete (r);
+    end;
+end;
+
+procedure TFPList.DoOr(ListA, ListB : TFPList);
+var r : integer;
+begin
+  if assigned (ListB) then
+    begin
+    CopyMove (ListA);
+    MergeMove (ListB);
+    end
+  else
+    MergeMove (ListA);
+end;
+
+procedure TFPList.DoXOr(ListA, ListB : TFPList);
+var r : integer;
+    l : TFPList;
+begin
+  if assigned (ListB) then
+    begin
+    self.Clear;
+    for r := 0 to ListA.count-1 do
+      if ListB.indexof (ListA[r]) < 0 then
+        self.Add (ListA[r]);
+    for r := 0 to ListB.count-1 do
+      if ListA.indexof (ListB[r]) < 0 then
+        self.Add (ListB[r]);
+    end
+  else
+    try
+      l := TFPList.Create;
+      l.CopyMove (Self);
+      for r := self.count-1 downto 0 do
+        if listA.indexof (self[r]) >= 0 then
+          self.delete (r);
+      for r := 0 to ListA.count-1 do
+        if l.indexof (ListA[r]) < 0 then
+          self.add (ListA[r]);
+    finally
+      l.Free;
+    end;
+end;
+
+
+procedure TFPList.Assign (ListA: TFPList; AOperator: TListAssignOp=laCopy; ListB: TFPList=nil);
+begin
+  case AOperator of
+    laCopy : DoCopy (ListA, ListB);             // replace dest with src
+    laSrcUnique : DoSrcUnique (ListA, ListB);   // replace dest with src that are not in dest
+    laAnd : DoAnd (ListA, ListB);               // remove from dest that are not in src
+    laDestUnique : DoDestUnique (ListA, ListB); // remove from dest that are in src
+    laOr : DoOr (ListA, ListB);                 // add to dest from src and not in dest
+    laXOr : DoXOr (ListA, ListB);               // add to dest from src and not in dest, remove from dest that are in src
+  end;
+end;
+
+{$else}
+
+{ generics based implementation of TFPList follows }
+
+procedure TFPList.Assign(Source: TFPList);
+begin
+  inherited Assign(Source);
+end;
+
+type
+  TFPPtrListSortCompare = function(const Item1, Item2: Pointer): Integer;
+
+procedure TFPList.Sort(Compare: TListSortCompare);
+begin
+  inherited Sort(TFPPtrListSortCompare(Compare));
+end;
+
+procedure TFPList.ForEachCall(Proc2call: TListCallback; Arg: Pointer);
+var
+  I: integer;
+begin
+  for I:=0 to Count-1 do
+    proc2call(InternalItems[I],arg);
+end;
+
+
+procedure TFPList.ForEachCall(Proc2call: TListStaticCallback; Arg: Pointer);
+var
+  I: integer;
+begin
+  for I:=0 to Count-1 do
+    Proc2call(InternalItems[I], Arg);
+end;
+
+{$endif}
+
+
+
+{****************************************************************************}
+{*                TList                                                     *}
+{****************************************************************************}
+
+{  TList = class(TObject)
+  private
+    FList: TFPList;
+}
+
+
+
+function TList.Get(Index: Integer): Pointer;
+begin
+  Result := FList.Get(Index);
+end;
+
+procedure TList.Grow;
+begin
+  // Only for compatibility with Delphi. Not needed.
+end;
+
+procedure TList.Put(Index: Integer; Item: Pointer);
+var p : pointer;
+begin
+  p := get(Index);
+  FList.Put(Index, Item);
+  if assigned (p) then
+    Notify (p, lnDeleted);
+  if assigned (Item) then
+    Notify (Item, lnAdded);
+end;
+
+function TList.Extract(item: Pointer): Pointer;
+var c : integer;
+begin
+  c := FList.Count;
+  Result := FList.Extract(item);
+  if c <> FList.Count then
+    Notify (Result, lnExtracted);
+end;
+
+procedure TList.Notify(Ptr: Pointer; Action: TListNotification);
+begin
+end;
+
+function TList.GetCapacity: integer;
+begin
+  Result := FList.Capacity;
+end;
+
+procedure TList.SetCapacity(NewCapacity: Integer);
+begin
+  FList.SetCapacity(NewCapacity);
+end;
+
+function TList.GetCount: Integer;
+begin
+  Result := FList.Count;
+end;
+
+procedure TList.SetCount(NewCount: Integer);
+begin
+  FList.SetCount(NewCount);
+end;
+
+constructor TList.Create;
+begin
+  inherited Create;
+  FList := TFPList.Create;
+end;
+
+destructor TList.Destroy;
+begin
+  If (Flist<>Nil) then
+    Clear;
+  FreeAndNil(FList);
+  inherited Destroy;
+end;
+
+function TList.Add(Item: Pointer): Integer;
+begin
+  Result := FList.Add(Item);
+  if Item <> nil then
+    Notify(Item, lnAdded);
+end;
+
+Procedure TList.AddList(AList : TList);
+begin
+  FList.AddList(AList.FList);
+end;
+
+procedure TList.Clear;
+
+begin
+  If Assigned(Flist) then
+    While (FList.Count>0) do
+      Delete(Count-1);
+end;
+
+procedure TList.Delete(Index: Integer);
+
+var P : pointer;
+
+begin
+  P:=FList.Get(Index);
+  FList.Delete(Index);
+  if assigned(p) then Notify(p, lnDeleted);
+end;
+
+class procedure TList.Error(const Msg: string; Data: PtrInt);
+begin
+  Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
+end;
+
+procedure TList.Exchange(Index1, Index2: Integer);
+begin
+  FList.Exchange(Index1, Index2);
+end;
+
+function TList.Expand: TList;
+begin
+  FList.Expand;
+  Result:=Self;
+end;
+
+function TList.First: Pointer;
+begin
+  Result := FList.First;
+end;
+
+function TList.IndexOf(Item: Pointer): Integer;
+begin
+  Result := FList.IndexOf(Item);
+end;
+
+procedure TList.Insert(Index: Integer; Item: Pointer);
+begin
+  FList.Insert(Index, Item);
+  if Item <> nil then
+    Notify(Item,lnAdded);
+end;
+
+function TList.Last: Pointer;
+begin
+  Result := FList.Last;
+end;
+
+procedure TList.Move(CurIndex, NewIndex: Integer);
+begin
+  FList.Move(CurIndex, NewIndex);
+end;
+
+function TList.Remove(Item: Pointer): Integer;
+begin
+  Result := IndexOf(Item);
+  if Result <> -1 then
+    Self.Delete(Result);
+end;
+
+procedure TList.Pack;
+begin
+  FList.Pack;
+end;
+
+procedure TList.Sort(Compare: TListSortCompare);
+begin
+  FList.Sort(Compare);
+end;
+
+procedure TList.CopyMove (aList : TList);
+var r : integer;
+begin
+  Clear;
+  for r := 0 to aList.count-1 do
+    Add (aList[r]);
+end;
+
+procedure TList.MergeMove (aList : TList);
+var r : integer;
+begin
+  For r := 0 to aList.count-1 do
+    if self.indexof(aList[r]) < 0 then
+      self.Add (aList[r]);
+end;
+
+procedure TList.DoCopy(ListA, ListB : TList);
+var l : TList;
+begin
+  if assigned (ListB) then
+    CopyMove (ListB)
+  else
+    CopyMove (ListA);
+end;
+
+procedure TList.DoDestUnique(ListA, ListB : TList);
+  procedure MoveElements (src, dest : TList);
+  var r : integer;
+  begin
+    self.clear;
+    for r := 0 to src.count-1 do
+      if dest.indexof(src[r]) < 0 then
+        self.Add (src[r]);
+  end;
+  
+var dest : TList;
+begin
+  if assigned (ListB) then
+    MoveElements (ListB, ListA)
+  else
+    try
+      dest := TList.Create;
+      dest.CopyMove (self);
+      MoveElements (ListA, dest)
+    finally
+      dest.Free;
+    end;
+end;
+
+procedure TList.DoAnd(ListA, ListB : TList);
+var r : integer;
+begin
+  if assigned (ListB) then
+    begin
+    self.clear;
+    for r := 0 to ListA.count-1 do
+      if ListB.indexOf (ListA[r]) >= 0 then
+        self.Add (ListA[r]);
+    end
+  else
+    begin
+    for r := self.Count-1 downto 0 do
+      if ListA.indexof (Self[r]) < 0 then
+        self.delete (r);
+    end;
+end;
+
+procedure TList.DoSrcUnique(ListA, ListB : TList);
+var r : integer;
+begin
+  if assigned (ListB) then
+    begin
+    self.Clear;
+    for r := 0 to ListA.Count-1 do
+      if ListB.indexof (ListA[r]) < 0 then
+        self.Add (ListA[r]);
+    end
+  else
+    begin
+    for r := self.count-1 downto 0 do
+      if ListA.indexof (self[r]) >= 0 then
+        self.delete (r);
+    end;
+end;
+
+procedure TList.DoOr(ListA, ListB : TList);
+var r : integer;
+begin
+  if assigned (ListB) then
+    begin
+    CopyMove (ListA);
+    MergeMove (ListB);
+    end
+  else
+    MergeMove (ListA);
+end;
+
+procedure TList.DoXOr(ListA, ListB : TList);
+var r : integer;
+    l : TList;
+begin
+  if assigned (ListB) then
+    begin
+    self.Clear;
+    for r := 0 to ListA.count-1 do
+      if ListB.indexof (ListA[r]) < 0 then
+        self.Add (ListA[r]);
+    for r := 0 to ListB.count-1 do
+      if ListA.indexof (ListB[r]) < 0 then
+        self.Add (ListB[r]);
+    end
+  else
+    try
+      l := TList.Create;
+      l.CopyMove (Self);
+      for r := self.count-1 downto 0 do
+        if listA.indexof (self[r]) >= 0 then
+          self.delete (r);
+      for r := 0 to ListA.count-1 do
+        if l.indexof (ListA[r]) < 0 then
+          self.add (ListA[r]);
+    finally
+      l.Free;
+    end;
+end;
+
+
+procedure TList.Assign (ListA: TList; AOperator: TListAssignOp=laCopy; ListB: TList=nil);
+begin
+  case AOperator of
+    laCopy : DoCopy (ListA, ListB);             // replace dest with src
+    laSrcUnique : DoSrcUnique (ListA, ListB);   // replace dest with src that are not in dest
+    laAnd : DoAnd (ListA, ListB);               // remove from dest that are not in src
+    laDestUnique : DoDestUnique (ListA, ListB); // remove from dest that are in src
+    laOr : DoOr (ListA, ListB);                 // add to dest from src and not in dest
+    laXOr : DoXOr (ListA, ListB);               // add to dest from src and not in dest, remove from dest that are in src
+  end;
+end;
+
+
+function TList.GetList: PPointerList;
+begin
+  Result := PPointerList(FList.List);
+end;
+
+
+{****************************************************************************}
+{*                             TThreadList                                  *}
+{****************************************************************************}
+
+
+constructor TThreadList.Create;
+  begin
+    inherited Create;
+    FDuplicates:=dupIgnore;
+    InitCriticalSection(FLock);
+    FList:=TList.Create;
+  end;
+
+
+destructor TThreadList.Destroy;
+  begin
+    LockList;
+    try
+      FList.Free;
+      inherited Destroy;
+    finally
+      UnlockList;
+      DoneCriticalSection(FLock);
+    end;
+  end;
+
+
+
+procedure TThreadList.Add(Item: Pointer);
+  begin
+    LockList;
+    try
+      if (Duplicates=dupAccept) or
+        // make sure it's not already in the list
+        (FList.IndexOf(Item)=-1) then
+         FList.Add(Item)
+       else if (Duplicates=dupError) then
+         FList.Error(SDuplicateItem,PtrUInt(Item));
+    finally
+      UnlockList;
+    end;
+  end;
+
+
+procedure TThreadList.Clear;
+  begin
+    Locklist;
+    try
+      FList.Clear;
+    finally
+      UnLockList;
+    end;
+  end;
+
+
+function TThreadList.LockList: TList;
+  begin
+    Result:=FList;
+    System.EnterCriticalSection(FLock);
+  end;
+
+
+procedure TThreadList.Remove(Item: Pointer);
+  begin
+    LockList;
+    try
+      FList.Remove(Item);
+    finally
+      UnlockList;
+    end;
+  end;
+
+
+procedure TThreadList.UnlockList;
+  begin
+    System.LeaveCriticalSection(FLock);
+  end;
+
+

rtl/objpas/classes/parser.inc

@@ -0,0 +1,457 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2007 by the Free Pascal development team
+
+    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.
+
+ **********************************************************************}
+
+{****************************************************************************}
+{*                             TParser                                      *}
+{****************************************************************************}
+
+const
+  ParseBufSize     = 4096;
+  LastSpecialToken = 5;
+
+  TokNames : array[0..LastSpecialToken] of string =
+  (
+    'EOF',
+    'Symbol',
+    'String',
+    'Integer',
+    'Float',
+    'WideString'
+  );
+
+function TParser.GetTokenName(aTok: char): string;
+begin
+  if ord(aTok) <= LastSpecialToken then
+    Result:=TokNames[ord(aTok)]
+  else Result:=aTok;
+end;
+
+procedure TParser.LoadBuffer;
+var toread : integer;
+begin
+  toread:=fStream.Size-fStream.Position;
+  if toread>ParseBufSize then toread:=ParseBufSize;
+  if toread=0 then
+  begin
+    fEofReached:=true;
+    exit;
+  end;
+  fStream.ReadBuffer(fBuf[0],toread);
+  fBuf[toread]:=#0;
+  inc(fDeltaPos,fPos);
+  fPos:=0;
+  fBufLen:=toread;
+end;
+
+procedure TParser.CheckLoadBuffer; inline;
+begin
+  if fBuf[fPos]=#0 then LoadBuffer;
+end;
+
+procedure TParser.ProcessChar; inline;
+begin
+  fLastTokenStr:=fLastTokenStr+fBuf[fPos];
+  inc(fPos);
+  CheckLoadBuffer;
+end;
+
+function TParser.IsNumber: boolean; inline;
+begin
+  Result:=fBuf[fPos] in ['0'..'9'];
+end;
+
+function TParser.IsHexNum: boolean; inline;
+begin
+  Result:=fBuf[fPos] in ['0'..'9','A'..'F','a'..'f'];
+end;
+
+function TParser.IsAlpha: boolean; inline;
+begin
+  Result:=fBuf[fPos] in ['_','A'..'Z','a'..'z'];
+end;
+
+function TParser.IsAlphaNum: boolean; inline;
+begin
+  Result:=IsAlpha or IsNumber;
+end;
+
+function TParser.GetHexValue(c: char): byte; inline;
+begin
+  case c of
+    '0'..'9' : Result:=ord(c)-$30;
+    'A'..'F' : Result:=ord(c)-$37; //-$41+$0A
+    'a'..'f' : Result:=ord(c)-$57; //-$61+$0A
+  end;
+end;
+
+function TParser.GetAlphaNum: string;
+begin
+  if not IsAlpha then
+    ErrorFmt(SParExpected,[GetTokenName(toSymbol)]);
+  Result:='';
+  while IsAlphaNum do
+  begin
+    Result:=Result+fBuf[fPos];
+    inc(fPos);
+    CheckLoadBuffer;
+  end;
+end;
+
+procedure TParser.HandleNewLine;
+begin
+  if fBuf[fPos]=#13 then //CR
+  begin
+    inc(fPos);
+    CheckLoadBuffer;
+    if fBuf[fPos]=#10 then inc(fPos); //CR LF
+  end
+  else inc(fPos); //LF
+  inc(fSourceLine);
+  fDeltaPos:=-(fPos-1);
+end;
+
+procedure TParser.SkipSpaces;
+begin
+  while fBuf[fPos] in [' ',#9] do
+    inc(fPos);
+end;
+
+procedure TParser.SkipWhitespace;
+begin
+  while true do
+  begin
+    CheckLoadBuffer;
+    case fBuf[fPos] of
+      ' ',#9  : SkipSpaces;
+      #10,#13 : HandleNewLine
+      else break;
+    end;
+  end;
+end;
+
+procedure TParser.HandleEof;
+begin
+  fToken:=toEOF;
+  fLastTokenStr:='';
+end;
+
+procedure TParser.HandleAlphaNum;
+begin
+  fLastTokenStr:=GetAlphaNum;
+  fToken:=toSymbol;
+end;
+
+procedure TParser.HandleNumber;
+type
+  floatPunct = (fpDot,fpE);
+  floatPuncts = set of floatPunct;
+var
+  allowed : floatPuncts;
+begin
+  fLastTokenStr:='';
+  while IsNumber do
+    ProcessChar;
+  fToken:=toInteger;
+  if (fBuf[fPos] in ['.','e','E']) then
+  begin
+    fToken:=toFloat;
+    allowed:=[fpDot,fpE];
+    while (fBuf[fPos] in ['.','e','E','0'..'9']) do
+    begin
+      case fBuf[fPos] of
+        '.'     : if fpDot in allowed then Exclude(allowed,fpDot) else break;
+        'E','e' : if fpE in allowed then
+                  begin
+                    allowed:=[];
+                    ProcessChar;
+                    if (fBuf[fPos] in ['+','-']) then ProcessChar;
+                    if not (fBuf[fPos] in ['0'..'9']) then
+                      ErrorFmt(SParInvalidFloat,[fLastTokenStr+fBuf[fPos]]);
+                  end
+                  else break;
+      end;
+      ProcessChar;
+    end;
+  end;
+  if (fBuf[fPos] in ['s','S','d','D','c','C']) then //single, date, currency
+  begin
+    fFloatType:=fBuf[fPos];
+    inc(fPos);
+    fToken:=toFloat;
+  end
+  else fFloatType:=#0;
+end;
+
+procedure TParser.HandleHexNumber;
+var valid : boolean;
+begin
+  fLastTokenStr:='$';
+  inc(fPos);
+  CheckLoadBuffer;
+  valid:=false;
+  while IsHexNum do
+  begin
+    valid:=true;
+    ProcessChar;
+  end;
+  if not valid then
+    ErrorFmt(SParInvalidInteger,[fLastTokenStr]);
+  fToken:=toInteger;
+end;
+
+function TParser.HandleQuotedString: string;
+begin
+  Result:='';
+  inc(fPos);
+  CheckLoadBuffer;
+  while true do
+  begin
+    case fBuf[fPos] of
+      #0     : ErrorStr(SParUnterminatedString);
+      #13,#10 : ErrorStr(SParUnterminatedString);
+      ''''   : begin
+                 inc(fPos);
+                 CheckLoadBuffer;
+                 if fBuf[fPos]<>'''' then exit;
+               end;
+    end;
+    Result:=Result+fBuf[fPos];
+    inc(fPos);
+    CheckLoadBuffer;
+  end;
+end;
+
+function TParser.HandleDecimalString(var ascii : boolean): widestring;
+var i : integer;
+begin
+  Result:='';
+  inc(fPos);
+  CheckLoadBuffer;
+  while IsNumber do
+  begin
+    Result:=Result+fBuf[fPos];
+    inc(fPos);
+    CheckLoadBuffer;
+  end;
+  if TryStrToInt(Result,i) and (i<256) then
+  begin
+    if i>127 then ascii:=false;
+    setlength(Result,1);
+    Result[1]:=widechar(word(i));
+  end
+  else
+    Result:='#'+Result;
+end;
+
+procedure TParser.HandleString;
+var ascii : boolean;
+begin
+  fLastTokenWStr:='';
+  ascii:=true;
+  while true do
+    case fBuf[fPos] of
+      '''' : fLastTokenWStr:=fLastTokenWStr+HandleQuotedString;
+      '#'  : fLastTokenWStr:=fLastTokenWStr+HandleDecimalString(ascii)
+      else break;
+    end;
+  if ascii then
+    fToken:=toString
+  else
+    fToken:=toWString;
+  fLastTokenStr:=fLastTokenWStr;
+end;
+
+procedure TParser.HandleMinus;
+begin
+  inc(fPos);
+  CheckLoadBuffer;
+  if IsNumber then
+  begin
+    HandleNumber;
+    fLastTokenStr:='-'+fLastTokenStr;
+  end
+  else
+  begin
+    fToken:='-';
+    fLastTokenStr:=fToken;
+  end;
+end;
+
+procedure TParser.HandleUnknown;
+begin
+  fToken:=fBuf[fPos];
+  fLastTokenStr:=fToken;
+  inc(fPos);
+end;
+
+constructor TParser.Create(Stream: TStream);
+begin
+  fStream:=Stream;
+  fBuf:=GetMem(ParseBufSize+1);
+  fBufLen:=0;
+  fPos:=0;
+  fDeltaPos:=1;
+  fSourceLine:=1;
+  fEofReached:=false;
+  fLastTokenStr:='';
+  fLastTokenWStr:='';
+  fFloatType:=#0;
+  fToken:=#0;
+  LoadBuffer;
+  NextToken;
+end;
+
+destructor TParser.Destroy;
+begin
+  fStream.Position:=SourcePos;
+  FreeMem(fBuf);
+end;
+
+procedure TParser.CheckToken(T: Char);
+begin
+  if fToken<>T then
+    ErrorFmt(SParWrongTokenType,[GetTokenName(T),GetTokenName(fToken)]);
+end;
+
+procedure TParser.CheckTokenSymbol(const S: string);
+begin
+  CheckToken(toSymbol);
+  if CompareText(fLastTokenStr,S)<>0 then
+    ErrorFmt(SParWrongTokenSymbol,[s,fLastTokenStr]);
+end;
+
+procedure TParser.Error(const Ident: string);
+begin
+  ErrorStr(Ident);
+end;
+
+procedure TParser.ErrorFmt(const Ident: string; const Args: array of const);
+begin
+  ErrorStr(Format(Ident,Args));
+end;
+
+procedure TParser.ErrorStr(const Message: string);
+begin
+  raise EParserError.CreateFmt(Message+SParLocInfo,[SourceLine,fPos+fDeltaPos,SourcePos]);
+end;
+
+procedure TParser.HexToBinary(Stream: TStream);
+var outbuf : array[0..ParseBufSize-1] of byte;
+    b : byte;
+    i : integer;
+begin
+  i:=0;
+  SkipWhitespace;
+  while IsHexNum do
+  begin
+    b:=(GetHexValue(fBuf[fPos]) shl 4);
+    inc(fPos);
+    CheckLoadBuffer;
+    if not IsHexNum then
+      Error(SParUnterminatedBinValue);
+    b:=b or GetHexValue(fBuf[fPos]);
+    inc(fPos);
+    outbuf[i]:=b;
+    inc(i);
+    if i>=ParseBufSize then
+    begin
+      Stream.WriteBuffer(outbuf[0],i);
+      i:=0;
+    end;
+    SkipWhitespace;
+  end;
+  if i>0 then
+    Stream.WriteBuffer(outbuf[0],i);
+  NextToken;
+end;
+
+function TParser.NextToken: Char;
+
+begin
+  SkipWhiteSpace;
+  if fEofReached then
+    HandleEof
+  else
+    case fBuf[fPos] of
+      '_','A'..'Z','a'..'z' : HandleAlphaNum;
+      '$'                   : HandleHexNumber;
+      '-'                   : HandleMinus;
+      '0'..'9'              : HandleNumber;
+      '''','#'              : HandleString
+      else
+        HandleUnknown;
+    end;
+  Result:=fToken;
+end;
+
+function TParser.SourcePos: Longint;
+begin
+  Result:=fStream.Position-fBufLen+fPos;
+end;
+
+function TParser.TokenComponentIdent: string;
+begin
+  if fToken<>toSymbol then
+    ErrorFmt(SParExpected,[GetTokenName(toSymbol)]);
+  CheckLoadBuffer;
+  while fBuf[fPos]='.' do
+  begin
+    ProcessChar;
+    fLastTokenStr:=fLastTokenStr+GetAlphaNum;
+  end;
+  Result:=fLastTokenStr;
+end;
+
+{$ifndef FPUNONE}
+Function TParser.TokenFloat: Extended;
+
+var errcode : word;
+
+begin
+  Val(fLastTokenStr,Result,errcode);
+  if errcode<>0 then
+    ErrorFmt(SParInvalidFloat,[fLastTokenStr]);
+end;
+{$endif}
+
+Function TParser.TokenInt: Int64;
+begin
+  if not TryStrToInt64(fLastTokenStr,Result) then
+    Result:=Int64(StrToQWord(fLastTokenStr)); //second chance for malformed files
+end;
+
+function TParser.TokenString: string;
+begin
+  case fToken of
+    toWString : Result:=fLastTokenWStr;
+    toFloat : if fFloatType<>#0 then
+                Result:=fLastTokenStr+fFloatType
+              else Result:=fLastTokenStr
+    else
+      Result:=fLastTokenStr;
+  end;
+end;
+
+function TParser.TokenWideString: WideString;
+begin
+  if fToken=toWString then
+    Result:=fLastTokenWStr
+  else
+    Result:=fLastTokenStr;
+end;
+
+function TParser.TokenSymbolIs(const S: string): Boolean;
+begin
+  Result:=(fToken=toSymbol) and (CompareText(fLastTokenStr,S)=0);
+end;
+

rtl/objpas/classes/reader.inc

@@ -0,0 +1,1512 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by the Free Pascal development team
+
+    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.
+
+ **********************************************************************}
+{****************************************************************************}
+{*                       TBinaryObjectReader                                *}
+{****************************************************************************}
+
+{$ifndef FPUNONE}
+{$IFNDEF FPC_HAS_TYPE_EXTENDED}
+function ExtendedToDouble(e : pointer) : double;
+var mant : qword;
+    exp : smallint;
+    sign : boolean;
+    d : qword;
+begin
+  move(pbyte(e)[0],mant,8); //mantissa         : bytes 0..7
+  move(pbyte(e)[8],exp,2);  //exponent and sign: bytes 8..9
+  mant:=LEtoN(mant);
+  exp:=LEtoN(word(exp));
+  sign:=(exp and $8000)<>0;
+  if sign then exp:=exp and $7FFF;
+  case exp of
+        0 : mant:=0;  //if denormalized, value is too small for double,
+                      //so it's always zero
+    $7FFF : exp:=2047 //either infinity or NaN
+    else
+    begin
+      dec(exp,16383-1023);
+      if (exp>=-51) and (exp<=0) then //can be denormalized
+      begin
+        mant:=mant shr (-exp);
+        exp:=0;
+      end
+      else
+      if (exp<-51) or (exp>2046) then //exponent too large.
+      begin
+        Result:=0;
+        exit;
+      end
+      else //normalized value
+        mant:=mant shl 1; //hide most significant bit
+    end;
+  end;
+  d:=word(exp);
+  d:=d shl 52;
+
+  mant:=mant shr 12;
+  d:=d or mant;
+  if sign then d:=d or $8000000000000000;
+  Result:=pdouble(@d)^;
+end;
+{$ENDIF}
+{$endif}
+
+function TBinaryObjectReader.ReadWord : word; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+begin
+  Read(Result,2);
+  Result:=LEtoN(Result);
+end;
+
+function TBinaryObjectReader.ReadDWord : longword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+begin
+  Read(Result,4);
+  Result:=LEtoN(Result);
+end;
+
+function TBinaryObjectReader.ReadQWord : qword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+begin
+  Read(Result,8);
+  Result:=LEtoN(Result);
+end;
+
+{$ifndef FPUNONE}
+function TBinaryObjectReader.ReadExtended : extended; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+{$IFNDEF FPC_HAS_TYPE_EXTENDED}
+var ext : array[0..9] of byte;
+{$ENDIF}
+begin
+  {$IFNDEF FPC_HAS_TYPE_EXTENDED}
+  Read(ext[0],10);
+  Result:=ExtendedToDouble(@(ext[0]));
+  {$ELSE}
+  Read(Result,sizeof(Result));
+  {$ENDIF}
+end;
+{$endif}
+
+constructor TBinaryObjectReader.Create(Stream: TStream; BufSize: Integer);
+begin
+  inherited Create;
+  If (Stream=Nil) then
+    Raise EReadError.Create(SEmptyStreamIllegalReader);
+  FStream := Stream;
+  FBufSize := BufSize;
+  GetMem(FBuffer, BufSize);
+end;
+
+destructor TBinaryObjectReader.Destroy;
+begin
+  { Seek back the amount of bytes that we didn't process until now: }
+  FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), soFromCurrent);
+
+  if Assigned(FBuffer) then
+    FreeMem(FBuffer, FBufSize);
+
+  inherited Destroy;
+end;
+
+function TBinaryObjectReader.ReadValue: TValueType;
+var
+  b: byte;
+begin
+  Read(b, 1);
+  Result := TValueType(b);
+end;
+
+function TBinaryObjectReader.NextValue: TValueType;
+begin
+  Result := ReadValue;
+  { We only 'peek' at the next value, so seek back to unget the read value: }
+  Dec(FBufPos);
+end;
+
+procedure TBinaryObjectReader.BeginRootComponent;
+var
+  Signature: LongInt;
+begin
+  { Read filer signature }
+  Read(Signature, 4);
+  if Signature <> LongInt({$ifdef FPC_SUPPORTS_UNALIGNED}unaligned{$endif}(FilerSignature)) then
+    raise EReadError.Create(SInvalidImage);
+end;
+
+procedure TBinaryObjectReader.BeginComponent(var Flags: TFilerFlags;
+  var AChildPos: Integer; var CompClassName, CompName: String);
+var
+  Prefix: Byte;
+  ValueType: TValueType;
+begin
+  { Every component can start with a special prefix: }
+  Flags := [];
+  if (Byte(NextValue) and $f0) = $f0 then
+  begin
+    Prefix := Byte(ReadValue);
+    Flags := TFilerFlags(longint(Prefix and $0f));
+    if ffChildPos in Flags then
+    begin
+      ValueType := ReadValue;
+      case ValueType of
+        vaInt8:
+          AChildPos := ReadInt8;
+        vaInt16:
+          AChildPos := ReadInt16;
+        vaInt32:
+          AChildPos := ReadInt32;
+        else
+          raise EReadError.Create(SInvalidPropertyValue);
+      end;
+    end;
+  end;
+
+  CompClassName := ReadStr;
+  CompName := ReadStr;
+end;
+
+function TBinaryObjectReader.BeginProperty: String;
+begin
+  Result := ReadStr;
+end;
+
+procedure TBinaryObjectReader.ReadBinary(const DestData: TMemoryStream);
+var
+  BinSize: LongInt;
+begin
+  BinSize:=LongInt(ReadDWord);
+  DestData.Size := BinSize;
+  Read(DestData.Memory^, BinSize);
+end;
+
+{$ifndef FPUNONE}
+function TBinaryObjectReader.ReadFloat: Extended;
+begin
+  Result:=ReadExtended;
+end;
+
+function TBinaryObjectReader.ReadSingle: Single;
+begin
+  Result:=single(ReadDWord);
+end;
+{$endif}
+
+function TBinaryObjectReader.ReadCurrency: Currency;
+begin
+  Result:=currency(ReadQWord);
+end;
+
+{$ifndef FPUNONE}
+function TBinaryObjectReader.ReadDate: TDateTime;
+begin
+  Result:=TDateTime(ReadQWord);
+end;
+{$endif}
+
+function TBinaryObjectReader.ReadIdent(ValueType: TValueType): String;
+var
+  i: Byte;
+begin
+  case ValueType of
+    vaIdent:
+      begin
+        Read(i, 1);
+        SetLength(Result, i);
+        Read(Pointer(@Result[1])^, i);
+      end;
+    vaNil:
+      Result := 'nil';
+    vaFalse:
+      Result := 'False';
+    vaTrue:
+      Result := 'True';
+    vaNull:
+      Result := 'Null';
+  end;
+end;
+
+function TBinaryObjectReader.ReadInt8: ShortInt;
+begin
+  Read(Result, 1);
+end;
+
+function TBinaryObjectReader.ReadInt16: SmallInt;
+begin
+  Result:=SmallInt(ReadWord);
+end;
+
+function TBinaryObjectReader.ReadInt32: LongInt;
+begin
+  Result:=LongInt(ReadDWord);
+end;
+
+function TBinaryObjectReader.ReadInt64: Int64;
+begin
+  Result:=Int64(ReadQWord);
+end;
+
+function TBinaryObjectReader.ReadSet(EnumType: Pointer): Integer;
+var
+  Name: String;
+  Value: Integer;
+begin
+  try
+    Result := 0;
+    while True do
+    begin
+      Name := ReadStr;
+      if Length(Name) = 0 then
+        break;
+      Value := GetEnumValue(PTypeInfo(EnumType), Name);
+      if Value = -1 then
+        raise EReadError.Create(SInvalidPropertyValue);
+      Result := Result or (1 shl Value);
+    end;
+  except
+    SkipSetBody;
+    raise;
+  end;
+end;
+
+function TBinaryObjectReader.ReadStr: String;
+var
+  i: Byte;
+begin
+  Read(i, 1);
+  SetLength(Result, i);
+  if i > 0 then
+    Read(Pointer(@Result[1])^, i);
+end;
+
+function TBinaryObjectReader.ReadString(StringType: TValueType): String;
+var
+  b: Byte;
+  i: Integer;
+begin
+  case StringType of
+    vaString:
+      begin
+        Read(b, 1);
+        i := b;
+      end;
+    vaLString:
+      i:=ReadDWord;
+  end;
+  SetLength(Result, i);
+  if i > 0 then
+    Read(Pointer(@Result[1])^, i);
+end;
+
+function TBinaryObjectReader.ReadWideString: WideString;
+var
+  len: DWord;
+{$IFDEF ENDIAN_BIG}
+  i : integer;
+{$ENDIF}
+begin
+  len := ReadDWord;
+  SetLength(Result, len);
+  if (len > 0) then
+  begin
+    Read(Pointer(@Result[1])^, len*2);
+    {$IFDEF ENDIAN_BIG}
+    for i:=1 to len do
+      Result[i]:=widechar(SwapEndian(word(Result[i])));
+    {$ENDIF}
+  end;
+end;
+
+procedure TBinaryObjectReader.SkipComponent(SkipComponentInfos: Boolean);
+var
+  Flags: TFilerFlags;
+  Dummy: Integer;
+  CompClassName, CompName: String;
+begin
+  if SkipComponentInfos then
+    { Skip prefix, component class name and component object name }
+    BeginComponent(Flags, Dummy, CompClassName, CompName);
+
+  { Skip properties }
+  while NextValue <> vaNull do
+    SkipProperty;
+  ReadValue;
+
+  { Skip children }
+  while NextValue <> vaNull do
+    SkipComponent(True);
+  ReadValue;
+end;
+
+procedure TBinaryObjectReader.SkipValue;
+
+  procedure SkipBytes(Count: LongInt);
+  var
+    Dummy: array[0..1023] of Byte;
+    SkipNow: Integer;
+  begin
+    while Count > 0 do
+    begin
+      if Count > 1024 then
+        SkipNow := 1024
+      else
+        SkipNow := Count;
+      Read(Dummy, SkipNow);
+      Dec(Count, SkipNow);
+    end;
+  end;
+
+var
+  Count: LongInt;
+begin
+  case ReadValue of
+    vaNull, vaFalse, vaTrue, vaNil: ;
+    vaList:
+      begin
+        while NextValue <> vaNull do
+          SkipValue;
+        ReadValue;
+      end;
+    vaInt8:
+      SkipBytes(1);
+    vaInt16:
+      SkipBytes(2);
+    vaInt32:
+      SkipBytes(4);
+    vaExtended:
+      SkipBytes(10);
+    vaString, vaIdent:
+      ReadStr;
+    vaBinary, vaLString:
+      begin
+        Count:=LongInt(ReadDWord);
+        SkipBytes(Count);
+      end;
+    vaWString:
+      begin
+        Count:=LongInt(ReadDWord);
+        SkipBytes(Count*sizeof(widechar));
+      end;
+    vaSet:
+      SkipSetBody;
+    vaCollection:
+      begin
+        while NextValue <> vaNull do
+        begin
+          { Skip the order value if present }
+          if NextValue in [vaInt8, vaInt16, vaInt32] then
+            SkipValue;
+          SkipBytes(1);
+          while NextValue <> vaNull do
+            SkipProperty;
+          ReadValue;
+        end;
+        ReadValue;
+      end;
+    vaSingle:
+{$ifndef FPUNONE}
+      SkipBytes(Sizeof(Single));
+{$else}
+      SkipBytes(4);
+{$endif}
+    {!!!: vaCurrency:
+      SkipBytes(SizeOf(Currency));}
+    vaDate, vaInt64:
+      SkipBytes(8);
+  end;
+end;
+
+{ private methods }
+
+procedure TBinaryObjectReader.Read(var Buf; Count: LongInt);
+var
+  CopyNow: LongInt;
+  Dest: Pointer;
+begin
+  Dest := @Buf;
+  while Count > 0 do
+  begin
+    if FBufPos >= FBufEnd then
+    begin
+      FBufEnd := FStream.Read(FBuffer^, FBufSize);
+      if FBufEnd = 0 then
+        raise EReadError.Create(SReadError);
+      FBufPos := 0;
+    end;
+    CopyNow := FBufEnd - FBufPos;
+    if CopyNow > Count then
+      CopyNow := Count;
+    Move(PChar(FBuffer)[FBufPos], Dest^, CopyNow);
+    Inc(FBufPos, CopyNow);
+    Inc(Dest, CopyNow);
+    Dec(Count, CopyNow);
+  end;
+end;
+
+procedure TBinaryObjectReader.SkipProperty;
+begin
+  { Skip property name, then the property value }
+  ReadStr;
+  SkipValue;
+end;
+
+procedure TBinaryObjectReader.SkipSetBody;
+begin
+  while Length(ReadStr) > 0 do;
+end;
+
+
+
+{****************************************************************************}
+{*                             TREADER                                      *}
+{****************************************************************************}
+
+type
+  TFieldInfo = packed record
+    FieldOffset: LongWord;
+    ClassTypeIndex: Word;
+    Name: ShortString;
+  end;
+
+  PFieldClassTable = ^TFieldClassTable;
+  TFieldClassTable =
+{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+  packed
+{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+  record
+    Count: Word;
+    Entries: array[Word] of TPersistentClass;
+  end;
+
+  PFieldTable = ^TFieldTable;
+  TFieldTable =
+{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+  packed
+{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+  record
+    FieldCount: Word;
+    ClassTable: PFieldClassTable;
+    // Fields: array[Word] of TFieldInfo;  Elements have variant size!
+  end;
+
+function GetFieldClass(Instance: TObject; const ClassName: string): TPersistentClass;
+var
+  UClassName: String;
+  ClassType: TClass;
+  ClassTable: PFieldClassTable;
+  i: Integer;
+{  FieldTable: PFieldTable; }
+begin
+  // At first, try to locate the class in the class tables
+  UClassName := UpperCase(ClassName);
+  ClassType := Instance.ClassType;
+  while ClassType <> TPersistent do
+  begin
+{    FieldTable := PFieldTable((Pointer(ClassType) + vmtFieldTable)^); }
+    ClassTable := PFieldTable((Pointer(ClassType) + vmtFieldTable)^)^.ClassTable;
+    if Assigned(ClassTable) then
+      for i := 0 to ClassTable^.Count - 1 do
+      begin
+        Result := ClassTable^.Entries[i];
+        if UpperCase(Result.ClassName) = UClassName then
+          exit;
+      end;
+     // Try again with the parent class type
+     ClassType := ClassType.ClassParent;
+  end;
+  Result := Classes.GetClass(ClassName);
+end;
+
+
+constructor TReader.Create(Stream: TStream; BufSize: Integer);
+begin
+  inherited Create;
+  If (Stream=Nil) then
+    Raise EReadError.Create(SEmptyStreamIllegalReader);
+  FDriver := CreateDriver(Stream, BufSize);
+end;
+
+destructor TReader.Destroy;
+begin
+  FDriver.Free;
+  inherited Destroy;
+end;
+
+function TReader.CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectReader;
+begin
+  Result := TBinaryObjectReader.Create(Stream, BufSize);
+end;
+
+procedure TReader.BeginReferences;
+begin
+  FLoaded := TList.Create;
+end;
+
+procedure TReader.CheckValue(Value: TValueType);
+begin
+  if FDriver.NextValue <> Value then
+    raise EReadError.Create(SInvalidPropertyValue)
+  else
+    FDriver.ReadValue;
+end;
+
+procedure TReader.DefineProperty(const Name: String; AReadData: TReaderProc;
+  WriteData: TWriterProc; HasData: Boolean);
+begin
+  if Assigned(AReadData) and (UpperCase(Name) = UpperCase(FPropName)) then
+  begin
+    AReadData(Self);
+    SetLength(FPropName, 0);
+  end;
+end;
+
+procedure TReader.DefineBinaryProperty(const Name: String;
+  AReadData, WriteData: TStreamProc; HasData: Boolean);
+var
+  MemBuffer: TMemoryStream;
+begin
+  if Assigned(AReadData) and (UpperCase(Name) = UpperCase(FPropName)) then
+  begin
+    { Check if the next property really is a binary property}
+    if FDriver.NextValue <> vaBinary then
+    begin
+      FDriver.SkipValue;
+      FCanHandleExcepts := True;
+      raise EReadError.Create(SInvalidPropertyValue);
+    end else
+      FDriver.ReadValue;
+
+    MemBuffer := TMemoryStream.Create;
+    try
+      FDriver.ReadBinary(MemBuffer);
+      FCanHandleExcepts := True;
+      AReadData(MemBuffer);
+    finally
+      MemBuffer.Free;
+    end;
+    SetLength(FPropName, 0);
+  end;
+end;
+
+function TReader.EndOfList: Boolean;
+begin
+  Result := FDriver.NextValue = vaNull;
+end;
+
+procedure TReader.EndReferences;
+begin
+  FLoaded.Free;
+  FLoaded := nil;
+end;
+
+function TReader.Error(const Message: String): Boolean;
+begin
+  Result := False;
+  if Assigned(FOnError) then
+    FOnError(Self, Message, Result);
+end;
+
+function TReader.FindMethod(ARoot: TComponent; const AMethodName: String): Pointer;
+var
+  ErrorResult: Boolean;
+begin
+  Result := ARoot.MethodAddress(AMethodName);
+  ErrorResult := Result = nil;
+
+  { always give the OnFindMethod callback a chance to locate the method }
+  if Assigned(FOnFindMethod) then
+    FOnFindMethod(Self, AMethodName, Result, ErrorResult);
+
+  if ErrorResult then
+    raise EReadError.Create(SInvalidPropertyValue);
+end;
+
+procedure TReader.DoFixupReferences;
+
+Var
+  R,RN : TLocalUnresolvedReference;
+  G : TUnresolvedInstance;
+  Ref : String;
+  C : TComponent;
+  P : integer;
+  L : TLinkedList;
+  
+begin
+  If Assigned(FFixups) then
+    begin
+    L:=TLinkedList(FFixups);
+    R:=TLocalUnresolvedReference(L.Root);
+    While (R<>Nil) do
+      begin
+      RN:=TLocalUnresolvedReference(R.Next);
+      Ref:=R.FRelative;
+      If Assigned(FOnReferenceName) then
+        FOnReferenceName(Self,Ref);
+      C:=FindNestedComponent(R.FRoot,Ref);
+      If Assigned(C) then
+        SetObjectProp(R.FInstance,R.FPropInfo,C)
+      else
+        begin
+        P:=Pos('.',R.FRelative);
+        If (P<>0) then
+          begin
+          G:=AddToResolveList(R.FInstance);
+          G.Addreference(R.FRoot,R.FPropInfo,Copy(R.FRelative,1,P-1),Copy(R.FRelative,P+1,Length(R.FRelative)-P));
+          end;
+        end;
+      L.RemoveItem(R);
+      R:=RN;
+      end;
+    FreeAndNil(FFixups);
+    end;
+end;
+
+procedure TReader.FixupReferences;
+var
+  i: Integer;
+begin
+  DoFixupReferences;
+  GlobalFixupReferences;
+  for i := 0 to FLoaded.Count - 1 do
+    TComponent(FLoaded[I]).Loaded;
+end;
+
+
+function TReader.NextValue: TValueType;
+begin
+  Result := FDriver.NextValue;
+end;
+
+procedure TReader.Read(var Buf; Count: LongInt);
+begin
+  //This should give an exception if read is not implemented (i.e. TTextObjectReader)
+  //but should work with TBinaryObjectReader.
+  Driver.Read(Buf, Count);
+end;
+
+procedure TReader.PropertyError;
+begin
+  FDriver.SkipValue;
+  raise EReadError.CreateFmt(SUnknownProperty,[FPropName]);
+end;
+
+function TReader.ReadBoolean: Boolean;
+var
+  ValueType: TValueType;
+begin
+  ValueType := FDriver.ReadValue;
+  if ValueType = vaTrue then
+    Result := True
+  else if ValueType = vaFalse then
+    Result := False
+  else
+    raise EReadError.Create(SInvalidPropertyValue);
+end;
+
+function TReader.ReadChar: Char;
+var
+  s: String;
+begin
+  s := ReadString;
+  if Length(s) = 1 then
+    Result := s[1]
+  else
+    raise EReadError.Create(SInvalidPropertyValue);
+end;
+
+function TReader.ReadWideChar: WideChar;
+
+var
+  W: WideString;
+  
+begin
+  W := ReadWideString;
+  if Length(W) = 1 then
+    Result := W[1]
+  else
+    raise EReadError.Create(SInvalidPropertyValue);
+end;
+            
+procedure TReader.ReadCollection(Collection: TCollection);
+var
+  Item: TCollectionItem;
+begin
+  Collection.BeginUpdate;
+  Collection.Clear;
+  while not EndOfList do begin
+    ReadListBegin;
+    Item := Collection.Add;
+    while NextValue<>vaNull do
+      ReadProperty(Item);
+    ReadListEnd;
+  end;
+  Collection.EndUpdate;
+  ReadListEnd;
+end;
+
+function TReader.ReadComponent(Component: TComponent): TComponent;
+var
+  Flags: TFilerFlags;
+
+  function Recover(var Component: TComponent): Boolean;
+  begin
+    Result := False;
+    if ExceptObject.InheritsFrom(Exception) then
+    begin
+      if not ((ffInherited in Flags) or Assigned(Component)) then
+        Component.Free;
+      Component := nil;
+      FDriver.SkipComponent(False);
+      Result := Error(Exception(ExceptObject).Message);
+    end;
+  end;
+
+var
+  CompClassName, Name: String;
+  n, ChildPos: Integer;
+  SavedParent, SavedLookupRoot: TComponent;
+  ComponentClass: TComponentClass;
+  C, NewComponent: TComponent;
+  SubComponents: TList;
+begin
+  FDriver.BeginComponent(Flags, ChildPos, CompClassName, Name);
+  SavedParent := Parent;
+  SavedLookupRoot := FLookupRoot;
+  SubComponents := nil;
+  try
+    Result := Component;
+    if not Assigned(Result) then
+      try
+        if ffInherited in Flags then
+        begin
+          { Try to locate the existing ancestor component }
+
+          if Assigned(FLookupRoot) then
+            Result := FLookupRoot.FindComponent(Name)
+          else
+            Result := nil;
+
+          if not Assigned(Result) then
+          begin
+            if Assigned(FOnAncestorNotFound) then
+              FOnAncestorNotFound(Self, Name,
+                FindComponentClass(CompClassName), Result);
+            if not Assigned(Result) then
+              raise EReadError.CreateFmt(SAncestorNotFound, [Name]);
+          end;
+
+          Parent := Result.GetParentComponent;
+          if not Assigned(Parent) then
+            Parent := Root;
+        end else
+        begin
+          Result := nil;
+          ComponentClass := FindComponentClass(CompClassName);
+          if Assigned(FOnCreateComponent) then
+            FOnCreateComponent(Self, ComponentClass, Result);
+          if not Assigned(Result) then
+          begin
+            NewComponent := TComponent(ComponentClass.NewInstance);
+            if ffInline in Flags then
+              NewComponent.FComponentState :=
+                NewComponent.FComponentState + [csLoading, csInline];
+            NewComponent.Create(Owner);
+
+            { Don't set Result earlier because else we would come in trouble
+              with the exception recover mechanism! (Result should be NIL if
+              an error occured) }
+            Result := NewComponent;
+          end;
+          Include(Result.FComponentState, csLoading);
+        end;
+      except
+        if not Recover(Result) then
+          raise;
+      end;
+
+    if Assigned(Result) then
+      try
+        Include(Result.FComponentState, csLoading);
+
+        { create list of subcomponents and set loading}
+        SubComponents := TList.Create;
+        for n := 0 to Result.ComponentCount - 1 do
+        begin
+          C := Result.Components[n];
+          if csSubcomponent in C.ComponentStyle
+          then begin
+            SubComponents.Add(C);
+            Include(C.FComponentState, csLoading);
+          end;
+        end;
+
+        if not (ffInherited in Flags) then
+          try
+            Result.SetParentComponent(Parent);
+            if Assigned(FOnSetName) then
+              FOnSetName(Self, Result, Name);
+            Result.Name := Name;
+            if FindGlobalComponent(Name) = Result then
+              Include(Result.FComponentState, csInline);
+          except
+            if not Recover(Result) then
+              raise;
+          end;
+        if not Assigned(Result) then
+          exit;
+        if csInline in Result.ComponentState then
+          FLookupRoot := Result;
+
+        { Read the component state }
+        Include(Result.FComponentState, csReading);
+        for n := 0 to Subcomponents.Count - 1 do
+          Include(TComponent(Subcomponents[n]).FComponentState, csReading);
+
+        Result.ReadState(Self);
+
+        Exclude(Result.FComponentState, csReading);
+        for n := 0 to Subcomponents.Count - 1 do
+          Exclude(TComponent(Subcomponents[n]).FComponentState, csReading);
+
+        if ffChildPos in Flags then
+          Parent.SetChildOrder(Result, ChildPos);
+
+        { Add component to list of loaded components, if necessary }
+        if (not ((ffInherited in Flags) or (csInline in Result.ComponentState))) or
+          (FLoaded.IndexOf(Result) < 0)
+          then begin
+            for n := 0 to Subcomponents.Count - 1 do
+              FLoaded.Add(Subcomponents[n]);
+            FLoaded.Add(Result);
+          end;
+      except
+        if ((ffInherited in Flags) or Assigned(Component)) then
+          Result.Free;
+        raise;
+      end;
+  finally
+    Parent := SavedParent;
+    FLookupRoot := SavedLookupRoot;
+    Subcomponents.Free;
+  end;
+end;
+
+procedure TReader.ReadData(Instance: TComponent);
+var
+  SavedOwner, SavedParent: TComponent;
+  
+begin
+  try
+    { Read properties }
+    while not EndOfList do
+      ReadProperty(Instance);
+    ReadListEnd;
+
+    { Read children }
+    SavedOwner := Owner;
+    SavedParent := Parent;
+    try
+      Owner := Instance.GetChildOwner;
+      if not Assigned(Owner) then
+        Owner := Root;
+      Parent := Instance.GetChildParent;
+
+      while not EndOfList do
+        ReadComponent(nil);
+      ReadListEnd;
+    finally
+      Owner := SavedOwner;
+      Parent := SavedParent;
+    end;
+
+    { Fixup references if necessary (normally only if this is the root) }
+    DoFixupReferences;
+  finally
+    FreeAndNil(FFixups);
+  end;
+end;
+
+{$ifndef FPUNONE}
+function TReader.ReadFloat: Extended;
+begin
+  if FDriver.NextValue = vaExtended then
+  begin
+    ReadValue;
+    Result := FDriver.ReadFloat
+  end else
+    Result := ReadInteger;
+end;
+
+function TReader.ReadSingle: Single;
+begin
+  if FDriver.NextValue = vaSingle then
+  begin
+    FDriver.ReadValue;
+    Result := FDriver.ReadSingle;
+  end else
+    Result := ReadInteger;
+end;
+{$endif}
+
+function TReader.ReadCurrency: Currency;
+begin
+  if FDriver.NextValue = vaCurrency then
+  begin
+    FDriver.ReadValue;
+    Result := FDriver.ReadCurrency;
+  end else
+    Result := ReadInteger;
+end;
+
+{$ifndef FPUNONE}
+function TReader.ReadDate: TDateTime;
+begin
+  if FDriver.NextValue = vaDate then
+  begin
+    FDriver.ReadValue;
+    Result := FDriver.ReadDate;
+  end else
+    Result := ReadInteger;
+end;
+{$endif}
+
+function TReader.ReadIdent: String;
+var
+  ValueType: TValueType;
+begin
+  ValueType := FDriver.ReadValue;
+  if ValueType in [vaIdent, vaNil, vaFalse, vaTrue, vaNull] then
+    Result := FDriver.ReadIdent(ValueType)
+  else
+    raise EReadError.Create(SInvalidPropertyValue);
+end;
+
+
+function TReader.ReadInteger: LongInt;
+begin
+  case FDriver.ReadValue of
+    vaInt8:
+      Result := FDriver.ReadInt8;
+    vaInt16:
+      Result := FDriver.ReadInt16;
+    vaInt32:
+      Result := FDriver.ReadInt32;
+  else
+    raise EReadError.Create(SInvalidPropertyValue);
+  end;
+end;
+
+function TReader.ReadInt64: Int64;
+begin
+  if FDriver.NextValue = vaInt64 then
+  begin
+    FDriver.ReadValue;
+    Result := FDriver.ReadInt64;
+  end else
+    Result := ReadInteger;
+end;
+
+procedure TReader.ReadListBegin;
+begin
+  CheckValue(vaList);
+end;
+
+procedure TReader.ReadListEnd;
+begin
+  CheckValue(vaNull);
+end;
+
+procedure TReader.ReadProperty(AInstance: TPersistent);
+var
+  Path: String;
+  Instance: TPersistent;
+  DotPos, NextPos: PChar;
+  PropInfo: PPropInfo;
+  Obj: TObject;
+  Name: String;
+  Skip: Boolean;
+  Handled: Boolean;
+  OldPropName: String;
+
+  function HandleMissingProperty(IsPath: Boolean): boolean;
+  begin
+    Result:=true;
+    if Assigned(OnPropertyNotFound) then begin
+      // user defined property error handling
+      OldPropName:=FPropName;
+      Handled:=false;
+      Skip:=false;
+      OnPropertyNotFound(Self,Instance,FPropName,IsPath,Handled,Skip);
+      if Handled and (not Skip) and (OldPropName<>FPropName) then
+        // try alias property
+        PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
+      if Skip then begin
+        FDriver.SkipValue;
+        Result:=false;
+        exit;
+      end;
+    end;
+  end;
+
+begin
+  try
+    Path := FDriver.BeginProperty;
+    try
+      Instance := AInstance;
+      FCanHandleExcepts := True;
+      DotPos := PChar(Path);
+      while True do
+      begin
+        NextPos := StrScan(DotPos, '.');
+        if Assigned(NextPos) then
+          FPropName := Copy(String(DotPos), 1, Integer(NextPos - DotPos))
+        else
+        begin
+          FPropName := DotPos;
+          break;
+        end;
+        DotPos := NextPos + 1;
+
+        PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
+        if not Assigned(PropInfo) then begin
+          if not HandleMissingProperty(true) then exit;
+          if not Assigned(PropInfo) then
+            PropertyError;
+        end;
+
+        if PropInfo^.PropType^.Kind = tkClass then
+          Obj := TObject(GetObjectProp(Instance, PropInfo))
+        else
+          Obj := nil;
+
+        if not (Obj is TPersistent) then
+        begin
+          { All path elements must be persistent objects! }
+          FDriver.SkipValue;
+          raise EReadError.Create(SInvalidPropertyPath);
+        end;
+        Instance := TPersistent(Obj);
+      end;
+
+      PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
+      if Assigned(PropInfo) then
+        ReadPropValue(Instance, PropInfo)
+      else
+      begin
+        FCanHandleExcepts := False;
+        Instance.DefineProperties(Self);
+        FCanHandleExcepts := True;
+        if Length(FPropName) > 0 then begin
+          if not HandleMissingProperty(false) then exit;
+          if not Assigned(PropInfo) then
+            PropertyError;
+        end;
+      end;
+    except
+      on e: Exception do
+      begin
+        SetLength(Name, 0);
+        if AInstance.InheritsFrom(TComponent) then
+          Name := TComponent(AInstance).Name;
+        if Length(Name) = 0 then
+          Name := AInstance.ClassName;
+        raise EReadError.CreateFmt(SPropertyException,
+          [Name, DotSep, Path, e.Message]);
+      end;
+    end;
+  except
+    on e: Exception do
+      if not FCanHandleExcepts or not Error(E.Message) then
+        raise;
+  end;
+end;
+
+procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
+const
+  NullMethod: TMethod = (Code: nil; Data: nil);
+var
+  PropType: PTypeInfo;
+  Value: LongInt;
+{  IdentToIntFn: TIdentToInt; }
+  Ident: String;
+  Method: TMethod;
+  Handled: Boolean;
+  TmpStr: String;
+begin
+  if not Assigned(PPropInfo(PropInfo)^.SetProc) then
+    raise EReadError.Create(SReadOnlyProperty);
+
+  PropType := PPropInfo(PropInfo)^.PropType;
+  case PropType^.Kind of
+    tkInteger:
+      if FDriver.NextValue = vaIdent then
+      begin
+        Ident := ReadIdent;
+        if GlobalIdentToInt(Ident,Value) then
+          SetOrdProp(Instance, PropInfo, Value)
+        else
+          raise EReadError.Create(SInvalidPropertyValue);
+      end else
+        SetOrdProp(Instance, PropInfo, ReadInteger);
+    tkBool:
+      SetOrdProp(Instance, PropInfo, Ord(ReadBoolean));
+    tkChar:
+      SetOrdProp(Instance, PropInfo, Ord(ReadChar));
+    tkWChar:
+      SetOrdProp(Instance, PropInfo, Ord(ReadWideChar));  
+    tkEnumeration:
+      begin
+        Value := GetEnumValue(PropType, ReadIdent);
+        if Value = -1 then
+          raise EReadError.Create(SInvalidPropertyValue);
+        SetOrdProp(Instance, PropInfo, Value);
+      end;
+{$ifndef FPUNONE}
+    tkFloat:
+      SetFloatProp(Instance, PropInfo, ReadFloat);
+{$endif}
+    tkSet:
+      begin
+        CheckValue(vaSet);
+        SetOrdProp(Instance, PropInfo,
+          FDriver.ReadSet(GetTypeData(PropType)^.CompType));
+      end;
+    tkMethod:
+      if FDriver.NextValue = vaNil then
+      begin
+        FDriver.ReadValue;
+        SetMethodProp(Instance, PropInfo, NullMethod);
+      end else
+      begin
+        Handled:=false;
+        Ident:=ReadIdent;
+        if Assigned(OnSetMethodProperty) then
+          OnSetMethodProperty(Self,Instance,PPropInfo(PropInfo),Ident,
+                              Handled);
+        if not Handled then begin
+          Method.Code := FindMethod(Root, Ident);
+          Method.Data := Root;
+          if Assigned(Method.Code) then
+            SetMethodProp(Instance, PropInfo, Method);
+        end;
+      end;
+    tkSString, tkLString, tkAString:
+    begin
+      TmpStr:=ReadString;
+      if Assigned(FOnReadStringProperty) then
+        FOnReadStringProperty(Self,Instance,PropInfo,TmpStr);
+      SetStrProp(Instance, PropInfo, TmpStr);
+    end;
+    tkWstring:
+      SetWideStrProp(Instance,PropInfo,ReadWideString);
+    {!!!: tkVariant}
+    tkClass:
+      case FDriver.NextValue of
+        vaNil:
+          begin
+            FDriver.ReadValue;
+            SetOrdProp(Instance, PropInfo, 0)
+          end;
+        vaCollection:
+          begin
+            FDriver.ReadValue;
+            ReadCollection(TCollection(GetObjectProp(Instance, PropInfo)));
+          end
+        else
+          begin
+          If Not Assigned(FFixups) then
+            FFixups:=TLinkedList.Create(TLocalUnresolvedReference);
+          With TLocalUnresolvedReference(TLinkedList(FFixups).Add) do
+            begin
+            FInstance:=Instance;
+            FRoot:=Root;
+            FPropInfo:=PropInfo;
+            FRelative:=ReadIdent;
+            end;
+          end;
+      end;
+    tkInt64, tkQWord: SetInt64Prop(Instance, PropInfo, ReadInt64);
+    else
+      raise EReadError.CreateFmt(SUnknownPropertyType, [Ord(PropType^.Kind)]);
+  end;
+end;
+
+function TReader.ReadRootComponent(ARoot: TComponent): TComponent;
+var
+  Dummy, i: Integer;
+  Flags: TFilerFlags;
+  CompClassName, CompName, ResultName: String;
+begin
+  FDriver.BeginRootComponent;
+  Result := nil;
+  {!!!: GlobalNameSpace.BeginWrite;  // Loading from stream adds to name space
+  try}
+    try
+      FDriver.BeginComponent(Flags, Dummy, CompClassName, CompName);
+      if not Assigned(ARoot) then
+      begin
+        { Read the class name and the object name and create a new object: }
+        Result := TComponentClass(FindClass(CompClassName)).Create(nil);
+        Result.Name := CompName;
+      end else
+      begin
+        Result := ARoot;
+
+        if not (csDesigning in Result.ComponentState) then
+        begin
+          Result.FComponentState :=
+            Result.FComponentState + [csLoading, csReading];
+
+          { We need an unique name }
+          i := 0;
+          { Don't use Result.Name directly, as this would influence
+            FindGlobalComponent in successive loop runs }
+          ResultName := CompName;
+          while Assigned(FindGlobalComponent(ResultName)) do
+          begin
+            Inc(i);
+            ResultName := CompName + '_' + IntToStr(i);
+          end;
+          Result.Name := ResultName;
+        end;
+      end;
+
+      FRoot := Result;
+      FLookupRoot := Result;
+      if Assigned(GlobalLoaded) then
+        FLoaded := GlobalLoaded
+      else
+        FLoaded := TList.Create;
+
+      try
+        if FLoaded.IndexOf(FRoot) < 0 then
+          FLoaded.Add(FRoot);
+        FOwner := FRoot;
+        FRoot.FComponentState := FRoot.FComponentState + [csLoading, csReading];
+        FRoot.ReadState(Self);
+        Exclude(FRoot.FComponentState, csReading);
+
+        if not Assigned(GlobalLoaded) then
+          for i := 0 to FLoaded.Count - 1 do
+            TComponent(FLoaded[i]).Loaded;
+
+      finally
+        if not Assigned(GlobalLoaded) then
+          FLoaded.Free;
+        FLoaded := nil;
+      end;
+      GlobalFixupReferences;
+    except
+      RemoveFixupReferences(ARoot, '');
+      if not Assigned(ARoot) then
+        Result.Free;
+      raise;
+    end;
+  {finally
+    GlobalNameSpace.EndWrite;
+  end;}
+end;
+
+procedure TReader.ReadComponents(AOwner, AParent: TComponent;
+  Proc: TReadComponentsProc);
+var
+  Component: TComponent;
+begin
+  Root := AOwner;
+  Owner := AOwner;
+  Parent := AParent;
+  BeginReferences;
+  try
+    while not EndOfList do
+    begin
+      FDriver.BeginRootComponent;
+      Component := ReadComponent(nil);
+      if Assigned(Proc) then
+        Proc(Component);
+    end;
+    ReadListEnd;
+    FixupReferences;
+  finally
+    EndReferences;
+  end;
+end;
+
+
+function TReader.ReadString: String;
+var
+  StringType: TValueType;
+begin
+  StringType := FDriver.ReadValue;
+  if StringType in [vaString, vaLString] then
+    Result := FDriver.ReadString(StringType)
+  else if StringType in [vaWString,vaUTF8String] then
+    Result:= FDriver.ReadWidestring
+  else
+    raise EReadError.Create(SInvalidPropertyValue);
+end;
+
+
+function TReader.ReadWideString: WideString;
+var
+ s: String;
+ i: Integer;
+begin
+  if NextValue in [vaWString,vaUTF8String] then
+  begin
+    ReadValue;
+    Result := FDriver.ReadWideString
+  end
+  else begin
+    //data probable from ObjectTextToBinary
+    s := ReadString;
+    setlength(result,length(s));
+    for i:= 1 to length(s) do begin
+     result[i]:= widechar(ord(s[i])); //no code conversion
+    end;
+  end;
+end;
+
+function TReader.ReadValue: TValueType;
+begin
+  Result := FDriver.ReadValue;
+end;
+
+procedure TReader.CopyValue(Writer: TWriter);
+
+  procedure CopyBytes(Count: Integer);
+{  var
+    Buffer: array[0..1023] of Byte; }
+  begin
+{!!!:    while Count > 1024 do
+    begin
+      FDriver.Read(Buffer, 1024);
+      Writer.Driver.Write(Buffer, 1024);
+      Dec(Count, 1024);
+    end;
+    if Count > 0 then
+    begin
+      FDriver.Read(Buffer, Count);
+      Writer.Driver.Write(Buffer, Count);
+    end;}
+  end;
+
+{var
+  s: String;
+  Count: LongInt; }
+begin
+  case FDriver.NextValue of
+    vaNull:
+      Writer.WriteIdent('NULL');
+    vaFalse:
+      Writer.WriteIdent('FALSE');
+    vaTrue:
+      Writer.WriteIdent('TRUE');
+    vaNil:
+      Writer.WriteIdent('NIL');
+    {!!!: vaList, vaCollection:
+      begin
+        Writer.WriteValue(FDriver.ReadValue);
+        while not EndOfList do
+          CopyValue(Writer);
+        ReadListEnd;
+        Writer.WriteListEnd;
+      end;}
+    vaInt8, vaInt16, vaInt32:
+      Writer.WriteInteger(ReadInteger);
+{$ifndef FPUNONE}
+    vaExtended:
+      Writer.WriteFloat(ReadFloat);
+{$endif}
+    {!!!: vaString:
+      Writer.WriteStr(ReadStr);}
+    vaIdent:
+      Writer.WriteIdent(ReadIdent);
+    {!!!: vaBinary, vaLString, vaWString:
+      begin
+        Writer.WriteValue(FDriver.ReadValue);
+        FDriver.Read(Count, SizeOf(Count));
+        Writer.Driver.Write(Count, SizeOf(Count));
+        CopyBytes(Count);
+      end;}
+    {!!!: vaSet:
+      Writer.WriteSet(ReadSet);}
+{$ifndef FPUNONE}
+    vaSingle:
+      Writer.WriteSingle(ReadSingle);
+{$endif}
+    {!!!: vaCurrency:
+      Writer.WriteCurrency(ReadCurrency);}
+{$ifndef FPUNONE}
+    vaDate:
+      Writer.WriteDate(ReadDate);
+{$endif}
+    vaInt64:
+      Writer.WriteInteger(ReadInt64);
+  end;
+end;
+
+function TReader.FindComponentClass(const AClassName: String): TComponentClass;
+
+var
+  PersistentClass: TPersistentClass;
+  UClassName: shortstring;
+
+  procedure FindInFieldTable(RootComponent: TComponent);
+  var
+    FieldClassTable: PFieldClassTable;
+    Entry: TPersistentClass;
+    i: Integer;
+    ComponentClassType: TClass;
+  begin
+    ComponentClassType := RootComponent.ClassType;
+    // it is not necessary to look in the FieldTable of TComponent,
+    // because TComponent doesn't have published properties that are
+    // descendants of TComponent
+    while ComponentClassType<>TComponent do begin
+      FieldClassTable :=
+        PFieldTable((Pointer(RootComponent.ClassType)+vmtFieldTable)^)^.ClassTable;
+      if assigned(FieldClassTable) then begin
+        for i := 0 to FieldClassTable^.Count -1 do begin
+          Entry := FieldClassTable^.Entries[i];
+          //writeln(format('Looking for %s in field table of class %s. Found %s',
+            //[AClassName, ComponentClassType.ClassName, Entry.ClassName]));
+          if (UpperCase(Entry.ClassName)=UClassName) and
+            (Entry.InheritsFrom(TComponent)) then begin
+            Result := TComponentClass(Entry);
+            Exit;
+          end;
+        end;
+      end;
+      // look in parent class
+      ComponentClassType := ComponentClassType.ClassParent;
+    end;
+  end;
+  
+begin
+  Result := nil;
+  UClassName:=UpperCase(AClassName);
+  FindInFieldTable(Root);
+  
+  if (Result=nil) and assigned(LookupRoot) and (LookupRoot<>Root) then
+    FindInFieldTable(LookupRoot);
+
+  if (Result=nil) then begin
+    PersistentClass := GetClass(AClassName);
+    if PersistentClass.InheritsFrom(TComponent) then
+      Result := TComponentClass(PersistentClass);
+  end;
+    
+  if (Result=nil) and assigned(OnFindComponentClass) then
+    OnFindComponentClass(Self, AClassName, Result);
+
+  if (Result=nil) or (not Result.InheritsFrom(TComponent)) then
+    raise EClassNotFound.CreateFmt(SClassNotFound, [AClassName]);
+end;
+
+

rtl/objpas/classes/resref.inc

@@ -0,0 +1,453 @@
+
+
+type
+  // Quadruple representing an unresolved component property.
+
+  { TUnresolvedReference }
+
+  TUnresolvedReference = class(TlinkedListItem)
+  Private
+    FRoot: TComponent;     // Root component when streaming
+    FPropInfo: PPropInfo;  // Property to set.
+    FGlobal,               // Global component.
+    FRelative : string;    // Path relative to global component.
+    Function Resolve(Instance : TPersistent) : Boolean; // Resolve this reference
+    Function RootMatches(ARoot : TComponent) : Boolean; Inline; // True if Froot matches or ARoot is nil.
+    Function NextRef : TUnresolvedReference; inline;
+  end;
+  
+  TLocalUnResolvedReference = class(TUnresolvedReference)
+    Finstance : TPersistent;
+  end;
+
+  // Linked list of TPersistent items that have unresolved properties.  
+
+  { TUnResolvedInstance }
+
+  TUnResolvedInstance = Class(TLinkedListItem)
+    Instance : TPersistent; // Instance we're handling unresolveds for
+    FUnresolved : TLinkedList; // The list
+    Destructor Destroy; override;
+    Function AddReference(ARoot : TComponent; APropInfo : PPropInfo; AGlobal,ARelative : String) : TUnresolvedReference;
+    Function RootUnresolved : TUnresolvedReference; inline; // Return root element in list.
+    Function ResolveReferences : Boolean; // Return true if all unresolveds were resolved.
+  end;
+
+  // Builds a list of TUnResolvedInstances, removes them from global list on free.
+  TBuildListVisitor = Class(TLinkedListVisitor)
+    List : TFPList;
+    Procedure Add(Item : TlinkedListItem); // Add TUnResolvedInstance item to list. Create list if needed
+    Destructor Destroy; override; // All elements in list (if any) are removed from the global list.
+  end;
+  
+  // Visitor used to try and resolve instances in the global list
+  TResolveReferenceVisitor = Class(TBuildListVisitor)
+    Function Visit(Item : TLinkedListItem) : Boolean; override;
+  end;
+  
+  // Visitor used to remove all references to a certain component.
+  TRemoveReferenceVisitor = Class(TBuildListVisitor)
+    FRef : String;
+    FRoot : TComponent;
+    Constructor Create(ARoot : TComponent;Const ARef : String);
+    Function Visit(Item : TLinkedListItem) : Boolean; override;
+  end;
+
+  // Visitor used to collect reference names.
+  TReferenceNamesVisitor = Class(TLinkedListVisitor)
+    FList : TStrings;
+    FRoot : TComponent;
+    Function Visit(Item : TLinkedListItem) : Boolean; override;
+    Constructor Create(ARoot : TComponent;AList : TStrings);
+  end;
+
+  // Visitor used to collect instance names.  
+  TReferenceInstancesVisitor = Class(TLinkedListVisitor)
+    FList : TStrings;
+    FRef  : String;
+    FRoot : TComponent;
+    Function Visit(Item : TLinkedListItem) : Boolean; override;
+    Constructor Create(ARoot : TComponent;Const ARef : String; AList : TStrings);
+  end;
+  
+  // Visitor used to redirect links to another root component.
+  TRedirectReferenceVisitor = Class(TLinkedListVisitor)
+    FOld,
+    FNew : String;
+    FRoot : TComponent;
+    Function Visit(Item : TLinkedListItem) : Boolean; override;
+    Constructor Create(ARoot : TComponent;Const AOld,ANew : String);
+  end;
+  
+var
+  NeedResolving : TLinkedList;
+  ResolveSection : TRTLCriticalSection;
+  LastAddInstance : TUnresolvedInstance;
+
+// Add an instance to the global list of instances which need resolving.
+Function FindUnresolvedInstance(AInstance: TPersistent) : TUnResolvedInstance;
+
+begin
+  Result:=Nil;
+  EnterCriticalSection(ResolveSection);
+  Try
+    If Assigned(NeedResolving) then
+      begin
+      Result:=TUnResolvedInstance(NeedResolving.Root);
+      While (Result<>Nil) and (Result.Instance<>AInstance) do
+        Result:=TUnResolvedInstance(Result.Next);
+      end;
+  finally
+    LeaveCriticalSection(ResolveSection);
+  end;
+end;
+
+Function AddtoResolveList(AInstance: TPersistent) : TUnResolvedInstance;
+
+begin
+  Result:=FindUnresolvedInstance(AInstance);
+  If (Result=Nil) then
+    begin
+    EnterCriticalSection(ResolveSection);
+    Try
+      If not Assigned(NeedResolving) then
+        NeedResolving:=TLinkedList.Create(TUnResolvedInstance);
+      Result:=NeedResolving.Add as TUnResolvedInstance;
+      Result.Instance:=AInstance;
+    finally
+      LeaveCriticalSection(ResolveSection);
+    end;
+    end;
+end;
+
+// Walk through the global list of instances to be resolved.  
+
+Procedure VisitResolveList(V : TLinkedListVisitor);
+
+begin
+  EnterCriticalSection(ResolveSection);
+  Try
+    try
+      NeedResolving.Foreach(V);
+    Finally
+      FreeAndNil(V);
+    end;  
+  Finally
+    LeaveCriticalSection(ResolveSection);
+  end;  
+end;
+
+procedure GlobalFixupReferences;
+
+var
+  V : TResolveReferenceVisitor;
+  I : Integer;
+    
+begin
+  If (NeedResolving=Nil) then 
+    Exit;
+  GlobalNameSpace.BeginWrite;
+  try
+    VisitResolveList(TResolveReferenceVisitor.Create);
+  finally
+    GlobalNameSpace.EndWrite;
+  end;
+end;
+
+
+procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
+
+begin
+  If (NeedResolving=Nil) then 
+    Exit;
+  VisitResolveList(TReferenceNamesVisitor.Create(Root,Names));
+end;
+
+procedure GetFixupInstanceNames(Root: TComponent; const ReferenceRootName: string; Names: TStrings);
+
+begin
+  If (NeedResolving=Nil) then
+    Exit;
+  VisitResolveList(TReferenceInstancesVisitor.Create(Root,ReferenceRootName,Names));
+end;
+
+procedure RedirectFixupReferences(Root: TComponent; const OldRootName, NewRootName: string);
+
+begin
+  If (NeedResolving=Nil) then
+      Exit;
+  VisitResolveList(TRedirectReferenceVisitor.Create(Root,OldRootName,NewRootName));
+end;
+
+procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
+
+begin
+  If (NeedResolving=Nil) then
+      Exit;
+  VisitResolveList(TRemoveReferenceVisitor.Create(Root,RootName));
+end;
+
+procedure RemoveFixups(Instance: TPersistent);
+
+begin
+  // This needs work.
+{
+  if not Assigned(GlobalFixupList) then
+    exit;
+
+  with GlobalFixupList.LockList do
+    try
+      for i := Count - 1 downto 0 do
+      begin
+        CurFixup := TPropFixup(Items[i]);
+        if (CurFixup.FInstance = Instance) then
+        begin
+          Delete(i);
+          CurFixup.Free;
+        end;
+      end;
+    finally
+      GlobalFixupList.UnlockList;
+    end;
+}
+end;
+
+{ TUnresolvedReference }
+
+Function TUnresolvedReference.Resolve(Instance : TPersistent) : Boolean;
+
+Var
+  C : TComponent;
+
+begin
+  C:=FindGlobalComponent(FGlobal);
+  Result:=(C<>Nil);
+  If Result then
+    begin
+    C:=FindNestedComponent(C,FRelative);
+    Result:=C<>Nil;
+    If Result then
+      SetObjectProp(Instance, FPropInfo,C);
+    end;
+end; 
+
+Function TUnresolvedReference.RootMatches(ARoot : TComponent) : Boolean; Inline;
+
+begin
+  Result:=(ARoot=Nil) or (ARoot=FRoot);
+end;
+
+Function TUnResolvedReference.NextRef : TUnresolvedReference;
+
+begin
+  Result:=TUnresolvedReference(Next);
+end;
+
+{ TUnResolvedInstance }
+
+destructor TUnResolvedInstance.Destroy;
+begin
+  FUnresolved.Free;
+  inherited Destroy;
+end;
+
+function TUnResolvedInstance.AddReference(ARoot: TComponent;
+  APropInfo: PPropInfo; AGlobal, ARelative: String): TUnresolvedReference;
+begin
+  If (FUnResolved=Nil) then
+    FUnResolved:=TLinkedList.Create(TUnresolvedReference);
+  Result:=FUnResolved.Add as TUnresolvedReference;
+  Result.FGlobal:=AGLobal;
+  Result.FRelative:=ARelative;
+  Result.FPropInfo:=APropInfo;
+  Result.FRoot:=ARoot;
+end;
+
+Function TUnResolvedInstance.RootUnresolved : TUnresolvedReference; 
+
+begin
+  Result:=Nil;
+  If Assigned(FUnResolved) then
+    Result:=TUnresolvedReference(FUnResolved.Root);
+end;
+
+Function TUnResolvedInstance.ResolveReferences:Boolean;
+
+Var
+  R,RN : TUnresolvedReference;
+
+begin
+  R:=RootUnResolved;
+  While (R<>Nil) do
+    begin
+    RN:=R.NextRef;
+    If R.Resolve(Self.Instance) then
+      FUnresolved.RemoveItem(R,True);
+    R:=RN;
+    end;
+  Result:=RootUnResolved=Nil;
+end;
+
+{ TReferenceNamesVisitor }
+
+Constructor TReferenceNamesVisitor.Create(ARoot : TComponent;AList : TStrings);
+
+begin
+  FRoot:=ARoot;
+  FList:=AList;
+end;
+
+Function TReferenceNamesVisitor.Visit(Item : TLinkedListItem) : Boolean;
+
+Var
+  R : TUnresolvedReference;
+
+begin
+  R:=TUnResolvedInstance(Item).RootUnresolved;
+  While (R<>Nil) do
+    begin
+    If R.RootMatches(FRoot) then
+      If (FList.IndexOf(R.FGlobal)=-1) then 
+        FList.Add(R.FGlobal);
+    R:=R.NextRef;
+    end;
+  Result:=True;
+end;
+
+{ TReferenceInstancesVisitor }
+
+Constructor TReferenceInstancesVisitor.Create(ARoot : TComponent; Const ARef : String;AList : TStrings);
+
+begin
+  FRoot:=ARoot;
+  FRef:=UpperCase(ARef);
+  FList:=AList;
+end;
+
+Function TReferenceInstancesVisitor.Visit(Item : TLinkedListItem) : Boolean;
+
+Var
+  R : TUnresolvedReference;
+
+begin
+  R:=TUnResolvedInstance(Item).RootUnresolved;
+  While (R<>Nil) do
+    begin
+    If (FRoot=R.FRoot) and (FRef=UpperCase(R.FGLobal)) Then
+      If Flist.IndexOf(R.FRelative)=-1 then
+        Flist.Add(R.FRelative);
+    R:=R.NextRef;
+    end;
+  Result:=True;
+end;
+
+{ TRedirectReferenceVisitor }
+
+Constructor TRedirectReferenceVisitor.Create(ARoot : TComponent; Const AOld,ANew  : String);
+
+begin
+  FRoot:=ARoot;
+  FOld:=UpperCase(AOld);
+  FNew:=ANew;
+end;
+
+Function TRedirectReferenceVisitor.Visit(Item : TLinkedListItem) : Boolean;
+
+Var
+  R : TUnresolvedReference;
+
+begin
+  R:=TUnResolvedInstance(Item).RootUnresolved;
+  While (R<>Nil) do
+    begin
+    If R.RootMatches(FRoot) and (FOld=UpperCase(R.FGLobal)) Then
+      R.FGlobal:=FNew;
+    R:=R.NextRef;
+    end;
+  Result:=True;
+end;
+
+{ TRemoveReferenceVisitor }
+
+Constructor TRemoveReferenceVisitor.Create(ARoot : TComponent; Const ARef  : String);
+
+begin
+  FRoot:=ARoot;
+  FRef:=UpperCase(ARef);
+end;
+
+Function TRemoveReferenceVisitor.Visit(Item : TLinkedListItem) : Boolean;
+
+Var
+  I : Integer;
+  UI : TUnResolvedInstance;
+  R : TUnresolvedReference;
+  L : TFPList;
+  
+begin
+  UI:=TUnResolvedInstance(Item);
+  R:=UI.RootUnresolved;
+  L:=Nil;
+  Try
+    // Collect all matches.
+    While (R<>Nil) do
+      begin
+      If R.RootMatches(FRoot) and (FRef=UpperCase(R.FGLobal)) Then
+        begin
+        If Not Assigned(L) then
+          L:=TFPList.Create;
+        L.Add(R);
+        end;
+      R:=R.NextRef;
+      end;
+    // Remove all matches.
+    IF Assigned(L) then
+      begin
+      For I:=0 to L.Count-1 do
+        UI.FUnresolved.RemoveItem(TLinkedListitem(L[i]),True);
+      end;
+    // If any references are left, leave them.
+    If UI.FUnResolved.Root=Nil then
+      begin
+      If List=Nil then
+        List:=TFPList.Create;
+      List.Add(UI);
+      end;
+  Finally
+    L.Free;
+  end;
+  Result:=True;
+end;
+
+{ TBuildListVisitor }
+
+Procedure TBuildListVisitor.Add(Item : TlinkedListItem);
+
+begin
+  If (List=Nil) then
+    List:=TFPList.Create;
+  List.Add(Item);
+end;  
+
+Destructor TBuildListVisitor.Destroy;
+
+Var
+  I : Integer;
+
+begin
+  If Assigned(List) then
+    For I:=0 to List.Count-1 do
+      NeedResolving.RemoveItem(TLinkedListItem(List[I]),True);
+  FreeAndNil(List);
+  Inherited;
+end;
+
+{ TResolveReferenceVisitor }
+
+Function TResolveReferenceVisitor.Visit(Item : TLinkedListItem) : Boolean; 
+
+begin
+  If TUnResolvedInstance(Item).ResolveReferences then
+    Add(Item);
+  Result:=True;  
+end;

rtl/objpas/classes/sllist.inc

@@ -0,0 +1,117 @@
+Type
+  TLinkedListItem = Class
+  Public
+    Next : TLinkedListItem;
+  end;
+  TLinkedListItemClass = Class of TLinkedListItem;
+  
+  { TLinkedListVisitor }
+
+  TLinkedListVisitor = Class
+    Function Visit(Item : TLinkedListItem) : Boolean; virtual; abstract;
+  end;
+  { TLinkedList }
+
+  TLinkedList = Class
+  private
+    FItemClass: TLinkedListItemClass;
+    FRoot: TLinkedListItem;
+    function GetCount: Integer;
+  Public
+    Constructor Create(AnItemClass : TLinkedListItemClass); virtual;
+    Destructor Destroy; override;
+    Procedure Clear;
+    Function Add : TLinkedListItem;
+    Procedure ForEach(Visitor: TLinkedListVisitor);
+    Procedure RemoveItem(Item : TLinkedListItem; FreeItem : Boolean = False);
+    Property Root : TLinkedListItem Read FRoot;
+    Property ItemClass : TLinkedListItemClass Read FItemClass;
+    Property Count : Integer Read GetCount;
+  end;
+
+{ TLinkedList }
+
+function TLinkedList.GetCount: Integer;
+
+Var
+  I : TLinkedListItem;
+
+begin
+  I:=FRoot;
+  Result:=0;
+  While I<>Nil do
+    begin
+    I:=I.Next;
+    Inc(Result);
+    end;
+end;
+
+constructor TLinkedList.Create(AnItemClass: TLinkedListItemClass);
+begin
+  FItemClass:=AnItemClass;
+end;
+
+destructor TLinkedList.Destroy;
+begin
+  Clear;
+  inherited Destroy;
+end;
+
+procedure TLinkedList.Clear;
+
+Var
+   I : TLinkedListItem;
+
+begin
+  // Can't use visitor, because it'd kill the next pointer...
+  I:=FRoot;
+  While I<>Nil do
+    begin
+    FRoot:=I;
+    I:=I.Next;
+    FRoot.Next:=Nil;
+    FreeAndNil(FRoot);
+    end;
+end;
+
+function TLinkedList.Add: TLinkedListItem;
+begin
+  Result:=FItemClass.Create;
+  Result.Next:=FRoot;
+  FRoot:=Result;
+end;
+
+procedure TLinkedList.ForEach(Visitor : TLinkedListVisitor);
+
+Var
+  I : TLinkedListItem;
+
+begin
+  I:=FRoot;
+  While (I<>Nil) and Visitor.Visit(I) do
+    I:=I.Next;
+end;
+
+procedure TLinkedList.RemoveItem(Item: TLinkedListItem; FreeItem : Boolean = False);
+
+Var
+  I : TLinkedListItem;
+
+begin
+  If (Item<>Nil) and (FRoot<>Nil) then
+    begin
+    If (Item=FRoot) then
+      FRoot:=Item.Next
+    else
+      begin
+      I:=FRoot;
+      While (I.Next<>Nil) and (I.Next<>Item) do
+        I:=I.Next;
+      If (I.Next=Item) then
+        I.Next:=Item.Next;
+      end;
+    If FreeItem Then
+      Item.Free;
+    end;
+end;
+

rtl/objpas/classes/stringl.inc

@@ -0,0 +1,1462 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by the Free Pascal development team
+
+    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.
+
+ **********************************************************************}
+{****************************************************************************}
+{*                             TStrings                                     *}
+{****************************************************************************}
+
+// Function to quote text. Should move maybe to sysutils !!
+// Also, it is not clear at this point what exactly should be done.
+
+{ //!! is used to mark unsupported things. }
+
+Function QuoteString (Const S : String; Quote : String) : String;
+Var
+  I,J : Integer;
+begin
+  J:=0;
+  Result:=S;
+  for i:=1to length(s) do
+   begin
+     inc(j);
+     if S[i]=Quote then
+      begin
+        System.Insert(Quote,Result,J);
+        inc(j);
+      end;
+   end;
+  Result:=Quote+Result+Quote;
+end;
+
+{
+  For compatibility we can't add a Constructor to TSTrings to initialize
+  the special characters. Therefore we add a routine which is called whenever
+  the special chars are needed.
+}
+
+Procedure Tstrings.CheckSpecialChars;
+
+begin
+  If Not FSpecialCharsInited then
+    begin
+    FQuoteChar:='"';
+    FDelimiter:=',';
+    FNameValueSeparator:='=';
+    FSpecialCharsInited:=true;
+    FLBS:=DefaultTextLineBreakStyle;
+    end;
+end;
+
+Function TStrings.GetLBS : TTextLineBreakStyle;
+begin
+  CheckSpecialChars;
+  Result:=FLBS;
+end;
+
+Procedure TStrings.SetLBS (AValue : TTextLineBreakStyle);
+begin
+  CheckSpecialChars;
+  FLBS:=AValue;
+end;
+
+procedure TStrings.SetDelimiter(c:Char);
+begin
+  CheckSpecialChars;
+  FDelimiter:=c;
+end;
+
+
+procedure TStrings.SetQuoteChar(c:Char);
+begin
+  CheckSpecialChars;
+  FQuoteChar:=c;
+end;
+
+procedure TStrings.SetNameValueSeparator(c:Char);
+begin
+  CheckSpecialChars;
+  FNameValueSeparator:=c;
+end;
+
+
+function TStrings.GetCommaText: string;
+
+Var
+  C1,C2 : Char;
+
+begin
+  CheckSpecialChars;
+  C1:=Delimiter;
+  C2:=QuoteChar;
+  Delimiter:=',';
+  QuoteChar:='"';
+  Try
+    Result:=GetDelimitedText;
+  Finally
+    Delimiter:=C1;
+    QuoteChar:=C2;
+  end;
+end;
+
+
+Function TStrings.GetDelimitedText: string;
+
+Var
+  I : integer;
+  p : pchar;
+begin
+  CheckSpecialChars;
+  result:='';
+  For i:=0 to count-1 do
+    begin
+    p:=pchar(strings[i]);
+    while not(p^ in [#0..' ',QuoteChar,Delimiter]) do
+     inc(p);
+// strings in list may contain #0
+    if p<>pchar(strings[i])+length(strings[i]) then
+     Result:=Result+QuoteString (Strings[I],QuoteChar)
+    else
+     result:=result+strings[i];
+    if I<Count-1 then Result:=Result+Delimiter;
+    end;
+  If (Length(Result)=0)and(count=1) then
+    Result:=QuoteChar+QuoteChar;
+end;
+
+procedure TStrings.GetNameValue(Index : Integer; Var AName,AValue : String);
+
+Var L : longint;
+
+begin
+  CheckSpecialChars;
+  AValue:=Strings[Index];
+  L:=Pos(FNameValueSeparator,AValue);
+  If L<>0 then
+    begin
+    AName:=Copy(AValue,1,L-1);
+    System.Delete(AValue,1,L);
+    end
+  else
+    AName:='';
+end;
+
+function TStrings.ExtractName(const s:String):String;
+var
+  L: Longint;
+begin
+  CheckSpecialChars;
+  L:=Pos(FNameValueSeparator,S);
+  If L<>0 then
+    Result:=Copy(S,1,L-1)
+  else
+    Result:='';
+end;
+
+function TStrings.GetName(Index: Integer): string;
+
+Var
+  V : String;
+
+begin
+  GetNameValue(Index,Result,V);
+end;
+
+Function TStrings.GetValue(const Name: string): string;
+
+Var
+  L : longint;
+  N : String;
+
+begin
+  Result:='';
+  L:=IndexOfName(Name);
+  If L<>-1 then
+    GetNameValue(L,N,Result);
+end;
+
+Function TStrings.GetValueFromIndex(Index: Integer): string;
+
+Var
+  N : String;
+
+begin
+  GetNameValue(Index,N,Result);
+end;
+
+Procedure TStrings.SetValueFromIndex(Index: Integer; const Value: string);
+
+begin
+  If (Value='') then
+    Delete(Index)
+  else
+    begin
+    If (Index<0) then
+      Index:=Add('');
+    CheckSpecialChars;
+    Strings[Index]:=GetName(Index)+FNameValueSeparator+Value;
+    end;
+end;
+
+procedure TStrings.ReadData(Reader: TReader);
+begin
+  Reader.ReadListBegin;
+  BeginUpdate;
+  try
+    Clear;
+    while not Reader.EndOfList do
+      Add(Reader.ReadString);
+  finally
+    EndUpdate;
+  end;
+  Reader.ReadListEnd;
+end;
+
+
+Procedure TStrings.SetDelimitedText(const AValue: string);
+
+var i,j:integer;
+    aNotFirst:boolean;
+begin
+ CheckSpecialChars;
+ BeginUpdate;
+
+ i:=1;
+ aNotFirst:=false;
+
+ try
+  Clear;
+  while i<=length(AValue) do begin
+   // skip delimiter
+   if aNotFirst and (i<=length(AValue)) and (AValue[i]=FDelimiter) then inc(i);
+
+   // skip spaces
+   while (i<=length(AValue)) and (Ord(AValue[i])<=Ord(' ')) do inc(i);
+  
+   // read next string
+   if i<=length(AValue) then begin
+    if AValue[i]=FQuoteChar then begin
+     // next string is quoted
+     j:=i+1;
+     while (j<=length(AValue)) and
+           ( (AValue[j]<>FQuoteChar) or
+             ( (j+1<=length(AValue)) and (AValue[j+1]=FQuoteChar) ) ) do begin
+      if (j<=length(AValue)) and (AValue[j]=FQuoteChar) then inc(j,2)
+                                                        else inc(j);
+     end;
+     // j is position of closing quote
+     Add( StringReplace (Copy(AValue,i+1,j-i-1),
+                         FQuoteChar+FQuoteChar,FQuoteChar, [rfReplaceAll]));
+     i:=j+1;
+    end else begin
+     // next string is not quoted
+     j:=i;
+     while (j<=length(AValue)) and
+           (Ord(AValue[j])>Ord(' ')) and
+           (AValue[j]<>FDelimiter) do inc(j);
+     Add( Copy(AValue,i,j-i));
+     i:=j;
+    end;
+   end else begin
+    if aNotFirst then Add('');
+   end;
+
+   // skip spaces
+   while (i<=length(AValue)) and (Ord(AValue[i])<=Ord(' ')) do inc(i);
+
+   aNotFirst:=true;
+  end;
+ finally
+  EndUpdate;
+ end;
+end;
+
+Procedure TStrings.SetCommaText(const Value: string);
+
+Var
+  C1,C2 : Char;
+
+begin
+  CheckSpecialChars;
+  C1:=Delimiter;
+  C2:=QuoteChar;
+  Delimiter:=',';
+  QuoteChar:='"';
+  Try
+    SetDelimitedText(Value);
+  Finally
+    Delimiter:=C1;
+    QuoteChar:=C2;
+  end;
+end;
+
+
+Procedure TStrings.SetStringsAdapter(const Value: IStringsAdapter);
+
+begin
+end;
+
+
+
+Procedure TStrings.SetValue(const Name, Value: string);
+
+Var L : longint;
+
+begin
+  CheckSpecialChars;
+  L:=IndexOfName(Name);
+  if L=-1 then
+   Add (Name+FNameValueSeparator+Value)
+  else
+   Strings[L]:=Name+FNameValueSeparator+value;
+end;
+
+
+
+procedure TStrings.WriteData(Writer: TWriter);
+var
+  i: Integer;
+begin
+  Writer.WriteListBegin;
+  for i := 0 to Count - 1 do
+    Writer.WriteString(Strings[i]);
+  Writer.WriteListEnd;
+end;
+
+
+
+procedure TStrings.DefineProperties(Filer: TFiler);
+var
+  HasData: Boolean;
+begin
+  if Assigned(Filer.Ancestor) then
+    // Only serialize if string list is different from ancestor
+    if Filer.Ancestor.InheritsFrom(TStrings) then
+      HasData := not Equals(TStrings(Filer.Ancestor))
+    else
+      HasData := True
+  else
+    HasData := Count > 0;
+  Filer.DefineProperty('Strings', @ReadData, @WriteData, HasData);
+end;
+
+
+Procedure TStrings.Error(const Msg: string; Data: Integer);
+begin
+  Raise EStringListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
+end;
+
+
+Procedure TStrings.Error(const Msg: pstring; Data: Integer);
+begin
+  Raise EStringListError.CreateFmt(Msg^,[Data]) at get_caller_addr(get_frame);
+end;
+
+
+Function TStrings.GetCapacity: Integer;
+
+begin
+  Result:=Count;
+end;
+
+
+
+Function TStrings.GetObject(Index: Integer): TObject;
+
+begin
+  Result:=Nil;
+end;
+
+
+
+Function TStrings.GetTextStr: string;
+
+Var P : Pchar;
+    I,L,NLS : Longint;
+    S,NL : String;
+
+begin
+  CheckSpecialChars;
+  // Determine needed place
+  Case FLBS of
+    tlbsLF   : NL:=#10;
+    tlbsCRLF : NL:=#13#10;
+    tlbsCR   : NL:=#13; 
+  end;
+  L:=0;
+  NLS:=Length(NL);
+  For I:=0 to count-1 do
+    L:=L+Length(Strings[I])+NLS;
+  Setlength(Result,L);
+  P:=Pointer(Result);
+  For i:=0 To count-1 do
+    begin
+    S:=Strings[I];
+    L:=Length(S);
+    if L<>0 then
+      System.Move(Pointer(S)^,P^,L);
+    P:=P+L;
+    For L:=1 to NLS do
+      begin
+      P^:=NL[L];
+      inc(P);
+      end;
+    end;
+end;
+
+
+
+Procedure TStrings.Put(Index: Integer; const S: string);
+
+Var Obj : TObject;
+
+begin
+  Obj:=Objects[Index];
+  Delete(Index);
+  InsertObject(Index,S,Obj);
+end;
+
+
+
+Procedure TStrings.PutObject(Index: Integer; AObject: TObject);
+
+begin
+  // Empty.
+end;
+
+
+
+Procedure TStrings.SetCapacity(NewCapacity: Integer);
+
+begin
+  // Empty.
+end;
+
+Function GetNextLine (Const Value : String; Var S : String; Var P : Integer) : Boolean;
+
+Var 
+  PS : PChar;
+  IP,L : Integer;
+  
+begin
+  L:=Length(Value);
+  S:='';
+  Result:=False;
+  If ((L-P)<0) then 
+    exit;
+  if ((L-P)=0) and (not (value[P] in [#10,#13])) Then
+    Begin
+      s:=value[P];
+      inc(P);
+      Exit(True);
+    End;
+  PS:=PChar(Value)+P-1;
+  IP:=P;
+  While ((L-P)>=0) and (not (PS^ in [#10,#13])) do 
+    begin
+    P:=P+1;
+    Inc(PS);
+    end;
+  SetLength (S,P-IP);
+  System.Move (Value[IP],Pointer(S)^,P-IP);
+  If (P<=L) and (Value[P]=#13) then 
+    Inc(P);
+  If (P<=L) and (Value[P]=#10) then
+    Inc(P); // Point to character after #10(#13)
+  Result:=True;
+end;
+
+Procedure TStrings.SetTextStr(const Value: string);
+
+Var
+  S : String;
+  P : Integer;
+
+begin
+  Try
+    beginUpdate;
+    Clear;
+    P:=1;
+    While GetNextLine (Value,S,P) do
+      Add(S);
+  finally
+    EndUpdate;
+  end;
+end;
+
+
+
+Procedure TStrings.SetUpdateState(Updating: Boolean);
+
+begin
+end;
+
+
+
+destructor TSTrings.Destroy;
+
+begin
+  inherited destroy;
+end;
+
+
+
+Function TStrings.Add(const S: string): Integer;
+
+begin
+  Result:=Count;
+  Insert (Count,S);
+end;
+
+
+
+Function TStrings.AddObject(const S: string; AObject: TObject): Integer;
+
+begin
+  Result:=Add(S);
+  Objects[result]:=AObject;
+end;
+
+
+
+Procedure TStrings.Append(const S: string);
+
+begin
+  Add (S);
+end;
+
+
+
+Procedure TStrings.AddStrings(TheStrings: TStrings);
+
+Var Runner : longint;
+
+begin
+  try
+    beginupdate;
+    For Runner:=0 to TheStrings.Count-1 do
+      self.AddObject (Thestrings[Runner],TheStrings.Objects[Runner]);
+  finally
+    EndUpdate;
+  end;
+end;
+
+
+
+Procedure TStrings.Assign(Source: TPersistent);
+
+Var
+  S : TStrings;
+
+begin
+  If Source is TStrings then
+    begin
+    S:=TStrings(Source);
+    BeginUpdate;
+    Try
+      clear;
+      FSpecialCharsInited:=S.FSpecialCharsInited;
+      FQuoteChar:=S.FQuoteChar;
+      FDelimiter:=S.FDelimiter;
+      FNameValueSeparator:=S.FNameValueSeparator;
+      AddStrings(S);
+    finally
+      EndUpdate;
+    end;
+    end
+  else
+    Inherited Assign(Source);
+end;
+
+
+
+Procedure TStrings.BeginUpdate;
+
+begin
+   if FUpdateCount = 0 then SetUpdateState(true);
+   inc(FUpdateCount);
+end;
+
+
+
+Procedure TStrings.EndUpdate;
+
+begin
+  If FUpdateCount>0 then
+     Dec(FUpdateCount);
+  if FUpdateCount=0 then
+    SetUpdateState(False);
+end;
+
+
+
+Function TStrings.Equals(TheStrings: TStrings): Boolean;
+
+Var Runner,Nr : Longint;
+
+begin
+  Result:=False;
+  Nr:=Self.Count;
+  if Nr<>TheStrings.Count then exit;
+  For Runner:=0 to Nr-1 do
+    If Strings[Runner]<>TheStrings[Runner] then exit;
+  Result:=True;
+end;
+
+
+
+Procedure TStrings.Exchange(Index1, Index2: Integer);
+
+Var
+  Obj : TObject;
+  Str : String;
+
+begin
+  Try
+    beginUpdate;
+    Obj:=Objects[Index1];
+    Str:=Strings[Index1];
+    Objects[Index1]:=Objects[Index2];
+    Strings[Index1]:=Strings[Index2];
+    Objects[Index2]:=Obj;
+    Strings[Index2]:=Str;
+  finally
+    EndUpdate;
+  end;
+end;
+
+
+
+Function TStrings.GetText: PChar;
+begin
+  Result:=StrNew(Pchar(Self.Text));
+end;
+
+
+Function TStrings.DoCompareText(const s1,s2 : string) : PtrInt;
+  begin
+    result:=CompareText(s1,s2);
+  end;
+
+
+Function TStrings.IndexOf(const S: string): Integer;
+begin
+  Result:=0;
+  While (Result<Count) and (DoCompareText(Strings[Result],S)<>0) do Result:=Result+1;
+  if Result=Count then Result:=-1;
+end;
+
+
+Function TStrings.IndexOfName(const Name: string): Integer;
+Var
+  len : longint;
+  S : String;
+begin
+  CheckSpecialChars;
+  Result:=0;
+  while (Result<Count) do
+    begin
+    S:=Strings[Result];
+    len:=pos(FNameValueSeparator,S)-1;
+    if (len>0) and (DoCompareText(Name,Copy(S,1,Len))=0) then
+      exit;
+    inc(result);
+    end;
+  result:=-1;
+end;
+
+
+Function TStrings.IndexOfObject(AObject: TObject): Integer;
+begin
+  Result:=0;
+  While (Result<count) and (Objects[Result]<>AObject) do Result:=Result+1;
+  If Result=Count then Result:=-1;
+end;
+
+
+Procedure TStrings.InsertObject(Index: Integer; const S: string;
+  AObject: TObject);
+
+begin
+  Insert (Index,S);
+  Objects[Index]:=AObject;
+end;
+
+
+
+Procedure TStrings.LoadFromFile(const FileName: string);
+Var
+        TheStream : TFileStream;
+begin
+  TheStream:=TFileStream.Create(FileName,fmOpenRead);
+  LoadFromStream(TheStream);
+  TheStream.Free;
+end;
+
+
+
+Procedure TStrings.LoadFromStream(Stream: TStream);
+{
+   Borlands method is no good, since a pipe for
+   instance doesn't have a size.
+   So we must do it the hard way.
+}
+Const
+  BufSize = 1024;
+  MaxGrow = 1 shl 29;
+
+Var
+  Buffer     : AnsiString;
+  BytesRead,
+  BufLen,
+  I,BufDelta     : Longint;
+begin
+  // reread into a buffer
+  try
+    beginupdate;
+    Buffer:='';
+    BufLen:=0;
+    I:=1;
+    Repeat
+      BufDelta:=BufSize*I;
+      SetLength(Buffer,BufLen+BufDelta);
+      BytesRead:=Stream.Read(Buffer[BufLen+1],BufDelta);
+      inc(BufLen,BufDelta);
+      If I<MaxGrow then
+        I:=I shl 1;
+    Until BytesRead<>BufDelta;
+    SetLength(Buffer, BufLen-BufDelta+BytesRead);
+    SetTextStr(Buffer);
+    SetLength(Buffer,0);
+  finally
+    EndUpdate;
+  end;
+end;
+
+
+Procedure TStrings.Move(CurIndex, NewIndex: Integer);
+Var
+  Obj : TObject;
+  Str : String;
+begin
+  BeginUpdate;
+  Obj:=Objects[CurIndex];
+  Str:=Strings[CurIndex];
+  Delete(Curindex);
+  InsertObject(NewIndex,Str,Obj);
+  EndUpdate;
+end;
+
+
+
+Procedure TStrings.SaveToFile(const FileName: string);
+
+Var TheStream : TFileStream;
+
+begin
+  TheStream:=TFileStream.Create(FileName,fmCreate);
+  SaveToStream(TheStream);
+  TheStream.Free;
+end;
+
+
+
+Procedure TStrings.SaveToStream(Stream: TStream);
+Var
+  S : String;
+begin
+  S:=Text;
+  Stream.WriteBuffer(Pointer(S)^,Length(S));
+end;
+
+
+
+
+Procedure TStrings.SetText(TheText: PChar);
+
+Var S : String;
+
+begin
+  If TheText<>Nil then
+    S:=StrPas(TheText)
+  else
+    S:='';
+  SetTextStr(S);  
+end;
+
+
+{****************************************************************************}
+{*                             TStringList                                  *}
+{****************************************************************************}
+
+{$if defined(VER2_0) or not defined(FPC_TESTGENERICS)}
+
+Procedure TStringList.ExchangeItems(Index1, Index2: Integer);
+
+Var P1,P2 : Pointer;
+
+begin
+  P1:=Pointer(Flist^[Index1].FString);
+  P2:=Pointer(Flist^[Index1].FObject);
+  Pointer(Flist^[Index1].Fstring):=Pointer(Flist^[Index2].Fstring);
+  Pointer(Flist^[Index1].FObject):=Pointer(Flist^[Index2].FObject);
+  Pointer(Flist^[Index2].Fstring):=P1;
+  Pointer(Flist^[Index2].FObject):=P2;
+end;
+
+
+
+Procedure TStringList.Grow;
+
+Var
+  NC : Integer;
+
+begin
+  NC:=FCapacity;
+  If NC>=256 then
+    NC:=NC+(NC Div 4)
+  else if NC=0 then
+    NC:=4
+  else
+    NC:=NC*4;
+  SetCapacity(NC);
+end;
+
+
+
+Procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
+var
+  Pivot, vL, vR: Integer;
+begin
+  if R - L <= 1 then begin // a little bit of time saver
+    if L < R then
+      if CompareFn(Self, L, R) > 0 then
+        ExchangeItems(L, R);
+
+    Exit;
+  end;
+
+  vL := L;
+  vR := R;
+
+  Pivot := L + Random(R - L); // they say random is best
+
+  while vL < vR do begin
+    while (vL < Pivot) and (CompareFn(Self, vL, Pivot) <= 0) do
+      Inc(vL);
+
+    while (vR > Pivot) and (CompareFn(Self, vR, Pivot) > 0) do
+      Dec(vR);
+
+    ExchangeItems(vL, vR);
+
+    if Pivot = vL then // swap pivot if we just hit it from one side
+      Pivot := vR
+    else if Pivot = vR then
+      Pivot := vL;
+  end;
+
+  if Pivot - 1 >= L then
+    QuickSort(L, Pivot - 1, CompareFn);
+  if Pivot + 1 <= R then
+    QuickSort(Pivot + 1, R, CompareFn);
+end;
+
+
+Procedure TStringList.InsertItem(Index: Integer; const S: string);
+begin
+  Changing;
+  If FCount=Fcapacity then Grow;
+  If Index<FCount then
+    System.Move (FList^[Index],FList^[Index+1],
+                 (FCount-Index)*SizeOf(TStringItem));
+  Pointer(Flist^[Index].Fstring):=Nil;  // Needed to initialize...
+  Flist^[Index].FString:=S;
+  Flist^[Index].Fobject:=Nil;
+  Inc(FCount);
+  Changed;
+end;
+
+
+Procedure TStringList.InsertItem(Index: Integer; const S: string; O: TObject);
+begin
+  Changing;
+  If FCount=Fcapacity then Grow;
+  If Index<FCount then
+    System.Move (FList^[Index],FList^[Index+1],
+                 (FCount-Index)*SizeOf(TStringItem));
+  Pointer(Flist^[Index].Fstring):=Nil;  // Needed to initialize...
+  Flist^[Index].FString:=S;
+  Flist^[Index].FObject:=O;
+  Inc(FCount);
+  Changed;
+end;
+
+
+Procedure TStringList.SetSorted(Value: Boolean);
+
+begin
+  If FSorted<>Value then
+    begin
+    If Value then sort;
+    FSorted:=VAlue
+    end;
+end;
+
+
+
+Procedure TStringList.Changed;
+
+begin
+  If (FUpdateCount=0) Then
+   If Assigned(FOnChange) then
+     FOnchange(Self);
+end;
+
+
+
+Procedure TStringList.Changing;
+
+begin
+  If FUpdateCount=0 then
+    if Assigned(FOnChanging) then
+      FOnchanging(Self);
+end;
+
+
+
+Function TStringList.Get(Index: Integer): string;
+
+begin
+  If (Index<0) or (INdex>=Fcount)  then
+    Error (SListIndexError,Index);
+  Result:=Flist^[Index].FString;
+end;
+
+
+
+Function TStringList.GetCapacity: Integer;
+
+begin
+  Result:=FCapacity;
+end;
+
+
+
+Function TStringList.GetCount: Integer;
+
+begin
+  Result:=FCount;
+end;
+
+
+
+Function TStringList.GetObject(Index: Integer): TObject;
+
+begin
+  If (Index<0) or (INdex>=Fcount)  then
+    Error (SListIndexError,Index);
+  Result:=Flist^[Index].FObject;
+end;
+
+
+
+Procedure TStringList.Put(Index: Integer; const S: string);
+
+begin
+  If Sorted then
+    Error(SSortedListError,0);
+  If (Index<0) or (INdex>=Fcount)  then
+    Error (SListIndexError,Index);
+  Changing;
+  Flist^[Index].FString:=S;
+  Changed;
+end;
+
+
+
+Procedure TStringList.PutObject(Index: Integer; AObject: TObject);
+
+begin
+  If (Index<0) or (INdex>=Fcount)  then
+    Error (SListIndexError,Index);
+  Changing;
+  Flist^[Index].FObject:=AObject;
+  Changed;
+end;
+
+
+
+Procedure TStringList.SetCapacity(NewCapacity: Integer);
+
+Var NewList : Pointer;
+    MSize : Longint;
+
+begin
+  If (NewCapacity<0) then
+     Error (SListCapacityError,NewCapacity);
+  If NewCapacity>FCapacity then
+    begin
+    GetMem (NewList,NewCapacity*SizeOf(TStringItem));
+    If NewList=Nil then
+      Error (SListCapacityError,NewCapacity);
+    If Assigned(FList) then
+      begin
+      MSize:=FCapacity*Sizeof(TStringItem);
+      System.Move (FList^,NewList^,MSize);
+      FillWord (Pchar(NewList)[MSize],(NewCapacity-FCapacity)*WordRatio, 0);
+      FreeMem (Flist,MSize);
+      end;
+    Flist:=NewList;
+    FCapacity:=NewCapacity;
+    end
+  else if NewCapacity<FCapacity then
+    begin
+    if NewCapacity = 0 then
+    begin
+      FreeMem(FList);
+      FList := nil;
+    end else
+    begin
+      GetMem(NewList, NewCapacity * SizeOf(TStringItem));
+      System.Move(FList^, NewList^, NewCapacity * SizeOf(TStringItem));
+      FreeMem(FList);
+      FList := NewList;
+    end;
+    FCapacity:=NewCapacity;
+    end;
+end;
+
+
+
+Procedure TStringList.SetUpdateState(Updating: Boolean);
+
+begin
+  If Updating then
+    Changing
+  else
+    Changed
+end;
+
+
+
+destructor TStringList.Destroy;
+
+Var I : Longint;
+
+begin
+  FOnChange:=Nil;
+  FOnChanging:=Nil;
+  // This will force a dereference. Can be done better...
+  For I:=0 to FCount-1 do
+    FList^[I].FString:='';
+  FCount:=0;
+  SetCapacity(0);
+  Inherited destroy;
+end;
+
+
+
+Function TStringList.Add(const S: string): Integer;
+
+begin
+  If Not Sorted then
+    Result:=FCount
+  else
+    If Find (S,Result) then
+      Case DUplicates of
+        DupIgnore : Exit;
+        DupError : Error(SDuplicateString,0)
+      end;
+   InsertItem (Result,S);
+end;
+
+
+
+Procedure TStringList.Clear;
+
+Var I : longint;
+
+begin
+  if FCount = 0 then Exit;
+  Changing;
+  For I:=0 to FCount-1 do
+    Flist^[I].FString:='';
+  FCount:=0;
+  SetCapacity(0);
+  Changed;
+end;
+
+
+
+Procedure TStringList.Delete(Index: Integer);
+
+begin
+  If (Index<0) or (Index>=FCount) then
+    Error(SlistINdexError,Index);
+  Changing;
+  Flist^[Index].FString:='';
+  Dec(FCount);
+  If Index<FCount then
+    System.Move(Flist^[Index+1],
+                Flist^[Index],
+                (Fcount-Index)*SizeOf(TStringItem));
+  Changed;
+end;
+
+
+
+Procedure TStringList.Exchange(Index1, Index2: Integer);
+
+begin
+  If (Index1<0) or (Index1>=FCount) then
+    Error(SListIndexError,Index1);
+  If (Index2<0) or (Index2>=FCount) then
+    Error(SListIndexError,Index2);
+  Changing;
+  ExchangeItems(Index1,Index2);
+  changed;
+end;
+
+
+procedure TStringList.SetCaseSensitive(b : boolean);
+  begin
+        if b<>FCaseSensitive then
+          begin
+                FCaseSensitive:=b;
+            if FSorted then
+              sort;
+          end;
+  end;
+
+
+Function TStringList.DoCompareText(const s1,s2 : string) : PtrInt;
+  begin
+        if FCaseSensitive then
+          result:=AnsiCompareStr(s1,s2)
+        else
+          result:=AnsiCompareText(s1,s2);
+  end;
+
+
+Function TStringList.Find(const S: string; var Index: Integer): Boolean;
+
+var
+  L, R, I: Integer;
+  CompareRes: PtrInt;
+begin
+  Result := false;
+  // Use binary search.
+  L := 0;
+  R := Count - 1;
+  while (L<=R) do
+  begin
+    I := L + (R - L) div 2;
+    CompareRes := DoCompareText(S, Flist^[I].FString);
+    if (CompareRes>0) then
+      L := I+1
+    else begin
+      R := I-1;
+      if (CompareRes=0) then begin
+         Result := true;
+         if (Duplicates<>dupAccept) then
+            L := I; // forces end of while loop
+      end;
+    end;
+  end;
+  Index := L;
+end;
+
+
+
+Function TStringList.IndexOf(const S: string): Integer;
+
+begin
+  If Not Sorted then
+    Result:=Inherited indexOf(S)
+  else
+    // faster using binary search...
+    If Not Find (S,Result) then
+      Result:=-1;
+end;
+
+
+
+Procedure TStringList.Insert(Index: Integer; const S: string);
+
+begin
+  If Sorted then
+    Error (SSortedListError,0)
+  else
+    If (Index<0) or (Index>FCount) then
+      Error (SListIndexError,Index)
+    else
+      InsertItem (Index,S);
+end;
+
+
+Procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
+
+begin
+  If Not Sorted and (FCount>1) then
+    begin
+    Changing;
+    QuickSort(0,FCount-1, CompareFn);
+    Changed;
+    end;
+end;
+
+function StringListAnsiCompare(List: TStringList; Index1, Index: Integer): Integer;
+
+begin
+  Result := List.DoCompareText(List.FList^[Index1].FString,
+    List.FList^[Index].FString);
+end;
+
+Procedure TStringList.Sort;
+
+begin
+  CustomSort(@StringListAnsiCompare);
+end;
+
+{$else}
+
+{ generics based implementation of TStringList follows }
+
+function StringListAnsiCompare(List: TStringList; Index1, Index2: Integer): Integer;
+begin
+  Result := List.DoCompareText(List.Strings[Index1], List.Strings[Index2]);
+end;
+
+constructor TStringList.Create;
+begin
+  inherited;
+  FMap := TFPStrObjMap.Create;
+  FMap.OnPtrCompare := @MapPtrCompare;
+  FOnCompareText := @DefaultCompareText;
+end;
+
+destructor TStringList.Destroy;
+begin
+  FMap.Free;
+  inherited;
+end;
+
+function TStringList.GetDuplicates: TDuplicates;
+begin
+  Result := FMap.Duplicates;
+end;
+
+function TStringList.GetSorted: boolean;
+begin
+  Result := FMap.Sorted;
+end;
+
+procedure TStringList.SetDuplicates(NewDuplicates: TDuplicates);
+begin
+  FMap.Duplicates := NewDuplicates;
+end;
+
+procedure TStringList.SetSorted(NewSorted: Boolean);
+begin
+  FMap.Sorted := NewSorted;
+end;
+
+procedure TStringList.Changed;
+begin
+  if FUpdateCount = 0 then
+   if Assigned(FOnChange) then
+     FOnChange(Self);
+end;
+
+procedure TStringList.Changing;
+begin
+  if FUpdateCount = 0 then
+    if Assigned(FOnChanging) then
+      FOnChanging(Self);
+end;
+
+function TStringList.Get(Index: Integer): string;
+begin
+  Result := FMap.Keys[Index];
+end;
+
+function TStringList.GetCapacity: Integer;
+begin
+  Result := FMap.Capacity;
+end;
+
+function TStringList.GetCount: Integer;
+begin
+  Result := FMap.Count;
+end;
+
+function TStringList.GetObject(Index: Integer): TObject;
+begin
+  Result := FMap.Data[Index];
+end;
+
+procedure TStringList.Put(Index: Integer; const S: string);
+begin
+  Changing;
+  FMap.Keys[Index] := S;
+  Changed;
+end;
+
+procedure TStringList.PutObject(Index: Integer; AObject: TObject);
+begin
+  Changing;
+  FMap.Data[Index] := AObject;
+  Changed;
+end;
+
+procedure TStringList.SetCapacity(NewCapacity: Integer);
+begin
+  FMap.Capacity := NewCapacity;
+end;
+
+procedure TStringList.SetUpdateState(Updating: Boolean);
+begin
+  if Updating then
+    Changing
+  else
+    Changed
+end;
+
+function TStringList.Add(const S: string): Integer;
+begin
+  Result := FMap.Add(S);
+end;
+
+procedure TStringList.Clear;
+begin
+  if FMap.Count = 0 then exit;
+  Changing;
+  FMap.Clear;
+  Changed;
+end;
+
+procedure TStringList.Delete(Index: Integer);
+begin
+  if (Index < 0) or (Index >= FMap.Count) then
+    Error(SListIndexError, Index);
+  Changing;
+  FMap.Delete(Index);
+  Changed;
+end;
+
+procedure TStringList.Exchange(Index1, Index2: Integer);
+begin
+  if (Index1 < 0) or (Index1 >= FMap.Count) then
+    Error(SListIndexError, Index1);
+  if (Index2 < 0) or (Index2 >= FMap.Count) then
+    Error(SListIndexError, Index2);
+  Changing;
+  FMap.InternalExchange(Index1, Index2);
+  Changed;
+end;
+
+procedure TStringList.SetCaseSensitive(NewSensitive: Boolean);
+begin
+  if NewSensitive <> FCaseSensitive then
+  begin
+    FCaseSensitive := NewSensitive;
+    if Sorted then
+      Sort;
+  end;
+end;
+
+function TStringList.MapPtrCompare(Key1, Key2: Pointer): Integer;
+begin
+  Result := FOnCompareText(string(Key1^), string(Key2^));
+end;
+
+function TStringList.DefaultCompareText(const s1, s2: string): PtrInt;
+begin
+  if FCaseSensitive then
+    Result := AnsiCompareStr(s1, s2)
+  else
+    Result := AnsiCompareText(s1, s2);
+end;
+
+function TStringList.DoCompareText(const s1, s2: string): PtrInt;
+begin
+  Result := FOnCompareText(s1, s2);
+end;
+
+function TStringList.Find(const S: string; var Index: Integer): Boolean;
+begin
+  Result := FMap.Find(S, Index);
+end;
+
+function TStringList.IndexOf(const S: string): Integer;
+begin
+  Result := FMap.IndexOf(S);
+end;
+
+procedure TStringList.Insert(Index: Integer; const S: string);
+begin
+  if not Sorted and (0 <= Index) and (Index < FMap.Count) then
+    Changing;
+  FMap.InsertKey(Index, S);
+  Changed;
+end;
+
+procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
+var 
+  I, J, Pivot: Integer;
+begin
+  repeat
+    I := L;
+    J := R;
+    Pivot := (L + R) div 2;
+    repeat
+      while CompareFn(Self, I, Pivot) < 0 do Inc(I);
+      while CompareFn(Self, J, Pivot) > 0 do Dec(J);
+      if I <= J then
+      begin
+        FMap.InternalExchange(I, J); // No check, indices are correct.
+        if Pivot = I then
+          Pivot := J
+        else if Pivot = J then
+          Pivot := I;
+        Inc(I);
+        Dec(j);
+      end;
+    until I > J;
+    if L < J then 
+      QuickSort(L,J, CompareFn);
+    L := I;
+  until I >= R;
+end;
+
+procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
+begin
+  if not Sorted and (FMap.Count > 1) then
+  begin
+    Changing;
+    QuickSort(0, FMap.Count-1, CompareFn);
+    Changed;
+  end;
+end;
+
+procedure TStringList.Sort;
+begin
+  if not Sorted and (FMap.Count > 1) then
+  begin
+    Changing;
+    FMap.Sort;
+    Changed;
+  end;
+end;
+
+{$endif}
+

rtl/objpas/classes/writer.inc

@@ -0,0 +1,880 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by the Free Pascal development team
+
+    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.
+
+ **********************************************************************}
+
+
+{****************************************************************************}
+{*                         TBinaryObjectWriter                              *}
+{****************************************************************************}
+
+{$ifndef FPUNONE}
+{$IFNDEF FPC_HAS_TYPE_EXTENDED}
+procedure DoubleToExtended(d : double; e : pointer);
+var mant : qword;
+    exp : smallint;
+    sign : boolean;
+begin
+  mant:=(qword(d) and $000FFFFFFFFFFFFF) shl 12;
+  exp :=(qword(d) shr 52) and $7FF;
+  sign:=(qword(d) and $8000000000000000)<>0;
+  case exp of
+       0 : begin
+             if mant<>0 then  //denormalized value: hidden bit is 0. normalize it
+             begin
+               exp:=16383-1022;
+               while (mant and $8000000000000000)=0 do
+               begin
+                 dec(exp);
+                 mant:=mant shl 1;
+               end;
+               dec(exp); //don't shift, most significant bit is not hidden in extended
+             end;
+           end;
+    2047 : exp:=$7FFF //either infinity or NaN
+    else
+    begin
+      inc(exp,16383-1023);
+      mant:=(mant shr 1) or $8000000000000000; //unhide hidden bit
+    end;
+  end;
+  if sign then exp:=exp or $8000;
+  mant:=NtoLE(mant);
+  exp:=NtoLE(word(exp));
+  move(mant,pbyte(e)[0],8); //mantissa         : bytes 0..7
+  move(exp,pbyte(e)[8],2);  //exponent and sign: bytes 8..9
+end;
+{$ENDIF}
+{$endif}
+
+procedure TBinaryObjectWriter.WriteWord(w : word); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+begin
+  w:=NtoLE(w);
+  Write(w,2);
+end;
+
+procedure TBinaryObjectWriter.WriteDWord(lw : longword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+begin
+  lw:=NtoLE(lw);
+  Write(lw,4);
+end;
+
+procedure TBinaryObjectWriter.WriteQWord(qw : qword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+begin
+  qw:=NtoLE(qw);
+  Write(qw,8);
+end;
+
+{$ifndef FPUNONE}
+procedure TBinaryObjectWriter.WriteExtended(e : extended); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+{$IFNDEF FPC_HAS_TYPE_EXTENDED}
+var ext : array[0..9] of byte;
+{$ENDIF}
+begin
+  {$IFNDEF FPC_HAS_TYPE_EXTENDED}
+  DoubleToExtended(e,@(ext[0]));
+  Write(ext[0],10);
+  {$ELSE}
+  Write(e,sizeof(e));
+  {$ENDIF}
+end;
+{$endif}
+
+constructor TBinaryObjectWriter.Create(Stream: TStream; BufSize: Integer);
+begin
+  inherited Create;
+  If (Stream=Nil) then
+    Raise EWriteError.Create(SEmptyStreamIllegalWriter);
+  FStream := Stream;
+  FBufSize := BufSize;
+  GetMem(FBuffer, BufSize);
+end;
+
+destructor TBinaryObjectWriter.Destroy;
+begin
+  // Flush all data which hasn't been written yet
+  FlushBuffer;
+
+  if Assigned(FBuffer) then
+    FreeMem(FBuffer, FBufSize);
+
+  inherited Destroy;
+end;
+
+procedure TBinaryObjectWriter.BeginCollection;
+begin
+  WriteValue(vaCollection);
+end;
+
+procedure TBinaryObjectWriter.BeginComponent(Component: TComponent;
+  Flags: TFilerFlags; ChildPos: Integer);
+var
+  Prefix: Byte;
+begin
+  if not FSignatureWritten then
+  begin
+    Write(FilerSignature, SizeOf(FilerSignature));
+    FSignatureWritten := True;
+  end;
+
+  { Only write the flags if they are needed! }
+  if Flags <> [] then
+  begin
+    Prefix := Integer(Flags) or $f0;
+    Write(Prefix, 1);
+    if ffChildPos in Flags then
+      WriteInteger(ChildPos);
+  end;
+
+  WriteStr(Component.ClassName);
+  WriteStr(Component.Name);
+end;
+
+procedure TBinaryObjectWriter.BeginList;
+begin
+  WriteValue(vaList);
+end;
+
+procedure TBinaryObjectWriter.EndList;
+begin
+  WriteValue(vaNull);
+end;
+
+procedure TBinaryObjectWriter.BeginProperty(const PropName: String);
+begin
+  WriteStr(PropName);
+end;
+
+procedure TBinaryObjectWriter.EndProperty;
+begin
+end;
+
+procedure TBinaryObjectWriter.WriteBinary(const Buffer; Count: LongInt);
+begin
+  WriteValue(vaBinary);
+  WriteDWord(longword(Count));
+  Write(Buffer, Count);
+end;
+
+procedure TBinaryObjectWriter.WriteBoolean(Value: Boolean);
+begin
+  if Value then
+    WriteValue(vaTrue)
+  else
+    WriteValue(vaFalse);
+end;
+
+{$ifndef FPUNONE}
+procedure TBinaryObjectWriter.WriteFloat(const Value: Extended);
+begin
+  WriteValue(vaExtended);
+  WriteExtended(Value);
+end;
+
+procedure TBinaryObjectWriter.WriteSingle(const Value: Single);
+begin
+  WriteValue(vaSingle);
+  WriteDWord(longword(Value));
+end;
+{$endif}
+
+procedure TBinaryObjectWriter.WriteCurrency(const Value: Currency);
+begin
+  WriteValue(vaCurrency);
+  WriteQWord(qword(Value));
+end;
+
+
+{$ifndef FPUNONE}
+procedure TBinaryObjectWriter.WriteDate(const Value: TDateTime);
+begin
+  WriteValue(vaDate);
+  WriteQWord(qword(Value));
+end;
+{$endif}
+
+procedure TBinaryObjectWriter.WriteIdent(const Ident: string);
+begin
+  { Check if Ident is a special identifier before trying to just write
+    Ident directly }
+  if UpperCase(Ident) = 'NIL' then
+    WriteValue(vaNil)
+  else if UpperCase(Ident) = 'FALSE' then
+    WriteValue(vaFalse)
+  else if UpperCase(Ident) = 'TRUE' then
+    WriteValue(vaTrue)
+  else if UpperCase(Ident) = 'NULL' then
+    WriteValue(vaNull) else
+  begin
+    WriteValue(vaIdent);
+    WriteStr(Ident);
+  end;
+end;
+
+procedure TBinaryObjectWriter.WriteInteger(Value: Int64);
+var
+  s: ShortInt;
+  i: SmallInt;
+  l: Longint;
+begin
+  { Use the smallest possible integer type for the given value: }
+  if (Value >= -128) and (Value <= 127) then
+  begin
+    WriteValue(vaInt8);
+    s := Value;
+    Write(s, 1);
+  end else if (Value >= -32768) and (Value <= 32767) then
+  begin
+    WriteValue(vaInt16);
+    i := Value;
+    WriteWord(word(i));
+  end else if (Value >= -$80000000) and (Value <= $7fffffff) then
+  begin
+    WriteValue(vaInt32);
+    l := Value;
+    WriteDWord(longword(l));
+  end else
+  begin
+    WriteValue(vaInt64);
+    WriteQWord(qword(Value));
+  end;
+end;
+
+procedure TBinaryObjectWriter.WriteMethodName(const Name: String);
+begin
+  if Length(Name) > 0 then
+  begin
+    WriteValue(vaIdent);
+    WriteStr(Name);
+  end else
+    WriteValue(vaNil);
+end;
+
+procedure TBinaryObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
+var
+  i: Integer;
+  Mask: LongInt;
+begin
+  WriteValue(vaSet);
+  Mask := 1;
+  for i := 0 to 31 do
+  begin
+    if (Value and Mask) <> 0 then
+      WriteStr(GetEnumName(PTypeInfo(SetType), i));
+    Mask := Mask shl 1;
+  end;
+  WriteStr('');
+end;
+
+procedure TBinaryObjectWriter.WriteString(const Value: String);
+var
+  i: Integer;
+  b: byte;
+begin
+  i := Length(Value);
+  if i <= 255 then
+  begin
+    WriteValue(vaString);
+    b := i;
+    Write(b, 1);
+  end else
+  begin
+    WriteValue(vaLString);
+    WriteDWord(longword(i));
+  end;
+  if i > 0 then
+    Write(Value[1], i);
+end;
+
+procedure TBinaryObjectWriter.WriteWideString(const Value: WideString);
+var len : longword;
+{$IFDEF ENDIAN_BIG}
+    i : integer;
+    ws : widestring;
+{$ENDIF}
+begin
+  WriteValue(vaWString);
+  len:=Length(Value);
+  WriteDWord(len);
+  if len > 0 then
+  begin
+    {$IFDEF ENDIAN_BIG}
+    setlength(ws,len);
+    for i:=1 to len do
+      ws[i]:=widechar(SwapEndian(word(Value[i])));
+    Write(ws[1], len*sizeof(widechar));
+    {$ELSE}
+    Write(Value[1], len*sizeof(widechar));
+    {$ENDIF}
+  end;
+end;
+
+procedure TBinaryObjectWriter.FlushBuffer;
+begin
+  FStream.WriteBuffer(FBuffer^, FBufPos);
+  FBufPos := 0;
+end;
+
+procedure TBinaryObjectWriter.Write(const Buffer; Count: LongInt);
+var
+  CopyNow: LongInt;
+  SourceBuf: PChar;
+begin
+  SourceBuf:=@Buffer;
+  while Count > 0 do
+  begin
+    CopyNow := Count;
+    if CopyNow > FBufSize - FBufPos then
+      CopyNow := FBufSize - FBufPos;
+    Move(SourceBuf^, PChar(FBuffer)[FBufPos], CopyNow);
+    Dec(Count, CopyNow);
+    Inc(FBufPos, CopyNow);
+    inc(SourceBuf, CopyNow);
+    if FBufPos = FBufSize then
+      FlushBuffer;
+  end;
+end;
+
+procedure TBinaryObjectWriter.WriteValue(Value: TValueType);
+var
+  b: byte;
+begin
+  b := byte(Value);
+  Write(b, 1);
+end;
+
+procedure TBinaryObjectWriter.WriteStr(const Value: String);
+var
+  i: integer;
+  b: byte;
+begin
+  i := Length(Value);
+  if i > 255 then
+    i := 255;
+  b := i;
+  Write(b, 1);
+  if i > 0 then
+    Write(Value[1], i);
+end;
+
+
+
+{****************************************************************************}
+{*                             TWriter                                      *}
+{****************************************************************************}
+
+
+constructor TWriter.Create(ADriver: TAbstractObjectWriter);
+begin
+  inherited Create;
+  FDriver := ADriver;
+end;
+
+constructor TWriter.Create(Stream: TStream; BufSize: Integer);
+begin
+  inherited Create;
+  If (Stream=Nil) then
+    Raise EWriteError.Create(SEmptyStreamIllegalWriter);
+  FDriver := CreateDriver(Stream, BufSize);
+  FDestroyDriver := True;
+end;
+
+destructor TWriter.Destroy;
+begin
+  if FDestroyDriver then
+    FDriver.Free;
+  inherited Destroy;
+end;
+
+function TWriter.CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectWriter;
+begin
+  Result := TBinaryObjectWriter.Create(Stream, BufSize);
+end;
+
+// Used as argument for calls to TComponent.GetChildren:
+procedure TWriter.AddToAncestorList(Component: TComponent);
+begin
+  FAncestorList.Add(Component);
+end;
+
+procedure TWriter.DefineProperty(const Name: String;
+  ReadData: TReaderProc; AWriteData: TWriterProc; HasData: Boolean);
+begin
+  if HasData and Assigned(AWriteData) then
+  begin
+    // Write the property name and then the data itself
+    Driver.BeginProperty(FPropPath + Name);
+    AWriteData(Self);
+    Driver.EndProperty;
+  end;
+end;
+
+procedure TWriter.DefineBinaryProperty(const Name: String;
+  ReadData, AWriteData: TStreamProc; HasData: Boolean);
+begin
+  if HasData and Assigned(AWriteData) then
+  begin
+    // Write the property name and then the data itself
+    Driver.BeginProperty(FPropPath + Name);
+    WriteBinary(AWriteData);
+    Driver.EndProperty;
+  end;
+end;
+
+procedure TWriter.Write(const Buffer; Count: Longint);
+begin
+  //This should give an exception if write is not implemented (i.e. TTextObjectWriter)
+  //but should work with TBinaryObjectWriter.
+  Driver.Write(Buffer, Count);
+end;
+
+procedure TWriter.SetRoot(ARoot: TComponent);
+begin
+  inherited SetRoot(ARoot);
+  // Use the new root as lookup root too
+  FLookupRoot := ARoot;
+end;
+
+procedure TWriter.WriteBinary(AWriteData: TStreamProc);
+var
+  MemBuffer: TMemoryStream;
+  BufferSize: Longint;
+begin
+  { First write the binary data into a memory stream, then copy this buffered
+    stream into the writing destination. This is necessary as we have to know
+    the size of the binary data in advance (we're assuming that seeking within
+    the writer stream is not possible) }
+  MemBuffer := TMemoryStream.Create;
+  try
+    AWriteData(MemBuffer);
+    BufferSize := MemBuffer.Size;
+    Driver.WriteBinary(MemBuffer.Memory^, BufferSize);
+  finally
+    MemBuffer.Free;
+  end;
+end;
+
+procedure TWriter.WriteBoolean(Value: Boolean);
+begin
+  Driver.WriteBoolean(Value);
+end;
+
+procedure TWriter.WriteChar(Value: Char);
+begin
+  WriteString(Value);
+end;
+
+procedure TWriter.WriteWideChar(Value: WideChar);
+begin
+  WriteWideString(Value);
+end;
+
+procedure TWriter.WriteCollection(Value: TCollection);
+var
+  i: Integer;
+begin
+  Driver.BeginCollection;
+  if Assigned(Value) then
+    for i := 0 to Value.Count - 1 do
+    begin
+      { Each collection item needs its own ListBegin/ListEnd tag, or else the
+        reader wouldn't be able to know where an item ends and where the next
+        one starts }
+      WriteListBegin;
+      WriteProperties(Value.Items[i]);
+      WriteListEnd;
+    end;
+  WriteListEnd;
+end;
+
+procedure TWriter.WriteComponent(Component: TComponent);
+var
+  i : integer;
+begin
+  Component.FComponentState:=Component.FComponentState+[csWriting];
+  Component.WriteState(Self);
+  Component.GetChildren(@WriteComponent,Root);
+  FDriver.EndList;
+  Component.FComponentState:=Component.FComponentState-[csWriting];
+end;
+
+procedure TWriter.WriteComponentData(Instance: TComponent);
+var Dummy: Integer;
+    Flags: TFilerFlags;
+begin
+  Flags := [];
+  FDriver.BeginComponent(Instance,Flags, Dummy);
+  WriteProperties(Instance);
+  WriteListEnd;
+end;
+
+procedure TWriter.WriteDescendent(ARoot: TComponent; AAncestor: TComponent);
+begin
+  FRoot := ARoot;
+  FAncestor := AAncestor;
+  FRootAncestor := AAncestor;
+  FLookupRoot := ARoot;
+
+  WriteComponent(ARoot);
+end;
+
+{$ifndef FPUNONE}
+procedure TWriter.WriteFloat(const Value: Extended);
+begin
+  Driver.WriteFloat(Value);
+end;
+
+procedure TWriter.WriteSingle(const Value: Single);
+begin
+  Driver.WriteSingle(Value);
+end;
+{$endif}
+
+procedure TWriter.WriteCurrency(const Value: Currency);
+begin
+  Driver.WriteCurrency(Value);
+end;
+
+{$ifndef FPUNONE}
+procedure TWriter.WriteDate(const Value: TDateTime);
+begin
+  Driver.WriteDate(Value);
+end;
+{$endif}
+
+procedure TWriter.WriteIdent(const Ident: string);
+begin
+  Driver.WriteIdent(Ident);
+end;
+
+procedure TWriter.WriteInteger(Value: LongInt);
+begin
+  Driver.WriteInteger(Value);
+end;
+
+procedure TWriter.WriteInteger(Value: Int64);
+begin
+  Driver.WriteInteger(Value);
+end;
+
+procedure TWriter.WriteListBegin;
+begin
+  Driver.BeginList;
+end;
+
+procedure TWriter.WriteListEnd;
+begin
+  Driver.EndList;
+end;
+
+procedure TWriter.WriteProperties(Instance: TPersistent);
+var PropCount,i : integer;
+    PropList  : PPropList;
+begin
+  PropCount:=GetPropList(Instance,PropList);
+  if PropCount>0 then begin
+    for i := 0 to PropCount-1 do
+      if IsStoredProp(Instance,PropList^[i]) then
+        WriteProperty(Instance,PropList^[i]);
+    Freemem(PropList);
+  end;
+end;
+
+procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: Pointer);
+var
+  HasAncestor: Boolean;
+  PropType: PTypeInfo;
+  Value, DefValue: LongInt;
+  Ident: String;
+  IntToIdentFn: TIntToIdent;
+{$ifndef FPUNONE}
+  FloatValue, DefFloatValue: Extended;
+{$endif}
+  MethodValue: TMethod;
+  DefMethodValue: TMethod;
+  WStrValue, WDefStrValue: WideString;
+  StrValue, DefStrValue: String;
+  AncestorObj: TObject;
+  Component: TComponent;
+  ObjValue: TObject;
+  SavedAncestor: TPersistent;
+  SavedPropPath, Name: String;
+  Int64Value, DefInt64Value: Int64;
+  BoolValue, DefBoolValue: boolean;
+  Handled: Boolean;
+
+begin
+  // do not stream properties without getter
+  if not Assigned(PPropInfo(PropInfo)^.GetProc) then
+    exit;
+  // properties without setter are only allowed, if they are subcomponents
+  PropType := PPropInfo(PropInfo)^.PropType;
+  if not Assigned(PPropInfo(PropInfo)^.SetProc) then begin
+    if PropType^.Kind<>tkClass then
+      exit;
+    ObjValue := TObject(GetObjectProp(Instance, PropInfo));
+    if not ObjValue.InheritsFrom(TComponent) or
+       not (csSubComponent in TComponent(ObjValue).ComponentStyle) then
+      exit;
+  end;
+
+  { Check if the ancestor can be used }
+  HasAncestor := Assigned(Ancestor) and ((Instance = Root) or
+    (Instance.ClassType = Ancestor.ClassType));
+
+  case PropType^.Kind of
+    tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
+      begin
+        Value := GetOrdProp(Instance, PropInfo);
+        if HasAncestor then
+          DefValue := GetOrdProp(Ancestor, PropInfo)
+        else
+          DefValue := PPropInfo(PropInfo)^.Default;
+        //writeln(PPropInfo(PropInfo)^.Name, ', HasAncestor=', ord(HasAncestor), ', Value=', Value, ', Default=', DefValue);
+        if (Value <> DefValue) or (DefValue=longint($80000000)) then
+        begin
+          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+          case PropType^.Kind of
+            tkInteger:
+              begin
+                // Check if this integer has a string identifier
+                IntToIdentFn := FindIntToIdent(PPropInfo(PropInfo)^.PropType);
+                if Assigned(IntToIdentFn) and IntToIdentFn(Value, Ident) then
+                  // Integer can be written a human-readable identifier
+                  WriteIdent(Ident)
+                else
+                  // Integer has to be written just as number
+                  WriteInteger(Value);
+              end;
+            tkChar:
+              WriteChar(Chr(Value));
+            tkWChar:
+              WriteWideChar(WideChar(Value));
+            tkSet:
+              Driver.WriteSet(Value, GetTypeData(PropType)^.CompType);
+            tkEnumeration:
+              WriteIdent(GetEnumName(PropType, Value));
+          end;
+          Driver.EndProperty;
+        end;
+      end;
+{$ifndef FPUNONE}
+    tkFloat:
+      begin
+        FloatValue := GetFloatProp(Instance, PropInfo);
+        if HasAncestor then
+          DefFloatValue := GetFloatProp(Ancestor, PropInfo)
+        else
+          DefFloatValue := 0;
+        if FloatValue <> DefFloatValue then
+        begin
+          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+          WriteFloat(FloatValue);
+          Driver.EndProperty;
+        end;
+      end;
+{$endif}
+    tkMethod:
+      begin
+        MethodValue := GetMethodProp(Instance, PropInfo);
+        if HasAncestor then
+          DefMethodValue := GetMethodProp(Ancestor, PropInfo)
+        else begin
+          DefMethodValue.Data := nil;
+          DefMethodValue.Code := nil;
+        end;
+
+        Handled:=false;
+        if Assigned(OnWriteMethodProperty) then
+          OnWriteMethodProperty(Self,Instance,PPropInfo(PropInfo),MethodValue,
+            DefMethodValue,Handled);
+        if (not Handled) and
+          (MethodValue.Code <> DefMethodValue.Code) and
+          ((not Assigned(MethodValue.Code)) or
+          ((Length(FLookupRoot.MethodName(MethodValue.Code)) >= 0))) then
+        begin
+          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+          if Assigned(MethodValue.Code) then
+            Driver.WriteMethodName(FLookupRoot.MethodName(MethodValue.Code))
+          else
+            Driver.WriteMethodName('');
+          Driver.EndProperty;
+        end;
+      end;
+    tkSString, tkLString, tkAString:
+      begin
+        StrValue := GetStrProp(Instance, PropInfo);
+        if HasAncestor then
+          DefStrValue := GetStrProp(Ancestor, PropInfo)
+        else
+          SetLength(DefStrValue, 0);
+
+        if StrValue <> DefStrValue then
+        begin
+          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+          if Assigned(FOnWriteStringProperty) then
+            FOnWriteStringProperty(Self,Instance,PropInfo,StrValue);
+          WriteString(StrValue);
+          Driver.EndProperty;
+        end;
+      end;
+    tkWString:
+      begin
+        WStrValue := GetWideStrProp(Instance, PropInfo);
+        if HasAncestor then
+          WDefStrValue := GetWideStrProp(Ancestor, PropInfo)
+        else
+          SetLength(WDefStrValue, 0);
+
+        if WStrValue <> WDefStrValue then
+        begin
+          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+          WriteWideString(WStrValue);
+          Driver.EndProperty;
+        end;
+      end;
+  {!!!: tkVariant:}
+    tkClass:
+      begin
+        ObjValue := TObject(GetObjectProp(Instance, PropInfo));
+        if HasAncestor then
+        begin
+          AncestorObj := TObject(GetObjectProp(Ancestor, PropInfo));
+          if Assigned(AncestorObj) then
+            if Assigned(ObjValue) and
+              (TComponent(AncestorObj).Owner = FRootAncestor) and
+              (TComponent(ObjValue).Owner = Root) and
+              (UpperCase(TComponent(AncestorObj).Name) = UpperCase(TComponent(ObjValue).Name)) then
+              AncestorObj := ObjValue
+//            else
+//              AncestorObj := nil;
+        end else
+          AncestorObj := nil;
+
+        if not Assigned(ObjValue) then
+          begin
+          if ObjValue <> AncestorObj then
+            begin
+            Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+            Driver.WriteIdent('NIL');
+            Driver.EndProperty;
+            end
+          end
+        else if ObjValue.InheritsFrom(TPersistent) then
+          begin
+          { Subcomponents are streamed the same way as persistents }
+          if ObjValue.InheritsFrom(TComponent)
+            and ((not (csSubComponent in TComponent(ObjValue).ComponentStyle)) 
+                 or ((TComponent(ObjValue).Owner<>Instance) and (TComponent(ObjValue).Owner<>Nil))) then
+            begin
+            Component := TComponent(ObjValue);
+            if (ObjValue <> AncestorObj)
+                and not (csTransient in Component.ComponentStyle) then
+              begin
+              { Determine the correct name of the component this property contains }
+              if Component.Owner = LookupRoot then
+                Name := Component.Name
+              else if Component = LookupRoot then
+                Name := 'Owner'
+              else if Assigned(Component.Owner) and (Length(Component.Owner.Name) > 0)
+                and (Length(Component.Name) > 0) then
+                Name := Component.Owner.Name + '.' + Component.Name
+              else if Length(Component.Name) > 0 then
+                Name := Component.Name + '.Owner'
+              else
+                SetLength(Name, 0);
+
+              if Length(Name) > 0 then
+                begin
+                Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+                WriteIdent(Name);
+                Driver.EndProperty;
+                end;  // length Name>0
+              end; //(ObjValue <> AncestorObj)
+            end // ObjValue.InheritsFrom(TComponent)
+          else if ObjValue.InheritsFrom(TCollection) then
+            begin
+            if (not HasAncestor) or (not CollectionsEqual(TCollection(ObjValue),
+              TCollection(GetObjectProp(Ancestor, PropInfo)))) then
+              begin
+              Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+              SavedPropPath := FPropPath;
+              try
+                SetLength(FPropPath, 0);
+                WriteCollection(TCollection(ObjValue));
+              finally
+                FPropPath := SavedPropPath;
+                Driver.EndProperty;
+              end;
+              end;
+            end // Tcollection
+          else
+            begin
+            SavedAncestor := Ancestor;
+            SavedPropPath := FPropPath;
+            try
+              FPropPath := FPropPath + PPropInfo(PropInfo)^.Name + '.';
+              if HasAncestor then
+                Ancestor := TPersistent(GetObjectProp(Ancestor, PropInfo));
+              WriteProperties(TPersistent(ObjValue));
+            finally
+              Ancestor := SavedAncestor;
+              FPropPath := SavedPropPath;
+            end;
+            end;
+          end; // Inheritsfrom(TPersistent)
+      end;
+    tkInt64, tkQWord:
+      begin
+        Int64Value := GetInt64Prop(Instance, PropInfo);
+        if HasAncestor then
+          DefInt64Value := GetInt64Prop(Ancestor, PropInfo)
+        else
+          DefInt64Value := 0;
+        if Int64Value <> DefInt64Value then
+        begin
+          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+          WriteInteger(Int64Value);
+          Driver.EndProperty;
+        end;
+      end;
+    tkBool:
+      begin
+        BoolValue := GetOrdProp(Instance, PropInfo)<>0;
+        if HasAncestor then
+          DefBoolValue := GetOrdProp(Ancestor, PropInfo)<>0
+        else
+          DefBoolValue := PPropInfo(PropInfo)^.Default<>0;
+        if BoolValue <> DefBoolValue then
+          begin
+          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+          WriteBoolean(BoolValue);
+          Driver.EndProperty;
+          end;
+      end;
+  end;
+end;
+
+procedure TWriter.WriteRootComponent(ARoot: TComponent);
+begin
+  WriteDescendent(ARoot, nil);
+end;
+
+procedure TWriter.WriteString(const Value: String);
+begin
+  Driver.WriteString(Value);
+end;
+
+procedure TWriter.WriteWideString(const Value: WideString);
+begin
+  Driver.WriteWideString(Value);
+end;
+

rtl/objpas/rtlconst.inc

@@ -216,6 +216,14 @@ ResourceString
   SOutOfResources               = 'Out of system resources';
   SParentRequired               = 'Element ''%s'' has no parent Window';
   SParseError                   = '%s on line %d';
+  SParLocInfo                   = ' (at %d,%d, stream offset %.8x)';
+  SParExpected                  = 'Wrong token type: %s expected';
+  SParWrongTokenType            = 'Wrong token type: %s expected but %s found';
+  SParWrongTokenSymbol          = 'Wrong token symbol: %s expected but %s found';
+  SParInvalidInteger            = 'Invalid integer number: %s';
+  SParInvalidFloat              = 'Invalid floating point number: %s';
+  SParUnterminatedString        = 'Unterminated string';
+  SParUnterminatedBinValue      = 'Unterminated byte value';
   SPictureDesc                  = ' (%dx%d)';
   SPictureLabel                 = 'Image:';
   SPreviewLabel                 = 'Preview';

rtl/objpas/strutils.pp

@@ -514,115 +514,121 @@ end;
     Extended search and replace
   ---------------------------------------------------------------------}
 
-Function SearchBuf(Buf: PChar; BufLen: Integer; SelStart, SelLength: Integer; SearchString: String; Options: TStringSearchOptions): PChar;
+type
+  TEqualFunction = function (const a,b : char) : boolean;
 
-var
-  Len,I,SLen: Integer;
-  C: Char;
-  Found : Boolean;
-  Direction: Shortint;
-  CharMap: array[Char] of Char;
+function EqualWithCase (const a,b : char) : boolean;
+begin
+  result := (a = b);
+end;
 
-  Function GotoNextWord(var P : PChar): Boolean;
+function EqualWithoutCase (const a,b : char) : boolean;
+begin
+  result := (lowerCase(a) = lowerCase(b));
+end;
 
-  begin
-    if (Direction=1) then
-      begin
-      // Skip characters
-      While (Len>0) and not (P^ in WordDelimiters) do
-        begin
-        Inc(P);
-        Dec(Len);
-        end;
-     // skip delimiters
-      While (Len>0) and (P^ in WordDelimiters) do
-        begin
-        Inc(P);
-        Dec(Len);
-        end;
-      Result:=Len>0;
-      end
-    else
+function IsWholeWord (bufstart, bufend, wordstart, wordend : pchar) : boolean;
+begin
+            // Check start
+  result := ((wordstart = bufstart) or ((wordstart-1)^ in worddelimiters)) and
+            // Check end
+            ((wordend = bufend) or ((wordend+1)^ in worddelimiters));
+end;
+
+function SearchDown(buf,aStart,endchar:pchar; SearchString:string;
+    Equals : TEqualFunction; WholeWords:boolean) : pchar;
+var Found : boolean;
+    s, c : pchar;
+begin
+  result := aStart;
+  Found := false;
+  while not Found and (result <= endchar) do
+    begin
+    // Search first letter
+    while (result <= endchar) and not Equals(result^,SearchString[1]) do
+      inc (result);
+    // Check if following is searchstring
+    c := result;
+    s := @(Searchstring[1]);
+    Found := true;
+    while (c <= endchar) and (s^ <> #0) and Found do
       begin
-      // Skip Delimiters
-      While (Len>0) and (P^ in WordDelimiters) do
-        begin
-        Dec(P);
-        Dec(Len);
-        end;
-     // skip characters
-      While (Len>0) and not (P^ in WordDelimiters) do
-        begin
-        Dec(P);
-        Dec(Len);
-        end;
-      Result:=Len>0;
-      // We're on the first delimiter. Pos back on char.
-      Inc(P);
-      Inc(Len);
+      Found := Equals(c^, s^);
+      inc (c);
+      inc (s);
       end;
-  end;
+    if s^ <> #0 then
+      Found := false;
+    // Check if it is a word
+    if Found and WholeWords then
+      Found := IsWholeWord(buf,endchar,result,c-1);
+    if not found then
+      inc (result);
+    end;
+  if not Found then
+    result := nil;
+end;
 
+function SearchUp(buf,aStart,endchar:pchar; SearchString:string;
+    equals : TEqualFunction; WholeWords:boolean) : pchar;
+var Found : boolean;
+    s, c, l : pchar;
 begin
-  Result:=nil;
-  Slen:=Length(SearchString);
-  if (BufLen<=0) or (Slen=0) then
-    Exit;
-  if soDown in Options then
+  result := aStart;
+  Found := false;
+  l := @(SearchString[length(SearchString)]);
+  while not Found and (result >= buf) do
     begin
-    Direction:=1;
-    Inc(SelStart,SelLength);
-    Len:=BufLen-SelStart-SLen+1;
-    if (Len<=0) then
-      Exit;
-    end
+    // Search last letter
+    while (result >= buf) and not Equals(result^,l^) do
+      dec (result);
+    // Check if before is searchstring
+    c := result;
+    s := l;
+    Found := true;
+    while (c >= buf) and (s >= @SearchString[1]) and Found do
+      begin
+      Found := Equals(c^, s^);
+      dec (c);
+      dec (s);
+      end;
+    if (s >= @(SearchString[1])) then
+      Found := false;
+    // Check if it is a word
+    if Found and WholeWords then
+      Found := IsWholeWord(buf,endchar,c+1,result);
+    if found then
+      result := c+1
+    else
+      dec (result);
+    end;
+  if not Found then
+    result := nil;
+end;
+
+//function SearchDown(buf,aStart,endchar:pchar; SearchString:string; equal : TEqualFunction; WholeWords:boolean) : pchar;
+function SearchBuf(Buf: PChar;BufLen: Integer;SelStart: Integer;SelLength: Integer;
+    SearchString: String;Options: TStringSearchOptions):PChar;
+var
+  equal : TEqualFunction;
+begin
+  SelStart := SelStart + SelLength;
+  if (SearchString = '') or (SelStart > BufLen) or (SelStart < 0) then
+    result := nil
   else
     begin
-    Direction:=-1;
-    Dec(SelStart,Length(SearchString));
-    Len:=SelStart+1;
-    end;
-  if (SelStart<0) or (SelStart>BufLen) then
-    Exit;
-  Result:=@Buf[SelStart];
-  for C:=Low(Char) to High(Char) do
-    if (soMatchCase in Options) then
-      CharMap[C]:=C
+    if soMatchCase in Options then
+      Equal := @EqualWithCase
     else
-      CharMap[C]:=Upcase(C);
-  if Not (soMatchCase in Options) then
-    SearchString:=UpCase(SearchString);
-  Found:=False;
-  while (Result<>Nil) and (Not Found) do
-    begin
-    if ((soWholeWord in Options) and
-        (Result<>@Buf[SelStart]) and
-        not GotoNextWord(Result)) then
-        Result:=Nil
+      Equal := @EqualWithoutCase;
+    if soDown in Options then
+      result := SearchDown(buf,buf+SelStart,Buf+(BufLen-1), SearchString, Equal, (soWholeWord in Options))
     else
-      begin
-        // try to match whole searchstring
-      I:=0;
-      while (I<Slen) and (CharMap[Result[I]]=SearchString[I+1]) do
-      Inc(I);
-      // Whole searchstring matched ?
-      if (I=SLen) then
-      Found:=(Len=0) or
-              (not (soWholeWord in Options)) or
-              (Result[SLen] in WordDelimiters);
-      if not Found then
-        begin
-        Inc(Result,Direction);
-        Dec(Len);
-        If (Len=0) then
-          Result:=Nil;
-        end;
-      end;
+      result := SearchUp(buf,buf+SelStart,Buf+(Buflen-1), SearchString, Equal, (soWholeWord in Options));
     end;
 end;
 
 
-
 Function SearchBuf(Buf: PChar; BufLen: Integer; SelStart, SelLength: Integer; SearchString: String): PChar;inline; // ; Options: TStringSearchOptions = [soDown]
 begin
   Result:=SearchBuf(Buf,BufLen,SelStart,SelLength,SearchString,[soDown]);