* moved out of packages/ back to topdir

api/Makefile

@@ -0,0 +1,510 @@
+#
+# Makefile generated by fpcmake v0.99.13 [2000/01/06]
+#
+
+defaultrule: all
+
+#####################################################################
+# Autodetect OS (Linux or Dos or Windows NT)
+# define inlinux when running under linux
+# define inWinNT when running under WinNT
+#####################################################################
+
+# We need only / in the path
+override PATH:=$(subst \,/,$(PATH))
+
+# Search for PWD and determine also if we are under linux
+PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH)))))
+ifeq ($(PWD),)
+PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH)))))
+ifeq ($(PWD),)
+nopwd:
+	@echo You need the GNU utils package to use this Makefile!
+	@echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip
+	@exit
+else
+inlinux=1
+endif
+else
+PWD:=$(firstword $(PWD))
+endif
+
+# Detect NT - NT sets OS to Windows_NT
+ifndef inlinux
+ifeq ($(OS),Windows_NT)
+inWinNT=1
+endif
+endif
+
+# Detect OS/2 - OS/2 has OS2_SHELL defined
+ifndef inlinux
+ifndef inWinNT
+ifdef OS2_SHELL
+inOS2=1
+endif
+endif
+endif
+
+# The extension of executables
+ifdef inlinux
+EXEEXT=
+else
+EXEEXT=.exe
+endif
+
+# The path which is searched separated by spaces
+ifdef inlinux
+SEARCHPATH=$(subst :, ,$(PATH))
+else
+SEARCHPATH=$(subst ;, ,$(PATH))
+endif
+
+#####################################################################
+# FPC version/target Detection
+#####################################################################
+
+# What compiler to use ?
+ifndef FPC
+# Compatibility with old makefiles
+ifdef PP
+FPC=$(PP)
+else
+ifdef inOS2
+FPC=ppos2$(EXEEXT)
+else
+FPC=ppc386$(EXEEXT)
+endif
+endif
+endif
+
+# Target OS
+ifndef OS_TARGET
+OS_TARGET:=$(shell $(FPC) -iTO)
+endif
+
+# Source OS
+ifndef OS_SOURCE
+OS_SOURCE:=$(shell $(FPC) -iSO)
+endif
+
+# Target CPU
+ifndef CPU_TARGET
+CPU_TARGET:=$(shell $(FPC) -iTP)
+endif
+
+# Source CPU
+ifndef CPU_SOURCE
+CPU_SOURCE:=$(shell $(FPC) -iSP)
+endif
+
+# FPC version
+ifndef FPC_VERSION
+FPC_VERSION:=$(shell $(FPC) -iV)
+endif
+
+export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION
+
+# Test FPCDIR to look if the RTL dir exists
+ifdef FPCDIR
+override FPCDIR:=$(subst \,/,$(FPCDIR))
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+else
+override FPCDIR=wrong
+endif
+
+# Detect FPCDIR
+ifeq ($(FPCDIR),wrong)
+ifdef inlinux
+override FPCDIR=/usr/lib/fpc/$(FPC_VERSION)
+else
+override FPCDIR:=$(subst /$(FPC)$(EXEEXT),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC)$(EXEEXT),$(SEARCHPATH))))))
+endif
+endif
+
+ifndef PACKAGEDIR
+PACKAGEDIR=$(FPCDIR)/packages
+endif
+ifndef COMPONENTDIR
+COMPONENTDIR=$(FPCDIR)/components
+endif
+# Check if packagedir really exists else turn it off
+ifeq ($(wildcard $(PACKAGEDIR)),)
+PACKAGEDIR=
+endif
+ifeq ($(wildcard $(COMPONENTDIR)),)
+COMPONENTDIR=
+endif
+
+# Create rtl,units dir
+ifneq ($(FPCDIR),.)
+override UNITSDIR=$(FPCDIR)/units/$(OS_TARGET)
+ifneq ($(wildcard $(FPCDIR)/rtl),)
+override RTLDIR=$(FPCDIR)/rtl/$(OS_TARGET)
+else
+override RTLDIR=$(UNITSDIR)/rtl
+endif
+endif
+
+#####################################################################
+# Default Settings
+#####################################################################
+
+# Release ? Then force OPT and don't use extra opts via commandline
+ifndef REDIRFILE
+REDIRFILE=log
+endif
+
+ifdef REDIR
+ifndef inlinux
+override FPC=redir -eo $(FPC)
+endif
+# set the verbosity to max
+override OPT+=-va
+override REDIR:= >> $(REDIRFILE)
+endif
+
+#####################################################################
+# User Settings
+#####################################################################
+
+
+# Targets
+
+override DIROBJECTS+=$(wildcard go32v2 linux win32 os2 test)
+
+# Clean
+
+
+# Install
+
+ZIPTARGET=install
+
+# Defaults
+
+
+# Directories
+
+
+# Packages
+
+override PACKAGES=rtl
+PACKAGEDIR_RTL=$(FPCDIR)/rtl/$(OS_TARGET)
+
+# Libraries
+
+
+#####################################################################
+# Standard rules
+#####################################################################
+
+all: $(addsuffix _all,$(OS_TARGET))
+
+debug: $(addsuffix _debug,$(OS_TARGET))
+
+examples: $(addsuffix _examples,$(OS_TARGET))
+
+test: $(addsuffix _test,$(OS_TARGET))
+
+smart: $(addsuffix _smart,$(OS_TARGET))
+
+shared: $(addsuffix _shared,$(OS_TARGET))
+
+showinstall: $(addsuffix _showinstall,$(OS_TARGET))
+
+install: $(addsuffix _install,$(OS_TARGET))
+
+sourceinstall: $(addsuffix _sourceinstall,$(OS_TARGET))
+
+zipinstall: $(addsuffix _zipinstall,$(OS_TARGET))
+
+zipinstalladd: $(addsuffix _zipinstalladd,$(OS_TARGET))
+
+clean: $(addsuffix _clean,$(OS_TARGET))
+
+cleanall: $(addsuffix _cleanall,$(OS_TARGET))
+
+require: $(addsuffix _require,$(OS_TARGET))
+
+info: $(addsuffix _info,$(OS_TARGET))
+
+.PHONY:  all debug examples test smart shared showinstall install sourceinstall zipinstall zipinstalladd clean cleanall require info
+
+
+ifdef PACKAGERTL
+ifneq ($(wildcard $(PACKAGEDIR_RTL)),)
+ifeq ($(wildcard $(PACKAGEDIR_RTL)/$(FPCMADE)),)
+override COMPILEPACKAGES+=rtl
+rtl_package:
+	$(MAKE) -C $(PACKAGEDIR_RTL) all
+endif
+endif
+endif
+
+.PHONY:  rtl_package
+
+
+# Target Dirs
+
+OBJECTDIRGO32V2=1
+OBJECTDIRLINUX=1
+OBJECTDIRWIN32=1
+OBJECTDIROS2=1
+OBJECTDIRTEST=1
+
+# Dir go32v2
+
+ifdef OBJECTDIRGO32V2
+.PHONY:  go32v2_all go32v2_debug go32v2_examples go32v2_test go32v2_smart go32v2_shared go32v2_showinstall go32v2_install go32v2_sourceinstall go32v2_zipinstall go32v2_zipinstalladd go32v2_clean go32v2_cleanall go32v2_require go32v2_info
+
+go32v2_all:
+	$(MAKE) -C go32v2 all
+
+go32v2_debug:
+	$(MAKE) -C go32v2 debug
+
+go32v2_examples:
+	$(MAKE) -C go32v2 examples
+
+go32v2_test:
+	$(MAKE) -C go32v2 test
+
+go32v2_smart:
+	$(MAKE) -C go32v2 smart
+
+go32v2_shared:
+	$(MAKE) -C go32v2 shared
+
+go32v2_showinstall:
+	$(MAKE) -C go32v2 showinstall
+
+go32v2_install:
+	$(MAKE) -C go32v2 install
+
+go32v2_sourceinstall:
+	$(MAKE) -C go32v2 sourceinstall
+
+go32v2_zipinstall:
+	$(MAKE) -C go32v2 zipinstall
+
+go32v2_zipinstalladd:
+	$(MAKE) -C go32v2 zipinstalladd
+
+go32v2_clean:
+	$(MAKE) -C go32v2 clean
+
+go32v2_cleanall:
+	$(MAKE) -C go32v2 cleanall
+
+go32v2_require:
+	$(MAKE) -C go32v2 require
+
+go32v2_info:
+	$(MAKE) -C go32v2 info
+endif
+
+# Dir linux
+
+ifdef OBJECTDIRLINUX
+.PHONY:  linux_all linux_debug linux_examples linux_test linux_smart linux_shared linux_showinstall linux_install linux_sourceinstall linux_zipinstall linux_zipinstalladd linux_clean linux_cleanall linux_require linux_info
+
+linux_all:
+	$(MAKE) -C linux all
+
+linux_debug:
+	$(MAKE) -C linux debug
+
+linux_examples:
+	$(MAKE) -C linux examples
+
+linux_test:
+	$(MAKE) -C linux test
+
+linux_smart:
+	$(MAKE) -C linux smart
+
+linux_shared:
+	$(MAKE) -C linux shared
+
+linux_showinstall:
+	$(MAKE) -C linux showinstall
+
+linux_install:
+	$(MAKE) -C linux install
+
+linux_sourceinstall:
+	$(MAKE) -C linux sourceinstall
+
+linux_zipinstall:
+	$(MAKE) -C linux zipinstall
+
+linux_zipinstalladd:
+	$(MAKE) -C linux zipinstalladd
+
+linux_clean:
+	$(MAKE) -C linux clean
+
+linux_cleanall:
+	$(MAKE) -C linux cleanall
+
+linux_require:
+	$(MAKE) -C linux require
+
+linux_info:
+	$(MAKE) -C linux info
+endif
+
+# Dir win32
+
+ifdef OBJECTDIRWIN32
+.PHONY:  win32_all win32_debug win32_examples win32_test win32_smart win32_shared win32_showinstall win32_install win32_sourceinstall win32_zipinstall win32_zipinstalladd win32_clean win32_cleanall win32_require win32_info
+
+win32_all:
+	$(MAKE) -C win32 all
+
+win32_debug:
+	$(MAKE) -C win32 debug
+
+win32_examples:
+	$(MAKE) -C win32 examples
+
+win32_test:
+	$(MAKE) -C win32 test
+
+win32_smart:
+	$(MAKE) -C win32 smart
+
+win32_shared:
+	$(MAKE) -C win32 shared
+
+win32_showinstall:
+	$(MAKE) -C win32 showinstall
+
+win32_install:
+	$(MAKE) -C win32 install
+
+win32_sourceinstall:
+	$(MAKE) -C win32 sourceinstall
+
+win32_zipinstall:
+	$(MAKE) -C win32 zipinstall
+
+win32_zipinstalladd:
+	$(MAKE) -C win32 zipinstalladd
+
+win32_clean:
+	$(MAKE) -C win32 clean
+
+win32_cleanall:
+	$(MAKE) -C win32 cleanall
+
+win32_require:
+	$(MAKE) -C win32 require
+
+win32_info:
+	$(MAKE) -C win32 info
+endif
+
+# Dir os2
+
+ifdef OBJECTDIROS2
+.PHONY:  os2_all os2_debug os2_examples os2_test os2_smart os2_shared os2_showinstall os2_install os2_sourceinstall os2_zipinstall os2_zipinstalladd os2_clean os2_cleanall os2_require os2_info
+
+os2_all:
+	$(MAKE) -C os2 all
+
+os2_debug:
+	$(MAKE) -C os2 debug
+
+os2_examples:
+	$(MAKE) -C os2 examples
+
+os2_test:
+	$(MAKE) -C os2 test
+
+os2_smart:
+	$(MAKE) -C os2 smart
+
+os2_shared:
+	$(MAKE) -C os2 shared
+
+os2_showinstall:
+	$(MAKE) -C os2 showinstall
+
+os2_install:
+	$(MAKE) -C os2 install
+
+os2_sourceinstall:
+	$(MAKE) -C os2 sourceinstall
+
+os2_zipinstall:
+	$(MAKE) -C os2 zipinstall
+
+os2_zipinstalladd:
+	$(MAKE) -C os2 zipinstalladd
+
+os2_clean:
+	$(MAKE) -C os2 clean
+
+os2_cleanall:
+	$(MAKE) -C os2 cleanall
+
+os2_require:
+	$(MAKE) -C os2 require
+
+os2_info:
+	$(MAKE) -C os2 info
+endif
+
+# Dir test
+
+ifdef OBJECTDIRTEST
+.PHONY:  test_all test_debug test_examples test_test test_smart test_shared test_showinstall test_install test_sourceinstall test_zipinstall test_zipinstalladd test_clean test_cleanall test_require test_info
+
+test_all:
+	$(MAKE) -C test all
+
+test_debug:
+	$(MAKE) -C test debug
+
+test_examples:
+	$(MAKE) -C test examples
+
+test_test:
+	$(MAKE) -C test test
+
+test_smart:
+	$(MAKE) -C test smart
+
+test_shared:
+	$(MAKE) -C test shared
+
+test_showinstall:
+	$(MAKE) -C test showinstall
+
+test_install:
+	$(MAKE) -C test install
+
+test_sourceinstall:
+	$(MAKE) -C test sourceinstall
+
+test_zipinstall:
+	$(MAKE) -C test zipinstall
+
+test_zipinstalladd:
+	$(MAKE) -C test zipinstalladd
+
+test_clean:
+	$(MAKE) -C test clean
+
+test_cleanall:
+	$(MAKE) -C test cleanall
+
+test_require:
+	$(MAKE) -C test require
+
+test_info:
+	$(MAKE) -C test info
+endif
+

api/Makefile.fpc

@@ -0,0 +1,13 @@
+#
+#   Makefile.fpc for Free Component Library
+#
+
+[targets]
+dirs=go32v2 linux win32 os2 test
+
+[defaults]
+defaultdir=$(OS_TARGET)
+
+[sections]
+none=1
+

api/README

@@ -0,0 +1,87 @@
+
+
+1. What is this?
+----------------
+
+This is the first public release of our system independent routine collection
+for Pascal. This package includes routines in four major areas:
+
+- file handling (FileCtrl, FileSys)
+- keyboard handling (Keyboard)
+- mouse handling (Mouse)
+- full-screen video handling (Video)
+
+2. Where to find documentation?
+-------------------------------
+
+Documentation is not available yet. However it is planned. If you need help
+feel free to ask on our public mailing lists.
+
+There are two mailing lists, one for users. To subscribe send a message to
[email protected] containing one single line:
+
+subscribe fpk-pascal
+
+The other mailing list is for developers. To subscribe to this list, send a 
+message to [email protected], containing:
+
+subscribe fpc-devel
+
+3. FTP sites
+-------------
+
+This unit collection is available at the following FTP site:
+
+ftp://ftp.uni-freiburg.de/pub/pc/msdos/fpk-pascal/develop/
+
+
+4. Installation
+---------------
+
+  * With FPK:
+     compile the unit with FPK-Pascal using your favourite switches.
+
+       ppc386 buildapi.pas
+
+     will do the trick. After this, copy the resulting .ppu and .o files to
+     your ppc lib directory. By default this is
+
+     /usr/lib/ppc/<version-you-are-using>/linuxunits
+
+     under Linux. Under DOS units are in \PP\LIB\
+
+  * With BP
+     compile the unit with Borland Pascal using the command:
+
+       bpc /cd buildapi.pas            for real target
+       bpc /cp buildapi.pas            for DPMI target
+       bpc /cw buildapi.pas            for Windows target
+
+     you may want to rename filectrl.pp to filectrl.pas if you want BP to
+     be able to access your source file more easily. Copy the resulting
+     .TPU, .TPP, .TPW files to your \BP\UNITS directory. (or to a directory
+     you created for add-on units, make sure that this directory is listed
+     in the Unit directories dialog)
+
+  * With Virtual Pascal/2
+  * With Speed Pascal/2
+     similar to the above ones, but since I don't have OS/2 installed right
+     now, I don't know.
+
+5. Copyright
+------------
+
+This library is under the terms and conditions of the LGPL. See the enclosed
+file COPYING.LIB for details. The library is not available as a shared lib (yet)
+so it may cause licensing problems if you want to use it in a commercial project.
+This will change as soon as the lib becomes available as a shared library.
+
+6. Troubleshooting
+------------------
+
+Due to the bugs in the FPK compiler you may run into problems while compiling
+the API. For example when I try to compile a unit which lists SysCalls in the
+uses clause (in the implementation) part, the compiler always wants to compile
+SysCalls (even if I have it in the lib directory.) copying the units to your 
+working directory helps. (you'll also need errno.inc and sysnr.inc)
+

api/go32v2/Makefile

@@ -0,0 +1,1072 @@
+#
+# Makefile generated by fpcmake v0.99.13 [2000/01/06]
+#
+
+defaultrule: all
+
+#####################################################################
+# Autodetect OS (Linux or Dos or Windows NT)
+# define inlinux when running under linux
+# define inWinNT when running under WinNT
+#####################################################################
+
+# We need only / in the path
+override PATH:=$(subst \,/,$(PATH))
+
+# Search for PWD and determine also if we are under linux
+PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH)))))
+ifeq ($(PWD),)
+PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH)))))
+ifeq ($(PWD),)
+nopwd:
+	@echo You need the GNU utils package to use this Makefile!
+	@echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip
+	@exit
+else
+inlinux=1
+endif
+else
+PWD:=$(firstword $(PWD))
+endif
+
+# Detect NT - NT sets OS to Windows_NT
+ifndef inlinux
+ifeq ($(OS),Windows_NT)
+inWinNT=1
+endif
+endif
+
+# Detect OS/2 - OS/2 has OS2_SHELL defined
+ifndef inlinux
+ifndef inWinNT
+ifdef OS2_SHELL
+inOS2=1
+endif
+endif
+endif
+
+# The extension of executables
+ifdef inlinux
+EXEEXT=
+else
+EXEEXT=.exe
+endif
+
+# The path which is searched separated by spaces
+ifdef inlinux
+SEARCHPATH=$(subst :, ,$(PATH))
+else
+SEARCHPATH=$(subst ;, ,$(PATH))
+endif
+
+#####################################################################
+# Default target
+#####################################################################
+
+override OS_TARGET:=go32v2
+
+#####################################################################
+# FPC version/target Detection
+#####################################################################
+
+# What compiler to use ?
+ifndef FPC
+# Compatibility with old makefiles
+ifdef PP
+FPC=$(PP)
+else
+ifdef inOS2
+FPC=ppos2$(EXEEXT)
+else
+FPC=ppc386$(EXEEXT)
+endif
+endif
+endif
+
+# Target OS
+ifndef OS_TARGET
+OS_TARGET:=$(shell $(FPC) -iTO)
+endif
+
+# Source OS
+ifndef OS_SOURCE
+OS_SOURCE:=$(shell $(FPC) -iSO)
+endif
+
+# Target CPU
+ifndef CPU_TARGET
+CPU_TARGET:=$(shell $(FPC) -iTP)
+endif
+
+# Source CPU
+ifndef CPU_SOURCE
+CPU_SOURCE:=$(shell $(FPC) -iSP)
+endif
+
+# FPC version
+ifndef FPC_VERSION
+FPC_VERSION:=$(shell $(FPC) -iV)
+endif
+
+export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION
+
+# Test FPCDIR to look if the RTL dir exists
+ifdef FPCDIR
+override FPCDIR:=$(subst \,/,$(FPCDIR))
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+else
+override FPCDIR=wrong
+endif
+
+# Default FPCDIR
+ifeq ($(FPCDIR),wrong)
+override FPCDIR=../..
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+endif
+
+# Detect FPCDIR
+ifeq ($(FPCDIR),wrong)
+ifdef inlinux
+override FPCDIR=/usr/lib/fpc/$(FPC_VERSION)
+else
+override FPCDIR:=$(subst /$(FPC)$(EXEEXT),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC)$(EXEEXT),$(SEARCHPATH))))))
+endif
+endif
+
+ifndef PACKAGEDIR
+PACKAGEDIR=$(FPCDIR)/packages
+endif
+ifndef COMPONENTDIR
+COMPONENTDIR=$(FPCDIR)/components
+endif
+# Check if packagedir really exists else turn it off
+ifeq ($(wildcard $(PACKAGEDIR)),)
+PACKAGEDIR=
+endif
+ifeq ($(wildcard $(COMPONENTDIR)),)
+COMPONENTDIR=
+endif
+
+# Create rtl,units dir
+ifneq ($(FPCDIR),.)
+override UNITSDIR=$(FPCDIR)/units/$(OS_TARGET)
+ifneq ($(wildcard $(FPCDIR)/rtl),)
+override RTLDIR=$(FPCDIR)/rtl/$(OS_TARGET)
+else
+override RTLDIR=$(UNITSDIR)/rtl
+endif
+endif
+
+#####################################################################
+# Default Settings
+#####################################################################
+
+# Release ? Then force OPT and don't use extra opts via commandline
+ifndef REDIRFILE
+REDIRFILE=log
+endif
+
+ifdef REDIR
+ifndef inlinux
+override FPC=redir -eo $(FPC)
+endif
+# set the verbosity to max
+override OPT+=-va
+override REDIR:= >> $(REDIRFILE)
+endif
+
+#####################################################################
+# User Settings
+#####################################################################
+
+
+# Pre Settings
+
+INC=../inc
+
+# Override defaults
+override PASEXT=.pas
+
+include ../test/Makefile.api
+include $(INC)/Makefile.api
+
+# Targets
+
+override UNITOBJECTS+=$(APIOBJECTS) vesamode
+override EXAMPLEOBJECTS+=$(TESTOBJECTS)
+
+# Clean
+
+
+# Install
+
+UNITSUBDIR=api
+ZIPTARGET=install
+
+# Defaults
+
+
+# Directories
+
+vpath %$(PASEXT) $(INC)
+ifndef TARGETDIR
+TARGETDIR=.
+endif
+
+# Packages
+
+override PACKAGES=rtl
+PACKAGEDIR_RTL=$(FPCDIR)/rtl/$(OS_TARGET)
+
+# Libraries
+
+LIBNAME=fpapi
+
+# Info
+
+INFOTARGET=fpc_infocfg fpc_infoobjects fpc_infoinstall 
+
+#####################################################################
+# Default Directories
+#####################################################################
+
+# Base dir
+ifdef PWD
+BASEDIR:=$(shell $(PWD))
+else
+BASEDIR=.
+endif
+
+# set the prefix directory where to install everything
+ifndef PREFIXINSTALLDIR
+ifdef inlinux
+PREFIXINSTALLDIR=/usr
+else
+PREFIXINSTALLDIR=/pp
+endif
+endif
+export PREFIXINSTALLDIR
+
+#####################################################################
+# Install Directories
+#####################################################################
+
+# set the base directory where to install everything
+ifndef BASEINSTALLDIR
+ifdef inlinux
+BASEINSTALLDIR=$(PREFIXINSTALLDIR)/lib/fpc/$(FPC_VERSION)
+else
+BASEINSTALLDIR=$(PREFIXINSTALLDIR)
+endif
+endif
+
+# set the directory where to install the binaries
+ifndef BININSTALLDIR
+ifdef inlinux
+BININSTALLDIR=$(PREFIXINSTALLDIR)/bin
+else
+BININSTALLDIR=$(BASEINSTALLDIR)/bin/$(OS_TARGET)
+endif
+endif
+
+# set the directory where to install the units.
+ifndef UNITINSTALLDIR
+UNITINSTALLDIR=$(BASEINSTALLDIR)/units/$(OS_TARGET)
+ifdef UNITSUBDIR
+UNITINSTALLDIR:=$(UNITINSTALLDIR)/$(UNITSUBDIR)
+endif
+endif
+
+# Where to install shared libraries
+ifndef LIBINSTALLDIR
+ifdef inlinux
+LIBINSTALLDIR=$(PREFIXINSTALLDIR)/lib
+else
+LIBINSTALLDIR=$(UNITINSTALLDIR)
+endif
+endif
+
+# Where the source files will be stored
+ifndef SOURCEINSTALLDIR
+ifdef inlinux
+SOURCEINSTALLDIR=$(PREFIXINSTALLDIR)/src/fpc-$(FPC_VERSION)
+else
+SOURCEINSTALLDIR=$(BASEINSTALLDIR)/source
+endif
+endif
+
+# Where the doc files will be stored
+ifndef DOCINSTALLDIR
+ifdef inlinux
+DOCINSTALLDIR=$(PREFIXINSTALLDIR)/doc/fpc-$(FPC_VERSION)
+else
+DOCINSTALLDIR=$(BASEINSTALLDIR)/doc
+endif
+endif
+
+# Where the some extra (data)files will be stored
+ifndef DATAINSTALLDIR
+DATAINSTALLDIR=$(BASEINSTALLDIR)
+endif
+
+
+#####################################################################
+# Compiler Command Line
+#####################################################################
+
+# Load commandline OPTDEF and add FPC_CPU define
+override FPCOPTDEF:=-d$(CPU_TARGET)
+
+# Load commandline OPT and add target and unit dir to be sure
+ifneq ($(OS_TARGET),$(OS_SOURCE))
+override FPCOPT+=-T$(OS_TARGET)
+endif
+
+ifdef UNITSDIR
+override FPCOPT+=-Fu$(UNITSDIR)
+endif
+
+ifdef RTLDIR
+override FPCOPT+=-Fu$(RTLDIR)
+endif
+
+# Target dirs
+ifdef TARGETDIR
+override FPCOPT+=-FE$(TARGETDIR)
+endif
+
+# Smartlinking
+ifdef SMARTLINK
+override FPCOPT+=-CX
+endif
+
+# Debug
+ifdef DEBUG
+override FPCOPT+=-g
+endif
+
+# Release mode (strip, optimize and don't load ppc386.cfg)
+ifdef RELEASE
+override FPCOPT+=-Xs -OG2p3 -n
+endif
+
+# Verbose settings (warning,note,info)
+ifdef VERBOSE
+override FPCOPT+=-vwni
+endif
+
+# Add commandline options
+ifdef OPT
+override FPCOPT+=$(OPT)
+endif
+ifdef UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
+endif
+ifdef LIBDIR
+override FPCOPT+=$(addprefix -Fl,$(LIBDIR))
+endif
+ifdef OBJDIR
+override FPCOPT+=$(addprefix -Fo,$(OBJDIR))
+endif
+ifdef INCDIR
+override FPCOPT+=$(addprefix -Fi,$(INCDIR))
+endif
+
+# Add defines from FPCOPTDEF to FPCOPT
+ifdef FPCOPTDEF
+override FPCOPT+=$(FPCOPTDEF)
+endif
+
+# Error file ?
+ifdef ERRORFILE
+override FPCOPT+=-Fr$(ERRORFILE)
+endif
+
+# Was a config file specified ?
+ifdef CFGFILE
+override FPCOPT+=@$(CFGFILE)
+endif
+
+# For win32 the options are passed using the environment variable FPCEXTCMD
+ifeq ($(OS_SOURCE),win32)
+override FPCEXTCMD:=$(FPCOPT)
+override FPCOPT:=!FPCEXTCMD
+export FPCEXTCMD
+endif
+
+# Compiler commandline
+override COMPILER:=$(FPC) $(FPCOPT)
+
+#####################################################################
+# Shell tools
+#####################################################################
+
+# To copy pograms
+ifndef COPY
+COPY:=cp -fp
+endif
+
+# Copy a whole tree
+ifndef COPYTREE
+COPYTREE:=cp -rfp
+endif
+
+# To move pograms
+ifndef MOVE
+MOVE:=mv -f
+endif
+
+# Check delete program
+ifndef DEL
+DEL:=rm -f
+endif
+
+# Check deltree program
+ifndef DELTREE
+DELTREE:=rm -rf
+endif
+
+# To install files
+ifndef INSTALL
+ifdef inlinux
+INSTALL:=install -m 644
+else
+INSTALL:=$(COPY)
+endif
+endif
+
+# To install programs
+ifndef INSTALLEXE
+ifdef inlinux
+INSTALLEXE:=install -m 755
+else
+INSTALLEXE:=$(COPY)
+endif
+endif
+
+# To make a directory.
+ifndef MKDIR
+ifdef inlinux
+MKDIR:=install -m 755 -d
+else
+MKDIR:=ginstall -m 755 -d
+endif
+endif
+
+export COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR
+
+#####################################################################
+# Default Tools
+#####################################################################
+
+# assembler, redefine it if cross compiling
+ifndef AS
+AS=as
+endif
+
+# linker, but probably not used
+ifndef LD
+LD=ld
+endif
+
+# ppas.bat / ppas.sh
+ifdef inlinux
+PPAS=ppas.sh
+else
+ifdef inOS2
+PPAS=ppas.cmd
+else
+PPAS=ppas.bat
+endif
+endif
+
+# also call ppas if with command option -s
+ifeq (,$(findstring -s ,$(COMPILER)))
+EXECPPAS=
+else
+EXECPPAS:=@$(PPAS)
+endif
+
+# ldconfig to rebuild .so cache
+ifdef inlinux
+LDCONFIG=ldconfig
+else
+LDCONFIG=
+endif
+
+# echo
+ifndef ECHO
+ECHO:=$(strip $(wildcard $(addsuffix /echo$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO:=echo
+else
+ECHO:=$(firstword $(ECHO))
+endif
+endif
+export ECHO
+
+# ppdep
+ifndef PPDEP
+PPDEP:=$(strip $(wildcard $(addsuffix /ppdep$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPDEP),)
+PPDEP=
+else
+PPDEP:=$(firstword $(PPDEP))
+endif
+endif
+export PPDEP
+
+# ppumove
+ifndef PPUMOVE
+PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUMOVE),)
+PPUMOVE=
+else
+PPUMOVE:=$(firstword $(PPUMOVE))
+endif
+endif
+export PPUMOVE
+
+# ppufiles
+ifndef PPUFILES
+PPUFILES:=$(strip $(wildcard $(addsuffix /ppufiles$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUFILES),)
+PPUFILES=
+else
+PPUFILES:=$(firstword $(PPUFILES))
+endif
+endif
+export PPUFILES
+
+# Look if UPX is found for go32v2 and win32. We can't use $UPX becuase
+# upx uses that one itself (PFV)
+ifndef UPXPROG
+ifeq ($(OS_TARGET),go32v2)
+UPXPROG:=1
+endif
+ifeq ($(OS_TARGET),win32)
+UPXPROG:=1
+endif
+ifdef UPXPROG
+UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(UPXPROG),)
+UPXPROG=
+else
+UPXPROG:=$(firstword $(UPXPROG))
+endif
+else
+UPXPROG=
+endif
+endif
+export UPXPROG
+
+# gdate/date
+ifndef DATE
+DATE:=$(strip $(wildcard $(addsuffix /date$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE:=$(strip $(wildcard $(addsuffix /gdate$(EXEEXT),$(SEACHPATH))))
+ifeq ($(DATE),)
+DATE=
+else
+DATE:=$(firstword $(DATE))
+endif
+else
+DATE:=$(firstword $(DATE))
+endif
+endif
+export DATE
+
+ifdef DATE
+DATESTR:=$(shell $(DATE) +%Y%m%d)
+else
+DATESTR=
+endif
+
+# ZipProg, you can't use Zip as the var name (PFV)
+ifndef ZIPPROG
+ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(ZIPPROG),)
+ZIPPROG=
+else
+ZIPPROG:=$(firstword $(ZIPPROG)) -D9 -r
+endif
+endif
+export ZIPPROG
+
+ifndef ZIPEXT
+ZIPEXT=.zip
+endif
+
+#####################################################################
+# Default extensions
+#####################################################################
+
+# Default needed extensions (Go32v2,Linux)
+LOADEREXT=.as
+PPLEXT=.ppl
+PPUEXT=.ppu
+OEXT=.o
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.so
+RSTEXT=.rst
+PACKAGESUFFIX=
+FPCMADE=fpcmade
+
+# Go32v1
+ifeq ($(OS_TARGET),go32v1)
+PPUEXT=.pp1
+OEXT=.o1
+ASMEXT=.s1
+SMARTEXT=.sl1
+STATICLIBEXT=.a1
+SHAREDLIBEXT=.so1
+PACKAGESUFFIX=v1
+FPCMADE=fpcmade.v1
+endif
+
+# Go32v2
+ifeq ($(OS_TARGET),go32v2)
+PACKAGESUFFIX=go32
+FPCMADE=fpcmade.dos
+endif
+
+# Linux
+ifeq ($(OS_TARGET),linux)
+PACKAGESUFFIX=linux
+FPCMADE=fpcmade.lnx
+endif
+
+# Win32
+ifeq ($(OS_TARGET),win32)
+PPUEXT=.ppw
+OEXT=.ow
+ASMEXT=.sw
+SMARTEXT=.slw
+STATICLIBEXT=.aw
+SHAREDLIBEXT=.dll
+PACKAGESUFFIX=win32
+FPCMADE=fpcmade.w32
+endif
+
+# OS/2
+ifeq ($(OS_TARGET),os2)
+PPUEXT=.ppo
+ASMEXT=.so2
+OEXT=.oo2
+SMARTEXT=.so
+STATICLIBEXT=.ao2
+SHAREDLIBEXT=.dll
+PACKAGESUFFIX=os2
+FPCMADE=fpcmade.os2
+endif
+
+# library prefix
+LIBPREFIX=lib
+ifeq ($(OS_TARGET),go32v2)
+LIBPREFIX=
+endif
+ifeq ($(OS_TARGET),go32v1)
+LIBPREFIX=
+endif
+
+# determine which .pas extension is used
+ifndef PASEXT
+ifdef EXEOBJECTS
+override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(EXEOBJECTS)))))
+else
+override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(UNITOBJECTS)))))
+endif
+ifeq ($(TESTPAS),)
+PASEXT=.pp
+else
+PASEXT=.pas
+endif
+endif
+
+#####################################################################
+# Standard rules
+#####################################################################
+
+all: fpc_all
+
+debug: fpc_debug
+
+examples: fpc_examples
+
+test: fpc_test
+
+smart: fpc_smart
+
+shared: fpc_shared
+
+showinstall: fpc_showinstall
+
+install: fpc_install
+
+sourceinstall: fpc_sourceinstall
+
+zipinstall: fpc_zipinstall
+
+zipinstalladd: fpc_zipinstalladd
+
+clean: fpc_clean
+
+cleanall: fpc_cleanall
+
+info: fpc_info
+
+.PHONY:  all debug examples test smart shared showinstall install sourceinstall zipinstall zipinstalladd clean cleanall info
+
+
+ifdef PACKAGERTL
+ifneq ($(wildcard $(PACKAGEDIR_RTL)),)
+ifeq ($(wildcard $(PACKAGEDIR_RTL)/$(FPCMADE)),)
+override COMPILEPACKAGES+=rtl
+rtl_package:
+	$(MAKE) -C $(PACKAGEDIR_RTL) all
+endif
+endif
+endif
+
+.PHONY:  rtl_package
+
+#####################################################################
+# Units
+#####################################################################
+
+.PHONY: fpc_units
+
+override ALLTARGET+=fpc_units
+
+override UNITPPUFILES=$(addsuffix $(PPUEXT),$(UNITOBJECTS))
+override INSTALLPPUFILES+=$(UNITPPUFILES)
+override CLEANPPUFILES+=$(UNITPPUFILES)
+
+fpc_units: $(UNITPPUFILES)
+
+#####################################################################
+# Examples
+#####################################################################
+
+.PHONY: fpc_examples fpc_test
+
+override EXAMPLEFILES:=$(addsuffix $(EXEEXT),$(EXAMPLEOBJECTS))
+override EXAMPLEOFILES:=$(addsuffix $(OEXT),$(EXAMPLEOBJECTS))
+
+override CLEANEXEFILES+=$(EXAMPLEFILES) $(EXAMPLEOFILES)
+
+fpc_examples: all $(EXAMPLEFILES)
+
+fpc_test: examples
+
+#####################################################################
+# General compile rules
+#####################################################################
+
+.PHONY: fpc_all fpc_debug
+
+$(FPCMADE):
+	@$(ECHO) Compiled > $(FPCMADE)
+
+fpc_all: $(addsuffix _package,$(COMPILEPACKAGES)) \
+	 $(addsuffix _component,$(COMPILECOMPONENTS)) \
+	 $(ALLTARGET) $(FPCMADE)
+
+fpc_debug:
+	$(MAKE) all DEBUG=1
+
+# General compile rules, available for both possible PASEXT
+
+.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp
+
+%$(PPUEXT): %.pp
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(PPUEXT): %.pas
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(EXEEXT): %.pp
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(EXEEXT): %.pas
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+#####################################################################
+# Library
+#####################################################################
+
+.PHONY: fpc_smart fpc_shared
+
+# Default sharedlib units are all unit objects
+ifndef SHAREDLIBUNITOBJECTS
+SHAREDLIBUNITOBJECTS:=$(UNITOBJECTS)
+endif
+
+fpc_smart:
+	$(MAKE) all SMARTLINK=1
+
+fpc_shared: all
+ifdef inlinux
+ifndef LIBNAME
+	@$(ECHO) "LIBNAME not set"
+else
+	$(PPUMOVE) $(SHAREDLIBUNITOBJECTS) -o$(LIBNAME)
+endif
+else
+	@$(ECHO) "Shared Libraries not supported"
+endif
+
+#####################################################################
+# Install rules
+#####################################################################
+
+.PHONY: fpc_showinstall fpc_install
+
+ifdef EXTRAINSTALLUNITS
+override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRAINSTALLUNITS))
+endif
+
+ifdef INSTALLPPUFILES
+ifdef PPUFILES
+ifdef inlinux
+INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
+INSTALLPPULIBFILES:=$(shell $(PPUFILES) -L $(INSTALLPPUFILES))
+else
+INSTALLPPULINKFILES:=$(shell $(PPUFILES) $(INSTALLPPUFILES))
+endif
+else
+INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
+endif
+endif
+
+fpc_showinstall: $(SHOWINSTALLTARGET)
+ifdef INSTALLEXEFILES
+	@$(ECHO) -e $(addprefix "\n"$(BININSTALLDIR)/,$(INSTALLEXEFILES))
+endif
+ifdef INSTALLPPUFILES
+	@$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPUFILES))
+ifneq ($(INSTALLPPULINKFILES),)
+	@$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPULINKFILES))
+endif
+ifneq ($(INSTALLPPULIBFILES),)
+	@$(ECHO) -e $(addprefix "\n"$(LIBINSTALLDIR)/,$(INSTALLPPULIBFILES))
+endif
+endif
+ifdef EXTRAINSTALLFILES
+	@$(ECHO) -e $(addprefix "\n"$(DATAINSTALLDIR)/,$(EXTRAINSTALLFILES))
+endif
+
+fpc_install: $(INSTALLTARGET)
+# Create UnitInstallFiles
+ifdef INSTALLEXEFILES
+	$(MKDIR) $(BININSTALLDIR)
+# Compress the exes if upx is defined
+ifdef UPXPROG
+	-$(UPXPROG) $(INSTALLEXEFILES)
+endif
+	$(INSTALLEXE) $(INSTALLEXEFILES) $(BININSTALLDIR)
+endif
+ifdef INSTALLPPUFILES
+	$(MKDIR) $(UNITINSTALLDIR)
+	$(INSTALL) $(INSTALLPPUFILES) $(UNITINSTALLDIR)
+ifneq ($(INSTALLPPULINKFILES),)
+	$(INSTALL) $(INSTALLPPULINKFILES) $(UNITINSTALLDIR)
+endif
+ifneq ($(INSTALLPPULIBFILES),)
+	$(MKDIR) $(LIBINSTALLDIR)
+	$(INSTALL) $(INSTALLPPULIBFILES) $(LIBINSTALLDIR)
+endif
+endif
+ifdef EXTRAINSTALLFILES
+	$(MKDIR) $(DATAINSTALLDIR)
+	$(INSTALL) $(EXTRAINSTALLFILES) $(DATAINSTALLDIR)
+endif
+
+#####################################################################
+# Source install rules
+#####################################################################
+
+.PHONY: fpc_sourceinstall
+
+fpc_sourceinstall: clean
+	$(MKDIR) $(SOURCEINSTALLDIR)
+	$(COPYTREE) $(BASEDIR) $(SOURCEINSTALLDIR)
+
+#####################################################################
+# Zip
+#####################################################################
+
+.PHONY: fpc_zipinstall fpc_zipinstalladd
+
+# Temporary path to pack a file
+ifndef PACKDIR
+ifndef inlinux
+PACKDIR=pack_tmp
+else
+PACKDIR=/tmp/fpc-pack
+endif
+endif
+
+# Test dir if none specified
+ifndef DESTZIPDIR
+DESTZIPDIR:=$(BASEDIR)
+endif
+
+# Add .zip/.tar.gz extension
+ifdef ZIPNAME
+ifndef inlinux
+override ZIPNAME:=$(ZIPNAME)$(ZIPEXT)
+endif
+endif
+
+# Note: This will not remove the zipfile first
+fpc_zipinstalladd:
+ifndef ZIPNAME
+	@$(ECHO) "Please specify ZIPNAME!"
+	@exit 1
+else
+	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
+ifdef inlinux
+	gzip -d $(DESTZIPDIR)/$(ZIPNAME).tar.gz
+	cd $(PACKDIR) ; tar rv --file $(DESTZIPDIR)/$(ZIPNAME).tar * ; cd $(BASEDIR)
+	gzip $(DESTZIPDIR)/$(ZIPNAME).tar
+else
+	cd $(PACKDIR) ; $(ZIPPROG) $(DESTZIPDIR)/$(ZIPNAME) * ; cd $(BASEDIR)
+endif
+	$(DELTREE) $(PACKDIR)
+endif
+
+# First remove the zip and then install
+fpc_zipinstall:
+ifndef ZIPNAME
+	@$(ECHO) "Please specify ZIPNAME!"
+	@exit 1
+else
+	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)
+	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
+ifdef inlinux
+	cd $(PACKDIR) ; tar cvz --file $(DESTZIPDIR)/$(ZIPNAME).tar.gz * ; cd $(BASEDIR)
+else
+	cd $(PACKDIR) ; $(ZIPPROG) $(DESTZIPDIR)/$(ZIPNAME) * ; cd $(BASEDIR)
+endif
+	$(DELTREE) $(PACKDIR)
+endif
+
+#####################################################################
+# Clean rules
+#####################################################################
+
+.PHONY: fpc_clean fpc_cleanall
+
+ifdef EXTRACLEANUNITS
+override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRACLEANUNITS))
+endif
+
+ifdef CLEANPPUFILES
+ifdef PPUFILES
+CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
+else
+CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
+endif
+endif
+
+fpc_clean: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+ifdef CLEANPPUFILES
+	-$(DEL) $(CLEANPPUFILES)
+endif
+ifneq ($(CLEANPPULINKFILES),)
+	-$(DEL) $(CLEANPPULINKFILES)
+endif
+ifdef CLEANRSTFILES
+	-$(DEL) $(CLEANRSTFILES)
+endif
+ifdef EXTRACLEANFILES
+	-$(DEL) $(EXTRACLEANFILES)
+endif
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(REDIRFILE)
+
+fpc_cleanall: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+	-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+	-$(DELTREE) *$(SMARTEXT)
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(REDIRFILE)
+
+#####################################################################
+# Info rules
+#####################################################################
+
+.PHONY: fpc_info fpc_cfginfo fpc_objectinfo fpc_toolsinfo fpc_installinfo \
+	fpc_dirinfo
+
+fpc_info: $(INFOTARGET)
+
+fpc_infocfg:
+	@$(ECHO)
+	@$(ECHO)  == Configuration info ==
+	@$(ECHO)
+	@$(ECHO)  FPC....... $(FPC)
+	@$(ECHO)  Version... $(FPC_VERSION)
+	@$(ECHO)  CPU....... $(CPU_TARGET)
+	@$(ECHO)  Source.... $(OS_SOURCE)
+	@$(ECHO)  Target.... $(OS_TARGET)
+	@$(ECHO)
+
+fpc_infoobjects:
+	@$(ECHO)
+	@$(ECHO)  == Object info ==
+	@$(ECHO)
+	@$(ECHO)  LoaderObjects..... $(LOADEROBJECTS)
+	@$(ECHO)  UnitObjects....... $(UNITOBJECTS)
+	@$(ECHO)  ExeObjects........ $(EXEOBJECTS)
+	@$(ECHO)
+	@$(ECHO)  ExtraCleanUnits... $(EXTRACLEANUNITS)
+	@$(ECHO)  ExtraCleanFiles... $(EXTRACLEANFILES)
+	@$(ECHO)
+	@$(ECHO)  ExtraInstallUnits. $(EXTRAINSTALLUNITS)
+	@$(ECHO)  ExtraInstallFiles. $(EXTRAINSTALLFILES)
+	@$(ECHO)
+
+fpc_infoinstall:
+	@$(ECHO)
+	@$(ECHO)  == Install info ==
+	@$(ECHO)
+ifdef DATE
+	@$(ECHO)  DateStr.............. $(DATESTR)
+endif
+	@$(ECHO)  PackageSuffix........ $(PACKAGESUFFIX)
+	@$(ECHO)
+	@$(ECHO)  BaseInstallDir....... $(BASEINSTALLDIR)
+	@$(ECHO)  BinInstallDir........ $(BININSTALLDIR)
+	@$(ECHO)  LibInstallDir........ $(LIBINSTALLDIR)
+	@$(ECHO)  UnitInstallDir....... $(UNITINSTALLDIR)
+	@$(ECHO)  SourceInstallDir..... $(SOURCEINSTALLDIR)
+	@$(ECHO)  DocInstallDir........ $(DOCINSTALLDIR)
+	@$(ECHO)  DataInstallDir....... $(DATAINSTALLDIR)
+	@$(ECHO)
+
+#####################################################################
+# Users rules
+#####################################################################
+
+video$(PPUEXT): $(INC)/video.pas video.inc
+
+keyboard$(PPUEXT): $(INC)/keyboard.pas keyboard.inc
+
+mouse$(PPUEXT): $(INC)/mouse.pas mouse.inc
+
+filectrl$(PPUEXT): $(INC)/filectrl.pas filectrl.inc

api/go32v2/Makefile.fpc

@@ -0,0 +1,41 @@
+#
+#   Makefile.fpc for Free Pascal API (used by Free Vision) for go32v2
+#
+
+[defaults]
+defaulttarget=go32v2
+
+[targets]
+units=$(APIOBJECTS) vesamode
+examples=$(TESTOBJECTS)
+
+[install]
+unitsubdir=api
+
+[libs]
+libname=fpapi
+
+[dirs]
+fpcdir=../..
+targetdir=.
+sourcesdir=$(INC)
+
+
+[presettings]
+INC=../inc
+
+# Override defaults
+override PASEXT=.pas
+
+include ../test/Makefile.api
+include $(INC)/Makefile.api
+
+
+[rules]
+video$(PPUEXT): $(INC)/video.pas video.inc
+
+keyboard$(PPUEXT): $(INC)/keyboard.pas keyboard.inc
+
+mouse$(PPUEXT): $(INC)/mouse.pas mouse.inc
+
+filectrl$(PPUEXT): $(INC)/filectrl.pas filectrl.inc

api/go32v2/filectrl.inc

@@ -0,0 +1,261 @@
+{
+  System independent filecontrol interface for go32v2
+
+  $Id$
+}
+uses
+  Go32;
+
+function OpenFileStr(FName: PChar; Flags: Longint): TFileHandle;
+Var
+  regs : trealregs;
+begin
+  copytodos(FName^,256);
+  if LFNSupport then
+   regs.realeax:=$716c
+  else
+   regs.realeax:=$6c00;
+  regs.realedx:=$1;
+  regs.realds:=tb_segment;
+  regs.realesi:=tb_offset;
+  regs.realebx:=$2000;
+  regs.realecx:=$20;
+  realintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   begin
+     ErrorCode:=lo(regs.realeax);
+     exit(0);
+   end
+  else
+   OpenFileStr:=regs.realeax and $ffff;
+end;
+
+
+function CreateFileStr(FName: PChar): TFileHandle;
+Var
+  regs : trealregs;
+begin
+  copytodos(FName^,256);
+  if LFNSupport then
+   regs.realeax:=$716c
+  else
+   regs.realeax:=$6c00;
+  regs.realedx:=$12;
+  regs.realds:=tb_segment;
+  regs.realesi:=tb_offset;
+  regs.realebx:=$2001;
+  regs.realecx:=$20;
+  realintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   begin
+     ErrorCode:=lo(regs.realeax);
+     exit(0);
+   end
+  else
+   CreateFileStr:=regs.realeax and $ffff;
+end;
+
+
+procedure DeleteFileStr(FName: PChar);
+var
+  regs : trealregs;
+begin
+  copytodos(FName^,256);
+  regs.realedx:=tb_offset;
+  regs.realds:=tb_segment;
+  if LFNSupport then
+   regs.realeax:=$7141
+  else
+   regs.realeax:=$4100;
+  regs.realesi:=0;
+  regs.realecx:=0;
+  realintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   ErrorCode:=lo(regs.realeax);
+end;
+
+
+procedure CloseFile(Handle: TFileHandle);
+var
+  regs : trealregs;
+begin
+  regs.realebx:=handle;
+  regs.realeax:=$3e00;
+  RealIntr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   ErrorCode:=lo(regs.realeax);
+end;
+
+
+function SeekFile(Handle: TFileHandle; Pos: TFileInt; SeekType: Word): TFileInt;
+var
+  regs : trealregs;
+begin
+  regs.realebx:=handle;
+  regs.realecx:=pos shr 16;
+  regs.realedx:=pos and $ffff;
+  regs.realeax:=$4200 or SeekType;
+  RealIntr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   begin
+     ErrorCode:=lo(regs.realeax);
+     SeekFile:=-1;
+   end
+  else
+   SeekFile:=lo(regs.realedx) shl 16+lo(regs.realeax);
+end;
+
+
+function ReadFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord;
+var
+  regs     : trealregs;
+  addr     : pchar;
+  len,
+  size,
+  readsize : longint;
+begin
+  len:=count;
+  addr:=@buff;
+  readsize:=0;
+  while len > 0 do
+   begin
+     if len>tb_size then
+      size:=tb_size
+     else
+      size:=len;
+     regs.realecx:=len;
+     regs.realedx:=tb_offset;
+     regs.realds:=tb_segment;
+     regs.realebx:=handle;
+     regs.realeax:=$3f00;
+     RealIntr($21,regs);
+     if (regs.realflags and carryflag) <> 0 then
+      begin
+        InOutRes:=lo(regs.realeax);
+        exit(0);
+      end
+     else
+      if regs.realeax<size then
+       begin
+         copyfromdos(addr^,regs.realeax);
+         exit(readsize+regs.realeax);
+       end;
+     copyfromdos(addr^,regs.realeax);
+     inc(readsize,regs.realeax);
+     inc(addr,regs.realeax);
+     dec(len,regs.realeax);
+   end;
+  readfile:=readsize;
+end;
+
+
+function WriteFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord;
+var
+  regs      : trealregs;
+  addr      : pchar;
+  len,
+  size,
+  writesize : longint;
+begin
+  len:=count;
+  addr:=@buff;
+  writesize:=0;
+  while len > 0 do
+   begin
+     if len>tb_size then
+      size:=tb_size
+     else
+      size:=len;
+     copytodos(addr^,size);
+     regs.realecx:=size;
+     regs.realedx:=tb_offset;
+     regs.realds:=tb_segment;
+     regs.realebx:=handle;
+     regs.realeax:=$4000;
+     RealIntr($21,regs);
+     if (regs.realflags and carryflag) <> 0 then
+      begin
+        ErrorCode:=lo(regs.realeax);
+        exit(writesize);
+      end;
+     dec(len,size);
+     inc(writesize,size);
+     inc(addr,size);
+   end;
+  WriteFile:=WriteSize;
+end;
+
+
+procedure FlushFile(Handle: TFileHandle);
+var
+  regs : trealregs;
+begin
+  regs.ebx:=handle;
+  regs.ah:=$68;
+  realintr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   ErrorCode:=lo(regs.realeax);
+end;
+
+
+procedure TruncateFile(Handle: TFileHandle);
+var
+  regs : trealregs;
+begin
+  regs.realecx:=0;
+  regs.realedx:=tb_offset;
+  regs.realds:=tb_segment;
+  regs.realebx:=handle;
+  regs.realeax:=$4000;
+  RealIntr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   ErrorCode:=lo(regs.realeax);
+end;
+
+function EndOfFile(Handle: TFileHandle): Boolean;
+begin
+  EndOfFile := FilePos(Handle) >= FileSize(Handle);
+end;
+
+function FilePos(Handle: TFileHandle): TFileInt;
+var
+  regs : trealregs;
+begin
+  regs.realebx:=handle;
+  regs.realecx:=0;
+  regs.realedx:=0;
+  regs.realeax:=$4201;
+  RealIntr($21,regs);
+  if (regs.realflags and carryflag) <> 0 then
+   Begin
+     InOutRes:=lo(regs.realeax);
+     filepos:=-1;
+   end
+  else
+   filepos:=lo(regs.realedx) shl 16+lo(regs.realeax);
+end;
+
+function FileSize(Handle: TFileHandle): TFileInt;
+var
+  aktfilepos : longint;
+begin
+  aktfilepos:=filepos(handle);
+  filesize:=seekfile(handle,0,2);
+  seekfile(handle,aktfilepos,0);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:30  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:37  peter
+    * moved to packages dir
+
+  Revision 1.1  1998/12/04 12:48:27  peter
+    * moved some dirs
+
+  Revision 1.1  1998/10/26 11:31:47  peter
+    + inital include files
+
+}

api/go32v2/keyboard.inc

@@ -0,0 +1,152 @@
+{
+  System independent keyboard interface for go32v2
+
+<<<<<<< keyboard.inc
+  $Id$
+
+  WARNING this code needs %fs to contain the DOS memory selector
+  don't forget to reload it after calling C functions
+  that could change it PM
+=======
+  $Id$
+>>>>>>> 1.3
+}
+uses
+  go32;
+
+procedure InitKeyboard;
+begin
+end;
+
+procedure DoneKeyboard;
+begin
+end;
+
+function GetKeyEvent: TKeyEvent;
+var
+  regs : trealregs;
+begin
+  if PendingKeyEvent<>0 then
+   begin
+     GetKeyEvent:=PendingKeyEvent;
+     PendingKeyEvent:=0;
+     exit;
+   end;
+  regs.ah:=$10;
+  realintr($16,regs);
+  if (regs.al=$e0) and (regs.ah<>0) then
+   regs.al:=0;
+  GetKeyEvent:=regs.ax or ((mem[$40:$17] and $f) shl 16);
+end;
+
+
+function PollKeyEvent: TKeyEvent;
+var
+  regs : trealregs;
+begin
+  if PendingKeyEvent<>0 then
+   exit(PendingKeyEvent);
+  regs.ah:=$11;
+  realintr($16,regs);
+  if (regs.realflags and zeroflag<>0) then
+   exit(0);
+  if (regs.al=$e0) and (regs.ah<>0) then
+   regs.al:=0;
+  PollKeyEvent:=regs.ax or ((mem[$40:$17] and $f) shl 16);
+end;
+
+
+function PollShiftStateEvent: TKeyEvent;
+begin
+  PollShiftStateEvent:=((mem[$40:$17] and $f) shl 16);
+end;
+
+
+{ Function key translation }
+type
+  TTranslationEntry = packed record
+    Min, Max: Byte;
+    Offset: Word;
+  end;
+const
+  TranslationTableEntries = 12;
+  TranslationTable: array [1..TranslationTableEntries] of TTranslationEntry =
+    ((Min: $3B; Max: $44; Offset: kbdF1),   { function keys F1-F10 }
+     (Min: $54; Max: $5D; Offset: kbdF1),   { Shift fn keys F1-F10 }
+     (Min: $5E; Max: $67; Offset: kbdF1),   { Ctrl fn keys F1-F10 }
+     (Min: $68; Max: $71; Offset: kbdF1),   { Alt fn keys F1-F10 }
+     (Min: $85; Max: $86; Offset: kbdF11),  { function keys F11-F12 }
+     (Min: $87; Max: $88; Offset: kbdF11),  { Shift+function keys F11-F12 }
+     (Min: $89; Max: $8A; Offset: kbdF11),  { Ctrl+function keys F11-F12 }
+     (Min: $8B; Max: $8C; Offset: kbdF11),  { Alt+function keys F11-F12 }
+     (Min:  71; Max:  73; Offset: kbdHome), { Keypad keys kbdHome-kbdPgUp }
+     (Min:  75; Max:  77; Offset: kbdLeft), { Keypad keys kbdLeft-kbdRight }
+     (Min:  79; Max:  81; Offset: kbdEnd),  { Keypad keys kbdEnd-kbdPgDn }
+     (Min: $52; Max: $53; Offset: kbdInsert));
+
+
+function TranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
+var
+  I: Integer;
+  ScanCode: Byte;
+begin
+  if KeyEvent and $03000000 = $03000000 then
+   begin
+     if KeyEvent and $000000FF <> 0 then
+      begin
+        TranslateKeyEvent := KeyEvent and $00FFFFFF;
+        exit;
+      end
+     else
+      begin
+        { This is a function key }
+        ScanCode := (KeyEvent and $0000FF00) shr 8;
+        for I := 1 to TranslationTableEntries do
+         begin
+           if (TranslationTable[I].Min <= ScanCode) and (ScanCode <= TranslationTable[I].Max) then
+            begin
+              TranslateKeyEvent := $02000000 + (KeyEvent and $00FF0000) +
+                (ScanCode - TranslationTable[I].Min) + TranslationTable[I].Offset;
+              exit;
+            end;
+         end;
+      end;
+   end;
+  TranslateKeyEvent := KeyEvent;
+end;
+
+
+function TranslateKeyEventUniCode(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+  TranslateKeyEventUniCode := KeyEvent;
+  ErrorHandler(errKbdNotImplemented, nil);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:30  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  1999/12/10 12:42:26  pierre
+   * several mods to handle different keyboard layouts
+
+  Revision 1.3  1999/11/24 23:36:56  peter
+    * moved to packages dir
+
+  Revision 1.2  1998/12/12 19:13:00  peter
+    * keyboard updates
+    * make test target, make all only makes units
+
+  Revision 1.1  1998/12/04 12:48:27  peter
+    * moved some dirs
+
+  Revision 1.3  1998/11/01 20:28:26  peter
+    * fixed strange al=$e0 after int $16 call
+
+  Revision 1.2  1998/10/28 21:18:24  peter
+    * more fixes
+
+  Revision 1.1  1998/10/26 11:31:47  peter
+    + inital include files
+
+}

api/go32v2/mouse.inc

@@ -0,0 +1,505 @@
+{
+  System dependent mouse implementation for go32v2
+
+  $Id$
+}
+
+uses
+  go32;
+
+var
+  RealSeg : Word;                                    { Real mode segment }
+  RealOfs : Word;                                    { Real mode offset }
+  CurrentMask : word;
+  MouseCallback : Pointer;                           { Mouse call back ptr }
+{$ifdef DEBUG}
+  EntryEDI,EntryESI : longint;
+  EntryDS,EntryES : word;
+{$endif DEBUG}
+  { Real mode registers in text segment below $ffff limit
+    for Windows NT
+    NOTE this might cause problem if someone want to
+    protect text section against writing (would be possible
+    with CWSDPMI under raw dos, not implemented yet !) }
+  ActionRegs    : TRealRegs;external name '___v2prt0_rmcb_regs';
+  v2prt0_ds_alias : word;external name '___v2prt0_ds_alias';
+const
+  MousePresent : boolean = false;
+{$ifdef DEBUG}
+  MouseError   : longint = 0;
+  CallCounter  : longint = 0;
+{$endif DEBUG}
+{$ASMMODE ATT}
+procedure MouseInt;assembler;
+asm
+        movb    %bl,mousebuttons
+        movw    %cx,mousewherex
+        movw    %dx,mousewherey
+        cmpb    MouseEventBufSize,PendingMouseEvents
+        je      .Lmouse_exit
+        movl    PendingMouseTail,%edi
+        shrw    $3,%cx
+        shrw    $3,%dx
+        movw    %bx,(%edi)
+        movw    %cx,2(%edi)
+        movw    %dx,4(%edi)
+        movw    $0,6(%edi)
+        addl    $8,%edi
+        leal    PendingMouseEvent,%eax
+        addl    MouseEventBufSize*8,%eax
+        cmpl    %eax,%edi
+        jne     .Lmouse_nowrap
+        leal    PendingMouseEvent,%edi
+.Lmouse_nowrap:
+        movl    %edi,PendingMouseTail
+        incb    PendingMouseEvents
+.Lmouse_exit:
+end;
+
+
+
+PROCEDURE Mouse_Trap; ASSEMBLER;
+ASM
+   PUSH %ES;                                          { Save ES register }
+   PUSH %DS;                                          { Save DS register }
+   PUSHL %EDI;                                        { Save register }
+   PUSHL %ESI;                                        { Save register }
+   ;{ caution : ds is not the selector for our data !! }
+{$ifdef DEBUG}
+   MOVL  %EDI,%ES:EntryEDI
+   MOVL  %ESI,%ES:EntryESI
+   MOVW  %DS,%AX
+   MOVW  %AX,%ES:EntryDS
+   MOVW  %ES,%AX
+   MOVW  %AX,%ES:EntryES
+{$endif DEBUG}
+ {  movw  %cs:v2prt0_ds_alias,%ax v2prt0 is not locked !!
+   movw  %ax,%ds
+   movw  %ax,%es }
+   PUSH %ES;                                          { Push data seg }
+   POP %DS;                                           { Load data seg }
+{$ifdef DEBUG}
+   incl callcounter
+   CMPL $ACTIONREGS,%edi
+   JE  .L_ActionRegsOK
+   INCL MouseError
+   JMP  .L_NoCallBack
+.L_ActionRegsOK:
+{$endif DEBUG}
+   MOVL MOUSECALLBACK, %EAX;                          { Fetch callback addr }
+   CMPL $0, %EAX;                                     { Check for nil ptr }
+   JZ .L_NoCallBack;                                  { Ignore if nil }
+   MOVL %EDI,%EAX;                                    { %EAX = @actionregs }
+   MOVL (%EAX), %EDI;                                 { EDI from actionregs }
+   MOVL 4(%EAX), %ESI;                                { ESI from actionregs }
+   MOVL 16(%EAX), %EBX;                               { EBX from actionregs }
+   MOVL 20(%EAX), %EDX;                               { EDX from actionregs }
+   MOVL 24(%EAX), %ECX;                               { ECX from actionregs }
+   MOVL 28(%EAX), %EAX;                               { EAX from actionregs }
+   CALL *MOUSECALLBACK;                               { Call callback proc }
+.L_NoCallBack:
+   POPL %ESI;                                         { Recover register }
+   POPL %EDI;                                         { Recover register }
+   POP %DS;                                           { Restore DS register }
+   POP %ES;                                           { Restore ES register }
+   {  This works for WinNT
+   movzwl %si,%eax
+   but CWSDPMI need this }
+   movl %esi,%eax
+   MOVL %ds:(%Eax), %EAX;
+   MOVL %EAX, %ES:42(%EDI);                           { Set as return addr }
+   ADDW $4, %ES:46(%EDI);                             { adjust stack }
+   IRET;                                              { Interrupt return }
+END;
+
+Function Allocate_mouse_bridge : boolean;
+var
+  error : word;
+begin
+  ASM
+    LEAL ACTIONREGS, %EDI;                       { Addr of actionregs }
+    LEAL MOUSE_TRAP, %ESI;                       { Procedure address }
+    PUSH %DS;                                    { Save DS segment }
+    PUSH %ES;                                    { Save ES segment }
+    MOVW v2prt0_ds_alias,%ES;                    { ES now has dataseg  alias that is never invalid }
+    PUSH %CS;
+    POP  %DS;                                    { DS now has codeseg }
+    MOVW $0x303, %AX;                            { Function id }
+    INT  $0x31;                                  { Call DPMI bridge }
+    JNC .L_call_ok;                              { Branch if ok }
+    POP  %ES;                                    { Restore ES segment }
+    POP  %DS;                                    { Restore DS segment }
+    MOVW $0,REALSEG;
+    MOVW $0,REALOFS;
+    JMP  .L_exit
+  .L_call_ok:
+    POP  %ES;                                    { Restore ES segment }
+    POP  %DS;                                    { Restore DS segment }
+    MOVW %CX,REALSEG;                            { Transfer real seg }
+    MOVW %DX,REALOFS;                            { Transfer real ofs }
+    MOVW $0, %AX;                                { Force error to zero }
+  .L_exit:
+    MOVW %AX, ERROR;                             { Return error state }
+  END;
+  Allocate_mouse_bridge:=error=0;
+end;
+
+Procedure Release_mouse_bridge;
+begin
+  ASM
+     MOVW $0x304, %AX;                            { Set function id }
+     MOVW REALSEG, %CX;                           { Bridged real seg }
+     MOVW REALOFS, %DX;                           { Bridged real ofs }
+     INT $0x31;                                   { Release bridge }
+     MOVW $0,REALSEG;
+     MOVW $0,REALOFS;
+  END;
+end;
+
+PROCEDURE Mouse_Action (Mask : Word; P : Pointer);
+VAR
+  Error : Word;
+  Rg    : TRealRegs;
+BEGIN
+  Error := 0;                                         { Preset no error }
+  If (P <> MouseCallBack) or (Mask<>CurrentMask) Then                        { Check func different }
+   Begin
+   { Remove old calback }
+     If (CurrentMask <> 0) Then
+      Begin
+        Rg.AX := 12;                                   { Function id }
+        Rg.CX := 0;                                    { Zero mask register }
+        Rg.ES := 0;                                    { Zero proc seg }
+        Rg.DX := 0;                                    { Zero proc ofs }
+        RealIntr($33, Rg);                             { Stop INT 33 callback }
+      End;
+     if RealSeg=0 then
+       error:=1;
+    { test addresses for Windows NT }
+    if (longint(@actionregs)>$ffff) {or
+       (longint(@mouse_trap)>$ffff)} then
+      begin
+         error:=1;
+      end
+    else If (P = Nil) Then
+     Begin
+       Mask := 0;                                    { Zero mask register }
+     End;
+    If (Error = 0) Then
+     Begin
+       MouseCallback := P;                            { Set call back addr }
+       if Mask<>0 then
+         begin
+           Rg.AX := 12;                                   { Set function id }
+           Rg.CX := Mask;                                 { Set mask register }
+           If Mask<>0 then
+             begin
+               Rg.ES := RealSeg;                              { Real mode segment }
+               Rg.DX := RealOfs;                              { Real mode offset }
+             end
+           else
+             begin
+               Rg.ES:=0;
+               Rg.DX:=0;
+             end;
+           RealIntr($33, Rg);                             { Set interrupt 33 }
+         end;
+       CurrentMask:=Mask;
+     End;
+   End;
+  If (Error <> 0) Then
+   Begin
+     Writeln('GO32V2 mouse handler set failed !!');
+     ReadLn;                                          { Wait for user to see }
+   End;
+END;
+
+
+{ We need to remove the mouse callback before exiting !! PM }
+
+const StoredExit : Pointer = Nil;
+      FirstMouseInitDone : boolean = false;
+
+procedure MouseSafeExit;
+begin
+  ExitProc:=StoredExit;
+  if MouseCallBack<>Nil then
+    Mouse_Action(0, Nil);
+  if not FirstMouseInitDone then
+    exit;
+  FirstMouseInitDone:=false;
+  Unlock_Code(Pointer(@Mouse_Trap), 400);            { Release trap code }
+  Unlock_Code(Pointer(@MouseInt), 400);               { Lock MouseInt code  }
+  Unlock_Data(ActionRegs, SizeOf(TRealRegs));        { Release registers }
+{$ifdef DEBUG}
+  Unlock_Data(EntryEDI, 4*SizeOf(longint));
+  Unlock_Data(callcounter, 2*SizeOf(longint));
+{$endif DEBUG}
+  { unlock Mouse Queue and related stuff ! }
+  Unlock_Data(PendingMouseEvent,
+        MouseEventBufSize*Sizeof(TMouseEvent)+2*Sizeof(PMouseEvent)+256);
+  UnLock_Data(MouseCallBack,SizeOf(Pointer));
+  Release_mouse_bridge;
+end;
+
+
+procedure InitMouse;
+begin
+  if not MousePresent then
+    begin
+      if DetectMouse=0 then
+        begin
+          Writeln('No mouse driver found ');
+          exit;
+        end
+      else
+        MousePresent:=true;
+    end;
+  PendingMouseHead:=@PendingMouseEvent;
+  PendingMouseTail:=@PendingMouseEvent;
+  PendingMouseEvents:=0;
+  FillChar(LastMouseEvent,sizeof(TMouseEvent),0);
+
+  { don't do this twice !! PM }
+
+  If not FirstMouseInitDone then
+    begin
+      StoredExit:=ExitProc;
+      ExitProc:=@MouseSafeExit;
+      Lock_Code(Pointer(@Mouse_Trap), 400);              { Lock trap code }
+      Lock_Code(Pointer(@MouseInt), 400);               { Lock MouseInt code  }
+      Lock_Data(ActionRegs, SizeOf(TRealRegs));          { Lock registers }
+      Lock_Data(MouseCallBack, SizeOf(pointer));
+      { lock Mouse Queue and related stuff ! }
+      Lock_Data(PendingMouseEvent,
+        MouseEventBufSize*Sizeof(TMouseEvent)+2*Sizeof(PMouseEvent)+256);
+{$ifdef DEBUG}
+      Lock_Data(EntryEDI, 4*SizeOf(longint));
+      Lock_Data(callcounter, 2*SizeOf(longint));
+{$endif DEBUG}
+      Allocate_mouse_bridge;
+      FirstMouseInitDone:=true;
+    end;
+  If MouseCallBack=Nil then
+    Mouse_Action($ffff, @MouseInt);                    { Set masks/interrupt }
+  ShowMouse;
+end;
+
+
+procedure DoneMouse;
+begin
+  HideMouse;
+  If (MouseCallBack <> Nil) Then
+    Mouse_Action(0, Nil);                            { Clear mask/interrupt }
+end;
+
+
+function DetectMouse:byte;assembler;
+asm
+        movl    $0x200,%eax
+        movl    $0x33,%ebx
+        int     $0x31
+        movw    %cx,%ax
+        orw     %ax,%dx
+        jz      .Lno_mouse
+        xorl    %eax,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        orw     %ax,%ax
+        jz      .Lno_mouse
+        movl    %ebx,%eax
+.Lno_mouse:
+end;
+
+
+procedure ShowMouse;assembler;
+asm
+        cmpb    $1,MousePresent
+        jne     .LShowMouseExit
+        movl    $1,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+.LShowMouseExit:
+end;
+
+
+procedure HideMouse;assembler;
+asm
+        cmpb    $1,MousePresent
+        jne     .LHideMouseExit
+        movl    $2,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+.LHideMouseExit:
+end;
+
+
+function GetMouseX:word;assembler;
+asm
+        cmpb    $1,MousePresent
+        jne     .LGetMouseXError
+        movl    $3,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        movzwl  %cx,%eax
+        shrl    $3,%eax
+        incl    %eax
+        ret
+.LGetMouseXError:
+        xorl    %eax,%eax
+end;
+
+
+function GetMouseY:word;assembler;
+asm
+        cmpb    $1,MousePresent
+        jne     .LGetMouseYError
+        movl    $3,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        movzwl  %dx,%eax
+        shrl    $3,%eax
+        incl    %eax
+        ret
+.LGetMouseYError:
+        xorl    %eax,%eax
+end;
+
+
+function GetMouseButtons:word;assembler;
+asm
+        cmpb    $1,MousePresent
+        jne     .LGetMouseButtonsError
+        movl    $3,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        movw    %bx,%ax
+        ret
+.LGetMouseButtonsError:
+        xorl    %eax,%eax
+end;
+
+
+procedure SetMouseXY(x,y:word);assembler;
+asm
+        cmpb    $1,MousePresent
+        jne     .LSetMouseXYExit
+        movw    x,%cx
+        movw    y,%dx
+        movl    $4,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+.LSetMouseXYExit:
+end;
+
+
+const
+  LastCallcounter : longint = 0;
+
+procedure GetMouseEvent(var MouseEvent: TMouseEvent);
+begin
+  if not MousePresent then
+    begin
+      Fillchar(MouseEvent,SizeOf(TMouseEvent),#0);
+    end;
+{$ifdef DEBUG}
+  if mouseError>0 then
+    Writeln('Errors in mouse Handler ',MouseError);
+{$ifdef EXTMOUSEDEBUG}
+  if callcounter>LastCallcounter then
+    Writeln('Number of calls in mouse Handler ',Callcounter);
+{$endif EXTMOUSEDEBUG}
+  LastCallcounter:=Callcounter;
+{$endif DEBUG}
+  repeat until PendingMouseEvents>0;
+  MouseEvent:=PendingMouseHead^;
+  inc(PendingMouseHead);
+  if longint(PendingMouseHead)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+   PendingMouseHead:=@PendingMouseEvent;
+  dec(PendingMouseEvents);
+  if (LastMouseEvent.x<>MouseEvent.x) or (LastMouseEvent.y<>MouseEvent.y) then
+   MouseEvent.Action:=MouseActionMove;
+  if (LastMouseEvent.Buttons<>MouseEvent.Buttons) then
+   begin
+     if (LastMouseEvent.Buttons=0) then
+      MouseEvent.Action:=MouseActionDown
+     else
+      MouseEvent.Action:=MouseActionUp;
+   end;
+  LastMouseEvent:=MouseEvent;
+end;
+
+
+function PollMouseEvent(var MouseEvent: TMouseEvent):boolean;
+begin
+  if PendingMouseEvents>0 then
+   begin
+     MouseEvent:=PendingMouseHead^;
+     PollMouseEvent:=true;
+   end
+  else
+   PollMouseEvent:=false;
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:30  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  1999/12/08 13:25:20  pierre
+   * fix form bug 731
+
+  Revision 1.12  1999/11/24 23:36:56  peter
+    * moved to packages dir
+
+  Revision 1.11  1999/10/18 15:46:24  pierre
+   * not int $0x33 call if no mouse driver present
+
+  Revision 1.10  1999/10/18 07:37:05  pierre
+   * Unlock code moved to exitproc because CWSDPMI has no lock counter
+
+  Revision 1.9  1999/10/16 08:35:52  jonas
+    * MouseCallBack was never unlocked
+
+  Revision 1.8  1999/10/15 23:53:07  pierre
+   * mouse problem with CWSDPMI solved
+
+  Revision 1.7  1999/10/15 11:46:33  pierre
+   * MouseInt was not locked !!
+
+  Revision 1.6  1999/03/03 16:42:27  pierre
+   + test for NT compatibility
+
+  Revision 1.5  1999/02/19 16:44:48  peter
+    * fixed (esi) which also got the 0xffff limit under NT
+
+  Revision 1.4  1999/02/19 12:28:39  pierre
+    + Uses now v2prt0_ds_alias for RMCB regs
+      regs are located in text section of v2prt0.as
+      so that its offset is below $ffff limit (for window NT !)
+
+  Revision 1.3  1999/02/08 09:39:13  pierre
+   * added exitproc to avoid real mode crash with function 12 of mouse interrupt
+
+  Revision 1.2  1998/12/11 00:13:19  peter
+    + SetMouseXY
+    * use far for exitproc procedure
+
+  Revision 1.1  1998/12/04 12:48:27  peter
+    * moved some dirs
+
+  Revision 1.2  1998/10/28 21:18:25  peter
+    * more fixes
+
+  Revision 1.1  1998/10/28 00:02:08  peter
+    + mouse
+    + video.clearscreen, video.videobufsize
+
+}

api/go32v2/vesamode.pas

@@ -0,0 +1,151 @@
+{
+   $Id$
+   VESA-Textmode support for the DOS version of the FPC API
+
+   Copyright (c) 1999 by Florian Klaempfl
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+}
+unit vesamode;
+
+  interface
+
+  implementation
+
+    uses
+       dos,go32,dpmiexcp,video;
+
+    type
+       twordarray = array[0..0] of word;
+
+       pwordarray = ^twordarray;
+       TVESAInfoBlock = record
+	 VESASignature   : ARRAY[0..3] OF CHAR;
+	 VESAVersion     : WORD;
+	 OEMStringPtr    : PChar;
+	 Capabilities    : LONGINT;
+	 VideoModePtr    : pwordarray;
+	 TotalMemory     : WORD;
+	 Reserved        : ARRAY[1..242] OF BYTE;
+       end;
+
+    function ReturnSuperVGAInfo(var ib : TVESAInfoBLock) : Word;
+
+      var
+	 regs : registers;
+
+      begin
+	 regs.ah:=$4f;
+	 regs.al:=0;
+	 regs.es:=tb_segment;
+	 regs.di:=tb_offset;
+	 intr($10,regs);
+	 dosmemget(tb_segment,tb_offset,ib,sizeof(ib));
+	 ReturnSuperVGAInfo:=regs.ax;
+      end;
+
+    function SetSuperVGAMode(m : word) : word;
+
+      var
+	 regs : registers;
+
+      begin
+	 regs.ah:=$4f;
+	 regs.al:=2;
+	 regs.bx:=m;
+	 intr($10,regs);
+	 SetSuperVGAMode:=regs.ax;
+      end;
+
+    function SetVESAMode(const VideoMode: TVideoMode; Params: Longint): Boolean;
+
+      var
+	 w : word;
+
+      begin
+	 w:=SetSuperVGAMode(Params);
+         if w<>$4f then
+	   SetVESAMode:=false
+	 else
+           begin
+              SetVESAMode:=true;
+              ScreenWidth:=VideoMode.Col;
+              ScreenHeight:=VideoMode.Row;
+              ScreenColor:=true;
+              // cheat to get a correct mouse
+              {
+              mem[$40:$84]:=ScreenHeight-1;
+              mem[$40:$4a]:=ScreenWidth;
+              memw[$40:$4c]:=ScreenHeight*((ScreenWidth shl 1)-1);
+              }
+           end;
+      end;
+
+var
+   infoblock : TVESAInfoBLock;
+   i : longint;
+   m : word;
+
+begin
+   ReturnSuperVGAInfo(infoblock);
+   if not((infoblock.VESASignature[0]<>'V') or
+      (infoblock.VESASignature[1]<>'E') or
+      (infoblock.VESASignature[2]<>'S') or
+      (infoblock.VESASignature[3]<>'A')) then
+     begin
+{$R-}
+   i:=0;
+   while true do
+     begin
+	dosmemget(hi(dword(infoblock.VideoModePtr)),lo(dword(infoblock.VideoModePtr))+i*2,m,2);
+	case m of
+           264:
+             RegisterVideoMode(80,60,true,@SetVESAMode,264);
+           265:
+             RegisterVideoMode(132,25,true,@SetVESAMode,265);
+           266:
+             RegisterVideoMode(132,43,true,@SetVESAMode,266);
+           267:
+             RegisterVideoMode(132,50,true,@SetVESAMode,267);
+           268:
+             RegisterVideoMode(132,60,true,@SetVESAMode,268);
+	   $ffff:
+	     break;
+	end;
+	inc(i);
+     end;
+   end;
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:30  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  1999/12/23 22:37:38  pierre
+    * Use @SetVesaMode for normal FPC syntax
+    * variable I was not initialized in unit initialization!!
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.2  1999/03/14 17:43:02  florian
+    + 80x50 mode support added
+    * some bugs in VESA mode support removed
+
+  Revision 1.1  1999/03/13 17:29:39  florian
+    + first implementation for VESA 1.x, only standard modes are supported
+
+}

api/go32v2/video.inc

@@ -0,0 +1,333 @@
+{
+  System independent low-level video interface for go32v2
+
+  $Id$
+}
+
+{$ASMMODE ATT}
+
+uses
+  go32;
+
+var
+  VideoSeg    : word;
+  OldVideoBuf : PVideoBuf;
+
+  { used to know if LastCursorType is valid }
+const
+  InitVideoCalled : boolean = false;
+  LastCursorType : word = crUnderline;
+
+{ allways set blink state again }
+
+procedure SetHighBitBlink;
+var
+  regs : trealregs;
+begin
+  regs.ax:=$1003;
+  regs.bx:=$0001;
+  realintr($10,regs);
+end;
+
+procedure InitVideo;
+var
+  regs : trealregs;
+begin
+  VideoSeg:=$b800;
+  if (ScreenWidth=$ffff) or (ScreenHeight=$ffff) or
+    (ScreenWidth=0) or (ScreenHeight=0) then
+    begin
+       ScreenColor:=true;
+       regs.ah:=$0f;
+       realintr($10,regs);
+       if (regs.al and 1)=0 then
+         ScreenColor:=false;
+       if regs.al=7 then
+         begin
+            ScreenColor:=false;
+            VideoSeg:=$b000;
+         end
+       else
+         VideoSeg:=$b800;
+       ScreenWidth:=regs.ah;
+       regs.ax:=$1130;
+       regs.bx:=0;
+       realintr($10,regs);
+       ScreenHeight:=regs.dl+1;
+    end;
+  regs.ah:=$03;
+  regs.bh:=0;
+  realintr($10,regs);
+  CursorLines:=regs.cl;
+  CursorX:=regs.dl;
+  CursorY:=regs.dh;
+  If InitVideoCalled then
+    Begin
+      FreeMem(VideoBuf,VideoBufSize);
+      FreeMem(OldVideoBuf,VideoBufSize);
+    End;
+{ allocate pmode memory buffer }
+  VideoBufSize:=ScreenWidth*ScreenHeight*2;
+  GetMem(VideoBuf,VideoBufSize);
+  GetMem(OldVideoBuf,VideoBufSize);
+  InitVideoCalled:=true;
+  SetHighBitBlink;
+  SetCursorType(LastCursorType);
+  { ClearScreen; removed here
+    to be able to catch the content of the monitor }
+
+end;
+
+
+procedure DoneVideo;
+begin
+  If InitVideoCalled then
+    Begin
+      LastCursorType:=GetCursorType;
+      ClearScreen;
+      SetCursorType(crUnderLine);
+      SetCursorPos(0,0);
+      FreeMem(VideoBuf,VideoBufSize);
+      VideoBuf:=nil;
+      FreeMem(OldVideoBuf,VideoBufSize);
+      OldVideoBuf:=nil;
+      InitVideoCalled:=false;
+      VideoBufSize:=0;
+    End;
+end;
+
+
+function GetCapabilities: Word;
+begin
+  GetCapabilities := $3F;
+end;
+
+
+procedure SetCursorPos(NewCursorX, NewCursorY: Word);
+var
+  regs : trealregs;
+begin
+  regs.ah:=$02;
+  regs.bh:=0;
+  regs.dh:=NewCursorY;
+  regs.dl:=NewCursorX;
+  realintr($10,regs);
+  CursorY:=regs.dh;
+  CursorX:=regs.dl;
+end;
+
+{ I don't know the maximum value for the scan line
+  probably 7 or 15 depending on resolution !!
+  }
+function GetCursorType: Word;
+var
+  regs : trealregs;
+begin
+  regs.ah:=$03;
+  regs.bh:=0;
+  realintr($10,regs);
+  GetCursorType:=crHidden;
+  if (regs.ch and $60)=0 then
+   begin
+     GetCursorType:=crBlock;
+     if (regs.ch and $1f)<>0 then
+      begin
+        GetCursorType:=crHalfBlock;
+        if regs.cl+1=(regs.ch and $1F) then
+         GetCursorType:=crUnderline;
+      end;
+   end;
+end;
+
+
+procedure SetCursorType(NewType: Word);
+var
+  regs : trealregs;
+const
+  MaxCursorLines = 7;
+begin
+  regs.ah:=$01;
+  regs.bx:=NewType;
+  case NewType of
+   crHidden    : regs.cx:=$2000;
+   crHalfBlock : begin
+                   regs.ch:=MaxCursorLines shr 1;
+                   regs.cl:=MaxCursorLines;
+                 end;
+   crBlock     : begin
+                   regs.ch:=0;
+                   regs.cl:=MaxCursorLines;
+                 end;
+   else          begin
+                   regs.ch:=MaxCursorLines-1;
+                   regs.cl:=MaxCursorLines;
+                 end;
+  end;
+  realintr($10,regs);
+end;
+
+
+function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean;
+type
+  wordrec=packed record
+    lo,hi : word;
+  end;
+var
+  regs : trealregs;
+begin
+  regs.ax:=wordrec(Params).lo;
+  regs.bx:=wordrec(Params).hi;
+  realintr($10,regs);
+  defaultvideomodeselector:=true;
+end;
+
+function VideoModeSelector8x8(const VideoMode: TVideoMode; Params: Longint): Boolean;
+type
+  wordrec=packed record
+    lo,hi : word;
+  end;
+var
+  regs : trealregs;
+begin
+  regs.ax:=3;
+  regs.bx:=0;
+  realintr($10,regs);
+  regs.ax:=$1112;
+  regs.bx:=$0;
+  realintr($10,regs);
+  videomodeselector8x8:=true;
+  ScreenColor:=true;
+  ScreenWidth:=80;
+  ScreenHeight:=50;
+end;
+
+procedure ClearScreen;
+begin
+  FillWord(VideoBuf^,VideoBufSize shr 1,$0720);
+  UpdateScreen(true);
+end;
+
+
+procedure UpdateScreen(Force: Boolean);
+begin
+  if LockUpdateScreen<>0 then
+   exit;
+  if not force then
+   begin
+     asm
+        movl    VideoBuf,%esi
+        movl    OldVideoBuf,%edi
+        movl    VideoBufSize,%ecx
+        shrl    $2,%ecx
+        repe
+        cmpsl
+        orl     %ecx,%ecx
+        jz      .Lno_update
+        movb    $1,force
+.Lno_update:
+     end;
+   end;
+  if Force then
+   begin
+{     dosmemput(videoseg,0,videobuf^,VideoBufSize);}
+      asm
+        pushw %es
+        pushl %edi
+        pushl %esi
+
+        xor  %edi, %edi
+        movw videoseg, %di
+        shll $0x4, %edi
+        movl videobuf, %esi
+        movl videobufsize, %ecx
+        movw %fs, %ax
+        movw %ax, %es
+        rep movsb
+
+        popl  %esi
+        popl  %edi
+        popw  %es
+      end ['EAX','ECX'];
+     move(videobuf^,oldvideobuf^,VideoBufSize);
+   end;
+end;
+
+
+procedure RegisterVideoModes;
+begin
+  RegisterVideoMode(40, 25, False,@DefaultVideoModeSelector, $00000000);
+  RegisterVideoMode(40, 25, True, @DefaultVideoModeSelector, $00000001);
+  RegisterVideoMode(80, 25, False,@DefaultVideoModeSelector, $00000002);
+  RegisterVideoMode(80, 25, True, @DefaultVideoModeSelector, $00000003);
+  RegisterVideoMode(80, 50, True, @VideoModeSelector8x8, 0);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:30  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.14  1999/10/03 19:53:26  peter
+    * changed screenheight detection
+
+  Revision 1.13  1999/08/16 18:26:20  peter
+    * asm updatescreen for speed reasons
+
+  Revision 1.12  1999/06/02 11:22:10  pierre
+   * @ needed for proc address
+
+  Revision 1.11  1999/04/01 12:51:51  pierre
+   * removed clearscreen in initvideo for capture
+
+  Revision 1.10  1999/03/21 22:49:40  florian
+    * correct screeneight in 80x50 mode
+
+  Revision 1.9  1999/03/14 22:15:49  florian
+    * my last changes doesn't work correctly, fixed more
+      the screen height calculation works incorrect in 80x50 mode
+
+  Revision 1.8  1999/03/14 17:43:03  florian
+    + 80x50 mode support added
+    * some bugs in VESA mode support removed
+
+  Revision 1.7  1999/02/19 16:42:48  peter
+    * fixed typo
+
+  Revision 1.6  1999/02/19 12:29:52  pierre
+    * several bugs related to Cursor fixed !
+      I still don't know the maximum value for
+      the scan line (depends on resolution used !)
+
+  Revision 1.5  1999/02/08 17:53:17  pierre
+   + added restoring of BlinkState in InitVideo, old mode not stored
+
+  Revision 1.4  1998/12/15 17:17:17  peter
+    + cursor at 1,1 at the end
+
+  Revision 1.3  1998/12/12 19:13:01  peter
+    * keyboard updates
+    * make test target, make all only makes units
+
+  Revision 1.2  1998/12/10 11:41:50  florian
+    * cursor is properly restored in DoneVideo
+
+  Revision 1.1  1998/12/04 12:48:27  peter
+    * moved some dirs
+
+  Revision 1.4  1998/11/01 20:29:11  peter
+    + lockupdatescreen counter to not let updatescreen() update
+
+  Revision 1.3  1998/10/28 21:18:26  peter
+    * more fixes
+
+  Revision 1.2  1998/10/28 00:02:08  peter
+    + mouse
+    + video.clearscreen, video.videobufsize
+
+  Revision 1.1  1998/10/26 11:31:47  peter
+    + inital include files
+
+}

api/inc/Makefile.api

@@ -0,0 +1 @@
+APIOBJECTS=common callspec video keyboard mouse filectrl filesys

api/inc/callspec.pas

@@ -0,0 +1,355 @@
+{
+   $Id$
+
+   This unit provides compiler-independent mechanisms to call special
+   functions, i.e. local functions/procedures, constructors, methods,
+   destructors, etc. As there are no procedural variables for these
+   special functions, there is no Pascal way to call them directly.
+
+   Copyright (c) 1997 Matthias K"oppe <[email protected]>
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************}
+unit CallSpec;
+
+{
+  As of this version, the following compilers are supported. Please
+  port CallSpec to other compilers (including earlier versions) and
+  send your code to the above address.
+
+  Compiler                    Comments
+  --------------------------- -------------------------------------
+  Turbo Pascal 6.0
+  Borland/Turbo Pascal 7.0
+  FPC Pascal 0.99.8
+}
+
+interface
+
+{$i platform.inc}
+
+{
+  The frame pointer points to the local variables of a procedure.
+  Use CurrentFramePointer to address the locals of the current procedure;
+  use PreviousFramePointer to addess the locals of the calling procedure.
+}
+type
+{$ifdef BIT_16}
+   FramePointer = Word;
+{$endif}
+{$ifdef BIT_32}
+   FramePointer = pointer;
+{$endif}
+
+function CurrentFramePointer: FramePointer;
+function PreviousFramePointer: FramePointer;
+
+{ This version of CallSpec supports four classes of special functions.
+  (Please write if you need other classes.)
+  For each, two types of argument lists are allowed:
+
+  `Void' indicates special functions with no explicit arguments.
+    Sample: constructor T.Init;
+  `Pointer' indicates special functions with one explicit pointer argument.
+    Sample: constructor T.Load(var S: TStream);
+}
+
+{ Constructor calls.
+
+  Ctor     Pointer to the constructor.
+  Obj      Pointer to the instance. NIL if new instance to be allocated.
+  VMT      Pointer to the VMT (obtained by TypeOf()).
+  returns  Pointer to the instance.
+}
+function CallVoidConstructor(Ctor: pointer; Obj: pointer; VMT: pointer): pointer;
+function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;
+
+{ Method calls.
+
+  Method   Pointer to the method.
+  Obj      Pointer to the instance. NIL if new instance to be allocated.
+  returns  Pointer to the instance.
+}
+function CallVoidMethod(Method: pointer; Obj: pointer): pointer;
+function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer;
+
+{ Local-function/procedure calls.
+
+  Func     Pointer to the local function (which must be far-coded).
+  Frame    Frame pointer of the wrapping function.
+}
+
+function CallVoidLocal(Func: pointer; Frame: FramePointer): pointer;
+function CallPointerLocal(Func: pointer; Frame: FramePointer; Param1: pointer): pointer;
+
+{ Calls of functions/procedures local to methods.
+
+  Func     Pointer to the local function (which must be far-coded).
+  Frame    Frame pointer of the wrapping method.
+  Obj      Pointer to the object that the method belongs to.
+}
+function CallVoidMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer): pointer;
+function CallPointerMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer; Param1: pointer): pointer;
+
+
+implementation
+
+{$ifdef PPC_FPC}
+
+{$ASMMODE ATT}
+
+{ This indicates an FPC version which uses the same call scheme for
+  method-local and procedure-local procedures, but which expects the
+  ESI register be loaded with the Self pointer in method-local procs. }
+
+type
+  VoidLocal = function(_EBP: FramePointer): pointer;
+  PointerLocal = function(_EBP: FramePointer; Param1: pointer): pointer;
+  VoidMethodLocal = function(_EBP: FRAMEPOINTER): pointer;
+  PointerMethodLocal = function(_EBP: FRAMEPOINTER; Param1: pointer): pointer;
+  VoidConstructor = function(VMT: pointer; Obj: pointer): pointer;
+  PointerConstructor = function(VMT: pointer; Obj: pointer; Param1: pointer): pointer;
+  VoidMethod = function(Obj: pointer): pointer;
+  PointerMethod = function(Obj: pointer; Param1: pointer): pointer;
+
+
+function CallVoidConstructor(Ctor: pointer; Obj: pointer; VMT: pointer): pointer;
+begin
+  { load the object pointer }
+  asm
+        movl Obj, %esi
+  end;
+  CallVoidConstructor := VoidConstructor(Ctor)(VMT, Obj)
+end;
+
+
+function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;
+begin
+  { load the object pointer }
+  asm
+        movl Obj, %esi
+  end;
+  CallPointerConstructor := PointerConstructor(Ctor)(VMT, Obj, Param1)
+end;
+
+
+function CallVoidMethod(Method: pointer; Obj: pointer): pointer;
+begin
+  { load the object pointer }
+  asm
+        movl Obj, %esi
+  end;
+  CallVoidMethod := VoidMethod(Method)(Obj)
+end;
+
+
+function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer;
+begin
+  { load the object pointer }
+  asm
+        movl Obj, %esi
+  end;
+  CallPointerMethod := PointerMethod(Method)(Obj, Param1)
+end;
+
+
+function CallVoidLocal(Func: pointer; Frame: FramePointer): pointer;
+begin
+  CallVoidLocal := VoidLocal(Func)(Frame)
+end;
+
+
+function CallPointerLocal(Func: pointer; Frame: FramePointer; Param1: pointer): pointer;
+begin
+  CallPointerLocal := PointerLocal(Func)(Frame, Param1)
+end;
+
+
+function CallVoidMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer): pointer;
+begin
+  { load the object pointer }
+  asm
+        movl Obj, %esi
+  end;
+  CallVoidMethodLocal := VoidMethodLocal(Func)(Frame)
+end;
+
+
+function CallPointerMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer; Param1: pointer): pointer;
+begin
+  { load the object pointer }
+  asm
+        movl Obj, %esi
+  end;
+  CallPointerMethodLocal := PointerMethodLocal(Func)(Frame, Param1)
+end;
+
+
+function CurrentFramePointer: FramePointer;assembler;
+asm
+    movl %ebp,%eax
+end ['EAX'];
+
+
+function PreviousFramePointer: FramePointer;assembler;
+asm
+    movl (%ebp), %eax
+end ['EAX'];
+
+{$endif PPC_FPC}
+
+
+{$ifdef PPC_BP}
+type
+  VoidConstructor = function(VmtOfs: Word; Obj: pointer): pointer;
+  PointerConstructor = function(Param1: pointer; VmtOfs: Word; Obj: pointer): pointer;
+  VoidMethod = function(Obj: pointer): pointer;
+  PointerMethod = function(Param1: pointer; Obj: pointer): pointer;
+
+function CallVoidConstructor(Ctor: pointer; Obj: pointer; VMT: pointer): pointer;
+begin
+  CallVoidConstructor := VoidConstructor(Ctor)(Ofs(VMT^), Obj)
+end;
+
+
+function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;
+begin
+  CallPointerConstructor := PointerConstructor(Ctor)(Param1, Ofs(VMT^), Obj)
+end;
+
+
+function CallVoidMethod(Method: pointer; Obj: pointer): pointer;
+begin
+  CallVoidMethod := VoidMethod(Method)(Obj)
+end;
+
+
+function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer;
+begin
+  CallPointerMethod := PointerMethod(Method)(Param1, Obj)
+end;
+
+
+function CallVoidLocal(Func: pointer; Frame: FramePointer): pointer; assembler;
+asm
+{$IFDEF Windows}
+        MOV     AX,[Frame]
+        AND     AL,0FEH
+        PUSH    AX
+{$ELSE}
+        push    [Frame]
+{$ENDIF}
+        call    dword ptr Func
+end;
+
+
+function CallPointerLocal(Func: pointer; Frame: FramePointer; Param1: pointer): pointer; assembler;
+asm
+        mov     ax, word ptr Param1
+        mov     dx, word ptr Param1+2
+        push    dx
+        push    ax
+{$IFDEF Windows}
+        MOV     AX,[Frame]
+        AND     AL,0FEH
+        PUSH    AX
+{$ELSE}
+        push    [Frame]
+{$ENDIF}
+        call    dword ptr Func
+end;
+
+
+function CallVoidMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer): pointer; assembler;
+asm
+{$IFDEF Windows}
+        MOV     AX,[Frame]
+        AND     AL,0FEH
+        PUSH    AX
+{$ELSE}
+        push    [Frame]
+{$ENDIF}
+        call    dword ptr Func
+end;
+
+
+function CallPointerMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer; Param1: pointer): pointer; assembler;
+asm
+        mov     ax, word ptr Param1
+        mov     dx, word ptr Param1+2
+        push    dx
+        push    ax
+{$IFDEF Windows}
+        MOV     AX,[Frame]
+        AND     AL,0FEH
+        PUSH    AX
+{$ELSE}
+        push    [Frame]
+{$ENDIF}
+        call    dword ptr Func
+end;
+
+
+function CurrentFramePointer: FramePointer; assembler;
+asm
+        mov     ax, bp
+end;
+
+
+function PreviousFramePointer: FramePointer; assembler;
+asm
+        mov     ax, ss:[bp]
+end;
+
+{$endif PPC_BP}
+
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:30  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/12/23 19:36:47  peter
+    * place unitfiles in target dirs
+
+  Revision 1.1  1999/11/24 23:36:37  peter
+    * moved to packages dir
+
+  Revision 1.2  1998/12/16 21:57:16  peter
+    * fixed currentframe,previousframe
+    + testcall to test the callspec unit
+
+  Revision 1.1  1998/12/04 12:48:24  peter
+    * moved some dirs
+
+  Revision 1.5  1998/12/04 09:53:44  peter
+    * removed objtemp global var
+
+  Revision 1.4  1998/11/24 17:14:24  peter
+    * fixed esi loading
+
+
+  Date       Version  Who     Comments
+  ---------- -------- ------- -------------------------------------
+  19-Sep-97  0.1      mkoeppe Initial version.
+  22-Sep-97  0.11     fk      0.9.3 support added, self isn't expected
+                              on the stack in local procedures of methods
+  23-Sep-97  0.12     mkoeppe Cleaned up 0.9.3 conditionals.
+  03-Oct-97  0.13     mkoeppe Fixed esi load in FPC 0.9
+  22-Oct-98  0.14     pfv     0.99.8 support for FPC
+}

api/inc/common.pas

@@ -0,0 +1,547 @@
+{****************************************************************************
+
+   Common types, and definitions
+
+   Copyright (c) 1997 Balazs Scheidler ([email protected])
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+   
+   
+   This library 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.  See the GNU
+   Library General Public License for more details.
+   
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+   $Id$
+ ****************************************************************************
+
+ Changelog:
+   
+   Common version 0.2.6
+
+   Date       Version  Who     Comments
+   07/12/97   0.1      Bazsi   Initial implementation (bazsi)
+   07/18/97   0.2      Bazsi   Linux specific error codes added
+   07/18/97   0.2.1    Bazsi   Some syntactical errors removed...
+   07/28/97   0.2.2    Bazsi   Base error code for Video registered
+   07/29/97   0.2.3    Bazsi   Some basic types added (PByte, PWord etc)
+   08/08/97   0.2.4    Bazsi   Finalized error handling code (Brad's code added)
+   08/27/97   0.2.5    Bazsi   BP doesn't like function types as return-values
+                               for functions, returning Pointer instead
+   09/06/97   0.2.6    Bazsi   Added base error code for Keyboard
+   11/06/97   0.2.7    Bazsi   Added base error code for FileCtrl
+   
+ Todo:
+ 
+ *  Some types found in the DOS unit should be included here (TextRec maybe 
+    renamed to TTextRec, FileRec etc.)
+ *  Other platform specific error codes.
+
+ ****************************************************************************}
+unit Common;
+
+interface
+
+{$i platform.inc}
+
+const
+  { Error codes }
+  errOk                 = 0;
+  errVioBase            = 1000;
+  errKbdBase            = 1010;
+  errFileCtrlBase	= 1020;
+  errMouseBase          = 1030;
+  { The following ranges have been defined for error codes:
+     0      - 1000           OS dependent codes
+     1000   - 10000          API reserved codes
+     10000  -                Add-on unit errors 
+    Before anyone adding a unit, contact [email protected] to assign a base
+    error code, to avoid collisions. 
+    
+    The symbolic names of error codes should be defined in the unit which uses
+    those error codes, except for OS dependent ones, which should be defined here
+    enclosed in IFDEFs. (The reason is that not always you can't always decide
+    which error-code belongs to one unit or the other) }
+
+{$IFDEF OS_Linux}
+  { for a more complete description of each error check /usr/include/asm/errno.h }
+  errNotPermitted         =   1;
+  errFileNotFound         =   2;
+  errNoSuchProcess        =   3;
+  errInterruptedCall      =   4;
+  errIOError              =   5;
+  errNoDevAddr            =   6;
+  errTooManyArguments     =   7;
+  errExecError            =   8;
+  errBadFileHandle        =   9;
+  errNoChild              =  10;
+  errTryAgain             =  11;
+  errWouldBlock           =  errTryAgain;
+  errOutOfMemory          =  12;
+  errNoPermission         =  13;
+  errInvalidAddress       =  14;  { Invalid pointer passed to kernel }
+  errNotBlockDev          =  15;
+  errDeviceBusy           =  16;
+  errFileExists           =  17;
+  errCrossDevice          =  18;  
+  errNoSuchDev            =  19;
+  errNotDirectory         =  20;
+  errIsDirectory          =  21;
+  errInvalidArgument      =  22;
+  errFileTableOverflow    =  23;
+  errTooManyOpenFiles     =  24;
+  errNotATTY              =  25;
+  errTextBusy             =  26;
+  errFileTooLarge         =  27;
+  errDiskFull             =  28;
+  errIllegalSeek          =  29;
+  errReadOnlyFS           =  30;
+  errTooManyLinks         =  31;
+  errBrokenPipe		  =  32;
+  errMathDomain           =  33;  { Math domain error, what does this mean? }
+  errMathRange            =  34;  { Math result out of range }
+  errDeadLock             =  35;
+  errFileNameTooLong      =  36;
+  errNoLock               =  37;  { No record locks available }
+  errNotImplemented       =  38;  { Kernel function not implemented }
+  errDirNotEmpty          =  39;
+  errSymlinkLoop          =  40;
+  errNoMessage            =  41;  { ??? maybe the IPC getmsg call returns this }
+  { Here are some errors that are too cryptic for me, I think they are not used
+    under Linux, only on some mainframes (channel errors etc) }
+  errBadFont              =  59;
+  errNotStream            =  60;
+  errNoData               =  61;
+  errTimeOut              =  62;
+  errNoMoreStreams        =  63;
+  errNoNetwork            =  64;
+  errPackageNotInstalled  =  65; { ??? }
+  errRemote               =  66;
+  errSevereLink           =  67;
+  errAdvertise            =  68; { Advertise error??? }
+  errSrMount              =  69;
+  errCommunication        =  70; { Communication error on send? }
+  errProtocol             =  71; { Protocol error }
+  errMuiltiHop            =  72; 
+  errDotDot               =  73; { RFS specific error ???}
+  errBadMessage           =  74; { Not a data message }
+  errOverflow             =  75;
+  errNotUnique            =  76; { Network name not unique }
+  errBadFileHandleState   =  77;
+  errRemoteChange         =  78; { Remote address changed }
+  errLibAccess            =  79; { Cannot access the needed shared lib }
+  errLibCorrupt           =  80; { Shared library corrupted }
+  errLibScn               =  81;
+  errLibTooMany           =  82; { Too many shared libraries }
+  errLibExec              =  83; { Attempting to execute a shared lib }
+  errIllegalSequence      =  84; { Illegal byte sequence ??? }
+  errRestart              =  85; { interrupted system call should be restarted }
+  errStreamPipe           =  86;
+  errTooManyUsers         =  87;
+  errNotSocket            =  88;
+  errDestAddrRequired     =  89;
+  errMessageTooLong       =  90;
+  errProtocolType         =  91;
+  errNoSuchProtocol       =  92;
+  errProtocolNotSupported =  93;
+  errSocketTypeNotSupported = 94;
+  errOperationNotSupported=  95;
+  errPFamilyNotSupported  =  96; { Protocol family not supported }
+  errAFamilyNotSupported  =  97; { Address family not supported }
+  errAddressInUse         =  98;
+  errAddressNotAvailable  =  99;
+  errNetDown              = 100;
+  errNetUnreachable       = 101;
+  errNetReset             = 102;
+  errConnAborted          = 103;
+  errConnReset            = 104;
+  errNoBufs               = 105;
+  errAlreadyConn          = 106;
+  errNotConn              = 107;
+  errShutdown             = 108;
+  errTooManyRefs          = 109;
+  errConnTimeOut          = 110;
+  errConnRefused          = 111;
+  errHostDown             = 112;
+  errNoRoute              = 113; { No route to host }
+  errOperationProgress    = 114; { Operation already in progress }
+  errStaleNFSHandle       = 115;
+  errStrucClean           = 116; { Structure needs cleaning ? }
+  { Xenix specific codes left out }
+  errRemoteIO             = 121;
+  errQuotaExceeded        = 122; 
+{$ENDIF}
+{$IFDEF OS_DOS}
+  { DOS specific error-codes to be added }
+{$ENDIF}
+
+
+
+type
+{$IFDEF BIT_32}
+  CPUWord = Longint;
+  CPUInt = Longint;
+{$ELSE}
+  CPUWord = Word;
+  CPUInt = Integer;
+{$ENDIF}
+
+  PByte = ^Byte;
+  PWord = ^Word;
+  PLongint = ^Longint;
+
+{ This code is taken from Brad Williams code, with some modifications }
+type
+  TErrorHandlerReturnValue = (errRetry, errAbort, errContinue);
+  { errRetry = retry the operation,
+    errAbort = abort, return error code,
+    errContinue = abort, without returning errorcode }
+
+  TErrorHandler = function (Code: Longint; Info: Pointer): TErrorHandlerReturnValue;
+    { ErrorHandler is the standard procedural interface for all error functions.
+      Info may contain any data type specific to the error code passed to the
+      function. }
+
+function GetErrorCode: Longint;
+{ Returns the last error code, and resets it to 0 (errOK) }
+function GetErrorInfo: Pointer;
+{ Returns the info assigned to the previous error, doesn't reset the value to nil }
+{$IFDEF PPC_BP}
+function SetErrorHandler(AErrorHandler: TErrorHandler): Pointer;
+{$ELSE}
+function SetErrorHandler(AErrorHandler: TErrorHandler): TErrorHandler;
+{$ENDIF}
+{ Sets ErrorHandler to AErrorHandler, and returns the old one }
+function DefaultErrorHandler(AErrorCode: Longint; AErrorInfo: Pointer): TErrorHandlerReturnValue;
+{ Default error handler, simply sets error code, and returns errContinue }
+
+const
+  ErrorCode: Longint = errOk;
+  ErrorInfo: Pointer = nil;
+  ErrorHandler: TErrorHandler = DefaultErrorHandler;
+
+implementation
+
+function GetErrorCode: Longint;
+begin
+  GetErrorCode := ErrorCode;
+  ErrorCode := 0;
+end;
+
+function GetErrorInfo: Pointer;
+begin
+  GetErrorInfo := ErrorInfo;
+end;
+
+{$IFDEF PPC_BP}
+function SetErrorHandler(AErrorHandler: TErrorHandler): Pointer;
+begin
+  SetErrorHandler := @ErrorHandler;
+  ErrorHandler := AErrorHandler;
+end;
+{$ELSE}
+function SetErrorHandler(AErrorHandler: TErrorHandler): TErrorHandler;
+begin
+  SetErrorHandler := ErrorHandler;
+  ErrorHandler := AErrorHandler;
+end;
+{$ENDIF}
+
+function DefaultErrorHandler(AErrorCode: Longint; AErrorInfo: Pointer): TErrorHandlerReturnValue;
+begin
+  ErrorCode := AErrorCode;
+  ErrorInfo := AErrorInfo;
+  DefaultErrorHandler := errAbort; { return error code }
+end;
+
+end.
+{
+   $Id$
+
+   Common types, and definitions
+
+   Copyright (c) 1997 Balazs Scheidler ([email protected])
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+
+ Todo:
+
+ *  Some types found in the DOS unit should be included here (TextRec maybe
+    renamed to TTextRec, FileRec etc.)
+ *  Other platform specific error codes.
+
+ ****************************************************************************}
+unit Common;
+
+interface
+
+{$i platform.inc}
+
+const
+  { Error codes }
+  errOk                 = 0;
+  errVioBase            = 1000;
+  errKbdBase            = 1010;
+  errFileCtrlBase       = 1020;
+  { The following ranges have been defined for error codes:
+     0      - 1000           OS dependent codes
+     1000   - 10000          API reserved codes
+     10000  -                Add-on unit errors
+    Before anyone adding a unit, contact [email protected] to assign a base
+    error code, to avoid collisions.
+
+    The symbolic names of error codes should be defined in the unit which uses
+    those error codes, except for OS dependent ones, which should be defined here
+    enclosed in IFDEFs. (The reason is that not always you can't always decide
+    which error-code belongs to one unit or the other) }
+
+{$IFDEF OS_Linux}
+  { for a more complete description of each error check /usr/include/asm/errno.h }
+  errNotPermitted         =   1;
+  errFileNotFound         =   2;
+  errNoSuchProcess        =   3;
+  errInterruptedCall      =   4;
+  errIOError              =   5;
+  errNoDevAddr            =   6;
+  errTooManyArguments     =   7;
+  errExecError            =   8;
+  errBadFileHandle        =   9;
+  errNoChild              =  10;
+  errTryAgain             =  11;
+  errWouldBlock           =  errTryAgain;
+  errOutOfMemory          =  12;
+  errNoPermission         =  13;
+  errInvalidAddress       =  14;  { Invalid pointer passed to kernel }
+  errNotBlockDev          =  15;
+  errDeviceBusy           =  16;
+  errFileExists           =  17;
+  errCrossDevice          =  18;
+  errNoSuchDev            =  19;
+  errNotDirectory         =  20;
+  errIsDirectory          =  21;
+  errInvalidArgument      =  22;
+  errFileTableOverflow    =  23;
+  errTooManyOpenFiles     =  24;
+  errNotATTY              =  25;
+  errTextBusy             =  26;
+  errFileTooLarge         =  27;
+  errDiskFull             =  28;
+  errIllegalSeek          =  29;
+  errReadOnlyFS           =  30;
+  errTooManyLinks         =  31;
+  errBrokenPipe           =  32;
+  errMathDomain           =  33;  { Math domain error, what does this mean? }
+  errMathRange            =  34;  { Math result out of range }
+  errDeadLock             =  35;
+  errFileNameTooLong      =  36;
+  errNoLock               =  37;  { No record locks available }
+  errNotImplemented       =  38;  { Kernel function not implemented }
+  errDirNotEmpty          =  39;
+  errSymlinkLoop          =  40;
+  errNoMessage            =  41;  { ??? maybe the IPC getmsg call returns this }
+  { Here are some errors that are too cryptic for me, I think they are not used
+    under Linux, only on some mainframes (channel errors etc) }
+  errBadFont              =  59;
+  errNotStream            =  60;
+  errNoData               =  61;
+  errTimeOut              =  62;
+  errNoMoreStreams        =  63;
+  errNoNetwork            =  64;
+  errPackageNotInstalled  =  65; { ??? }
+  errRemote               =  66;
+  errSevereLink           =  67;
+  errAdvertise            =  68; { Advertise error??? }
+  errSrMount              =  69;
+  errCommunication        =  70; { Communication error on send? }
+  errProtocol             =  71; { Protocol error }
+  errMuiltiHop            =  72;
+  errDotDot               =  73; { RFS specific error ???}
+  errBadMessage           =  74; { Not a data message }
+  errOverflow             =  75;
+  errNotUnique            =  76; { Network name not unique }
+  errBadFileHandleState   =  77;
+  errRemoteChange         =  78; { Remote address changed }
+  errLibAccess            =  79; { Cannot access the needed shared lib }
+  errLibCorrupt           =  80; { Shared library corrupted }
+  errLibScn               =  81;
+  errLibTooMany           =  82; { Too many shared libraries }
+  errLibExec              =  83; { Attempting to execute a shared lib }
+  errIllegalSequence      =  84; { Illegal byte sequence ??? }
+  errRestart              =  85; { interrupted system call should be restarted }
+  errStreamPipe           =  86;
+  errTooManyUsers         =  87;
+  errNotSocket            =  88;
+  errDestAddrRequired     =  89;
+  errMessageTooLong       =  90;
+  errProtocolType         =  91;
+  errNoSuchProtocol       =  92;
+  errProtocolNotSupported =  93;
+  errSocketTypeNotSupported = 94;
+  errOperationNotSupported=  95;
+  errPFamilyNotSupported  =  96; { Protocol family not supported }
+  errAFamilyNotSupported  =  97; { Address family not supported }
+  errAddressInUse         =  98;
+  errAddressNotAvailable  =  99;
+  errNetDown              = 100;
+  errNetUnreachable       = 101;
+  errNetReset             = 102;
+  errConnAborted          = 103;
+  errConnReset            = 104;
+  errNoBufs               = 105;
+  errAlreadyConn          = 106;
+  errNotConn              = 107;
+  errShutdown             = 108;
+  errTooManyRefs          = 109;
+  errConnTimeOut          = 110;
+  errConnRefused          = 111;
+  errHostDown             = 112;
+  errNoRoute              = 113; { No route to host }
+  errOperationProgress    = 114; { Operation already in progress }
+  errStaleNFSHandle       = 115;
+  errStrucClean           = 116; { Structure needs cleaning ? }
+  { Xenix specific codes left out }
+  errRemoteIO             = 121;
+  errQuotaExceeded        = 122;
+{$ENDIF}
+{$IFDEF OS_DOS}
+  { DOS specific error-codes to be added }
+{$ENDIF}
+
+
+
+type
+{$IFDEF BIT_32}
+  CPUWord = Longint;
+  CPUInt = Longint;
+{$ELSE}
+  CPUWord = Word;
+  CPUInt = Integer;
+{$ENDIF}
+
+  PByte = ^Byte;
+  PWord = ^Word;
+  PLongint = ^Longint;
+
+{ This code is taken from Brad Williams code, with some modifications }
+type
+  TErrorHandlerReturnValue = (errRetry, errAbort, errContinue);
+  { errRetry = retry the operation,
+    errAbort = abort, return error code,
+    errContinue = abort, without returning errorcode }
+
+  TErrorHandler = function (Code: Longint; Info: Pointer): TErrorHandlerReturnValue;
+    { ErrorHandler is the standard procedural interface for all error functions.
+      Info may contain any data type specific to the error code passed to the
+      function. }
+
+function GetErrorCode: Longint;
+{ Returns the last error code, and resets it to 0 (errOK) }
+function GetErrorInfo: Pointer;
+{ Returns the info assigned to the previous error, doesn't reset the value to nil }
+{$IFDEF PPC_BP}
+function SetErrorHandler(AErrorHandler: TErrorHandler): Pointer;
+{$ELSE}
+function SetErrorHandler(AErrorHandler: TErrorHandler): TErrorHandler;
+{$ENDIF}
+{ Sets ErrorHandler to AErrorHandler, and returns the old one }
+function DefaultErrorHandler(AErrorCode: Longint; AErrorInfo: Pointer): TErrorHandlerReturnValue;
+{ Default error handler, simply sets error code, and returns errContinue }
+
+const
+  ErrorCode: Longint = errOk;
+  ErrorInfo: Pointer = nil;
+  ErrorHandler: TErrorHandler = DefaultErrorHandler;
+
+implementation
+
+function GetErrorCode: Longint;
+begin
+  GetErrorCode := ErrorCode;
+  ErrorCode := 0;
+end;
+
+function GetErrorInfo: Pointer;
+begin
+  GetErrorInfo := ErrorInfo;
+end;
+
+{$IFDEF PPC_BP}
+function SetErrorHandler(AErrorHandler: TErrorHandler): Pointer;
+begin
+  SetErrorHandler := @ErrorHandler;
+  ErrorHandler := AErrorHandler;
+end;
+{$ELSE}
+function SetErrorHandler(AErrorHandler: TErrorHandler): TErrorHandler;
+begin
+  SetErrorHandler := ErrorHandler;
+  ErrorHandler := AErrorHandler;
+end;
+{$ENDIF}
+
+function DefaultErrorHandler(AErrorCode: Longint; AErrorInfo: Pointer): TErrorHandlerReturnValue;
+begin
+  ErrorCode := AErrorCode;
+  ErrorInfo := AErrorInfo;
+  DefaultErrorHandler := errAbort; { return error code }
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/12/23 19:36:47  peter
+    * place unitfiles in target dirs
+
+  Revision 1.1  1999/11/24 23:36:37  peter
+    * moved to packages dir
+
+  Revision 1.1  1998/12/04 12:48:24  peter
+    * moved some dirs
+
+  Revision 1.5  1998/10/28 00:02:05  peter
+    + mouse
+    + video.clearscreen, video.videobufsize
+
+  Revision 1.4  1998/10/26 11:22:48  peter
+    * updates
+
+  
+   Date       Version  Who     Comments
+   07/12/97   0.1      Bazsi   Initial implementation (bazsi)
+   07/18/97   0.2      Bazsi   Linux specific error codes added
+   07/18/97   0.2.1    Bazsi   Some syntactical errors removed...
+   07/28/97   0.2.2    Bazsi   Base error code for Video registered
+   07/29/97   0.2.3    Bazsi   Some basic types added (PByte, PWord etc)
+   08/08/97   0.2.4    Bazsi   Finalized error handling code (Brad's code added)
+   08/27/97   0.2.5    Bazsi   BP doesn't like function types as return-values
+                               for functions, returning Pointer instead
+   09/06/97   0.2.6    Bazsi   Added base error code for Keyboard
+   11/06/97   0.2.7    Bazsi   Added base error code for FileCtrl
+}

api/inc/filectrl.pas

@@ -0,0 +1,207 @@
+{
+   $Id$
+
+   System independent low-level file interface
+
+   Copyright (c) 1997 Balazs Scheidler ([email protected])
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+
+  Todo:
+   OS/2 versions of TruncateFile, FlushFile
+
+ ****************************************************************************}
+unit FileCtrl;
+
+interface
+{$I platform.inc}
+
+uses
+  Common, FileSys;
+
+{ The following platforms are supported
+    OS/2 either 1.x, or 2.x
+    Linux
+    DOS  16 bit, DPMI, Windows 3.1
+  Not supported:
+    Win32 (yet)
+}
+
+const
+{ standard file handles under DOS, under linux only stdin, stdout and strerr
+  is defined }
+  stdin         = 0;
+  stdout        = 1;
+  stderr        = 2;
+  stdaux        = 3;
+  stdprn        = 4;
+
+  { file access constants }
+  filRead       = 0;
+  filWrite      = 1;
+  filReadWrite  = 2;
+
+  { seek constants }
+  skBeg         = 0;
+  skCur         = 1;
+  skEnd         = 2;
+
+  FilePerms: Word = $1A4;  { rw-r--r-- }
+
+type
+{$IFDEF BIT_16}
+  TFileHandle = Word;
+{$ELSE}
+  TFileHandle = Longint;
+{$ENDIF}
+
+{ System independent calls }
+{ All of these functions do what their name imply, set ErrorCode (in Common)
+  to the returned error. }
+
+{ Under linux, I'll use FilePerms as permissions, instead of expecting an
+  additional parameter }
+
+{$IFDEF PPC_Feature_Overriding}
+function OpenFile(FName: PChar; Flags: Longint): TFileHandle;
+function CreateFile(FName: PChar): TFileHandle;
+procedure DeleteFile(FName: PChar); { should be moved to FileSys }
+{$ENDIF}
+function OpenFileStr(FName: PChar; Flags: Longint): TFileHandle;
+function CreateFileStr(FName: PChar): TFileHandle;
+procedure DeleteFileStr(FName: PChar); { should be moved to FileSys }
+
+function OpenFile(FName: TFileName; Flags: Longint): TFileHandle;
+function CreateFile(FName: TFileName): TFileHandle;
+procedure DeleteFile(FName: TFileName);
+
+procedure CloseFile(Handle: TFileHandle);
+function SeekFile(Handle: TFileHandle; Pos: TFileInt; SeekType: Word): TFileInt;
+function ReadFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord;
+function WriteFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord;
+procedure FlushFile(Handle: TFileHandle);
+procedure TruncateFile(Handle: TFileHandle);
+function EndOfFile(Handle: TFileHandle): Boolean;
+function FilePos(Handle: TFileHandle): TFileInt;
+function FileSize(Handle: TFileHandle): TFileInt;
+
+procedure CopyFile(F1, F2: TFileHandle; Length: TFileInt);
+
+implementation
+
+{ Include system dependent part }
+{$i filectrl.inc}
+
+function OpenFile(FName: TFileName; Flags: Longint): TFileHandle;
+begin
+  FName := FName + #0;
+  OpenFile := OpenFileStr(@FName[1], Flags);
+end;
+
+function CreateFile(FName: TFileName): TFileHandle;
+begin
+  FName := FName+#0;
+  CreateFile := CreateFileStr(@FName[1]);
+end;
+
+procedure DeleteFile(FName: TFileName);
+begin
+  FName := FName + #0;
+  DeleteFileStr(@FName[1]);
+end;
+
+{$IFDEF PPC_Feature_Overriding}
+function OpenFile(FName: PChar; Flags: Longint): TFileHandle;
+begin
+  OpenFile := OpenFileStr(FName, Flags);
+end;
+
+function CreateFile(FName: PChar): TFileHandle;
+begin
+  CreateFile := CreateFileStr(FName);
+end;
+
+procedure DeleteFile(FName: PChar);
+begin
+  DeleteFileStr(FName);
+end;
+{$ENDIF}
+
+
+procedure CopyFile(F1, F2: TFileHandle; Length: TFileInt);
+var
+  Buf: array [0..1023] of Byte;
+  Len: Word;
+begin
+  while (ErrorCode = 0) and (Length <> 0) do begin
+    if Length < 1024 then Len := Length else Len := 1024;
+    Len := ReadFile(F1, Buf, Len);
+    WriteFile(F2, Buf, Len);
+    Dec(Length, Len);
+  end;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/12/23 19:36:47  peter
+    * place unitfiles in target dirs
+
+  Revision 1.1  1999/11/24 23:36:37  peter
+    * moved to packages dir
+
+  Revision 1.3  1999/04/13 09:29:44  daniel
+  * Reverted a terrible mistake
+
+  Revision 1.1  1998/12/04 12:48:24  peter
+    * moved some dirs
+
+  Revision 1.6  1998/10/26 11:22:49  peter
+    * updates
+
+  
+   Date       Version  Who     Comments
+   07/06/97   0.1      bazsi   Initial implementation
+                               many of the platforms implemented, but not
+                               tested at all
+   07/07/97   0.1.1    bazsi   Some changes suggested by Marco Schmidt
+                               (TFileInt)
+                               Tested under Linux (FPC) and DOS (BP).
+   07/12/97   0.1.2    bazsi   Converted to the new error-handling scheme,
+                               began adding error codes, but this will be
+                               changed (!)
+   07/18/97   0.2      bazsi   Error codes moved to common
+   07/18/97   0.2.1    bazsi   Corrected some syntactical errors (haven't
+                               checked before uploading...)
+   07/19/97   0.2.2    bazsi   Overriden versions using Pascal style strings
+   07/19/97   0.3      bazsi   EndOfFile, TruncateFile added, FlushFile
+                               implemented on Linux, DOS
+   07/28/97   0.3.1    bazsi   Corrected some DOS 16 bit bugs (setting ErrorCode)
+   08/07/97   0.3.2    bazsi   renamed to .PAS
+                               PChar versions are named xxxxStr, overriden
+                               versions are provided if PPC_Feature_Overriding is
+                               defined (the Str versions are provided in both cases)
+   08/24/97   0.3.3    bazsi   FileSys added to uses clause
+
+   04/15/98   0.3.4    Michael Updated Linux implementation.
+   05/05/98   0.3.5    mkoeppe Fixed ReadFile, WriteFile return value in Linux.
+
+}

api/inc/filesys.pas

@@ -0,0 +1,1093 @@
+{
+   $Id$
+
+   Unit to access the file system
+   All file operations except those on open files (see FileCtrl for that)
+
+   Copyright by Marco Schmidt <[email protected]>
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************}
+unit FileSys;
+
+interface
+
+{$I platform.inc} { Conditional directives :
+                    compiler, operating system }
+
+uses
+  Common          { Error handling }
+
+{$IFDEF PPC_FPC}
+  , Strings
+{$ENDIF}
+
+{$IFDEF OS_DOS}
+  , DOS           { GetFAttr, GetFTime, FindFirst, FindNext, ... }
+{$else not OS_DOS}
+ {$ifdef PPC_FPC}
+  {$ifdef OS_WINDOWS}
+  {$define OS_DOS}
+  , DOS
+  {$endif OS_WIN32}
+ {$endif PPC_FPC}
+{$ENDIF}
+
+{$IFDEF OS_LINUX}
+  , linux
+{$ENDIF}
+  ;
+
+
+const
+
+  { Maximum length of a file name (must be <= 255, for we use
+    standard Pascal strings) }
+  MaxNameLength = {$IFDEF PPC_BP}
+                  79;
+                  {$ELSE}
+                  255;
+                  {$ENDIF}
+
+  { Character to separate directories in a path }
+  PathSeparator = {$IFDEF OS_Linux}
+                  '/';
+                  {$ELSE}
+                  '\';
+                  {$ENDIF}
+
+  { Defines if a character is inserted into a number string every three
+    digits;
+    true :  returns "3,555,234"
+    false : returns "3555234" }
+  SeparateThousands : Boolean = true;
+
+  { Character to be used to separate three digits in FileIntToString }
+  ThousandsSeparator : Char = ',';
+
+  { "CheckName" function return values }
+  cnUnknown     = 0;
+  cnFile        = 1;
+  cnDirectory   = 2;
+
+  { File attribute bit masks }
+
+  faReadOnly    = $0001;
+  faSystem      = $0002;
+  faHidden      = $0004;
+  faVolumeID    = $0008;
+  faDirectory   = $0010;
+  faArchive     = $0020;
+  faAnyFile     = faReadOnly or
+                  faSystem or
+                  faHidden or
+                  faVolumeID or
+                  faDirectory or
+                  faArchive;      { = $003f }
+
+  { Wildcard characters for use with "ContainsWildcards" }
+
+  NumWildcardChars = 2;
+  WildcardChars : Array[0..NumWildcardChars-1] of Char =
+      ('*', '?');
+
+type
+  { file attribute type }
+  TFileAttr = {$IFDEF PPC_BP}
+              Word;               { DOS: RSHVAD }
+              {$ELSE}
+              Longint;            { Any other OS }
+              {$ENDIF}
+
+  { Stores date and time in a system-independent way }
+  TDateTime = packed record
+    DOW    : Byte; { 0=Sunday, 1=Monday, ... }
+    Day    : Byte; { 1..31 }
+    Month  : Byte; { 1..12 }
+    Year   : Word; { 1601..3999 }
+    IsLeap : Boolean; { is "Year" a leap year ? }
+    Hour   : Byte; { 0..23 }
+    Minute : Byte; { 0..59 }
+    Second : Byte; { 0..59 }
+    Valid  : Boolean; { set by "CheckDateTime" }
+  end;
+
+  { Stores file size & offset values;
+    may have to be changed for other environments }
+  TFileInt  = Longint; { 32 bit signed, as we have no unsigned 32 bit type }
+
+  { directory / file name }
+  TFileName = String[MaxNameLength];
+
+  { record to describe a file or directory entry;
+    used in combination with a file search }
+  TFileDescriptor = packed record
+    { fields available for all platforms }
+    Attr             : TFileAttr;
+    IsDirectory      : Boolean;
+    LastModification : TDateTime;
+    Name             : TFileName;
+    Size             : TFileInt;
+    { platform-specific fields }
+    {$IFDEF OS_LINUX}
+    Created          : TDateTime;
+    LastAccessed     : TDateTime;
+    {$ENDIF OS_LINUX}
+  end;
+
+  { Search record declaration for FPC for DOS (we're not using the DOS unit
+    that provides SearchRec) }
+
+  {$IFDEF PPC_FPC}
+    {$IFDEF OS_DOS}
+
+    type
+      TDOSSearchRec = packed record
+        Fill:     Array[1..21] of Byte;
+        Attr:     Byte;
+        Time:     Longint;
+        Reserved: Word; { requires the DOS extender (DJ GNU-C) }
+        Size:     Longint;
+        Name:     String[15]; { the same size as declared by (DJ GNU C) }
+      end;
+
+    {$ENDIF OS_DOS}
+  {$ENDIF PPC_FPC}
+
+  { File search record to be used with
+    StartSearch, ContinueSearch and TerminateSearch }
+
+  TFileSearch = packed record
+    { Input fields for all platforms }
+    Specs   : TFileName;
+    { OS-specific input fields }
+    {$IFDEF OS_DOS}
+    Attr    : TFileAttr;
+    {$ENDIF}
+
+    { Output fields for all platforms }
+    FD      : TFileDescriptor;
+    Success : Boolean;
+
+    { OS-specific output fields }
+
+    {$IFDEF OS_Linux}
+    GL : PGlob;
+    {$ELSE OS_Linux}
+    SR      : DOS.SearchRec;
+    {$ENDIF OS_Linux}
+  end;
+
+procedure CheckDateTime(var DT: TDateTime);
+function  CheckName(AName: TFileName): Byte;
+function  ContainsWildcards(AName: TFileName): Boolean;
+procedure ContinueSearch(var FS: TFileSearch);
+procedure CreateDir(AName: TFileName);
+function  DateToString(const DT: TDateTime): String;
+procedure DeleteDir(AName: TFileName);
+procedure DeleteFile(AName: TFileName);
+function  EqualNames(Name1, Name2: TFileName): Boolean;
+function  Exists(AName: TFileName): Boolean;
+function  ExpandName(AName: TFileName): TFileName;
+function  FileAttrToString(AFileAttr: TFileAttr): String;
+function  FileIntToString(FI: TFileInt): String;
+function  GetCurrentDir: TFileName;
+procedure GetFAttr(AName: TFileName; var Attr: TFileAttr);
+procedure GetFTime(AName: TFileName; var DT: TDateTime);
+function  IsValidName(AName: TFileName) : Boolean;
+procedure RenameDir(OldName, NewName: TFileName);
+procedure RenameFile(OldName, NewName: TFileName);
+procedure SetCurrentDir(AName: TFileName);
+procedure SetFAttr(AName: TFileName; AFileAttr: TFileAttr);
+procedure SetFTime(AName: TFileName; DT: TDateTime);
+procedure SplitName(AName: TFileName; var Path, RawName, Extension: TFileName);
+procedure StartSearch(var FS: TFileSearch);
+procedure TerminateSearch(var FS: TFileSearch);
+function  TimeToString(DT: TDateTime): String;
+
+implementation
+
+{ Structure of the implementation section
+  ---------------------------------------
+  - proc. & functions that do not appear in the interface section and
+    are the same for all platforms
+  - proc. & functions that do appear in the interface section and
+    are the same for all platforms
+  - proc. & functions that do not appear in the interface section and
+    are DOS-specific
+  - proc. & functions that do appear in the interface section and
+    are not the same for all platforms
+}
+
+{ procedures and functions that do not appear in the interface section and
+  are the same for all platforms }
+
+function weekday(y,m,d : longint) : longint;
+
+{ Calculates th day of the week. Florian provided this.
+  returns -1 on error }
+
+    var
+       century_offset : integer;
+       temp : longint;
+       _is_leap_year : boolean;
+
+    const
+       month_table : array[1..12] of longint = (1,4,4,0,2,5,0,3,6,1,4,6);
+
+  function is_leap_year(y : longint) : boolean;
+
+    begin
+       if (y mod 100)=0 then
+         is_leap_year:=((y mod 400)=0)
+       else
+         is_leap_year:=(y mod 4)=0;
+    end;
+
+  { Beginning of weekday }
+  begin
+       if (m<1) or (m>12) then
+         begin
+            weekday:=-1;
+            exit;
+         end;
+       case y of
+          1700..1799 : century_offset:=4;
+          1800..1899 : century_offset:=2;
+          1900..1999 : century_offset:=0;
+          2000..2099 : century_offset:=-1;
+          else
+            begin
+               if (y>=2100) then
+                 begin
+                 end;
+               weekday:=-1;
+               exit;
+            end;
+       end;
+       _is_leap_year:=is_leap_year(y);
+       y:=y mod 100;
+       temp:=(y div 12)+(y mod 12)+((y mod 12) div 4);
+       temp:=temp mod 7;
+       temp:=(temp+month_table[m]+d) mod 7;
+       { do some corrections for special years }
+       { other century ? }
+       inc(temp,century_offset);
+       { leap year correction }
+       if _is_leap_year and (m<3) then
+         dec(temp);
+       { now is sonday 1, but should be for example 0 }
+       dec(temp);
+       { the result could be less than zero }
+       while temp<0 do
+         inc(temp,7);
+       weekday:=temp mod 7;
+    end;
+
+
+{ Returns Longint value as String }
+function LongToStr(L: Longint): String;
+var
+  S: String[20];
+begin
+  System.Str(L, S);
+  LongToStr := S;
+end;
+
+{ Returns Longint value as String, adding a leading '0' character if value
+  is >= 0 and <= 9 (LZ = leading zero) }
+function LongToStrLZ(L: Longint): String;
+var
+  Z: String[1];
+begin
+  if (L >= 0) and (L <= 9)
+    then Z := '0'
+    else Z := '';
+  LongToStrLZ := Z + LongToStr(L);
+end;
+
+{ Procedures and functions that do appear in the interface section and are
+  the same for all platforms }
+
+{ Checks if date and time in "dt" is valid; also determines the day of the
+  week }
+procedure CheckDateTime(var DT: TDateTime);
+const
+  MonthLength : array[1..12] of Byte =
+    (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
+begin
+  DT.Valid := false;
+  { check data that is within a fixed range }
+  with DT do
+    if (Hour < 0) or (Hour > 23) or
+       (Minute < 0) or (Minute > 59) or
+       (Second < 0) or (Second > 59) or
+       (Month < 1) or (Month > 12) or
+       (Day < 1) or
+       (Year < 1600) or (Year > 3999)
+      then  exit;
+  { determine if year is leap year }
+  DT.IsLeap := ((dt.Year mod 4) = 0) and
+                 (not (((dt.Year mod 100)  = 0) and
+                      ((dt.Year mod 400) <> 0)));
+  { check if day is within limits }
+  if ( DT.IsLeap      and (dt.Month = 2) and (dt.Day > 29)) or
+     ((not dt.IsLeap) and (dt.Day > MonthLength[dt.Month]))
+    then exit;
+  { date seems to be alright, compute day of the week
+    (formula taken from DDJ 06/95 [#231], p.11) }
+  if weekday (dt.year,dt.month,dt.day)<0 then
+     dt.dow:=0
+  else
+     dt.dow:=weekday(dt.year,dt.month,dt.day);
+{  Removed - caused segfault in linux. Michael.
+
+  dt.DOW := (((( 3 * (dt.Year) - ( 7 * ((dt.Year) +
+            ((dt.Month)+9) div 12)) div 4 +
+            (23 * (dt.Month)) div 9 + (dt.Day) + 2 +
+            (((dt.Year) - Ord ((dt.Month) < 3)) div 100 + 1)
+             * 3 div 4 - 16 ) + 1 ) mod 7));
+}
+  dt.Valid := true;
+end;
+
+{ Returns if AName contains at least one of the characters from global
+  constant WildcardChars }
+function ContainsWildcards(AName: TFileName): Boolean;
+var
+  I, J: Longint;
+begin
+  ContainsWildcards := false;
+  if (Length(AName) = 0)
+    then exit;
+  { compare each character in AName with each character in WildCards }
+  for I := 1 to Length (AName) do
+    for J := 0 to NumWildcardChars-1 do
+      if (AName[I] = WildcardChars[J])
+        then begin
+               ContainsWildcards := true;
+               exit;
+             end;
+end;
+
+{ Returns date part of TDateTime as String : "Tue 29 Jul 1997" }
+function DateToString(const DT: TDateTime): String;
+const
+  DOWNames : array[0..6] of String[3] =
+    ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
+  MonthNames : array[1..12] of String[3] =
+    ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
+     'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
+begin
+  if DT.Valid
+    then DateToString := DOWNames [dt.DOW] + ' ' +
+                         LongToStrLZ (dt.Day) + ' ' +
+                         MonthNames [dt.Month] + ' ' +
+                         LongToStr   (dt.Year)
+    else DateToString := '';
+end;
+
+{ Returns if two names are considered equal for the file system }
+function  EqualNames(Name1, Name2: TFileName): Boolean;
+{$IFDEF OS_DOS}
+var
+  I: Byte;
+begin
+  { case-insensitive comparision of strings }
+  EqualNames := false;
+  if (Length(Name1) <> Length(Name2)) or (Length(Name1) = 0)
+    then exit;
+  for I := 1 to Length(Name1) do
+    if (Upcase(Name1[I]) <> Upcase(Name2[I]))
+      then exit;
+  EqualNames := true;
+end;
+{$ELSE}
+begin
+  { case-sensitive comparision of strings }
+  EqualNames := (Name1 = Name2);
+end;
+{$ENDIF}
+
+{ Returns if name "AName" is in use (as file or directory) }
+function Exists(AName: TFileName): Boolean;
+begin
+  Exists := (CheckName (AName) <> cnUnknown);
+end;
+
+{ Splits AName into its path, raw name and extension; example:
+  "c:\pp\fv\archive.zip" will be split into path "c:\pp\fv\",
+  raw name "archive" and extension "zip" }
+procedure SplitName(AName: TFileName; var Path, RawName, Extension: TFileName);
+var
+  HasDot, HasSeparator: Boolean;
+  I, NameLength, DotOffset, SeparatorOffset: Longint;
+begin
+  NameLength := Length(AName);
+  Path := '';
+  RawName := '';
+  Extension := '';
+  { search for last separator in name }
+  SeparatorOffset := -1;
+  HasSeparator := false;
+  I := NameLength;
+  while (I > 0) and (not HasSeparator) do begin
+    if (AName[i] = PathSeparator)
+      then begin
+             HasSeparator := true;
+             SeparatorOffset := I;
+           end;
+    Dec(I);
+  end;
+  if HasSeparator
+    then begin
+           Path := System.Copy(AName, 1, SeparatorOffset);
+           SeparatorOffset := SeparatorOffset + 1;
+         end
+    else SeparatorOffset := 1;
+  I := SeparatorOffset;
+  { search for last dot in name (not in path /
+    think of 'dir/files.old/filename') }
+  HasDot := false;
+  while (I <= NameLength) do begin
+    if (AName[I] = '.')
+      then begin
+             HasDot := true;
+             DotOffset := I;
+           end;
+    Inc(I);
+  end;
+  if HasDot
+    then begin
+           RawName := System.Copy (AName,
+                                   SeparatorOffset,
+                                   DotOffset-SeparatorOffset);
+           Extension := System.Copy (AName,
+                                     DotOffset + 1,
+                                     NameLength - DotOffset);
+         end
+    else begin
+           { no extension }
+           RawName := System.Copy (AName,
+                                   SeparatorOffset,
+                                   NameLength - SeparatorOffset);
+         end;
+end;
+
+{ Returns time part of "DT" as "23:04:38" }
+function TimeToString(DT: TDateTime): String;
+begin
+  if DT.Valid
+    then TimeToString := LongToStrLZ(DT.Hour) + ':' +
+                         LongToStrLZ(DT.Minute) + ':' +
+                         LongToStrLZ(DT.Second)
+    else TimeToString := '';
+end;
+
+{$IFDEF OS_DOS} { procedures & functions for the DOS platform }
+
+{ Functions and procedures not declared in the interface section }
+
+{ Returns date part of dt in DOS format, as unsigned 16 bit integer }
+procedure GetDOSDate(DT: TDateTime; var W: Word);
+begin
+  W := (DT.Day and $1f) or
+       ((DT.Month and $f) shl 5) or
+       (((DT.Year - 1980) and $7f) shl 9);
+end;
+
+{ Returns time part of DT in DOS format, as unsigned 16 bit integer }
+procedure GetDOSTime(DT: TDateTime; var W: Word);
+begin
+  W := ((DT.Second shr 1) and $1f) or
+       ((DT.Minute and $3f) shl 5) or
+       ((DT.Hour and $1f) shl 11);
+end;
+
+{ Returns date and time as 32 bit integer value (DOS time format) }
+procedure GetDOSDateTime(DT : TDateTime; var L: Longint);
+var
+  W: Word;
+begin
+  GetDOSTime(DT, W);
+  L := W;
+  GetDOSDate(DT, W);
+  L := L + (W * 65536); { shifting by 16 doesn't work everywhere ... }
+end;
+
+{ Sets date part of DT to W }
+procedure SetDOSDate(W: Word; var DT: TDateTime);
+begin
+  DT.Day := W and $1f;
+  DT.Month := (W shr 5) and $f;
+  DT.Year := 1980 + (W shr 9) and $7f;
+end;
+
+{ Sets time part of DT to W }
+procedure SetDOSTime(W: Word; var DT: TDateTime);
+begin
+  DT.Second := (W and $1f) shl 1;
+  DT.Minute := (W shr 5) and $3f;
+  DT.Hour := (W shr 11) and $1f;
+end;
+
+{ Sets DT to data from L }
+procedure SetDOSDateTime(L: Longint; var DT: TDateTime);
+begin
+  SetDOSTime(L mod 65536, DT);
+  SetDOSDate(L div 65536, DT);
+end;
+
+{ Converts DOS.SearchRec to TFileDesciptor }
+procedure SearchRecToFileDescriptor (    SR: DOS.SearchRec;
+                                     var FD: TFileDescriptor);
+begin
+  FD.Name := SR.Name;
+  FD.Attr := SR.Attr;
+  FD.Size := SR.Size;
+  FD.IsDirectory := ((SR.Attr and faDirectory) <> 0);
+  SetDOSDateTime(SR.Time, FD.LastModification);
+  CheckDateTime(FD.LastModification);
+end;
+
+{$ENDIF} { OS_DOS }
+
+{$IFDEF OS_LINUX}
+{ Functions and procedures not decalred in interface section,
+  Linux operating system }
+
+Procedure EpochToDateTime (Epoch : Longint; var DT : TDateTime);
+{ Returns a Checked datetime, starting from a Unix epoch-style time }
+
+var y,m,d,h,mi,s : integer; { needed because of call by var }
+
+begin
+  Linux.EpochToLocal(Epoch,Y,M,D,h,mi,s);
+  DT.Year   :=y;
+  DT.Month  :=m;
+  DT.Day    :=d;
+  DT.Hour   :=h;
+  DT.Minute :=mi;
+  DT.Second :=s;
+  CheckDateTime (DT);
+end;
+
+Procedure StatToFileDescriptor (Info : Stat; Var Fd : TFileDescriptor);
+{Starting from a stat record, returns a TFileDescriptor record.
+ Name is not filled in !}
+begin
+  Fd.Attr:=Info.Mode;
+  Fd.IsDirectory:=S_ISDIR(Info.mode);
+  EpochToDateTime(Info.Mtime,Fd.LastModification);
+  EpochToDateTime(Info.Atime,Fd.LastAccessed);
+  EpochToDateTime(Info.Ctime,Fd.Created);
+  Fd.Size:=Info.size;
+end;
+{$ENDIF} {OS_LINUX}
+
+{ Functions and procedures declared in the interface section }
+
+{ Returns type of name as cnXXXX constant (unknown, file, directory) }
+function CheckName(AName: TFileName): Byte;
+var
+  FS: TFileSearch;
+begin
+  FS.Specs := AName;
+  {$IFDEF OS_DOS}
+  FS.Attr := faAnyFile;
+  {$ENDIF}
+  StartSearch(fs);
+  if FS.Success
+    then begin
+           if FS.FD.IsDirectory
+             then CheckName := cnDirectory
+             else CheckName := cnFile;
+         end
+    else CheckName := cnUnknown;
+  TerminateSearch(FS);
+end;
+
+{ Continues a file search started by StartSearch }
+procedure ContinueSearch(var FS: TFileSearch);
+{$IFDEF OS_Linux}
+Var g : PGLob;
+    info : stat;
+
+begin
+  if Not FS.Success then exit;
+  FS.Success:=False;
+  if FS.GL=nil then exit; { Paranoia setting }
+  g:=FS.GL;
+  FS.GL:=FS.GL^.NEXT;
+  strdispose(g^.name);
+  dispose (g);
+  If FS.GL=Nil then exit;
+  linux.fstat(strpas(FS.GL^.Name),info);
+  if linuxerror<>0 then
+    begin
+    StatToFileDescriptor (info,FS.FD);
+    FS.FD.Name:=strpas(FS.GL^.Name);
+    FS.Success:=True;
+    end;
+end;
+{$ELSE OS_Linux}
+begin
+  if fs.Success
+    then begin
+           DOS.FindNext(FS.SR);
+           FS.Success := (DOS.DOSError = 0);
+           if FS.Success
+             then SearchRecToFileDescriptor(fs.sr, fs.fd);
+         end;
+end;
+{$ENDIF OS_Linux}
+
+{ Create a new subdirectory AName }
+procedure CreateDir(AName : TFileName);
+begin
+  {$I-}
+  System.MkDir(AName);
+  {$I+}
+  ErrorCode := System.IOResult;
+end;
+
+{ Deletes the directory AName }
+procedure DeleteDir(AName : TFileName);
+begin
+  {$I-}
+  System.RmDir(AName);
+  {$I+}
+  ErrorCode := System.IOResult;
+end;
+
+{ Deletes the file AName }
+procedure DeleteFile(AName: TFileName);
+var
+  F: file;
+begin
+  Assign(F, AName);
+  {$I-}
+  System.Erase(F);
+  {$I+}
+  ErrorCode := System.IOResult;
+end;
+
+{ Returns the full version of AName }
+function ExpandName(AName : TFileName): TFileName;
+begin
+{$IFDEF OS_LINUX}
+  ExpandName := Linux.FExpand(AName);
+{$ELSE}
+  ExpandName := DOS.FExpand(AName);
+{$ENDIF}
+end;
+
+{ Returns a string version of AFileAttr; OS-dependent }
+function FileAttrToString(AFileAttr: TFileAttr): String;
+{$IFDEF OS_DOS}
+{ Volume Label and Directory are not regarded }
+const
+  NumChars = 4;
+  AttrChars: String[NumChars] = 'RSHA';
+  AttrMasks: Array[0..NumChars-1] of Word = (1, 2, 4, 32);
+var
+  I: Word;
+  S: String[NumChars];
+begin
+  s[0] := Chr(NumChars);
+  for I := 1 to NumChars do begin
+    if ((AFileAttr and AttrMasks[i-1]) = 0)
+      then S[I] := '.'
+      else S[I] := AttrChars[i];
+  end;
+  FileAttrToString := S;
+end;
+{$ELSE OS_DOS}
+{$IFDEF OS_LINUX}
+var temp : string[9];
+    i : longint;
+
+const
+    full = 'rwxrwxrwx';
+
+begin
+  temp:='---------';
+  for i:=0 to 8 do
+    if (AFileAttr and (1 shl i))=(1 shl I) then temp[9-i]:=full[9-i];
+  FileAttrToString := Temp;
+end;
+{$ELSE OS_LINUX}
+begin
+  FileAttrToString:='';
+end;
+{$ENDIF OS_LINUX}
+{$ENDIF OS_DOS}
+
+{ Returns a string version of the file integer value fi }
+function FileIntToString(fi: TFileInt): String;
+var
+  S: String[14]; { maximum is "-2,147,483,648" }
+  I: Integer;    { must be signed ! }
+begin
+  Str(fi, S);
+  if SeparateThousands
+    then begin
+           I := System.Length(S) - 2;
+           while (I > 1) and (not (I = 2) and (s[1] = '-')) do begin
+             System.Insert (ThousandsSeparator, S, I);
+             Dec(I, 3);
+           end;
+         end;
+  FileIntToString := S;
+end;
+
+{ Returns the currently set directory }
+function GetCurrentDir: TFileName;
+{$IFDEF PPC_BP}
+var
+  I: Byte;
+  R: DOS.Registers;
+  S: TFileName;
+begin
+  { to get a full name, we have to get the drive letter ourselves }
+
+  { get current drive letter first }
+  R.AH := $19;
+  DOS.MsDos(R);
+
+  S[1] := Chr(Ord('A') + R.AL);
+  S[2] := ':';
+  S[3] := '\';
+
+  { get current directory }
+  R.AH := $47;
+  R.DL := $00;
+  R.DS := Seg(S[4]);
+  R.SI := Ofs(S[4]);
+  DOS.MsDos (r);
+  if ((R.Flags and FCarry) <> 0)
+    then begin
+           { error }
+         end;
+
+  { determine length of current directory }
+  I := 4;
+  while (S[I] <> #0) and (I < MaxNameLength) do
+    Inc(I);
+  S[0] := Chr(I - 1);
+
+  GetCurrentDir := S;
+end;
+{$ELSE}
+var
+  S: TFileName;
+begin
+  System.GetDir(0, S);
+  GetCurrentDir := S;
+end;
+{$ENDIF}
+
+{ Gets attribute of AName }
+procedure GetFAttr(AName: TFileName; var Attr: TFileAttr);
+{$IFDEF OS_DOS}
+var
+  F: file;
+  W: word;
+begin
+  Assign(F, AName);
+  {$I-}
+  DOS.GetFAttr(F, W);
+  Attr:=W;
+  {$I+}
+  ErrorCode := DOS.DOSError;
+end;
+{$ELSE}
+{$IFDEF OS_LINUX}
+var
+  info : stat;
+begin
+  Linux.FStat (AName,Info);
+  ErrorCode:=LinuxError;
+  if ErrorCode<>0 then exit;
+  Attr:=Info.Mode;
+end;
+{$ELSE}
+begin
+end;
+{$ENDIF}
+{$ENDIF}
+
+{ Gets date and time of last modification of AName }
+procedure GetFTime(AName: TFileName; var DT: TDateTime);
+{$IFDEF OS_DOS}
+var
+  F: file;
+  L: Longint;
+begin
+  DT.Valid := false;
+  { open file }
+  Assign(F, AName);
+  {$I-}
+  Reset(F);
+  {$I+}
+  ErrorCode := System.IOResult;
+  if (ErrorCode <> errOK)
+    then exit;
+  { get date/time of last modification in DOS format }
+  {$I-}
+  DOS.GetFTime(F, L);
+  {$I+}
+  ErrorCode := DOS.DOSError;
+  if (ErrorCode <> errOK)
+    then exit;
+  { close file }
+  {$I-}
+  Close(F);
+  {$I+}
+  ErrorCode := System.IOResult;
+  { convert date/time L to TDateTime format }
+  GetDOSDateTime(DT, L);
+  CheckDateTime(DT);
+end;
+{$ELSE}
+{$IFDEF OS_LINUX}
+var info : Stat;
+
+begin
+  Linux.FStat (AName,Info);
+  ErrorCode:=LinuxError;
+  if ErrorCode<>0 then exit;
+  EpochToDateTime (info.mtime,DT);
+end;
+{$ELSE}
+begin
+end;
+{$ENDIF}
+{$ENDIF}
+
+{ Returns if AName is a valid file name (not if it actually exists) }
+function IsValidName(AName: TFileName): Boolean;
+{$IFDEF OS_DOS}
+  { isn't ready yet }
+
+  { Returns if a name (without a path) is valid }
+  function ValidName(S: TFileName): Boolean;
+  var
+    I: Byte;
+  begin
+    ValidName := false;
+    if (Length(S) > 12)
+      then exit;
+    I := Pos('.', S);
+
+    ValidName := true;
+  end;
+
+const
+  InvalidChars: String[2] = '*?';
+
+var
+  I, J: Longint;
+  P, R, E: TFileName;
+begin
+  IsValidName := false;
+  { check for invalid characters }
+  for I := 1 to Length(AName) do
+    for J := 1 to Length(InvalidChars) do
+      if (AName[I] = InvalidChars[J])
+        then exit;
+  SplitName(AName, P, R, E);
+  if (Length(R) > 0) or (Length(E) > 0)
+    then begin
+           if (not ValidName(R + E))
+             then exit;
+         end;
+
+  IsValidName := true;
+end;
+{$ELSE}
+{$IFDEF OS_LINUX}
+begin
+  IsVAlidName:=((pos('?',AName)=0) and (pos('*',AName)=0))
+end;
+{$ELSE}
+begin
+  IsValidName:=True;
+end;
+{$ENDIF}
+{$ENDIF}
+
+{ Renames directory from OldName to NewName }
+procedure RenameDir(OldName, NewName : TFileName);
+begin
+  { for DOS, renaming files and directories should be the same ... }
+  RenameFile(OldName, NewName);
+end;
+
+{ Renames file from OldName to NewName }
+procedure RenameFile(OldName, NewName : TFileName);
+var
+  F: file;
+begin
+  Assign(F, OldName);
+  {$I-}
+  System.Rename(F, NewName);
+  {$I+}
+  ErrorCode := IOResult;
+end;
+
+{ Sets current directory to AName }
+procedure SetCurrentDir(AName : TFileName);
+begin
+  {$I-}
+  System.ChDir(AName);
+  {$I+}
+  ErrorCode := IOResult;
+end;
+
+{ Sets attribute of file AName to AFileAttr }
+procedure SetFAttr(AName: TFileName; AFileAttr: TFileAttr);
+{$IFDEF OS_DOS}
+var
+  F: file;
+begin
+  Assign(F, AName);
+  {$I-}
+  DOS.SetFAttr(F, AFileAttr);
+  {$I+}
+  ErrorCode := DOS.DOSError;
+end;
+{$ELSE}
+{$IFDEF OS_LINUX}
+begin
+  Linux.Chmod (Aname,AFileAttr);
+  ErrorCode:=LinuxError;
+end;
+{$ELSE}
+begin
+end;
+{$ENDIF}
+{$ENDIF}
+
+{ Sets date and time of last modification of file AName to dt }
+procedure SetFTime(AName: TFileName; DT: TDateTime);
+{$IFDEF OS_DOS}
+var
+  F: file;
+  L: Longint;
+begin
+  GetDOSDateTime(DT, L);
+  Assign(f, AName);
+  {$I-}
+  DOS.SetFTime(F, L);
+  {$I+}
+  ErrorCode := DOS.DOSError;
+end;
+{$ELSE}
+{$IFDEF OS_LINUX}
+var
+  utim : utimebuf;
+begin
+  utim.actime:=LocalToEpoch(DT.Year,DT.Month,DT.Day,DT.Hour,DT.Minute,DT.second);
+  utim.modtime:=utim.actime;
+  utime (AName,utim);
+  ErrorCode:=linuxerror
+end;
+{$ELSE}
+begin
+end;
+{$ENDIF}
+{$ENDIF}
+
+{ Starts a file search, using input data from fs }
+procedure StartSearch(var FS: TFileSearch);
+{$IFDEF OS_Linux}
+var
+  info : stat;
+begin
+  FS.Success:=False;
+  FS.GL:=Linux.Glob(FS.Specs);
+  if FS.GL=nil then exit;
+  linux.fstat(strpas(FS.GL^.Name),info);
+  if linuxerror=0 then
+    begin
+    StatToFileDescriptor (info,FS.FD);
+    FS.FD.Name:=strpas(FS.GL^.Name);
+    FS.Success:=True;
+    end;
+end;
+{$ELSE OS_Linux}
+{ this version works for every platform/os/bits combination that has a
+  working DOS unit : BP/FPC/Virtual Pascal }
+begin
+  DOS.FindFirst(fs.Specs, fs.Attr, fs.sr);
+  fs.Success := (DOS.DOSError = 0);
+  if fs.Success
+    then SearchRecToFileDescriptor(FS.SR, FS.FD);
+end;
+{$ENDIF OS_Linux}
+
+{ Terminates a file search }
+procedure TerminateSearch (var FS: TFileSearch);
+begin
+{$IFDEF OS_LINUX}
+GlobFree (FS.GL);
+{$ELSE}
+  {$IFNDEF PPC_BP}
+  DOS.FindClose(fs.sr);
+  {$ENDIF}
+{$ENDIF}
+end;
+
+{ Unit initialization }
+begin
+  { Empty, though we could retrieve the thousands separator and
+    date/time formats here (in case the OS supports that) }
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/12/23 19:36:47  peter
+    * place unitfiles in target dirs
+
+  Revision 1.1  1999/11/24 23:36:37  peter
+    * moved to packages dir
+
+  Revision 1.4  1999/05/17 13:55:18  pierre
+   * FPC win32 also need dos unit
+
+  Revision 1.3  1999/04/13 09:25:47  daniel
+  * Reverted a terrible mistake
+
+  Revision 1.1  1998/12/04 12:48:24  peter
+    * moved some dirs
+
+  Revision 1.5  1998/10/26 11:22:50  peter
+    * updates
+
+
+  ?            0.1      marco   Initial implementation
+  ?                             Several fixes ...
+  08/29/1997   0.4      marco   Some platform adjustments
+  09/16/1997   0.4.1    marco   Added "EqualNames"
+  09/17/1997   0.5      michael Implemented linux part.
+  09/20/1997   0.5.1    marco   Added LastAccessed/Created to Linux part of
+                                file descriptor
+  04/15/1998   0.5.2    michael Updated linux part.
+}

api/inc/keyboard.pas

@@ -0,0 +1,265 @@
+{
+   $Id$
+
+   Keyboard unit, part of the portable API for Pascal
+
+   Copyright (c) 1997 Balazs Scheidler ([email protected])
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************}
+unit Keyboard;
+
+interface
+{$i platform.inc}
+
+uses
+{$ifdef DEBUG}
+{$ifdef win32}
+  windows,
+{$endif win32}
+{$endif DEBUG}
+
+  Common;
+
+const
+  { We have an errorcode base of 1010 }
+  errKbdInitError               = errKbdBase + 0;
+  errKbdNotImplemented          = errKbdBase + 1;
+
+type
+  TKeyEvent = Longint;
+
+{ The structure of a TKeyEvent follows in LSB-MSB order:
+  2 bytes: depending on flags either the physical representation of a key
+           (under DOS scancode, ascii code pair), or the translated
+           ASCII/unicode character
+  1 byte:  shift-state when this key was pressed (or shortly after)
+  1 byte:  flags, the following flags are defined:
+           bit0-1
+                   0: the lowest two bytes is the translated ASCII value
+                   1: the lowest two bytes is the translated Unicode value
+                      (wide-char)
+                   2: the lowest two bytes is a function key, and the lowest
+                      two bytes contains its platform independent code
+                   3: the lowest two bytes is the physical representation
+           bit2
+                   0: the key is pressed
+                   1: the key is released (This event is not guaranteed to occur on all platforms)
+           bit3-7  undefined, should be 0
+
+
+  If there are two keys returning the same char-code, there's no way to find
+  out which one was pressed (Gray+ and Simple+). If you need to know which
+  was pressed, you'll need to use the untranslated keycodes, which is system
+  dependent. System dependent constants may be defined to cover those, with
+  possibily having the same name (but different value). }
+
+{ System independent function key codes }
+const
+  kbdF1        = $FF01;
+  kbdF2        = $FF02;
+  kbdF3        = $FF03;
+  kbdF4        = $FF04;
+  kbdF5        = $FF05;
+  kbdF6        = $FF06;
+  kbdF7        = $FF07;
+  kbdF8        = $FF08;
+  kbdF9        = $FF09;
+  kbdF10       = $FF0A;
+  kbdF11       = $FF0B;
+  kbdF12       = $FF0C;
+  kbdF13       = $FF0D;
+  kbdF14       = $FF0E;
+  kbdF15       = $FF0F;
+  kbdF16       = $FF10;
+  kbdF17       = $FF11;
+  kbdF18       = $FF12;
+  kbdF19       = $FF13;
+  kbdF20       = $FF14;
+  { $15 - $1F reserved for future Fxx keys }
+  kbdHome      = $FF20;
+  kbdUp        = $FF21;
+  kbdPgUp      = $FF22;
+  kbdLeft      = $FF23;
+  kbdMiddle    = $FF24;
+  kbdRight     = $FF25;
+  kbdEnd       = $FF26;
+  kbdDown      = $FF27;
+  kbdPgDn      = $FF28;
+
+  kbdInsert    = $FF29;
+  kbdDelete    = $FF2A;
+  { $2B - $2F reserved for future keypad keys }
+
+  { possible flag values }
+  kbASCII       = $00;
+  kbUniCode     = $01;
+  kbFnKey       = $02;
+  kbPhys        = $03;
+
+  kbReleased    = $04;
+
+  { shiftstate flags }
+  kbLeftShift   = 1;
+  kbRightShift  = 2;
+  kbShift       = kbLeftShift or kbRightShift;
+  kbCtrl        = 4;
+  kbAlt         = 8;
+
+var
+  PendingKeyEvent : TKeyEvent;
+
+
+procedure InitKeyboard;
+{ Initializes the keyboard interface, additional platform specific parameters
+  can be passed by global variables (RawMode etc.) for the first implementation
+  under DOS it does nothing }
+
+procedure DoneKeyboard;
+{ Deinitializes the keyboard interface }
+
+function GetKeyEvent: TKeyEvent;
+{ Returns the last keyevent, and waits for one if not available }
+
+procedure PutKeyEvent(KeyEvent: TKeyEvent);
+{ Adds the given KeyEvent to the input queue. Please note that depending on
+  the implementation this can hold only one value (NO FIFOs etc) }
+
+function PollKeyEvent: TKeyEvent;
+{ Checks if a keyevent is available, and returns it if one is found. If no
+  event is pending, it returns 0 }
+
+function PollShiftStateEvent: TKeyEvent;
+{ Return the current shiftstate in a keyevent }
+
+function TranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
+{ Performs ASCII translation of the KeyEvent }
+
+function TranslateKeyEventUniCode(KeyEvent: TKeyEvent): TKeyEvent;
+{ Performs Unicode translation of the KeyEvent }
+
+function GetKeyEventFlags(KeyEvent: TKeyEvent): Byte;
+{ Returns the flags part of the given KeyEvent }
+
+function GetKeyEventChar(KeyEvent: TKeyEvent): Char;
+{ Returns the charcode part of the given KeyEvent, if it contains a translated
+  keycode }
+
+function GetKeyEventUniCode(KeyEvent: TKeyEvent): Word;
+{ Returns the unicode part of the given KeyEvent, if it contains a translated
+  unicode character }
+
+function GetKeyEventCode(KeyEvent: TKeyEvent): Word;
+{ Returns the translated function keycode part of the given KeyEvent, if it
+  contains a translated function keycode }
+
+function GetKeyEventShiftState(KeyEvent: TKeyEvent): Byte;
+{ Returns the shift-state values of the given KeyEvent }
+
+function IsFunctionKey(KeyEvent: TKeyEvent): Boolean;
+{ Returns true if the given key was a function key or not }
+{$ifdef DEBUG}
+{$ifdef win32}
+var last_ir : INPUT_RECORD;
+{$endif win32}
+{$endif DEBUG}
+
+implementation
+
+{ Include platform dependent routines }
+
+{$i keyboard.inc}
+
+
+{ Platform independent routines }
+
+procedure PutKeyEvent(KeyEvent: TKeyEvent);
+begin
+  PendingKeyEvent := KeyEvent;
+end;
+
+function GetKeyEventFlags(KeyEvent: TKeyEvent): Byte;
+begin
+  GetKeyEventFlags := (KeyEvent and $FF000000) shr 24;
+end;
+
+function GetKeyEventChar(KeyEvent: TKeyEvent): Char;
+begin
+  if KeyEvent and $03000000 = $00000000 then
+    GetKeyEventChar := Chr(KeyEvent and $000000FF)
+   else
+    GetKeyEventChar := #0;
+end;
+
+function GetKeyEventUniCode(KeyEvent: TKeyEvent): Word;
+begin
+  if KeyEvent and $03000000 = $01000000 then
+    GetKeyEventUniCode := KeyEvent and $0000FFFF
+   else
+    GetKeyEventUniCode := 0;
+end;
+
+function GetKeyEventCode(KeyEvent: TKeyEvent): Word;
+begin
+  GetKeyEventCode := KeyEvent and $0000FFFF
+end;
+
+function GetKeyEventShiftState(KeyEvent: TKeyEvent): Byte;
+begin
+  GetKeyEventShiftState := (KeyEvent and $00FF0000) shr 16;
+end;
+
+function IsFunctionKey(KeyEvent: TKeyEvent): Boolean;
+begin
+  IsFunctionKey := KeyEvent and $03000000 = $02000000;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/12/23 19:36:47  peter
+    * place unitfiles in target dirs
+
+  Revision 1.2  1999/12/09 21:29:15  pierre
+   + some debug code for win32
+
+  Revision 1.3  1999/11/24 23:36:56  peter
+    * moved to packages dir
+
+  Revision 1.2  1998/12/12 19:12:58  peter
+    * keyboard updates
+    * make test target, make all only makes units
+
+  Revision 1.1  1998/12/04 12:48:24  peter
+    * moved some dirs
+
+  Revision 1.6  1998/10/29 12:49:47  peter
+    * more fixes
+
+  Revision 1.5  1998/10/28 21:18:22  peter
+    * more fixes
+
+  Revision 1.4  1998/10/26 11:22:51  peter
+    * updates
+
+
+   Date       Version   Who     Comments
+   07/28/98   0.2       Bazsi   Added some constants
+}

api/inc/mouse.pas

@@ -0,0 +1,173 @@
+{
+   $Id$
+
+   Mouse unit, part of the portable API for Pascal
+
+   Copyright (c) 1997 Balazs Scheidler ([email protected])
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************}
+unit Mouse;
+{$G+}
+interface
+{$i platform.inc}
+
+uses
+  Common;
+
+const
+  { We have an errorcode base of 1010 }
+  errMouseInitError               = errMouseBase + 0;
+  errMouseNotImplemented          = errMouseBase + 1;
+
+type
+  PMouseEvent=^TMouseEvent;
+  TMouseEvent=packed record { 8 bytes }
+    buttons : word;
+    x,y     : word;
+    Action  : word;
+  end;
+
+const
+  MouseActionDown = $0001;                         { Mouse down event }
+  MouseActionUp   = $0002;                         { Mouse up event }
+  MouseActionMove = $0004;                         { Mouse move event }
+
+  MouseLeftButton   = $01;                         { Left mouse button }
+  MouseRightButton  = $02;                         { Right mouse button }
+  MouseMiddleButton = $04;                         { Middle mouse button }
+
+{$ifdef OS_WINDOWS}
+  MouseEventBufSize = 255;
+{$else OS_WINDOWS}
+  MouseEventBufSize = 16;
+{$endif OS_WINDOWS}
+
+var
+  PendingMouseEvent  : array[0..MouseEventBufSize-1] of TMouseEvent;
+  PendingMouseHead,
+  PendingMouseTail   : PMouseEvent;
+  PendingMouseEvents : byte;
+
+  LastMouseEvent : TMouseEvent;
+
+  MouseIntFlag : Byte;                                { Mouse in int flag }
+  MouseButtons : Byte;                                { Mouse button state }
+  MouseWhereX,
+  MouseWhereY  : Word;                                { Mouse position }
+
+
+procedure InitMouse;
+{ Initialize the mouse interface }
+
+procedure DoneMouse;
+{ Deinitialize the mouse interface }
+
+function DetectMouse:byte;
+{ Detect if a mouse is present, returns the amount of buttons or 0
+  if no mouse is found }
+
+procedure ShowMouse;
+{ Show the mouse cursor }
+
+procedure HideMouse;
+{ Hide the mouse cursor }
+
+function GetMouseX:word;
+{ Return the current X position of the mouse }
+
+function GetMouseY:word;
+{ Return the current Y position of the mouse }
+
+function GetMouseButtons:word;
+{ Return the current button state of the mouse }
+
+procedure SetMouseXY(x,y:word);
+{ Place the mouse cursor on x,y }
+
+procedure GetMouseEvent(var MouseEvent:TMouseEvent);
+{ Returns the last Mouseevent, and waits for one if not available }
+
+procedure PutMouseEvent(const MouseEvent: TMouseEvent);
+{ Adds the given MouseEvent to the input queue. Please note that depending on
+  the implementation this can hold only one value (NO FIFOs etc) }
+
+function PollMouseEvent(var MouseEvent: TMouseEvent):boolean;
+{ Checks if a Mouseevent is available, and returns it if one is found. If no
+  event is pending, it returns 0 }
+
+implementation
+
+{ Include platform dependent routines }
+
+{$i mouse.inc}
+
+{ Platform independent routines }
+{$IFNDEF OS2}
+procedure PutMouseEvent(const MouseEvent: TMouseEvent);
+begin
+  if PendingMouseEvents<MouseEventBufSize then
+   begin
+     PendingMouseTail^:=MouseEvent;
+     inc(PendingMouseTail);
+     if longint(PendingMouseTail)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+      PendingMouseTail:=@PendingMouseEvent;
+      { why isn't this done here ?
+        so the win32 version do this by hand:
+       inc(PendingMouseEvents); }
+   end
+  else
+end;
+{$ENDIF}
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  1999/12/31 17:25:24  marco
+
+
+  Added {$G+}, TP version required it.
+
+  Revision 1.1  1999/12/23 19:36:47  peter
+    * place unitfiles in target dirs
+
+  Revision 1.1  1999/11/24 23:36:37  peter
+    * moved to packages dir
+
+  Revision 1.5  1999/07/29 11:38:56  peter
+    * fixed comment for tp7
+
+  Revision 1.4  1999/07/17 22:37:07  florian
+    * implemented mouse handling
+
+  Revision 1.3  1999/04/23 17:54:58  hajny
+  PutMouseEvent modified for support of two queues in OS/2
+
+  Revision 1.2  1998/12/11 00:13:17  peter
+    + SetMouseXY
+    * use far for exitproc procedure
+
+  Revision 1.1  1998/12/04 12:48:24  peter
+    * moved some dirs
+
+  Revision 1.1  1998/10/28 00:02:07  peter
+    + mouse
+    + video.clearscreen, video.videobufsize
+
+}

api/inc/platform.inc

@@ -0,0 +1,320 @@
+{
+   $Id$
+   Include file to sort out compilers/platforms/targets
+
+   Copyright (c) 1997 Balazs Scheidler ([email protected])
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+
+   This include file defines some conditional defines to allow us to select
+   the compiler/platform/target in a consequent way.
+
+    OS_XXXX         The operating system used (XXXX may be one of:
+                       DOS, OS2, Linux, Windows, Go32)
+    PPC_XXXX        The compiler used: BP, FPK, Virtual, Speed
+    BIT_XX          The number of bits of the target platform: 16 or 32
+    PROC_XXXX       The mode of the target processor (Real or Protected)
+                    This shouldn't be used, except for i386 specific parts.
+    ASM_XXXX        This is the assembler type: BP, ISO-ANSI, FPK
+
+ ****************************************************************************
+
+   Changelog:
+
+     Date       Version        Who        Comments
+     02 Jul 97  0.1            Bazsi      Initial implementation
+     28 Aug 97  0.2            LdeB       Fixed OS2 platform sort out
+     29 Aug 97  0.3            LdeB       Added assembler type change
+     29 Aug 97  0.4            LdeB       OS_DOS removed from Windows
+     23 Oct 97  0.5            LdeB       Delphi & Speed compilers added
+     05 May 98  0.6            LdeB       Virtual pascal 2.0 added
+     19 May 98  0.7            LdeB       Delphi2/3 definitions altered
+      6 Aug 98  0.8            CEC/LdeB   FPC only support - fixed for Win32
+     10 Aug 98  0.9            LdeB       BP_VMTLink def/Undef for object reg.
+     27 Aug 98  1.0            LdeB       Fixed Atari etc not $UNDEF OS_DOS.
+
+     25 Oct 98  1.1            pfv        Delphi4
+
+ ****************************************************************************
+
+    This is how the IFDEF and UNDEF statements below should translate.
+
+
+ PLATFORM  SYSTEM    COMPILER  COMP ID      CPU MODE        BITS    ASSEMBLER
+ --------  ------    --------  -------      --------        ----    ---------
+
+ DOS      OS_DOS      BP/TP7   PPC_BP       PROC_Real       BIT_16  ASM_BP
+                      FPC      PPC_FPC      PROC_Protected  BIT_32  ASM_FPC
+
+ DPMI     OS_DOS      BP/TP7   PPC_BP       PROC_Protected  BIT_16  ASM_BP
+
+ LINUX    OS_LINUX    FPC      PPC_FPC      PROC_Protected  BIT_32  ASM_FPC
+
+ WINDOWS  OS_WINDOWS  BP/TP7   PPC_BP       PROC_Protected  BIT_16  ASM_BP
+                      DELPHI   PPC_DELPHI   PROC_Protected  BIT_16  ASM_BP
+                      DELPHI2  PPC_DELPHI&2 PROC_Protected  BIT_16  ASM_BP
+
+ WIN95/NT OS_WINDOWS  DELPHI2  PPC_DELPHI&2 PROC_Protected  BIT_32  ASM_BP
+                      DELPHI3  PPC_DELPHI&3 PROC_Protected  BIT_32  ASM_BP
+                      DELPHI4  PPC_DELPHI&3 PROC_Protected  BIT_32  ASM_BP
+                      VIRTUAL  PPC_VIRTUAL  PROC_Protected  BIT 32  ASM_BP
+
+ OS2      OS_OS2      BPOS2    PPC_BPOS2    PROC_Protected  BIT_16  ASM_BP
+                      VIRTUAL  PPC_VIRTUAL  PROC_Protected  BIT_32  ASM_BP
+                      SPEED    PPC_SPEED    PROC_Protected  BIT_32  ASM_BP
+                      FPC      PPC_FPC      PROC_Protected  BIT_32  ASM_FPC
+ ****************************************************************************}
+{****************************************************************************
+
+FOR ALL COMPILERS BP_VMTLink will be defined but FPC and Delphi3 undefine it
+
+ ****************************************************************************}
+{****************************************************************************
+
+FOR FPC THESE ARE THE TRANSLATIONS
+
+  PLATFORM  SYSTEM    COMPILER  HANDLE SIZE      ASM          CPU
+ --------  ------    --------  -----------      ----         ---
+
+ DOS      OS_DOS,OS_GO32 FPC     32-bit           AT&T         CPU86
+
+ WIN32    OS_WINDOWS   FPC     32-bit           AT&T         ----
+
+ LINUX    OS_LINUX     FPC     32-bit           AT&T         ----
+
+ OS2      OS_OS2       FPC     ?????            AT&T         CPU86
+
+ ATARI    OS_ATARI     FPC     32-bit           Internal     CPU68
+
+ MACOS    OS_MAC       FPC     ?????            Internal     CPU68
+
+ AMIGA    OS_AMIGA     FPC     32-bit           Internal     CPU68
+
+ ****************************************************************************}
+
+{---------------------------------------------------------------------------}
+{  Initial assume BORLAND 16 BIT DOS COMPILER - Updated 27Aug98 LdB         }
+{---------------------------------------------------------------------------}
+{$DEFINE OS_DOS}
+{$DEFINE PROC_Real}
+{$DEFINE BIT_16}
+{$DEFINE PPC_BP}
+{$DEFINE ASM_BP}
+{$DEFINE BP_VMTLink}
+
+{---------------------------------------------------------------------------}
+{  BORLAND 16 BIT DPMI changes protected mode - Updated 27Aug98 LdB         }
+{---------------------------------------------------------------------------}
+{$IFDEF DPMI}
+  {$UNDEF PROC_Real}
+  {$DEFINE PROC_Protected}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  FPC 32 BIT COMPILER changes ASM, 32 bits etc - Updated 27Aug98 LdB       }
+{---------------------------------------------------------------------------}
+{$IFDEF FPC}
+  {$UNDEF PROC_Real}
+  {$DEFINE PROC_Protected}
+  {$UNDEF BIT_16}
+  {$DEFINE BIT_32}
+  {$UNDEF PPC_BP}
+  {$DEFINE PPC_FPC}
+  {$UNDEF ASM_BP}
+  {$DEFINE ASM_FPC}
+  {$UNDEF BP_VMTLink}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  FPC LINUX COMPILER changes operating system - Updated 27Aug98 LdB        }
+{  Note: Other linux compilers would need to change other details           }
+{---------------------------------------------------------------------------}
+{$IFDEF LINUX}
+  {$UNDEF OS_DOS}
+  {$DEFINE OS_LINUX}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  FPC GO32V2 COMPILER changes operating system - Updated 27Aug98 LdB       }
+{---------------------------------------------------------------------------}
+{$IFDEF GO32V2}
+  {$DEFINE OS_GO32}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  32 BIT WINDOWS COMPILERS changes bit size - Updated 27Aug98 LdB          }
+{---------------------------------------------------------------------------}
+{$IFDEF WIN32}
+  {$IFNDEF WINDOWS}
+    {$DEFINE WINDOWS}
+  {$ENDIF}
+  {$UNDEF BIT_16}
+  {$DEFINE BIT_32}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  WINDOWS COMPILERS change op system and proc mode - Updated 27Aug98 LdB   }
+{---------------------------------------------------------------------------}
+{$IFDEF WINDOWS}
+  {$UNDEF OS_DOS}
+  {$DEFINE OS_WINDOWS}
+  {$UNDEF PROC_Real}
+  {$DEFINE PROC_Protected}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  DELPHI1 COMPILER changes compiler type - Updated 27Aug98 LdB             }
+{---------------------------------------------------------------------------}
+{$IFDEF VER80}
+  {$UNDEF PPC_BP}
+  {$DEFINE PPC_DELPHI}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  DELPHI2 COMPILER changes compiler type - Updated 27Aug98 LdB             }
+{---------------------------------------------------------------------------}
+{$IFDEF VER90}
+  {$UNDEF PPC_BP}
+  {$DEFINE PPC_DELPHI}
+  {$DEFINE PPC_DELPHI2}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  DELPHI3 COMPILER changes compiler type - Updated 27Aug98 LdB             }
+{---------------------------------------------------------------------------}
+{$IFDEF VER100}
+  {$UNDEF PPC_BP}
+  {$DEFINE PPC_DELPHI}
+  {$DEFINE PPC_DELPHI3}
+  {$UNDEF BP_VMTLink}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  DELPHI4 COMPILER changes compiler type - Updated 25Oct98 pfv             }
+{---------------------------------------------------------------------------}
+{$IFDEF VER120}
+  {$UNDEF PPC_BP}
+  {$DEFINE PPC_DELPHI}
+  {$DEFINE PPC_DELPHI3}
+  {$DEFINE PPC_DELPHI4}
+  {$UNDEF BP_VMTLink}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  OS2 COMPILERS change compiler type and mode - Updated 27Aug98 LdB        }
+{  Note: Assumes BPOS2 16BIT OS2 patch except for FPC which undefines this  }
+{---------------------------------------------------------------------------}
+{$IFDEF OS2}
+  {$UNDEF OS_DOS}
+  {$DEFINE OS_OS2}
+  {$UNDEF PROC_Real}
+  {$DEFINE PROC_Protected}
+  {$UNDEF PPC_BP}
+  {$DEFINE PPC_BPOS2}
+  {$IFDEF FPC}
+    {$UNDEF PPC_BPOS2}
+  {$ENDIF}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  VIRTUAL PASCAL changes compiler type/32 bit - Updated 27Aug98 LdB        }
+{  Note: VP2 can compile win 32 code so changes op system as needed         }
+{---------------------------------------------------------------------------}
+{$IFDEF VirtualPascal}
+  {$UNDEF BIT_16}
+  {$DEFINE BIT_32}
+  {$IFDEF PPC_BPOS2}
+    {$UNDEF PPC_BPOS2}
+  {$ENDIF}
+  {$DEFINE PPC_VIRTUAL}
+  {$IFDEF WIN32}
+    {$UNDEF PPC_BP}
+    {$UNDEF OS_OS2}
+    {$DEFINE OS_WINDOWS}
+  {$ENDIF}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  SPEED COMPILER changes compiler type/32 bit  - Updated 27Aug98 LdB       }
+{---------------------------------------------------------------------------}
+{$IFDEF Speed}
+  {$UNDEF BIT_16}
+  {$DEFINE BIT_32}
+  {$UNDEF PPC_BPOS2}
+  {$DEFINE PPC_SPEED}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  FPC AMIGA COMPILER changes op system and CPU type - Updated 27Aug98 LdB  }
+{---------------------------------------------------------------------------}
+{$IFDEF AMIGA}
+  {$UNDEF OS_DOS}
+  {$DEFINE OS_AMIGA}
+  {$IFDEF CPU86}
+    {$UNDEF CPU86}
+  {$ENDIF}
+  {$IFNDEF CPU68}
+    {$DEFINE CPU68}
+  {$ENDIF}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  FPC ATARI COMPILER changes op system and CPU type - Updated 27Aug98 LdB  }
+{---------------------------------------------------------------------------}
+{$IFDEF ATARI}
+  {$UNDEF OS_DOS}
+  {$DEFINE OS_ATARI}
+  {$IFDEF CPU86}
+    {$UNDEF CPU86}
+  {$ENDIF}
+  {$IFNDEF CPU68}
+    {$DEFINE CPU68}
+  {$ENDIF}
+{$ENDIF}
+
+{---------------------------------------------------------------------------}
+{  FPC MAC COMPILER changes op system and CPU type - Updated 27Aug98 LdB    }
+{---------------------------------------------------------------------------}
+{$IFDEF MACOS}
+  {$UNDEF OS_DOS}
+  {$DEFINE OS_MAC}
+  {$IFDEF CPU86}
+    {$UNDEF CPU86}
+  {$ENDIF}
+  {$IFNDEF CPU68}
+    {$DEFINE CPU68}
+  {$ENDIF}
+{$ENDIF}
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/12/23 19:36:47  peter
+    * place unitfiles in target dirs
+
+  Revision 1.1  1999/11/24 23:36:37  peter
+    * moved to packages dir
+
+  Revision 1.1  1998/12/04 12:48:24  peter
+    * moved some dirs
+
+  Revision 1.5  1998/10/26 11:22:53  peter
+    * updates
+
+}

api/inc/video.pas

@@ -0,0 +1,284 @@
+{
+   $Id$
+
+   System independent low-level video interface
+   Based on Daniel Mantion's interface designs
+
+   Copyright (c) 1997 Balazs Scheidler ([email protected])
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+
+  Todo:
+   - getting escape sequences from termcap
+   - implement library on other platforms (OS/2)
+
+ ****************************************************************************}
+unit Video;
+
+interface
+
+uses
+  Common;
+
+{$i platform.inc}
+
+type
+  PVideoMode = ^TVideoMode;
+  TVideoMode = record
+    Col,Row : Word;
+    Color   : Boolean;
+  end;
+  TVideoModeSelector = function (const VideoMode: TVideoMode; Params: Longint): Boolean;
+
+  TVideoCell = Word;
+  PVideoCell = ^TVideoCell;
+
+  TVideoBuf = array[0..3999] of TVideoCell;
+  PVideoBuf = ^TVideoBuf;
+
+const
+  { Foreground and background color constants }
+  Black         = 0;
+  Blue          = 1;
+  Green         = 2;
+  Cyan          = 3;
+  Red           = 4;
+  Magenta       = 5;
+  Brown         = 6;
+  LightGray     = 7;
+
+  { Foreground color constants }
+  DarkGray      = 8;
+  LightBlue     = 9;
+  LightGreen    = 10;
+  LightCyan     = 11;
+  LightRed      = 12;
+  LightMagenta  = 13;
+  Yellow        = 14;
+  White         = 15;
+
+  { Add-in for blinking }
+  Blink         = 128;
+
+  { Capabilities bitmask }
+  cpUnderLine     = $0001;
+  cpBlink         = $0002;
+  cpColor         = $0004;
+  cpChangeFont    = $0008;
+  cpChangeMode    = $0010;
+  cpChangeCursor  = $0020;
+
+  { Possible cursor types }
+  crHidden        = 0;
+  crUnderLine     = 1;
+  crBlock         = 2;
+  crHalfBlock     = 3;
+
+  { Possible error codes }
+  vioOK              = 0;
+  errVioInit         = errVioBase + 1; { Initialization error, shouldn't occur on DOS, but may
+                         on Linux }
+  errVioNotSupported = errVioBase + 2; { call to an unsupported function }
+  errVioNoSuchMode   = errVioBase + 3; { No such video mode }
+
+const
+  ScreenWidth  : Word = 0;
+  ScreenHeight : Word = 0;
+
+var
+  ScreenColor  : Boolean;
+  CursorX,
+  CursorY      : Word;
+  LockUpdateScreen : Word;
+  VideoBuf     : PVideoBuf;
+  VideoBufSize : Longint;
+  CursorLines  : Byte;
+const
+  LowAscii     : Boolean=true;
+
+procedure InitVideo;
+{ Initializes the video subsystem }
+procedure DoneVideo;
+{ Deinitializes the video subsystem }
+function GetCapabilities: Word;
+{ Return the capabilities of the current environment }
+procedure ClearScreen;
+{ Clears the screen }
+procedure UpdateScreen(Force: Boolean);
+{ Force specifies whether the whole screen has to be redrawn, or (if target
+  platform supports it) its parts only }
+procedure SetCursorPos(NewCursorX, NewCursorY: Word);
+{ Position the cursor to the given position }
+function GetCursorType: Word;
+{ Return the cursor type: Hidden, UnderLine or Block }
+procedure SetCursorType(NewType: Word);
+{ Set the cursor to the given type }
+function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean;
+
+procedure GetVideoMode(var Mode: TVideoMode);
+{ Return dimensions of the current video mode }
+procedure SetVideoMode(Mode: TVideoMode);
+{ Set video-mode to have Mode dimensions, may return errVioNoSuchMode }
+procedure RegisterVideoMode(Col, Row: Word; Color: Boolean; VideoModeSelector: TVideoModeSelector; Params: Longint);
+{ Registers a video mode to be selectable by SetVideoMode }
+
+{ moved to interface because we need a way to retrieve the modes }
+{ System independent part }
+type
+  PVideoModeList = ^TVideoModeList;
+  TVideoModeList = record
+    Col, Row: Word;
+    Color: Boolean;
+    VideoModeSelector: TVideoModeSelector;
+    Params: Longint;
+    Next: PVideoModeList;
+  end;
+
+const
+  Modes: PVideoModeList = nil;
+implementation
+
+{ Include system dependent part }
+{$i video.inc}
+
+procedure GetVideoMode(var Mode: TVideoMode);
+begin
+  Mode.Col := ScreenWidth;
+  Mode.Row := ScreenHeight;
+  Mode.Color := ScreenColor;
+end;
+
+procedure SetVideoMode(Mode: TVideoMode);
+var
+  P: PVideoModeList;
+begin
+  P := Modes;
+  while (P<>Nil) and ((P^.Row <> Mode.Row) or (P^.Col <> Mode.Col) or (P^.Color<>Mode.Color)) do
+    P := P^.Next;
+  if P <> nil then begin
+    DoneVideo;
+    ScreenWidth:=$ffff;
+    ScreenHeight:=$ffff;
+    P^.VideoModeSelector(PVideoMode(P)^, P^.Params);
+    InitVideo;
+   end
+   else begin
+    ErrorHandler(errVioNoSuchMode, @Mode);
+  end;
+end;
+
+procedure RegisterVideoMode(Col, Row: Word; Color: Boolean; VideoModeSelector: TVideoModeSelector; Params: Longint);
+var
+  P: PVideoModeList;
+begin
+  New(P);
+  P^.Col := Col;
+  P^.Row := Row;
+  P^.Color := Color;
+  P^.VideoModeSelector := VideoModeSelector;
+  P^.Params := Params;
+  P^.Next := Modes;
+  Modes := P;
+end;
+
+
+var
+  OldExitProc : pointer;
+procedure UnRegisterVideoModes;{$ifdef PPC_BP}far;{$endif}
+var
+  P: PVideoModeList;
+begin
+  ExitProc:=OldExitProc;
+  while assigned(modes) do
+   begin
+     p:=modes;
+     modes:=modes^.next;
+     dispose(p);
+   end;
+end;
+
+
+begin
+  RegisterVideoModes;
+  OldExitProc:=ExitProc;
+  ExitProc:=@UnRegisterVideoModes;
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/12/23 19:36:47  peter
+    * place unitfiles in target dirs
+
+  Revision 1.1  1999/11/24 23:36:37  peter
+    * moved to packages dir
+
+  Revision 1.9  1999/03/14 22:15:48  florian
+    * my last changes doesn't work correctly, fixed more
+      the screen height calculation works incorrect in 80x50 mode
+
+  Revision 1.8  1999/03/14 17:43:00  florian
+    + 80x50 mode support added
+    * some bugs in VESA mode support removed
+
+  Revision 1.7  1999/03/13 17:34:01  florian
+    * again SetVideoMode fixed
+
+  Revision 1.6  1999/03/13 17:30:47  florian
+    * endless loop in SetVideoMode fixed
+
+  Revision 1.5  1999/02/22 12:46:15  peter
+    + lowascii boolean if ascii < #32 is handled correctly
+
+  Revision 1.4  1998/12/23 22:41:08  peter
+    + color consts
+
+  Revision 1.3  1998/12/11 00:13:18  peter
+    + SetMouseXY
+    * use far for exitproc procedure
+
+  Revision 1.2  1998/12/08 10:09:56  peter
+    * unregister videomodes at the end
+
+  Revision 1.1  1998/12/04 12:48:24  peter
+    * moved some dirs
+
+  Revision 1.14  1998/11/01 20:29:10  peter
+    + lockupdatescreen counter to not let updatescreen() update
+
+  Revision 1.13  1998/10/28 21:18:23  peter
+    * more fixes
+
+  Revision 1.12  1998/10/28 00:02:07  peter
+    + mouse
+    + video.clearscreen, video.videobufsize
+
+  Revision 1.11  1998/10/27 11:24:20  peter
+    * fixed the log
+
+
+   Date       Version   Who       Comments
+   07/06/97   0.1       bazsi     Initial implementation
+                                  Console mode (Linux) ready
+   07/28/97   0.2       bazsi     Linux on foreign terminals ready
+   08/27/97   0.3       bazsi     Noone else did it, so I did it: DOS support
+                                  (I had to boot DOS... ;-(
+                                  Mode-switching implemented
+   07/28/97   0.3.1     bazsi     added support for terminfo. remote terminal
+                                  support is broken now
+}

api/linux/Makefile

@@ -0,0 +1,1072 @@
+#
+# Makefile generated by fpcmake v0.99.13 [2000/01/06]
+#
+
+defaultrule: all
+
+#####################################################################
+# Autodetect OS (Linux or Dos or Windows NT)
+# define inlinux when running under linux
+# define inWinNT when running under WinNT
+#####################################################################
+
+# We need only / in the path
+override PATH:=$(subst \,/,$(PATH))
+
+# Search for PWD and determine also if we are under linux
+PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH)))))
+ifeq ($(PWD),)
+PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH)))))
+ifeq ($(PWD),)
+nopwd:
+	@echo You need the GNU utils package to use this Makefile!
+	@echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip
+	@exit
+else
+inlinux=1
+endif
+else
+PWD:=$(firstword $(PWD))
+endif
+
+# Detect NT - NT sets OS to Windows_NT
+ifndef inlinux
+ifeq ($(OS),Windows_NT)
+inWinNT=1
+endif
+endif
+
+# Detect OS/2 - OS/2 has OS2_SHELL defined
+ifndef inlinux
+ifndef inWinNT
+ifdef OS2_SHELL
+inOS2=1
+endif
+endif
+endif
+
+# The extension of executables
+ifdef inlinux
+EXEEXT=
+else
+EXEEXT=.exe
+endif
+
+# The path which is searched separated by spaces
+ifdef inlinux
+SEARCHPATH=$(subst :, ,$(PATH))
+else
+SEARCHPATH=$(subst ;, ,$(PATH))
+endif
+
+#####################################################################
+# Default target
+#####################################################################
+
+override OS_TARGET:=linux
+
+#####################################################################
+# FPC version/target Detection
+#####################################################################
+
+# What compiler to use ?
+ifndef FPC
+# Compatibility with old makefiles
+ifdef PP
+FPC=$(PP)
+else
+ifdef inOS2
+FPC=ppos2$(EXEEXT)
+else
+FPC=ppc386$(EXEEXT)
+endif
+endif
+endif
+
+# Target OS
+ifndef OS_TARGET
+OS_TARGET:=$(shell $(FPC) -iTO)
+endif
+
+# Source OS
+ifndef OS_SOURCE
+OS_SOURCE:=$(shell $(FPC) -iSO)
+endif
+
+# Target CPU
+ifndef CPU_TARGET
+CPU_TARGET:=$(shell $(FPC) -iTP)
+endif
+
+# Source CPU
+ifndef CPU_SOURCE
+CPU_SOURCE:=$(shell $(FPC) -iSP)
+endif
+
+# FPC version
+ifndef FPC_VERSION
+FPC_VERSION:=$(shell $(FPC) -iV)
+endif
+
+export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION
+
+# Test FPCDIR to look if the RTL dir exists
+ifdef FPCDIR
+override FPCDIR:=$(subst \,/,$(FPCDIR))
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+else
+override FPCDIR=wrong
+endif
+
+# Default FPCDIR
+ifeq ($(FPCDIR),wrong)
+override FPCDIR=../..
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+endif
+
+# Detect FPCDIR
+ifeq ($(FPCDIR),wrong)
+ifdef inlinux
+override FPCDIR=/usr/lib/fpc/$(FPC_VERSION)
+else
+override FPCDIR:=$(subst /$(FPC)$(EXEEXT),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC)$(EXEEXT),$(SEARCHPATH))))))
+endif
+endif
+
+ifndef PACKAGEDIR
+PACKAGEDIR=$(FPCDIR)/packages
+endif
+ifndef COMPONENTDIR
+COMPONENTDIR=$(FPCDIR)/components
+endif
+# Check if packagedir really exists else turn it off
+ifeq ($(wildcard $(PACKAGEDIR)),)
+PACKAGEDIR=
+endif
+ifeq ($(wildcard $(COMPONENTDIR)),)
+COMPONENTDIR=
+endif
+
+# Create rtl,units dir
+ifneq ($(FPCDIR),.)
+override UNITSDIR=$(FPCDIR)/units/$(OS_TARGET)
+ifneq ($(wildcard $(FPCDIR)/rtl),)
+override RTLDIR=$(FPCDIR)/rtl/$(OS_TARGET)
+else
+override RTLDIR=$(UNITSDIR)/rtl
+endif
+endif
+
+#####################################################################
+# Default Settings
+#####################################################################
+
+# Release ? Then force OPT and don't use extra opts via commandline
+ifndef REDIRFILE
+REDIRFILE=log
+endif
+
+ifdef REDIR
+ifndef inlinux
+override FPC=redir -eo $(FPC)
+endif
+# set the verbosity to max
+override OPT+=-va
+override REDIR:= >> $(REDIRFILE)
+endif
+
+#####################################################################
+# User Settings
+#####################################################################
+
+
+# Pre Settings
+
+INC=../inc
+
+# Override defaults
+override PASEXT=.pas
+
+include ../test/Makefile.api
+include $(INC)/Makefile.api
+
+# Targets
+
+override UNITOBJECTS+=terminfo $(APIOBJECTS)
+override EXAMPLEOBJECTS+=$(TESTOBJECTS)
+
+# Clean
+
+
+# Install
+
+UNITSUBDIR=api
+ZIPTARGET=install
+
+# Defaults
+
+
+# Directories
+
+vpath %$(PASEXT) $(INC)
+ifndef TARGETDIR
+TARGETDIR=.
+endif
+
+# Packages
+
+override PACKAGES=rtl
+PACKAGEDIR_RTL=$(FPCDIR)/rtl/$(OS_TARGET)
+
+# Libraries
+
+LIBNAME=fpapi
+
+# Info
+
+INFOTARGET=fpc_infocfg fpc_infoobjects fpc_infoinstall 
+
+#####################################################################
+# Default Directories
+#####################################################################
+
+# Base dir
+ifdef PWD
+BASEDIR:=$(shell $(PWD))
+else
+BASEDIR=.
+endif
+
+# set the prefix directory where to install everything
+ifndef PREFIXINSTALLDIR
+ifdef inlinux
+PREFIXINSTALLDIR=/usr
+else
+PREFIXINSTALLDIR=/pp
+endif
+endif
+export PREFIXINSTALLDIR
+
+#####################################################################
+# Install Directories
+#####################################################################
+
+# set the base directory where to install everything
+ifndef BASEINSTALLDIR
+ifdef inlinux
+BASEINSTALLDIR=$(PREFIXINSTALLDIR)/lib/fpc/$(FPC_VERSION)
+else
+BASEINSTALLDIR=$(PREFIXINSTALLDIR)
+endif
+endif
+
+# set the directory where to install the binaries
+ifndef BININSTALLDIR
+ifdef inlinux
+BININSTALLDIR=$(PREFIXINSTALLDIR)/bin
+else
+BININSTALLDIR=$(BASEINSTALLDIR)/bin/$(OS_TARGET)
+endif
+endif
+
+# set the directory where to install the units.
+ifndef UNITINSTALLDIR
+UNITINSTALLDIR=$(BASEINSTALLDIR)/units/$(OS_TARGET)
+ifdef UNITSUBDIR
+UNITINSTALLDIR:=$(UNITINSTALLDIR)/$(UNITSUBDIR)
+endif
+endif
+
+# Where to install shared libraries
+ifndef LIBINSTALLDIR
+ifdef inlinux
+LIBINSTALLDIR=$(PREFIXINSTALLDIR)/lib
+else
+LIBINSTALLDIR=$(UNITINSTALLDIR)
+endif
+endif
+
+# Where the source files will be stored
+ifndef SOURCEINSTALLDIR
+ifdef inlinux
+SOURCEINSTALLDIR=$(PREFIXINSTALLDIR)/src/fpc-$(FPC_VERSION)
+else
+SOURCEINSTALLDIR=$(BASEINSTALLDIR)/source
+endif
+endif
+
+# Where the doc files will be stored
+ifndef DOCINSTALLDIR
+ifdef inlinux
+DOCINSTALLDIR=$(PREFIXINSTALLDIR)/doc/fpc-$(FPC_VERSION)
+else
+DOCINSTALLDIR=$(BASEINSTALLDIR)/doc
+endif
+endif
+
+# Where the some extra (data)files will be stored
+ifndef DATAINSTALLDIR
+DATAINSTALLDIR=$(BASEINSTALLDIR)
+endif
+
+
+#####################################################################
+# Compiler Command Line
+#####################################################################
+
+# Load commandline OPTDEF and add FPC_CPU define
+override FPCOPTDEF:=-d$(CPU_TARGET)
+
+# Load commandline OPT and add target and unit dir to be sure
+ifneq ($(OS_TARGET),$(OS_SOURCE))
+override FPCOPT+=-T$(OS_TARGET)
+endif
+
+ifdef UNITSDIR
+override FPCOPT+=-Fu$(UNITSDIR)
+endif
+
+ifdef RTLDIR
+override FPCOPT+=-Fu$(RTLDIR)
+endif
+
+# Target dirs
+ifdef TARGETDIR
+override FPCOPT+=-FE$(TARGETDIR)
+endif
+
+# Smartlinking
+ifdef SMARTLINK
+override FPCOPT+=-CX
+endif
+
+# Debug
+ifdef DEBUG
+override FPCOPT+=-g
+endif
+
+# Release mode (strip, optimize and don't load ppc386.cfg)
+ifdef RELEASE
+override FPCOPT+=-Xs -OG2p3 -n
+endif
+
+# Verbose settings (warning,note,info)
+ifdef VERBOSE
+override FPCOPT+=-vwni
+endif
+
+# Add commandline options
+ifdef OPT
+override FPCOPT+=$(OPT)
+endif
+ifdef UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
+endif
+ifdef LIBDIR
+override FPCOPT+=$(addprefix -Fl,$(LIBDIR))
+endif
+ifdef OBJDIR
+override FPCOPT+=$(addprefix -Fo,$(OBJDIR))
+endif
+ifdef INCDIR
+override FPCOPT+=$(addprefix -Fi,$(INCDIR))
+endif
+
+# Add defines from FPCOPTDEF to FPCOPT
+ifdef FPCOPTDEF
+override FPCOPT+=$(FPCOPTDEF)
+endif
+
+# Error file ?
+ifdef ERRORFILE
+override FPCOPT+=-Fr$(ERRORFILE)
+endif
+
+# Was a config file specified ?
+ifdef CFGFILE
+override FPCOPT+=@$(CFGFILE)
+endif
+
+# For win32 the options are passed using the environment variable FPCEXTCMD
+ifeq ($(OS_SOURCE),win32)
+override FPCEXTCMD:=$(FPCOPT)
+override FPCOPT:=!FPCEXTCMD
+export FPCEXTCMD
+endif
+
+# Compiler commandline
+override COMPILER:=$(FPC) $(FPCOPT)
+
+#####################################################################
+# Shell tools
+#####################################################################
+
+# To copy pograms
+ifndef COPY
+COPY:=cp -fp
+endif
+
+# Copy a whole tree
+ifndef COPYTREE
+COPYTREE:=cp -rfp
+endif
+
+# To move pograms
+ifndef MOVE
+MOVE:=mv -f
+endif
+
+# Check delete program
+ifndef DEL
+DEL:=rm -f
+endif
+
+# Check deltree program
+ifndef DELTREE
+DELTREE:=rm -rf
+endif
+
+# To install files
+ifndef INSTALL
+ifdef inlinux
+INSTALL:=install -m 644
+else
+INSTALL:=$(COPY)
+endif
+endif
+
+# To install programs
+ifndef INSTALLEXE
+ifdef inlinux
+INSTALLEXE:=install -m 755
+else
+INSTALLEXE:=$(COPY)
+endif
+endif
+
+# To make a directory.
+ifndef MKDIR
+ifdef inlinux
+MKDIR:=install -m 755 -d
+else
+MKDIR:=ginstall -m 755 -d
+endif
+endif
+
+export COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR
+
+#####################################################################
+# Default Tools
+#####################################################################
+
+# assembler, redefine it if cross compiling
+ifndef AS
+AS=as
+endif
+
+# linker, but probably not used
+ifndef LD
+LD=ld
+endif
+
+# ppas.bat / ppas.sh
+ifdef inlinux
+PPAS=ppas.sh
+else
+ifdef inOS2
+PPAS=ppas.cmd
+else
+PPAS=ppas.bat
+endif
+endif
+
+# also call ppas if with command option -s
+ifeq (,$(findstring -s ,$(COMPILER)))
+EXECPPAS=
+else
+EXECPPAS:=@$(PPAS)
+endif
+
+# ldconfig to rebuild .so cache
+ifdef inlinux
+LDCONFIG=ldconfig
+else
+LDCONFIG=
+endif
+
+# echo
+ifndef ECHO
+ECHO:=$(strip $(wildcard $(addsuffix /echo$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO:=echo
+else
+ECHO:=$(firstword $(ECHO))
+endif
+endif
+export ECHO
+
+# ppdep
+ifndef PPDEP
+PPDEP:=$(strip $(wildcard $(addsuffix /ppdep$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPDEP),)
+PPDEP=
+else
+PPDEP:=$(firstword $(PPDEP))
+endif
+endif
+export PPDEP
+
+# ppumove
+ifndef PPUMOVE
+PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUMOVE),)
+PPUMOVE=
+else
+PPUMOVE:=$(firstword $(PPUMOVE))
+endif
+endif
+export PPUMOVE
+
+# ppufiles
+ifndef PPUFILES
+PPUFILES:=$(strip $(wildcard $(addsuffix /ppufiles$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUFILES),)
+PPUFILES=
+else
+PPUFILES:=$(firstword $(PPUFILES))
+endif
+endif
+export PPUFILES
+
+# Look if UPX is found for go32v2 and win32. We can't use $UPX becuase
+# upx uses that one itself (PFV)
+ifndef UPXPROG
+ifeq ($(OS_TARGET),go32v2)
+UPXPROG:=1
+endif
+ifeq ($(OS_TARGET),win32)
+UPXPROG:=1
+endif
+ifdef UPXPROG
+UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(UPXPROG),)
+UPXPROG=
+else
+UPXPROG:=$(firstword $(UPXPROG))
+endif
+else
+UPXPROG=
+endif
+endif
+export UPXPROG
+
+# gdate/date
+ifndef DATE
+DATE:=$(strip $(wildcard $(addsuffix /date$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE:=$(strip $(wildcard $(addsuffix /gdate$(EXEEXT),$(SEACHPATH))))
+ifeq ($(DATE),)
+DATE=
+else
+DATE:=$(firstword $(DATE))
+endif
+else
+DATE:=$(firstword $(DATE))
+endif
+endif
+export DATE
+
+ifdef DATE
+DATESTR:=$(shell $(DATE) +%Y%m%d)
+else
+DATESTR=
+endif
+
+# ZipProg, you can't use Zip as the var name (PFV)
+ifndef ZIPPROG
+ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(ZIPPROG),)
+ZIPPROG=
+else
+ZIPPROG:=$(firstword $(ZIPPROG)) -D9 -r
+endif
+endif
+export ZIPPROG
+
+ifndef ZIPEXT
+ZIPEXT=.zip
+endif
+
+#####################################################################
+# Default extensions
+#####################################################################
+
+# Default needed extensions (Go32v2,Linux)
+LOADEREXT=.as
+PPLEXT=.ppl
+PPUEXT=.ppu
+OEXT=.o
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.so
+RSTEXT=.rst
+PACKAGESUFFIX=
+FPCMADE=fpcmade
+
+# Go32v1
+ifeq ($(OS_TARGET),go32v1)
+PPUEXT=.pp1
+OEXT=.o1
+ASMEXT=.s1
+SMARTEXT=.sl1
+STATICLIBEXT=.a1
+SHAREDLIBEXT=.so1
+PACKAGESUFFIX=v1
+FPCMADE=fpcmade.v1
+endif
+
+# Go32v2
+ifeq ($(OS_TARGET),go32v2)
+PACKAGESUFFIX=go32
+FPCMADE=fpcmade.dos
+endif
+
+# Linux
+ifeq ($(OS_TARGET),linux)
+PACKAGESUFFIX=linux
+FPCMADE=fpcmade.lnx
+endif
+
+# Win32
+ifeq ($(OS_TARGET),win32)
+PPUEXT=.ppw
+OEXT=.ow
+ASMEXT=.sw
+SMARTEXT=.slw
+STATICLIBEXT=.aw
+SHAREDLIBEXT=.dll
+PACKAGESUFFIX=win32
+FPCMADE=fpcmade.w32
+endif
+
+# OS/2
+ifeq ($(OS_TARGET),os2)
+PPUEXT=.ppo
+ASMEXT=.so2
+OEXT=.oo2
+SMARTEXT=.so
+STATICLIBEXT=.ao2
+SHAREDLIBEXT=.dll
+PACKAGESUFFIX=os2
+FPCMADE=fpcmade.os2
+endif
+
+# library prefix
+LIBPREFIX=lib
+ifeq ($(OS_TARGET),go32v2)
+LIBPREFIX=
+endif
+ifeq ($(OS_TARGET),go32v1)
+LIBPREFIX=
+endif
+
+# determine which .pas extension is used
+ifndef PASEXT
+ifdef EXEOBJECTS
+override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(EXEOBJECTS)))))
+else
+override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(UNITOBJECTS)))))
+endif
+ifeq ($(TESTPAS),)
+PASEXT=.pp
+else
+PASEXT=.pas
+endif
+endif
+
+#####################################################################
+# Standard rules
+#####################################################################
+
+all: fpc_all
+
+debug: fpc_debug
+
+examples: fpc_examples
+
+test: fpc_test
+
+smart: fpc_smart
+
+shared: fpc_shared
+
+showinstall: fpc_showinstall
+
+install: fpc_install
+
+sourceinstall: fpc_sourceinstall
+
+zipinstall: fpc_zipinstall
+
+zipinstalladd: fpc_zipinstalladd
+
+clean: fpc_clean
+
+cleanall: fpc_cleanall
+
+info: fpc_info
+
+.PHONY:  all debug examples test smart shared showinstall install sourceinstall zipinstall zipinstalladd clean cleanall info
+
+
+ifdef PACKAGERTL
+ifneq ($(wildcard $(PACKAGEDIR_RTL)),)
+ifeq ($(wildcard $(PACKAGEDIR_RTL)/$(FPCMADE)),)
+override COMPILEPACKAGES+=rtl
+rtl_package:
+	$(MAKE) -C $(PACKAGEDIR_RTL) all
+endif
+endif
+endif
+
+.PHONY:  rtl_package
+
+#####################################################################
+# Units
+#####################################################################
+
+.PHONY: fpc_units
+
+override ALLTARGET+=fpc_units
+
+override UNITPPUFILES=$(addsuffix $(PPUEXT),$(UNITOBJECTS))
+override INSTALLPPUFILES+=$(UNITPPUFILES)
+override CLEANPPUFILES+=$(UNITPPUFILES)
+
+fpc_units: $(UNITPPUFILES)
+
+#####################################################################
+# Examples
+#####################################################################
+
+.PHONY: fpc_examples fpc_test
+
+override EXAMPLEFILES:=$(addsuffix $(EXEEXT),$(EXAMPLEOBJECTS))
+override EXAMPLEOFILES:=$(addsuffix $(OEXT),$(EXAMPLEOBJECTS))
+
+override CLEANEXEFILES+=$(EXAMPLEFILES) $(EXAMPLEOFILES)
+
+fpc_examples: all $(EXAMPLEFILES)
+
+fpc_test: examples
+
+#####################################################################
+# General compile rules
+#####################################################################
+
+.PHONY: fpc_all fpc_debug
+
+$(FPCMADE):
+	@$(ECHO) Compiled > $(FPCMADE)
+
+fpc_all: $(addsuffix _package,$(COMPILEPACKAGES)) \
+	 $(addsuffix _component,$(COMPILECOMPONENTS)) \
+	 $(ALLTARGET) $(FPCMADE)
+
+fpc_debug:
+	$(MAKE) all DEBUG=1
+
+# General compile rules, available for both possible PASEXT
+
+.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp
+
+%$(PPUEXT): %.pp
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(PPUEXT): %.pas
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(EXEEXT): %.pp
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(EXEEXT): %.pas
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+#####################################################################
+# Library
+#####################################################################
+
+.PHONY: fpc_smart fpc_shared
+
+# Default sharedlib units are all unit objects
+ifndef SHAREDLIBUNITOBJECTS
+SHAREDLIBUNITOBJECTS:=$(UNITOBJECTS)
+endif
+
+fpc_smart:
+	$(MAKE) all SMARTLINK=1
+
+fpc_shared: all
+ifdef inlinux
+ifndef LIBNAME
+	@$(ECHO) "LIBNAME not set"
+else
+	$(PPUMOVE) $(SHAREDLIBUNITOBJECTS) -o$(LIBNAME)
+endif
+else
+	@$(ECHO) "Shared Libraries not supported"
+endif
+
+#####################################################################
+# Install rules
+#####################################################################
+
+.PHONY: fpc_showinstall fpc_install
+
+ifdef EXTRAINSTALLUNITS
+override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRAINSTALLUNITS))
+endif
+
+ifdef INSTALLPPUFILES
+ifdef PPUFILES
+ifdef inlinux
+INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
+INSTALLPPULIBFILES:=$(shell $(PPUFILES) -L $(INSTALLPPUFILES))
+else
+INSTALLPPULINKFILES:=$(shell $(PPUFILES) $(INSTALLPPUFILES))
+endif
+else
+INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
+endif
+endif
+
+fpc_showinstall: $(SHOWINSTALLTARGET)
+ifdef INSTALLEXEFILES
+	@$(ECHO) -e $(addprefix "\n"$(BININSTALLDIR)/,$(INSTALLEXEFILES))
+endif
+ifdef INSTALLPPUFILES
+	@$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPUFILES))
+ifneq ($(INSTALLPPULINKFILES),)
+	@$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPULINKFILES))
+endif
+ifneq ($(INSTALLPPULIBFILES),)
+	@$(ECHO) -e $(addprefix "\n"$(LIBINSTALLDIR)/,$(INSTALLPPULIBFILES))
+endif
+endif
+ifdef EXTRAINSTALLFILES
+	@$(ECHO) -e $(addprefix "\n"$(DATAINSTALLDIR)/,$(EXTRAINSTALLFILES))
+endif
+
+fpc_install: $(INSTALLTARGET)
+# Create UnitInstallFiles
+ifdef INSTALLEXEFILES
+	$(MKDIR) $(BININSTALLDIR)
+# Compress the exes if upx is defined
+ifdef UPXPROG
+	-$(UPXPROG) $(INSTALLEXEFILES)
+endif
+	$(INSTALLEXE) $(INSTALLEXEFILES) $(BININSTALLDIR)
+endif
+ifdef INSTALLPPUFILES
+	$(MKDIR) $(UNITINSTALLDIR)
+	$(INSTALL) $(INSTALLPPUFILES) $(UNITINSTALLDIR)
+ifneq ($(INSTALLPPULINKFILES),)
+	$(INSTALL) $(INSTALLPPULINKFILES) $(UNITINSTALLDIR)
+endif
+ifneq ($(INSTALLPPULIBFILES),)
+	$(MKDIR) $(LIBINSTALLDIR)
+	$(INSTALL) $(INSTALLPPULIBFILES) $(LIBINSTALLDIR)
+endif
+endif
+ifdef EXTRAINSTALLFILES
+	$(MKDIR) $(DATAINSTALLDIR)
+	$(INSTALL) $(EXTRAINSTALLFILES) $(DATAINSTALLDIR)
+endif
+
+#####################################################################
+# Source install rules
+#####################################################################
+
+.PHONY: fpc_sourceinstall
+
+fpc_sourceinstall: clean
+	$(MKDIR) $(SOURCEINSTALLDIR)
+	$(COPYTREE) $(BASEDIR) $(SOURCEINSTALLDIR)
+
+#####################################################################
+# Zip
+#####################################################################
+
+.PHONY: fpc_zipinstall fpc_zipinstalladd
+
+# Temporary path to pack a file
+ifndef PACKDIR
+ifndef inlinux
+PACKDIR=pack_tmp
+else
+PACKDIR=/tmp/fpc-pack
+endif
+endif
+
+# Test dir if none specified
+ifndef DESTZIPDIR
+DESTZIPDIR:=$(BASEDIR)
+endif
+
+# Add .zip/.tar.gz extension
+ifdef ZIPNAME
+ifndef inlinux
+override ZIPNAME:=$(ZIPNAME)$(ZIPEXT)
+endif
+endif
+
+# Note: This will not remove the zipfile first
+fpc_zipinstalladd:
+ifndef ZIPNAME
+	@$(ECHO) "Please specify ZIPNAME!"
+	@exit 1
+else
+	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
+ifdef inlinux
+	gzip -d $(DESTZIPDIR)/$(ZIPNAME).tar.gz
+	cd $(PACKDIR) ; tar rv --file $(DESTZIPDIR)/$(ZIPNAME).tar * ; cd $(BASEDIR)
+	gzip $(DESTZIPDIR)/$(ZIPNAME).tar
+else
+	cd $(PACKDIR) ; $(ZIPPROG) $(DESTZIPDIR)/$(ZIPNAME) * ; cd $(BASEDIR)
+endif
+	$(DELTREE) $(PACKDIR)
+endif
+
+# First remove the zip and then install
+fpc_zipinstall:
+ifndef ZIPNAME
+	@$(ECHO) "Please specify ZIPNAME!"
+	@exit 1
+else
+	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)
+	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
+ifdef inlinux
+	cd $(PACKDIR) ; tar cvz --file $(DESTZIPDIR)/$(ZIPNAME).tar.gz * ; cd $(BASEDIR)
+else
+	cd $(PACKDIR) ; $(ZIPPROG) $(DESTZIPDIR)/$(ZIPNAME) * ; cd $(BASEDIR)
+endif
+	$(DELTREE) $(PACKDIR)
+endif
+
+#####################################################################
+# Clean rules
+#####################################################################
+
+.PHONY: fpc_clean fpc_cleanall
+
+ifdef EXTRACLEANUNITS
+override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRACLEANUNITS))
+endif
+
+ifdef CLEANPPUFILES
+ifdef PPUFILES
+CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
+else
+CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
+endif
+endif
+
+fpc_clean: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+ifdef CLEANPPUFILES
+	-$(DEL) $(CLEANPPUFILES)
+endif
+ifneq ($(CLEANPPULINKFILES),)
+	-$(DEL) $(CLEANPPULINKFILES)
+endif
+ifdef CLEANRSTFILES
+	-$(DEL) $(CLEANRSTFILES)
+endif
+ifdef EXTRACLEANFILES
+	-$(DEL) $(EXTRACLEANFILES)
+endif
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(REDIRFILE)
+
+fpc_cleanall: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+	-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+	-$(DELTREE) *$(SMARTEXT)
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(REDIRFILE)
+
+#####################################################################
+# Info rules
+#####################################################################
+
+.PHONY: fpc_info fpc_cfginfo fpc_objectinfo fpc_toolsinfo fpc_installinfo \
+	fpc_dirinfo
+
+fpc_info: $(INFOTARGET)
+
+fpc_infocfg:
+	@$(ECHO)
+	@$(ECHO)  == Configuration info ==
+	@$(ECHO)
+	@$(ECHO)  FPC....... $(FPC)
+	@$(ECHO)  Version... $(FPC_VERSION)
+	@$(ECHO)  CPU....... $(CPU_TARGET)
+	@$(ECHO)  Source.... $(OS_SOURCE)
+	@$(ECHO)  Target.... $(OS_TARGET)
+	@$(ECHO)
+
+fpc_infoobjects:
+	@$(ECHO)
+	@$(ECHO)  == Object info ==
+	@$(ECHO)
+	@$(ECHO)  LoaderObjects..... $(LOADEROBJECTS)
+	@$(ECHO)  UnitObjects....... $(UNITOBJECTS)
+	@$(ECHO)  ExeObjects........ $(EXEOBJECTS)
+	@$(ECHO)
+	@$(ECHO)  ExtraCleanUnits... $(EXTRACLEANUNITS)
+	@$(ECHO)  ExtraCleanFiles... $(EXTRACLEANFILES)
+	@$(ECHO)
+	@$(ECHO)  ExtraInstallUnits. $(EXTRAINSTALLUNITS)
+	@$(ECHO)  ExtraInstallFiles. $(EXTRAINSTALLFILES)
+	@$(ECHO)
+
+fpc_infoinstall:
+	@$(ECHO)
+	@$(ECHO)  == Install info ==
+	@$(ECHO)
+ifdef DATE
+	@$(ECHO)  DateStr.............. $(DATESTR)
+endif
+	@$(ECHO)  PackageSuffix........ $(PACKAGESUFFIX)
+	@$(ECHO)
+	@$(ECHO)  BaseInstallDir....... $(BASEINSTALLDIR)
+	@$(ECHO)  BinInstallDir........ $(BININSTALLDIR)
+	@$(ECHO)  LibInstallDir........ $(LIBINSTALLDIR)
+	@$(ECHO)  UnitInstallDir....... $(UNITINSTALLDIR)
+	@$(ECHO)  SourceInstallDir..... $(SOURCEINSTALLDIR)
+	@$(ECHO)  DocInstallDir........ $(DOCINSTALLDIR)
+	@$(ECHO)  DataInstallDir....... $(DATAINSTALLDIR)
+	@$(ECHO)
+
+#####################################################################
+# Users rules
+#####################################################################
+
+video$(PPUEXT): $(INC)/video.pas video.inc
+
+keyboard$(PPUEXT): $(INC)/keyboard.pas keyboard.inc
+
+mouse$(PPUEXT): $(INC)/mouse.pas mouse.inc
+
+filectrl$(PPUEXT): $(INC)/filectrl.pas filectrl.inc

api/linux/Makefile.fpc

@@ -0,0 +1,41 @@
+#
+#   Makefile.fpc for Free Pascal API (used by Free Vision) for linux
+#
+
+[defaults]
+defaulttarget=linux
+
+[targets]
+units=terminfo $(APIOBJECTS)
+examples=$(TESTOBJECTS)
+
+[install]
+unitsubdir=api
+
+[libs]
+libname=fpapi
+
+[dirs]
+fpcdir=../..
+targetdir=.
+sourcesdir=$(INC)
+
+
+[presettings]
+INC=../inc
+
+# Override defaults
+override PASEXT=.pas
+
+include ../test/Makefile.api
+include $(INC)/Makefile.api
+
+
+[rules]
+video$(PPUEXT): $(INC)/video.pas video.inc
+
+keyboard$(PPUEXT): $(INC)/keyboard.pas keyboard.inc
+
+mouse$(PPUEXT): $(INC)/mouse.pas mouse.inc
+
+filectrl$(PPUEXT): $(INC)/filectrl.pas filectrl.inc

api/linux/filectrl.inc

@@ -0,0 +1,173 @@
+{
+  System independent filecontrol interface for linux
+
+  $Id$
+}
+uses
+  Linux;
+
+function OpenFileStr(FName: PChar; Flags: Longint): TFileHandle; [ alias: 'OpenFile' ];
+var
+  RC : longint;
+  Todo: TErrorHandlerReturnValue;
+begin
+  repeat
+    OpenFileStr:=fdOpen(FName, Flags, FilePerms);
+    RC:=LinuxError;
+    if (RC > 0) then
+      Todo := ErrorHandler(RC, FName);
+  until (RC <= 0) or (Todo <> errRetry);
+end;
+
+function CreateFileStr(FName: PChar): TFileHandle; [ alias: 'CreateFile' ];
+const
+  O_RDONLY = 0;
+  O_WRONLY = 1;
+  O_RDWR   = 2;
+  O_CREATE = 64;
+  O_EXCL   = 128;
+  O_NOCTTY = 256;
+  O_TRUNC  = 512;
+  O_APPEND = 1024;
+begin
+  CreateFileStr := OpenFileStr(FName, O_RDWR+O_CREATE+O_TRUNC);
+end;
+
+procedure CloseFile(Handle: TFileHandle);
+var
+  RC: Longint;
+  Todo: TErrorHandlerReturnValue;
+begin
+  repeat
+    fdClose(Handle);
+    RC := LinuxError;
+    if (RC > 0) then
+      Todo := ErrorHandler(RC, nil);
+  until (RC <= 0) or (Todo <> errRetry);
+end;
+
+function SeekFile(Handle: TFileHandle; Pos: TFileInt; SeekType: Word): TFileInt;
+var
+  RC: Longint;
+  Todo: TErrorHandlerReturnValue;
+begin
+  repeat
+    RC := -fdSeek(Handle, Pos, SeekType);
+    if (RC > 0) then
+      Todo := ErrorHandler(RC, nil);
+  until (RC <= 0) or (Todo <> errRetry);
+  SeekFile := -RC;
+end;
+
+procedure DeleteFileStr(FName: PChar); [ alias: 'DeleteFile' ];
+var
+  RC: Longint;
+  Todo: TErrorHandlerReturnValue;
+begin
+  repeat
+    UnLink(FName);
+    RC:=LinuxError;
+    if (RC > 0) then
+      Todo := ErrorHandler(RC, nil);
+  until (RC <= 0) or (Todo <> errRetry);
+end;
+
+function ReadFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord;
+var
+  RC: Longint;
+  BytesRead: LongInt;
+  Todo: TErrorHandlerReturnValue;
+begin
+  repeat
+    BytesRead := fdRead(Handle, Buff, Count);
+    RC:=LinuxError;
+    if (RC > 0) then
+      Todo := ErrorHandler(RC, nil);
+  until (RC <= 0) or (Todo <> errRetry);
+  if (RC > 0) then
+    ReadFile := 0
+   else
+    ReadFile := BytesRead;
+end;
+
+
+function WriteFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord;
+var
+  RC: Longint;
+  BytesWritten: LongInt;
+  Todo: TErrorHandlerReturnValue;
+begin
+  repeat
+    BytesWritten := fdWrite(Handle, Buff, Count);
+    RC:=LinuxError;
+    if (RC > 0) then
+      Todo := ErrorHandler(RC, nil);
+  until (RC <= 0) or (Todo <> errRetry);
+  if (RC > 0) then
+    WriteFile := 0
+   else
+    WriteFile := BytesWritten;
+end;
+
+{ The following two routines should go to syscalls... }
+
+procedure FlushFile(Handle: TFileHandle);
+var
+  RC: Longint;
+  Todo: TErrorHandlerReturnValue;
+begin
+  repeat
+    fdFlush(Handle);
+    RC:=LinuxError;
+    if (RC > 0) then
+      Todo := ErrorHandler(RC, nil);
+  until (RC <= 0) or (Todo <> errRetry);
+end;
+
+procedure TruncateFile(Handle: TFileHandle);
+var
+  RC: Longint;
+  Todo: TErrorHandlerReturnValue;
+begin
+  repeat
+    fdTruncate(Handle,0);
+    RC:=LinuxError;
+    if (RC > 0) then
+      Todo := ErrorHandler(RC, nil);
+  until (RC <= 0) or (Todo <> errRetry);
+end;
+
+function EndOfFile(Handle: TFileHandle): Boolean;
+begin
+  EndOfFile := FilePos(Handle) >= FileSize(Handle);
+end;
+
+function FilePos(Handle: TFileHandle): TFileInt;
+begin
+  FilePos := SeekFile(Handle, 0, skCur);
+end;
+
+function FileSize(Handle: TFileHandle): TFileInt;
+var
+  L: Longint;
+begin
+  L := FilePos(Handle);
+  FileSize := SeekFile(Handle, 0, skEnd);
+  SeekFile(Handle, L, skBeg);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.1  1998/12/04 12:48:30  peter
+    * moved some dirs
+
+  Revision 1.1  1998/10/26 11:31:47  peter
+    + inital include files
+
+}

api/linux/gpm114.pas

@@ -0,0 +1,133 @@
+{
+  $Id$
+
+  Low level unit for GPM v1.14, the mouse server for Linux
+
+  This program is free software; you can redistribute it and/or modify
+  it under the terms of the GNU Library General Public License as published
+  by the Free Software Foundation; either version 2 of the License, or
+  (at your option) any later version.
+
+  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.  See the
+  GNU General Public License for more details.
+
+  You should have received a copy of the GNU General Public License
+  along with this program; if not, write to the Free Software
+  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *************************************************************************}
+unit gpm114;
+interface
+
+uses
+  linux;
+
+{$LINKLIB c}
+{$LINKLIB gpm}
+
+const
+  { Buttons }
+  GPM_B_LEFT         = 4;
+  GPM_B_MIDDLE       = 2;
+  GPM_B_RIGHT        = 1;
+
+  { Event types }
+  GPM_MOVE           = 1;
+  GPM_DRAG           = 2;
+  GPM_DOWN           = 4;
+  GPM_UP             = 8;
+
+  GPM_SINGLE         = 16;            { at most one in three is set }
+  GPM_DOUBLE         = 32;
+  GPM_TRIPLE         = 64;
+
+  GPM_MFLAG          = 128;
+  GPM_HARD           = 256;
+
+  GPM_ENTER          = 512;
+  GPM_LEAVE          = 1024;
+
+  GPM_BARE_EVENTS    = $60F;
+
+  { Margins }
+  GPM_TOP            = 1;
+  GPM_BOT            = 2;
+  GPM_LFT            = 4;
+  GPM_RGT            = 8;
+
+type
+{$PACKRECORDS 4}
+  TGPMConnect = record
+    EventMask, DefaultMask: Word;
+    MinMod, MaxMod: Word;
+    Pid: Longint;
+    vc: Longint;
+  end;
+
+  TGPMEvent = record
+    Buttons, Modifiers: Byte;
+    vc: Word;
+    Dx, Dy, X, Y: Integer;
+    EventType: Word;
+    Clicks: Longint;
+    GPMMargin: Word;
+  end;
+
+  TGPMHandler = function (const GPMEvent: TGPMEvent; ClientData: Pointer): Longint;cdecl;
+
+{ Global variables }
+var
+  gpm_flag           : Longint;cvar;external;
+  gpm_consolefd      : Longint;cvar;external name 'gpm_fd';
+  gpm_tried          : Longbool;cvar;external;
+  gpm_hflag          : Longbool;cvar;external;
+  gpm_morekeys       : Longbool;cvar;external;
+  gpm_zerobased      : Longbool;cvar;external;
+  gpm_visiblepointer : Longbool;cvar;external;
+  gpm_mx             : Longint;cvar;external;
+  gpm_my             : Longint;cvar;external;
+  gpm_timeout        : timeval;cvar;external;
+  gpm_handler        : TGPMHandler;cvar;external;
+  gpm_data           : Pointer;cvar;external;
+  gpm_console_fd     : Longint;cvar;external;
+
+function Gpm_Open(var Connect: TGPMConnect; Flag: Longint): Longint;cdecl;
+function Gpm_Close:Longint;cdecl;
+function Gpm_GetEvent(var Event: TGpmEvent): Longint;cdecl;
+
+function Gpm_GetLibVersion(var where: Longint): PChar;cdecl;
+function Gpm_GetServerVersion(var where: Longint): PChar;cdecl;
+function Gpm_GetSnapshot(var Event: TGPMEvent): Longint;cdecl;
+
+implementation
+
+function Gpm_Open(var Connect: TGPMConnect; Flag: Longint): Longint; cdecl;external;
+function Gpm_Close: Longint; cdecl;external;
+function Gpm_GetEvent(var Event: TGpmEvent): Longint; cdecl;external;
+
+function Gpm_GetLibVersion(var where: Longint): PChar; cdecl;external;
+function Gpm_GetServerVersion(var where: Longint): PChar; cdecl;external;
+function Gpm_GetSnapshot(var Event: TGPMEvent): Longint; cdecl;external;
+
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.1  1999/07/01 19:41:26  peter
+    * define OLDGPM to compile with old gpm (for v1.14) else the new
+      gpm unit from rtl will be used (v1.17)
+
+  Revision 1.1  1998/12/04 12:48:30  peter
+    * moved some dirs
+
+  Revision 1.1  1998/10/29 11:02:51  peter
+    + mouse for linux
+
+}

api/linux/keyboard.inc

@@ -0,0 +1,594 @@
+{
+  System independent keyboard interface for linux
+
+  $Id$
+}
+
+uses
+  Linux;
+
+
+var
+  OldIO : TermIos;
+Procedure SetRawMode(b:boolean);
+Var
+  Tio : Termios;
+Begin
+  TCGetAttr(1,Tio);
+  if b then
+   begin
+     OldIO:=Tio;
+     Tio.c_iflag:=Tio.c_iflag and (not (IGNBRK or BRKINT or PARMRK or ISTRIP or
+                                INLCR or IGNCR or ICRNL or IXON));
+     Tio.c_lflag:=Tio.c_lflag and (not (ECHO or ECHONL or ICANON or ISIG or IEXTEN));
+   end
+  else
+   begin
+     Tio.c_iflag:=OldIO.c_iflag;
+     Tio.c_lflag:=OldIO.c_lflag;
+   end;
+  TCSetAttr(1,TCSANOW,Tio);
+End;
+
+type
+  chgentry=packed record
+    tab,
+    idx,
+    oldtab,
+    oldidx : byte;
+    oldval,
+    newval : word;
+  end;
+  kbentry=packed record
+    kb_table,
+    kb_index : byte;
+    kb_value : word;
+  end;
+
+const
+  kbdchanges=10;
+  kbdchange:array[1..kbdchanges] of chgentry=(
+    (tab:8; idx:$3b; oldtab:0; oldidx:$3b; oldval:0; newval:0),
+    (tab:8; idx:$3c; oldtab:0; oldidx:$3c; oldval:0; newval:0),
+    (tab:8; idx:$3d; oldtab:0; oldidx:$3d; oldval:0; newval:0),
+    (tab:8; idx:$3e; oldtab:0; oldidx:$3e; oldval:0; newval:0),
+    (tab:8; idx:$3f; oldtab:0; oldidx:$3f; oldval:0; newval:0),
+    (tab:8; idx:$40; oldtab:0; oldidx:$40; oldval:0; newval:0),
+    (tab:8; idx:$41; oldtab:0; oldidx:$41; oldval:0; newval:0),
+    (tab:8; idx:$42; oldtab:0; oldidx:$42; oldval:0; newval:0),
+    (tab:8; idx:$43; oldtab:0; oldidx:$43; oldval:0; newval:0),
+    (tab:8; idx:$44; oldtab:0; oldidx:$44; oldval:0; newval:0)
+  );
+ KDGKBENT=$4B46;
+ KDSKBENT=$4B47;
+
+procedure PatchKeyboard;
+var
+  e : ^chgentry;
+  entry : kbentry;
+  i : longint;
+begin
+  for i:=1to kbdchanges do
+   begin
+     e:=@kbdchange[i];
+     entry.kb_table:=e^.tab;
+     entry.kb_index:=e^.idx;
+     Ioctl(stdinputhandle,KDGKBENT,@entry);
+     e^.oldval:=entry.kb_value;
+     entry.kb_table:=e^.oldtab;
+     entry.kb_index:=e^.oldidx;
+     ioctl(stdinputhandle,KDGKBENT,@entry);
+     e^.newval:=entry.kb_value;
+   end;
+  for i:=1to kbdchanges do
+   begin
+     e:=@kbdchange[i];
+     entry.kb_table:=e^.tab;
+     entry.kb_index:=e^.idx;
+     entry.kb_value:=e^.newval;
+     Ioctl(stdinputhandle,KDSKBENT,@entry);
+   end;
+end;
+
+
+procedure UnpatchKeyboard;
+var
+  e : ^chgentry;
+  entry : kbentry;
+  i : longint;
+begin
+  for i:=1to kbdchanges do
+   begin
+     e:=@kbdchange[i];
+     entry.kb_table:=e^.tab;
+     entry.kb_index:=e^.idx;
+     entry.kb_value:=e^.oldval;
+     Ioctl(stdinputhandle,KDSKBENT,@entry);
+   end;
+end;
+
+
+
+{ Buffered Input routines }
+const
+  InSize=256;
+var
+  InBuf  : array[0..InSize-1] of char;
+  InCnt,
+  InHead,
+  InTail : longint;
+
+function ttyRecvChar:char;
+var
+  Readed,i : longint;
+begin
+{Buffer Empty? Yes, Input from StdIn}
+  if (InHead=InTail) then
+   begin
+   {Calc Amount of Chars to Read}
+     i:=InSize-InHead;
+     if InTail>InHead then
+      i:=InTail-InHead;
+   {Read}
+     Readed:=fdRead(StdInputHandle,InBuf[InHead],i);
+   {Increase Counters}
+     inc(InCnt,Readed);
+     inc(InHead,Readed);
+   {Wrap if End has Reached}
+     if InHead>=InSize then
+      InHead:=0;
+   end;
+{Check Buffer}
+  if (InCnt=0) then
+   ttyRecvChar:=#0
+  else
+   begin
+     ttyRecvChar:=InBuf[InTail];
+     dec(InCnt);
+     inc(InTail);
+     if InTail>=InSize then
+      InTail:=0;
+   end;
+end;
+
+
+Const
+  KeyBufferSize = 20;
+var
+  KeyBuffer : Array[0..KeyBufferSize-1] of Char;
+  KeyPut,
+  KeySend   : longint;
+
+Procedure PushKey(Ch:char);
+Var
+  Tmp : Longint;
+Begin
+  Tmp:=KeyPut;
+  Inc(KeyPut);
+  If KeyPut>=KeyBufferSize Then
+   KeyPut:=0;
+  If KeyPut<>KeySend Then
+   KeyBuffer[Tmp]:=Ch
+  Else
+   KeyPut:=Tmp;
+End;
+
+
+Function PopKey:char;
+Begin
+  If KeyPut<>KeySend Then
+   Begin
+     PopKey:=KeyBuffer[KeySend];
+     Inc(KeySend);
+     If KeySend>=KeyBufferSize Then
+      KeySend:=0;
+   End
+  Else
+   PopKey:=#0;
+End;
+
+
+Procedure PushExt(b:byte);
+begin
+  PushKey(#0);
+  PushKey(chr(b));
+end;
+
+
+const
+  AltKeyStr  : string[38]='qwertyuiopasdfghjklzxcvbnm1234567890-=';
+  AltCodeStr : string[38]=#016#017#018#019#020#021#022#023#024#025#030#031#032#033#034#035#036#037#038+
+                          #044#045#046#047#048#049#050#120#121#122#123#124#125#126#127#128#129#130#131;
+Function FAltKey(ch:char):byte;
+var
+  Idx : longint;
+Begin
+  Idx:=Pos(ch,AltKeyStr);
+  if Idx>0 then
+   FAltKey:=byte(AltCodeStr[Idx])
+  else
+   FAltKey:=0;
+End;
+
+
+Function KeyPressed:Boolean;
+var
+  fdsin : fdSet;
+Begin
+  if (KeySend<>KeyPut) or (InCnt>0) then
+   KeyPressed:=true
+  else
+   begin
+     FD_Zero(fdsin);
+     fd_Set(StdInputHandle,fdsin);
+     Keypressed:=(Select(StdInputHandle+1,@fdsin,nil,nil,1)>0);
+   end;
+End;
+
+
+Function ReadKey:char;
+Var
+  ch       : char;
+  OldState,
+  State    : longint;
+  fdsin    : fdSet;
+Begin
+{Check Buffer first}
+  if KeySend<>KeyPut then
+   begin
+     ReadKey:=PopKey;
+     exit;
+   end;
+{Wait for Key}
+  repeat
+  until keypressed;
+  ch:=ttyRecvChar;
+{Esc Found ?}
+  If (ch=#27) then
+   begin
+     FD_Zero(fdsin);
+     fd_Set(StdInputHandle,fdsin);
+     State:=1;
+     if InCnt=0 then
+      Select(StdInputHandle+1,@fdsin,nil,nil,10);
+     while (State<>0) and (KeyPressed) do
+      begin
+        ch:=ttyRecvChar;
+        OldState:=State;
+        State:=0;
+        case OldState of
+        1 : begin {Esc}
+              case ch of
+          'a'..'z',
+          '0'..'9',
+           '-','=' : PushExt(FAltKey(ch));
+               #10 : PushKey(#10);
+               #13 : PushKey(#10);
+              #127 : PushKey(#8);
+               '[' : State:=2;
+               else
+                begin
+                  PushKey(ch);
+                  PushKey(#27);
+                end;
+               end;
+            end;
+        2 : begin {Esc[}
+              case ch of
+               '[' : State:=3;
+               'A' : PushExt(72);
+               'B' : PushExt(80);
+               'C' : PushExt(77);
+               'D' : PushExt(75);
+               'G' : PushKey('5');
+               'H' : PushExt(71);
+               'K' : PushExt(79);
+               '1' : State:=4;
+               '2' : State:=5;
+               '3' : PushExt(83);
+               '4' : PushExt(79);
+               '5' : PushExt(73);
+               '6' : PushExt(81);
+              else
+               begin
+                 PushKey(ch);
+                 PushKey('[');
+                 PushKey(#27);
+               end;
+              end;
+              if ch in ['3'..'6'] then
+               State:=255;
+            end;
+        3 : begin {Esc[[}
+              case ch of
+               'A' : PushExt(59);
+               'B' : PushExt(60);
+               'C' : PushExt(61);
+               'D' : PushExt(62);
+               'E' : PushExt(63);
+              end;
+            end;
+        4 : begin
+              case ch of
+               '~' : PushExt(71);
+               '7' : PushExt(64);
+               '8' : PushExt(65);
+               '9' : PushExt(66);
+              end;
+              if (Ch<>'~') then
+               State:=255;
+            end;
+        5 : begin
+              case ch of
+               '~' : PushExt(82);
+               '0' : pushExt(67);
+               '1' : PushExt(68);
+               '3' : PushExt(133);
+               '4' : PushExt(134);
+              end;
+              if (Ch<>'~') then
+               State:=255;
+            end;
+      255 : ;
+        end;
+        if (State<>0) and (InCnt=0) then
+         Select(StdInputHandle+1,@fdsin,nil,nil,10);
+      end;
+     if State=1 then
+      PushKey(ch);
+   end
+  else
+   Begin
+     case ch of
+     #127 : PushKey(#8);
+     else
+      PushKey(ch);
+     end;
+   End;
+  ReadKey:=PopKey;
+End;
+
+
+function ShiftState:byte;
+var
+  arg,shift : longint;
+begin
+  arg:=6;
+  shift:=0;
+  if IOCtl(StdInputHandle,TIOCLINUX,@arg) then
+   begin
+     if (arg and (2 or 8))<>0 then
+      inc(shift,8);
+     if (arg and 4)<>0 then
+      inc(shift,4);
+     if (arg and 1)<>0 then
+      inc(shift,3);
+   end;
+  ShiftState:=shift;
+end;
+
+
+{ Exported functions }
+
+procedure InitKeyboard;
+begin
+  SetRawMode(true);
+  patchkeyboard;
+end;
+
+
+procedure DoneKeyboard;
+begin
+  unpatchkeyboard;
+  SetRawMode(false);
+end;
+
+
+function GetKeyEvent: TKeyEvent;
+
+  function EvalScan(b:byte):byte;
+  const
+    DScan:array[0..31] of byte = (
+      $39, $02, $28, $04, $05, $06, $08, $28,
+      $0A, $0B, $09, $0D, $33, $0C, $34, $35,
+      $0B, $02, $03, $04, $05, $06, $07, $08,
+      $09, $0A, $27, $27, $33, $0D, $34, $35);
+   LScan:array[0..31] of byte = (
+      $29, $1E, $30, $2E, $20, $12, $21, $22,
+      $23, $17, $24, $25, $26, $32, $31, $18,
+      $19, $10, $13, $1F, $14, $16, $2F, $11,
+      $2D, $15, $2C, $1A, $2B, $1B, $29, $0C);
+  begin
+    if (b and $E0)=$20  { digits / leters } then
+     EvalScan:=DScan[b and $1F]
+    else
+     case b of
+      $08:EvalScan:=$0E; { backspace }
+      $09:EvalScan:=$0F; { TAB }
+      $0D:EvalScan:=$1C; { CR }
+      $1B:EvalScan:=$01; { esc }
+      $40:EvalScan:=$03; { @ }
+      $5E:EvalScan:=$07; { ^ }
+      $60:EvalScan:=$29; { ` }
+     else
+      EvalScan:=LScan[b and $1F];
+     end;
+  end;
+
+  function EvalScanZ(b:byte):byte;
+  begin
+    EvalScanZ:=b;
+    if b in [$3B..$44] { F1..F10 -> Alt-F1..Alt-F10} then
+     EvalScanZ:=b+$2D;
+  end;
+const
+  CtrlArrow : array [71..81] of byte =
+   ($77,$8d,$84,$8e,$73,$8f,$74,$90,$75,$91,$76);
+var
+  MyScan,
+  SState : byte;
+  MyChar : char;
+begin {main}
+  if PendingKeyEvent<>0 then
+   begin
+     GetKeyEvent:=PendingKeyEvent;
+     PendingKeyEvent:=0;
+     exit;
+   end;
+
+  MyChar:=Readkey;
+  MyScan:=ord(MyChar);
+  SState:=ShiftState;
+
+  case MyChar of
+   #26 : begin { ^Z - replace Alt for Linux OS }
+           MyChar:=ReadKey;
+           MyScan:=ord(MyChar);
+           if MyScan=0 then
+            MyScan:=EvalScanZ(ord(ReadKey))
+           else
+            begin
+              MyScan:=EvalScan(ord(MyChar));
+              if MyScan in [$02..$0D] then
+               inc(MyScan,$76);
+              MyChar:=chr(0);
+            end;
+         end;
+    #0 : begin
+           MyScan:=ord(ReadKey);
+           { Handle Ctrl-<x> }
+           if (SState and 4)<>0 then
+            begin
+              case MyScan of
+                71..81 : { cArrow }
+                  MyScan:=CtrlArrow[MyScan];
+                $3b..$44 : { cF1-cF10 }
+                  MyScan:=MyScan+$23;
+              end;
+            end;
+           { Handle Alt-<x> }
+           if (SState and 8)<>0 then
+            begin
+              case MyScan of
+                $3b..$44 : { aF1-aF10 }
+                  MyScan:=MyScan+$2d;
+              end;
+            end;
+         end;
+    else begin
+           MyScan:=EvalScan(ord(MyChar));
+         end;
+  end;
+  GetKeyEvent:=$3000000 or ord(MyChar) or (MyScan shl 8) or (SState shl 16);
+end;
+
+
+function PollKeyEvent: TKeyEvent;
+begin
+  if PendingKeyEvent<>0 then
+   exit(PendingKeyEvent);
+  if keypressed then
+   begin
+     { just get the key and place it in the pendingkeyevent }
+     PendingKeyEvent:=GetKeyEvent;
+     PollKeyEvent:=PendingKeyEvent;
+   end
+  else
+   PollKeyEvent:=0;
+end;
+
+
+function PollShiftStateEvent: TKeyEvent;
+begin
+  PollShiftStateEvent:=ShiftState shl 16;
+end;
+
+
+{ Function key translation }
+type
+  TTranslationEntry = packed record
+    Min, Max: Byte;
+    Offset: Word;
+  end;
+const
+  TranslationTableEntries = 12;
+  TranslationTable: array [1..TranslationTableEntries] of TTranslationEntry =
+    ((Min: $3B; Max: $44; Offset: kbdF1),   { function keys F1-F10 }
+     (Min: $54; Max: $5D; Offset: kbdF1),   { Shift fn keys F1-F10 }
+     (Min: $5E; Max: $67; Offset: kbdF1),   { Ctrl fn keys F1-F10 }
+     (Min: $68; Max: $71; Offset: kbdF1),   { Alt fn keys F1-F10 }
+     (Min: $85; Max: $86; Offset: kbdF11),  { function keys F11-F12 }
+     (Min: $87; Max: $88; Offset: kbdF11),  { Shift+function keys F11-F12 }
+     (Min: $89; Max: $8A; Offset: kbdF11),  { Ctrl+function keys F11-F12 }
+     (Min: $8B; Max: $8C; Offset: kbdF11),  { Alt+function keys F11-F12 }
+     (Min:  71; Max:  73; Offset: kbdHome), { Keypad keys kbdHome-kbdPgUp }
+     (Min:  75; Max:  77; Offset: kbdLeft), { Keypad keys kbdLeft-kbdRight }
+     (Min:  79; Max:  81; Offset: kbdEnd),  { Keypad keys kbdEnd-kbdPgDn }
+     (Min: $52; Max: $53; Offset: kbdInsert));
+
+function TranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
+var
+  I: Integer;
+  ScanCode: Byte;
+begin
+  if KeyEvent and $03000000 = $03000000 then
+   begin
+     if KeyEvent and $000000FF <> 0 then
+      begin
+        TranslateKeyEvent := KeyEvent and $00FFFFFF;
+        exit;
+      end
+     else
+      begin
+        { This is a function key }
+        ScanCode := (KeyEvent and $0000FF00) shr 8;
+        for I := 1 to TranslationTableEntries do
+         begin
+           if (TranslationTable[I].Min <= ScanCode) and (ScanCode <= TranslationTable[I].Max) then
+            begin
+              TranslateKeyEvent := $02000000 + (KeyEvent and $00FF0000) +
+                (ScanCode - TranslationTable[I].Min) + TranslationTable[I].Offset;
+              exit;
+            end;
+         end;
+      end;
+   end;
+  TranslateKeyEvent := KeyEvent;
+end;
+
+
+function TranslateKeyEventUniCode(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+  TranslateKeyEventUniCode := KeyEvent;
+  ErrorHandler(errKbdNotImplemented, nil);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.5  1999/02/16 10:44:53  peter
+    * alt-f<x> support
+
+  Revision 1.4  1998/12/15 10:30:34  peter
+    + ctrl arrows support
+    * better backspace
+
+  Revision 1.3  1998/12/12 19:13:02  peter
+    * keyboard updates
+    * make test target, make all only makes units
+
+  Revision 1.1  1998/12/04 12:48:30  peter
+    * moved some dirs
+
+  Revision 1.3  1998/10/29 12:49:48  peter
+    * more fixes
+
+  Revision 1.1  1998/10/26 11:31:47  peter
+    + inital include files
+
+}

api/linux/mouse.inc

@@ -0,0 +1,231 @@
+{
+  System independent mouse interface for linux
+
+  $Id$
+}
+
+uses
+  Linux,Video
+{$ifdef OLDGPM}
+  ,gpm114
+{$else}
+  ,gpm
+{$endif}
+  ;
+
+const
+  mousecur    : boolean = false;
+  mousecurofs : longint = -1;
+
+var
+  mousecurcell : TVideoCell;
+
+
+procedure PlaceMouseCur(ofs:longint);
+var
+  upd : boolean;
+begin
+  if VideoBuf=nil then
+   exit;
+  upd:=false;
+  if (MouseCurOfs<>-1) and (VideoBuf^[MouseCurOfs]=MouseCurCell) then
+   begin
+     VideoBuf^[MouseCurOfs]:=MouseCurCell xor $7f00;
+     upd:=true;
+   end;
+  MouseCurOfs:=ofs;
+  if (MouseCurOfs<>-1) then
+   begin
+     MouseCurCell:=VideoBuf^[MouseCurOfs] xor $7f00;
+     VideoBuf^[MouseCurOfs]:=MouseCurCell;
+     upd:=true;
+   end;
+  if upd then
+   Updatescreen(false);
+end;
+
+
+procedure InitMouse;
+var
+  connect : TGPMConnect;
+begin
+  PendingMouseHead:=@PendingMouseEvent;
+  PendingMouseTail:=@PendingMouseEvent;
+  PendingMouseEvents:=0;
+  FillChar(LastMouseEvent,sizeof(TMouseEvent),0);
+{ open gpm }
+  connect.EventMask:=GPM_MOVE or GPM_DRAG or GPM_DOWN or GPM_UP;
+  connect.DefaultMask:=0;
+  connect.MinMod:=0;
+  connect.MaxMod:=0;
+  Gpm_Open(connect,0);
+{ show mousepointer }
+  ShowMouse;
+end;
+
+
+procedure DoneMouse;
+begin
+  HideMouse;
+  Gpm_Close;
+end;
+
+
+function DetectMouse:byte;
+begin
+{ always a mouse deamon present }
+  DetectMouse:=2;
+end;
+
+
+procedure ShowMouse;
+begin
+  PlaceMouseCur(MouseCurOfs);
+  mousecur:=true;
+end;
+
+
+procedure HideMouse;
+begin
+  PlaceMouseCur(-1);
+  mousecur:=false;
+end;
+
+
+function GetMouseX:word;
+var
+  e : TGPMEvent;
+begin
+  if gpm_fd<0 then
+   exit(0);
+  Gpm_GetSnapshot(e);
+  GetMouseX:=e.x-1;
+end;
+
+
+function GetMouseY:word;
+var
+  e : TGPMEvent;
+begin
+  if gpm_fd<0 then
+   exit(0);
+  Gpm_GetSnapshot(e);
+  GetMouseY:=e.y-1;
+end;
+
+
+function GetMouseButtons:word;
+var
+  e : TGPMEvent;
+begin
+  if gpm_fd<0 then
+   exit(0);
+  Gpm_GetSnapshot(e);
+  GetMouseButtons:=e.buttons;
+end;
+
+
+procedure SetMouseXY(x,y:word);
+begin
+end;
+
+
+procedure GetMouseEvent(var MouseEvent: TMouseEvent);
+var
+  e : TGPMEvent;
+begin
+  if gpm_fd<0 then
+   exit;
+  Gpm_GetEvent(e);
+  MouseEvent.x:=e.x-1;
+  MouseEvent.y:=e.y-1;
+  MouseEvent.buttons:=0;
+  if e.buttons and Gpm_b_left<>0 then
+   inc(MouseEvent.buttons,1);
+  if e.buttons and Gpm_b_right<>0 then
+   inc(MouseEvent.buttons,2);
+  if e.buttons and Gpm_b_middle<>0 then
+   inc(MouseEvent.buttons,4);
+  case (e.EventType and $f) of
+    GPM_MOVE,
+    GPM_DRAG : MouseEvent.Action:=MouseActionMove;
+    GPM_DOWN : MouseEvent.Action:=MouseActionDown;
+    GPM_UP   : MouseEvent.Action:=MouseActionUp;
+  else
+   MouseEvent.Action:=0;
+  end;
+  LastMouseEvent:=MouseEvent;
+{ update mouse cursor }
+  if mousecur then
+   PlaceMouseCur(MouseEvent.y*ScreenWidth+MouseEvent.x);
+end;
+
+
+function PollMouseEvent(var MouseEvent: TMouseEvent):boolean;
+
+var
+  e : TGPMEvent;
+  fds : FDSet;
+begin
+  if gpm_fd<0 then
+   exit(false);
+  FD_Zero(fds);
+  FD_Set(gpm_fd,fds);
+  if (Select(gpm_fd+1,@fds,nil,nil,1)>0) then
+   begin
+     Gpm_GetSnapshot(e);
+     MouseEvent.x:=e.x-1;
+     MouseEvent.y:=e.y-1;
+     MouseEvent.buttons:=0;
+     if e.buttons and Gpm_b_left<>0 then
+      inc(MouseEvent.buttons,1);
+     if e.buttons and Gpm_b_right<>0 then
+      inc(MouseEvent.buttons,2);
+     if e.buttons and Gpm_b_middle<>0 then
+      inc(MouseEvent.buttons,4);
+     case (e.EventType and $f) of
+      GPM_MOVE,
+      GPM_DRAG : MouseEvent.Action:=MouseActionMove;
+      GPM_DOWN : MouseEvent.Action:=MouseActionDown;
+      GPM_UP   : MouseEvent.Action:=MouseActionUp;
+     else
+      MouseEvent.Action:=0;
+     end;
+     PollMouseEvent:=true;
+   end
+  else
+   PollMouseEvent:=false;
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.5  1999/07/01 19:41:26  peter
+    * define OLDGPM to compile with old gpm (for v1.14) else the new
+      gpm unit from rtl will be used (v1.17)
+
+  Revision 1.4  1999/06/23 00:01:30  peter
+    * check for videobuf=nil
+
+  Revision 1.3  1999/03/31 20:20:18  michael
+  + Fixed probmem preventing IDE to run in x-term.
+
+  Revision 1.2  1998/12/11 00:13:20  peter
+    + SetMouseXY
+    * use far for exitproc procedure
+
+  Revision 1.1  1998/12/04 12:48:30  peter
+    * moved some dirs
+
+  Revision 1.3  1998/12/01 15:08:16  peter
+    * fixes for linux
+
+  Revision 1.2  1998/10/29 12:49:49  peter
+    * more fixes
+
+}

api/linux/terminfo.pas

@@ -0,0 +1,675 @@
+{
+   $Id$
+
+   An interface unit for the terminfo database
+
+   Copyright (c) 1997 Balazs Scheidler ([email protected])
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************}
+
+unit TermInfo;
+
+interface
+
+{$linklib ncurses}
+{$linklib c}
+
+const
+  { boolean values }
+  auto_left_margin              = 0;
+  auto_right_margin             = 1;
+  no_esc_ctlc                   = 2;
+  ceol_standout_glitch          = 3;
+  eat_newline_glitch            = 4;
+  erase_overstrike              = 5;
+  generic_type                  = 6;
+  hard_copy                     = 7;
+  has_meta_key                  = 8;
+  has_status_line               = 9;
+  insert_null_glitch            = 10;
+  memory_above                  = 11;
+  memory_below                  = 12;
+  move_insert_mode              = 13;
+  move_standout_mode            = 14;
+  over_strike                   = 15;
+  status_line_esc_ok            = 16;
+  dest_tabs_magic_smso          = 17;
+  tilde_glitch                  = 18;
+  transparent_underline         = 19;
+  xon_xoff                      = 20;
+  needs_xon_xoff                = 21;
+  prtr_silent                   = 22;
+  hard_cursor                   = 23;
+  non_rev_rmcup                 = 24;
+  no_pad_char                   = 25;
+  non_dest_scroll_region        = 26;
+  can_change                    = 27;
+  back_color_erase              = 28;
+  hue_lightness_saturation      = 29;
+  col_addr_glitch               = 30;
+  cr_cancels_micro_mode         = 31;
+  has_print_wheel               = 32;
+  row_addr_glitch               = 33;
+  semi_auto_right_margin        = 34;
+  cpi_changes_res               = 35;
+  lpi_changes_res               = 36;
+
+  { numbers ... }
+  columns                       = 0;
+  init_tabs                     = 1;
+  lines                         = 2;
+  lines_of_memory               = 3;
+  magic_cookie_glitch           = 4;
+  padding_baud_rate             = 5;
+  virtual_terminal              = 6;
+  width_status_line             = 7;
+  num_labels                    = 8;
+  label_height                  = 9;
+  label_width                   = 10;
+  max_attributes                = 11;
+  maximum_windows               = 12;
+  max_colors                    = 13;
+  max_pairs                     = 14;
+  no_color_video                = 15;
+  buffer_capacity               = 16;
+  dot_vert_spacing              = 17;
+  dot_horz_spacing              = 18;
+  max_micro_address             = 19;
+  max_micro_jump                = 20;
+  micro_char_size               = 21;
+  micro_line_size               = 22;
+  number_of_pins                = 23;
+  output_res_char               = 24;
+  output_res_line               = 25;
+  output_res_horz_inch          = 26;
+  output_res_vert_inch          = 27;
+  print_rate                    = 28;
+  wide_char_size                = 29;
+  buttons                       = 30;
+  bit_image_entwining           = 31;
+  bit_image_type                = 32;
+
+  { strings }
+  back_tab                      = 0;
+  bell                          = 1;
+  carriage_return               = 2;
+  change_scroll_region          = 3;
+  clear_all_tabs                = 4;
+  clear_screen                  = 5;
+  clr_eol                       = 6;
+  clr_eos                       = 7;
+  column_address                = 8;
+  command_character             = 9;
+  cursor_address                = 10;
+  cursor_down                   = 11;
+  cursor_home                   = 12;
+  cursor_invisible              = 13;
+  cursor_left                   = 14;
+  cursor_mem_address            = 15;
+  cursor_normal                 = 16;
+  cursor_right                  = 17;
+  cursor_to_ll                  = 18;
+  cursor_up                     = 19;
+  cursor_visible                = 20;
+  delete_character              = 21;
+  delete_line                   = 22;
+  dis_status_line               = 23;
+  down_half_line                = 24;
+  enter_alt_charset_mode        = 25;
+  enter_blink_mode              = 26;
+  enter_bold_mode               = 27;
+  enter_ca_mode                 = 28;
+  enter_delete_mode             = 29;
+  enter_dim_mode                = 30;
+  enter_insert_mode             = 31;
+  enter_secure_mode             = 32;
+  enter_protected_mode          = 33;
+  enter_reverse_mode            = 34;
+  enter_standout_mode           = 35;
+  enter_underline_mode          = 36;
+  erase_chars                   = 37;
+  exit_alt_charset_mode         = 38;
+  exit_attribute_mode           = 39;
+  exit_ca_mode                  = 40;
+  exit_delete_mode              = 41;
+  exit_insert_mode              = 42;
+  exit_standout_mode            = 43;
+  exit_underline_mode           = 44;
+  flash_screen                  = 45;
+  form_feed                     = 46;
+  from_status_line              = 47;
+  init_1string                  = 48;
+  init_2string                  = 49;
+  init_3string                  = 50;
+  init_file                     = 51;
+  insert_character              = 52;
+  insert_line                   = 53;
+  insert_padding                = 54;
+  key_backspace                 = 55;
+  key_catab                     = 56;
+  key_clear                     = 57;
+  key_ctab                      = 58;
+  key_dc                        = 59;
+  key_dl                        = 60;
+  key_down                      = 61;
+  key_eic                       = 62;
+  key_eol                       = 63;
+  key_eos                       = 64;
+  key_f0                        = 65;
+  key_f1                        = 66;
+  key_f10                       = 67;
+  key_f2                        = 68;
+  key_f3                        = 69;
+  key_f4                        = 70;
+  key_f5                        = 71;
+  key_f6                        = 72;
+  key_f7                        = 73;
+  key_f8                        = 74;
+  key_f9                        = 75;
+  key_home                      = 76;
+  key_ic                        = 77;
+  key_il                        = 78;
+  key_left                      = 79;
+  key_ll                        = 80;
+  key_npage                     = 81;
+  key_ppage                     = 82;
+  key_right                     = 83;
+  key_sf                        = 84;
+  key_sr                        = 85;
+  key_stab                      = 86;
+  key_up                        = 87;
+  keypad_local                  = 88;
+  keypad_xmit                   = 89;
+  lab_f0                        = 90;
+  lab_f1                        = 91;
+  lab_f10                       = 92;
+  lab_f2                        = 93;
+  lab_f3                        = 94;
+  lab_f4                        = 95;
+  lab_f5                        = 96;
+  lab_f6                        = 97;
+  lab_f7                        = 98;
+  lab_f8                        = 99;
+  lab_f9                        = 100;
+  meta_off                      = 101;
+  meta_on                       = 102;
+  newline                       = 103;
+  pad_char                      = 104;
+  parm_dch                      = 105;
+  parm_delete_line              = 106;
+  parm_down_cursor              = 107;
+  parm_ich                      = 108;
+  parm_index                    = 109;
+  parm_insert_line              = 110;
+  parm_left_cursor              = 111;
+  parm_right_cursor             = 112;
+  parm_rindex                   = 113;
+  parm_up_cursor                = 114;
+  pkey_key                      = 115;
+  pkey_local                    = 116;
+  pkey_xmit                     = 117;
+  print_screen                  = 118;
+  prtr_off                      = 119;
+  prtr_on                       = 120;
+  repeat_char                   = 121;
+  reset_1string                 = 122;
+  reset_2string                 = 123;
+  reset_3string                 = 124;
+  reset_file                    = 125;
+  restore_cursor                = 126;
+  row_address                   = 127;
+  save_cursor                   = 128;
+  scroll_forward                = 129;
+  scroll_reverse                = 130;
+  set_attributes                = 131;
+  set_tab                       = 132;
+  set_window                    = 133;
+  tab                           = 134;
+  to_status_line                = 135;
+  underline_char                = 136;
+  up_half_line                  = 137;
+  init_prog                     = 138;
+  key_a1                        = 139;
+  key_a3                        = 140;
+  key_b2                        = 141;
+  key_c1                        = 142;
+  key_c3                        = 143;
+  prtr_non                      = 144;
+  char_padding                  = 145;
+  acs_chars                     = 146;
+  plab_norm                     = 147;
+  key_btab                      = 148;
+  enter_xon_mode                = 149;
+  exit_xon_mode                 = 150;
+  enter_am_mode                 = 151;
+  exit_am_mode                  = 152;
+  xon_character                 = 153;
+  xoff_character                = 154;
+  ena_acs                       = 155;
+  label_on                      = 156;
+  label_off                     = 157;
+  key_beg                       = 158;
+  key_cancel                    = 159;
+  key_close                     = 160;
+  key_command                   = 161;
+  key_copy                      = 162;
+  key_create                    = 163;
+  key_end                       = 164;
+  key_enter                     = 165;
+  key_exit                      = 166;
+  key_find                      = 167;
+  key_help                      = 168;
+  key_mark                      = 169;
+  key_message                   = 170;
+  key_move                      = 171;
+  key_next                      = 172;
+  key_open                      = 173;
+  key_options                   = 174;
+  key_previous                  = 175;
+  key_print                     = 176;
+  key_redo                      = 177;
+  key_reference                 = 178;
+  key_refresh                   = 179;
+  key_replace                   = 180;
+  key_restart                   = 181;
+  key_resume                    = 182;
+  key_save                      = 183;
+  key_suspend                   = 184;
+  key_undo                      = 185;
+  key_sbeg                      = 186;
+  key_scancel                   = 187;
+  key_scommand                  = 188;
+  key_scopy                     = 189;
+  key_screate                   = 190;
+  key_sdc                       = 191;
+  key_sdl                       = 192;
+  key_select                    = 193;
+  key_send                      = 194;
+  key_seol                      = 195;
+  key_sexit                     = 196;
+  key_sfind                     = 197;
+  key_shelp                     = 198;
+  key_shome                     = 199;
+  key_sic                       = 200;
+  key_sleft                     = 201;
+  key_smessage                  = 202;
+  key_smove                     = 203;
+  key_snext                     = 204;
+  key_soptions                  = 205;
+  key_sprevious                 = 206;
+  key_sprint                    = 207;
+  key_sredo                     = 208;
+  key_sreplace                  = 209;
+  key_sright                    = 210;
+  key_srsume                    = 211;
+  key_ssave                     = 212;
+  key_ssuspend                  = 213;
+  key_sundo                     = 214;
+  req_for_input                 = 215;
+  key_f11                       = 216;
+  key_f12                       = 217;
+  key_f13                       = 218;
+  key_f14                       = 219;
+  key_f15                       = 220;
+  key_f16                       = 221;
+  key_f17                       = 222;
+  key_f18                       = 223;
+  key_f19                       = 224;
+  key_f20                       = 225;
+  key_f21                       = 226;
+  key_f22                       = 227;
+  key_f23                       = 228;
+  key_f24                       = 229;
+  key_f25                       = 230;
+  key_f26                       = 231;
+  key_f27                       = 232;
+  key_f28                       = 233;
+  key_f29                       = 234;
+  key_f30                       = 235;
+  key_f31                       = 236;
+  key_f32                       = 237;
+  key_f33                       = 238;
+  key_f34                       = 239;
+  key_f35                       = 240;
+  key_f36                       = 241;
+  key_f37                       = 242;
+  key_f38                       = 243;
+  key_f39                       = 244;
+  key_f40                       = 245;
+  key_f41                       = 246;
+  key_f42                       = 247;
+  key_f43                       = 248;
+  key_f44                       = 249;
+  key_f45                       = 250;
+  key_f46                       = 251;
+  key_f47                       = 252;
+  key_f48                       = 253;
+  key_f49                       = 254;
+  key_f50                       = 255;
+  key_f51                       = 256;
+  key_f52                       = 257;
+  key_f53                       = 258;
+  key_f54                       = 259;
+  key_f55                       = 260;
+  key_f56                       = 261;
+  key_f57                       = 262;
+  key_f58                       = 263;
+  key_f59                       = 264;
+  key_f60                       = 265;
+  key_f61                       = 266;
+  key_f62                       = 267;
+  key_f63                       = 268;
+  clr_bol                       = 269;
+  clear_margins                 = 270;
+  set_left_margin               = 271;
+  set_right_margin              = 272;
+  label_format                  = 273;
+  set_clock                     = 274;
+  display_clock                 = 275;
+  remove_clock                  = 276;
+  create_window                 = 277;
+  goto_window                   = 278;
+  hangup                        = 279;
+  dial_phone                    = 280;
+  quick_dial                    = 281;
+  tone                          = 282;
+  pulse                         = 283;
+  flash_hook                    = 284;
+  fixed_pause                   = 285;
+  wait_tone                     = 286;
+  user0                         = 287;
+  user1                         = 288;
+  user2                         = 289;
+  user3                         = 290;
+  user4                         = 291;
+  user5                         = 292;
+  user6                         = 293;
+  user7                         = 294;
+  user8                         = 295;
+  user9                         = 296;
+  orig_pair                     = 297;
+  orig_colors                   = 298;
+  initialize_color              = 299;
+  initialize_pair               = 300;
+  set_color_pair                = 301;
+  set_foreground                = 302;
+  set_background                = 303;
+  change_char_pitch             = 304;
+  change_line_pitch             = 305;
+  change_res_horz               = 306;
+  change_res_vert               = 307;
+  define_char                   = 308;
+  enter_doublewide_mode         = 309;
+  enter_draft_quality           = 310;
+  enter_italics_mode            = 311;
+  enter_leftward_mode           = 312;
+  enter_micro_mode              = 313;
+  enter_near_letter_quality     = 314;
+  enter_normal_quality          = 315;
+  enter_shadow_mode             = 316;
+  enter_subscript_mode          = 317;
+  enter_superscript_mode        = 318;
+  enter_upward_mode             = 319;
+  exit_doublewide_mode          = 320;
+  exit_italics_mode             = 321;
+  exit_leftward_mode            = 322;
+  exit_micro_mode               = 323;
+  exit_shadow_mode              = 324;
+  exit_subscript_mode           = 325;
+  exit_superscript_mode         = 326;
+  exit_upward_mode              = 327;
+  micro_column_address          = 328;
+  micro_down                    = 329;
+  micro_left                    = 330;
+  micro_right                   = 331;
+  micro_row_address             = 332;
+  micro_up                      = 333;
+  order_of_pins                 = 334;
+  parm_down_micro               = 335;
+  parm_left_micro               = 336;
+  parm_right_micro              = 337;
+  parm_up_micro                 = 338;
+  select_char_set               = 339;
+  set_bottom_margin             = 340;
+  set_bottom_margin_parm        = 341;
+  set_left_margin_parm          = 342;
+  set_right_margin_parm         = 343;
+  set_top_margin                = 344;
+  set_top_margin_parm           = 345;
+  start_bit_image               = 346;
+  start_char_set_def            = 347;
+  stop_bit_image                = 348;
+  stop_char_set_def             = 349;
+  subscript_characters          = 350;
+  superscript_characters        = 351;
+  these_cause_cr                = 352;
+  zero_motion                   = 353;
+  char_set_names                = 354;
+  key_mouse                     = 355;
+  mouse_info                    = 356;
+  req_mouse_pos                 = 357;
+  get_mouse                     = 358;
+  set_a_foreground              = 359;
+  set_a_background              = 360;
+  pkey_plab                     = 361;
+  device_type                   = 362;
+  code_set_init                 = 363;
+  set0_des_seq                  = 364;
+  set1_des_seq                  = 365;
+  set2_des_seq                  = 366;
+  set3_des_seq                  = 367;
+  set_lr_margin                 = 368;
+  set_tb_margin                 = 369;
+  bit_image_repeat              = 370;
+  bit_image_newline             = 371;
+  bit_image_carriage_return     = 372;
+  color_names                   = 373;
+  define_bit_image_region       = 374;
+  end_bit_image_region          = 375;
+  set_color_band                = 376;
+  set_page_length               = 377;
+  display_pc_char               = 378;
+  enter_pc_charset_mode         = 379;
+  exit_pc_charset_mode          = 380;
+  enter_scancode_mode           = 381;
+  exit_scancode_mode            = 382;
+  pc_term_options               = 383;
+  scancode_escape               = 384;
+  alt_scancode_esc              = 385;
+  enter_horizontal_hl_mode      = 386;
+  enter_left_hl_mode            = 387;
+  enter_low_hl_mode             = 388;
+  enter_right_hl_mode           = 389;
+  enter_top_hl_mode             = 390;
+  enter_vertical_hl_mode        = 391;
+
+  { older synonyms for some booleans }
+  beehive_glitch                = no_esc_ctlc;
+  teleray_glitch                = dest_tabs_magic_smso;
+  micro_col_size                = micro_char_size;
+  { internal }
+  termcap_init2               = 392;
+  termcap_reset               = 393;
+  magic_cookie_glitch_ul      = 33;
+  backspaces_with_bs          = 37;
+  crt_no_scrolling            = 38;
+  no_correctly_working_cr     = 39;
+  carriage_return_delay       = 34;
+  new_line_delay              = 35;
+  linefeed_if_not_lf          = 394;
+  backspace_if_not_bs         = 395;
+  gnu_has_meta_key            = 40;
+  linefeed_is_newline         = 41;
+  backspace_delay             = 36;
+  horizontal_tab_delay        = 37;
+  number_of_function_keys     = 38;
+  other_non_function_keys     = 396;
+  arrow_key_map               = 397;
+  has_hardware_tabs           = 42;
+  return_does_clr_eol         = 43;
+  acs_ulcorner                = 398;
+  acs_llcorner                = 399;
+  acs_urcorner                = 400;
+  acs_lrcorner                = 401;
+  acs_ltee                    = 402;
+  acs_rtee                    = 403;
+  acs_btee                    = 404;
+  acs_ttee                    = 405;
+  acs_hline                   = 406;
+  acs_vline                   = 407;
+  acs_plus                    = 408;
+  memory_lock                 = 409;
+  memory_unlock               = 410;
+  box_chars_1                 = 411;
+
+
+const
+  NCCS = 32;
+  BoolCount = 44;
+  NumCount = 39;
+  StrCount = 412;
+
+type
+  TCFlag_t = Longint;
+  Speed_t = Longint;
+  TermIOS = record
+    c_iflag, c_oflag, c_cflag, c_lflag: TCFlag_t;
+    c_line: Byte;
+    c_cc: array [0..NCCS-1] of Char;
+    c_ispeed, c_ospeed: Speed_t;
+    Pad: word;
+  end;
+
+
+  TermType = record
+    Term_Names: PChar;
+    Str_Table: PChar;
+    Booleans: array [0..BoolCount - 1] of Boolean;
+    Numbers: array [0..NumCount - 1] of Word;
+    Pad: Word;
+    Strings: array [0..StrCount - 1] of PChar;
+  end;
+
+  Terminal_ptr = ^Terminal;
+  Terminal = record
+    TType: TermType;
+    FileDes: Word;
+    Ottyb, Nttyb: Termios;
+    Pad: Word;
+  end;
+
+  WriterFunc = function (P: PChar): Longint;
+
+var
+  cur_term : Terminal_ptr;external name 'cur_term';
+
+function set_curterm(term: Terminal_ptr): Terminal_ptr;cdecl;
+function del_curterm(term: Terminal_ptr): Longint;cdecl;
+
+{ sets whether to use environment variables for LINES and COLUMNS }
+procedure use_env(B: Longint);cdecl;
+
+function putp(Ndx: Longint): Longint;
+
+{ this function must be called before any terminal properties are accessed }
+function setupterm(Term: PChar; fd: Longint; var ErrCode: Longint): Longint;cdecl;
+
+{ reinitialize lib }
+function restartterm(Term: PChar; fd: Longint; var ErrCode: Longint): Longint;cdecl;
+
+{function tgetent(P1, P2: PChar): Longint;
+function tgetflag(P: PChar): Longint;
+function tgetnum(P: PChar): Longint;
+function tgoto(P: PChar; L1, L2: Longint): PChar;
+function tgetstr(P: PChar; var R: PChar): PChar;
+function tigetflag(P: PChar): Longint;
+function tigetnum(P: PChar): Longint;
+function tigetstr(P: PChar): PChar;
+function tparm(P: PChar, ...): PChar;
+function tparam(const char *, char *, int, ...): PChar;}
+function tputs(Ndx: Word; L1: Longint; F: WriterFunc): Longint;
+
+implementation
+
+uses
+  Linux;
+
+
+function putp(Ndx: Longint): Longint;
+var
+  P: PChar;
+begin
+  P := cur_term^.ttype.Strings[Ndx];
+  putp := fdWrite(cur_term^.filedes, P, StrLen(P));
+end;
+
+function tputs(Ndx: Word; L1: Longint; F: WriterFunc): Longint;
+var
+  P: PChar;
+begin
+  L1 := L1;
+  P := cur_term^.ttype.Strings[Ndx];
+  tputs := F(P);
+end;
+
+function set_curterm(term: Terminal_ptr): Terminal_ptr; cdecl; external;
+function del_curterm(term: Terminal_ptr): Longint; cdecl; external;
+procedure use_env(B: Longint); cdecl; external;
+function restartterm(Term: PChar; fd: Longint; var ErrCode: Longint): Longint; cdecl; external;
+function setupterm(Term: PChar; fd: Longint; var ErrCode: Longint): Longint; cdecl; external;
+
+{function tgetent(P1, P2: PChar): Longint; cdecl; external;
+function tgetflag(P: PChar): Longint; cdecl; external;
+function tgetnum(P: PChar): Longint; cdecl; external;
+function tgoto(P: PChar; L1, L2: Longint): PChar; cdecl; external;
+function tgetstr(P: PChar; var R: PChar): PChar; cdecl; external;
+function tigetflag(P: PChar): Longint; cdecl; external;
+function tigetnum(P: PChar): Longint; cdecl; external;
+function tigetstr(P: PChar): PChar; cdecl; external;
+function tparm(P: PChar; ...): PChar; cdecl; external;
+function tparam(const char *, char *, int, ...): PChar; cdecl; external;}
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.3  1999/04/22 14:48:27  peter
+    * remove asm
+
+  Revision 1.2  1998/12/07 12:25:51  peter
+    * link with ncurses which is more available the curses
+
+  Revision 1.1  1998/12/04 12:48:30  peter
+    * moved some dirs
+
+  Revision 1.1  1998/10/26 11:31:47  peter
+    + inital include files
+
+  Revision 1.3  1998/10/26 09:36:26  peter
+    * fixed cdecl
+
+  Revision 1.2  1998/07/29 20:17:47  bazsi
+  some updates to Video, it now uses terminfo. Some modifications for FreeVision.
+
+  Revision 1.1  1998/06/13 12:38:54  bazsi
+}

api/linux/video.inc

@@ -0,0 +1,521 @@
+{
+  System independent low-level video interface for linux
+
+  $Id$
+}
+uses
+  Linux, Strings, FileCtrl, TermInfo;
+
+var
+  LastCursorType : byte;
+  TtyFd: Longint;
+  Console: Boolean;
+  OldVideoBuf: PVideoBuf;
+  CurColor: Byte;
+
+{$ASMMODE ATT}
+
+procedure SendEscapeSeqNdx(Ndx: Word);
+var
+  P: PChar;
+begin
+  P:=cur_term^.ttype.Strings[Ndx];
+  if assigned(p) then
+   fdWrite(TTYFd, P^, StrLen(P));
+end;
+
+
+procedure SendEscapeSeq(const S: String);
+begin
+  fdWrite(TTYFd, S[1], Length(S));
+end;
+
+
+Function IntStr(l:longint):string;
+var
+  s : string;
+begin
+  Str(l,s);
+  IntStr:=s;
+end;
+
+
+Function XY2Ansi(x,y,ox,oy:longint):String;
+{
+  Returns a string with the escape sequences to go to X,Y on the screen
+}
+Begin
+  if y=oy then
+   begin
+     if x=ox then
+      begin
+        XY2Ansi:='';
+        exit;
+      end;
+     if x=1 then
+      begin
+        XY2Ansi:=#13;
+        exit;
+      end;
+     if x>ox then
+      begin
+        XY2Ansi:=#27'['+IntStr(x-ox)+'C';
+        exit;
+      end
+     else
+      begin
+        XY2Ansi:=#27'['+IntStr(ox-x)+'D';
+        exit;
+      end;
+   end;
+  if x=ox then
+   begin
+     if y>oy then
+      begin
+        XY2Ansi:=#27'['+IntStr(y-oy)+'B';
+        exit;
+      end
+     else
+      begin
+        XY2Ansi:=#27'['+IntStr(oy-y)+'A';
+        exit;
+      end;
+   end;
+  if (x=1) and (oy+1=y) then
+   XY2Ansi:=#13#10
+  else
+   XY2Ansi:=#27'['+IntStr(y)+';'+IntStr(x)+'H';
+End;
+
+
+
+const
+  AnsiTbl : string[8]='04261537';
+Function Attr2Ansi(Attr,OAttr:longint):string;
+{
+  Convert Attr to an Ansi String, the Optimal code is calculate
+  with use of the old OAttr
+}
+var
+  hstr : string[16];
+  OFg,OBg,Fg,Bg : longint;
+
+  procedure AddSep(ch:char);
+  begin
+    if length(hstr)>0 then
+     hstr:=hstr+';';
+    hstr:=hstr+ch;
+  end;
+
+begin
+  if Attr=OAttr then
+   begin
+     Attr2Ansi:='';
+     exit;
+   end;
+  Hstr:='';
+  Fg:=Attr and $f;
+  Bg:=Attr shr 4;
+  OFg:=Attr and $f;
+  OBg:=Attr shr 4;
+  if (OFg<>7) or (Fg=7) or ((OFg>7) and (Fg<8)) or ((OBg>7) and (Bg<8)) then
+   begin
+     hstr:='0';
+     OFg:=7;
+     OBg:=0;
+   end;
+  if (Fg>7) and (OFg<8) then
+   begin
+     AddSep('1');
+     OFg:=OFg or 8;
+   end;
+  if (Bg and 8)<>(OBg and 8) then
+   begin
+     AddSep('5');
+     OBg:=OBg or 8;
+   end;
+  if (Fg<>OFg) then
+   begin
+     AddSep('3');
+     hstr:=hstr+AnsiTbl[(Fg and 7)+1];
+   end;
+  if (Bg<>OBg) then
+   begin
+     AddSep('4');
+     hstr:=hstr+AnsiTbl[(Bg and 7)+1];
+   end;
+  if hstr='0' then
+   hstr:='';
+  Attr2Ansi:=#27'['+hstr+'m';
+end;
+
+
+procedure UpdateTTY(Force:boolean);
+type
+  tchattr=packed record
+    ch : char;
+    attr : byte;
+  end;
+var
+  outbuf   : array[0..1023+255] of char;
+  chattr   : tchattr;
+  skipped  : boolean;
+  outptr,
+  spaces,
+  eol,
+  LastX,LastY,
+  x,y,
+  SpaceAttr,
+  LastAttr : longint;
+  p,pold   : pvideocell;
+
+  procedure outdata(hstr:string);
+  begin
+    while (eol>0) do
+     begin
+       hstr:=#13#10+hstr;
+       dec(eol);
+     end;
+    move(hstr[1],outbuf[outptr],length(hstr));
+    inc(outptr,length(hstr));
+    if outptr>1024 then
+     begin
+       fdWrite(TTYFd,outbuf,outptr);
+       outptr:=0;
+     end;
+  end;
+
+  procedure OutClr(c:byte);
+  begin
+    if c=LastAttr then
+     exit;
+    OutData(Attr2Ansi(c,LastAttr));
+    LastAttr:=c;
+  end;
+
+  procedure OutSpaces;
+  begin
+    if (Spaces=0) then
+     exit;
+    OutClr(SpaceAttr);
+    OutData(Space(Spaces));
+    LastX:=x;
+    LastY:=y;
+    Spaces:=0;
+  end;
+
+begin
+  OutPtr:=0;
+  Eol:=0;
+  skipped:=true;
+  p:=PVideoCell(VideoBuf);
+  pold:=PVideoCell(OldVideoBuf);
+{ init Attr and X,Y }
+  OutData(#27'[m'#27'[H');
+  LastAttr:=7;
+  LastX:=1;
+  LastY:=1;
+  for y:=1 to ScreenHeight do
+   begin
+     SpaceAttr:=0;
+     Spaces:=0;
+     for x:=1 to ScreenWidth do
+      begin
+        if (not force) and (p^=pold^) then
+         begin
+           if (Spaces>0) then
+            OutSpaces;
+           skipped:=true;
+         end
+        else
+         begin
+           if skipped then
+            begin
+              OutData(XY2Ansi(x,y,LastX,LastY));
+              LastX:=x;
+              LastY:=y;
+              skipped:=false;
+            end;
+           chattr:=tchattr(p^);
+           if chattr.ch in [#0,#255] then
+            chattr.ch:=' ';
+           if chattr.ch=' ' then
+            begin
+              if Spaces=0 then
+               SpaceAttr:=chattr.Attr;
+              if (chattr.attr and $f0)=(spaceattr and $f0) then
+               chattr.Attr:=SpaceAttr
+              else
+               begin
+                 OutSpaces;
+                 SpaceAttr:=chattr.Attr;
+               end;
+              inc(Spaces);
+            end
+           else
+            begin
+              if (Spaces>0) then
+               OutSpaces;
+              if LastAttr<>chattr.Attr then
+               OutClr(chattr.Attr);
+              OutData(chattr.ch);
+              LastX:=x+1;
+              LastY:=y;
+            end;
+           p^:=tvideocell(chattr);
+         end;
+        inc(p);
+        inc(pold);
+      end;
+     if (Spaces>0) then
+      OutSpaces;
+     if force then
+      inc(eol);
+   end;
+  eol:=0;
+  OutData(XY2Ansi(CursorX,CursorY,LastX,LastY));
+  fdWrite(TTYFd,outbuf,outptr);
+end;
+
+
+procedure InitVideo;
+const
+  fontstr : string[3]=#27'(K';
+var
+  ThisTTY: String[30];
+  FName: String;
+  WS: packed record
+    ws_row, ws_col, ws_xpixel, ws_ypixel: Word;
+  end;
+  Err: Longint;
+begin
+  LowAscii:=false;
+  if VideoBufSize<>0 then
+   DoneVideo;
+  { check for tty }
+  ThisTTY:=TTYName(stdin);
+  if IsATTY(stdin) then
+   begin
+     { write code to set a correct font }
+     fdWrite(stdout,fontstr[1],length(fontstr));
+     { running on a tty, find out whether locally or remotely }
+     if (Copy(ThisTTY, 1, 8) = '/dev/tty') and
+        (ThisTTY[9] >= '0') and (ThisTTY[9] <= '9') then
+      begin
+        { running on the console }
+        FName:='/dev/vcsa' + ThisTTY[9];
+        TTYFd:=OpenFile(FName, filReadWrite); { open console }
+      end
+     else
+      TTYFd:=-1;
+     if TTYFd<>-1 then
+      Console:=true
+     else
+      begin
+        { running on a remote terminal, no error with /dev/vcsa }
+        Console:=False;
+        TTYFd:=stdout;
+      end;
+     ioctl(stdin, TIOCGWINSZ, @WS);
+     ScreenWidth:=WS.ws_Col;
+     ScreenHeight:=WS.ws_Row;
+     if WS.ws_Col=0 then
+      WS.ws_Col:=80;
+     if WS.ws_Row=0 then
+      WS.ws_Row:=25;
+     CurColor:=$07;
+     CursorX:=1;
+     CursorY:=1;
+     ScreenColor:=True;
+     { allocate pmode memory buffer }
+     VideoBufSize:=ScreenWidth*ScreenHeight*2;
+     GetMem(VideoBuf,VideoBufSize);
+     GetMem(OldVideoBuf,VideoBufSize);
+     { Start with a clear screen }
+     if not Console then
+      begin
+        setupterm(nil, stdout, err);
+        SendEscapeSeqNdx(cursor_home);
+        SendEscapeSeqNdx(cursor_normal);
+        SendEscapeSeqNdx(cursor_visible);
+        SendEscapeSeqNdx(enter_ca_mode);
+        SetCursorType(crUnderLine);
+      end;
+     ClearScreen;
+   end
+  else
+   ErrorCode:=errVioInit; { not a TTY }
+end;
+
+procedure DoneVideo;
+begin
+  if VideoBufSize=0 then
+   exit;
+  ClearScreen;
+  if Console then
+   SetCursorPos(1,1)
+  else
+   begin
+     SendEscapeSeqNdx(exit_ca_mode);
+     SendEscapeSeqNdx(cursor_home);
+     SendEscapeSeqNdx(cursor_normal);
+     SendEscapeSeqNdx(cursor_visible);
+     SetCursorType(crUnderLine);
+     SendEscapeSeq(#27'[H');
+   end;
+  FreeMem(VideoBuf,VideoBufSize);
+  FreeMem(OldVideoBuf,VideoBufSize);
+  VideoBufSize:=0;
+end;
+
+
+procedure ClearScreen;
+begin
+  FillWord(VideoBuf^,VideoBufSize shr 1,$0720);
+  if Console then
+   UpdateScreen(true)
+  else
+   begin
+     SendEscapeSeq(#27'[0m');
+     SendEscapeSeqNdx(clear_screen);
+   end;
+end;
+
+
+procedure UpdateScreen(Force: Boolean);
+var
+  DoUpdate : boolean;
+begin
+  if LockUpdateScreen<>0 then
+   exit;
+  if not force then
+   begin
+{$ifdef i386}
+     asm
+          movl    VideoBuf,%esi
+          movl    OldVideoBuf,%edi
+          movl    VideoBufSize,%ecx
+          shrl    $2,%ecx
+          repe
+          cmpsl
+          orl     %ecx,%ecx
+          setne   DoUpdate
+     end;
+{$endif i386}
+   end
+  else
+   DoUpdate:=true;
+  if not DoUpdate then
+   exit;
+  if Console then
+   begin
+     fdSeek(TTYFd, 4, skBeg);
+     fdWrite(TTYFd, VideoBuf^,VideoBufSize);
+   end
+  else
+   begin
+     UpdateTTY(force);
+   end;
+  Move(VideoBuf^, OldVideoBuf^, VideoBufSize);
+end;
+
+
+function GetCapabilities: Word;
+begin
+{ about cpColor... we should check the terminfo database... }
+  GetCapabilities:=cpUnderLine + cpBlink + cpColor;
+end;
+
+
+procedure SetCursorPos(NewCursorX, NewCursorY: Word);
+var
+  Pos : array [1..2] of Byte;
+begin
+  if Console then
+   begin
+     fdSeek(TTYFd, 2, skBeg);
+     Pos[1]:=NewCursorX;
+     Pos[2]:=NewCursorY;
+     fdWrite(TTYFd, Pos, 2);
+   end
+  else
+   begin
+     { newcursorx,y is 0 based ! }
+     SendEscapeSeq(XY2Ansi(NewCursorX+1,NewCursorY+1,0,0));
+   end;
+  CursorX:=NewCursorX+1;
+  CursorY:=NewCursorY+1;
+end;
+
+
+function GetCursorType: Word;
+begin
+  GetCursorType:=LastCursorType;
+end;
+
+
+procedure SetCursorType(NewType: Word);
+begin
+  LastCursorType:=NewType;
+  case NewType of
+   crBlock :
+     SendEscapeSeq(#27'[?17;0;64c');
+   crHidden :
+     SendEscapeSeq(#27'[?1c');
+  else
+    SendEscapeSeq(#27'[?2c');
+  end;
+end;
+
+
+function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean;
+begin
+  DefaultVideoModeSelector:=false;
+end;
+
+
+procedure RegisterVideoModes;
+begin
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.5  1999/07/05 21:38:19  peter
+    * works now also on not /dev/tty* units
+    * if col,row is 0,0 then take 80x25 by default
+
+  Revision 1.4  1999/02/22 12:46:16  peter
+    + lowascii boolean if ascii < #32 is handled correctly
+
+  Revision 1.3  1999/02/08 10:34:26  peter
+    * cursortype futher implemented
+
+  Revision 1.2  1998/12/12 19:13:03  peter
+    * keyboard updates
+    * make test target, make all only makes units
+
+  Revision 1.1  1998/12/04 12:48:30  peter
+    * moved some dirs
+
+  Revision 1.6  1998/12/03 10:18:07  peter
+    * tty fixed
+
+  Revision 1.5  1998/12/01 15:08:17  peter
+    * fixes for linux
+
+  Revision 1.4  1998/11/01 20:29:12  peter
+    + lockupdatescreen counter to not let updatescreen() update
+
+  Revision 1.3  1998/10/29 12:49:50  peter
+    * more fixes
+
+  Revision 1.1  1998/10/26 11:31:47  peter
+    + inital include files
+
+}

api/maketp.bat

@@ -0,0 +1,2 @@
+tpc /M tpapi -Itp -Utp
+del tpapi.exe

api/os2/filectrl.inc

@@ -0,0 +1,165 @@
+{
+  System independent filecontrol interface for os2
+
+  $Id$
+}
+
+{$IFDEF PPC_Virtual}
+  uses
+    OS2Base;
+{$ENDIF}
+{$IFDEF PPC_Speed}
+  uses
+    BseDOS;
+{$ENDIF}
+
+{ not converted to the new error handling scheme (ie: calling
+  ErrorHandler, instead of dumping an error code to ErrorCode) }
+
+{$IFDEF BIT_16}
+
+{ There's a unit for DOSCALLS for BPOS2 available as well, should be using
+  these functions from there... }
+
+function DosClose (Handle: Word): Word; far;
+  external 'DOSCALLS' Index 59;                    { Dos close function }
+
+function DosOpen (FileName: PChar; var Handle: Word;
+  var ActionTaken: Word; FileSize: LongInt;
+  FileAttr: Word; OpenFlag, OpenMode: Word;
+  Reserved: Pointer): Word; far;
+  external 'DOSCALLS' index 70;                    { Dos open function }
+
+function DosDelete(FileName: PChar; Reserved: Longint): Word; far;
+  external 'DOSCALLS' index 60;
+
+function DosRead(Handle: Word; var BufferArea;
+  BufferLength: Word; var BytesRead : Word): Word; far;
+  external 'DOSCALLS' index 137;                   { Dos read procedure }
+
+function DosWrite(Handle: Word; var BufferArea;
+  BufferLength: Word; var BytesRead : Word): Word; far;
+  external 'DOSCALLS' index 138;                   { Dos write procedure }
+
+function DosSetFilePtr (Handle: Word; ulOffset: LongInt;
+  MoveType: Word; var NewPointer: LongInt): LongInt; far;
+  external 'DOSCALLS' index 58;                    { Dos write procedure }
+
+{$ENDIF}
+
+function OpenFile(FName: PChar; Flags: Longint): TFileHandle;
+var
+  Handle, ActionTaken: CPUWord;
+begin
+  ErrorCode := DosOpen(FName, Handle, ActionTaken, 0, $20, 1, Flags);
+  if ErrorCode <> 0 then
+    OpenFile := -1
+   else begin
+    OpenFile := Handle;
+    ErrorCode := 0;
+  end;
+end;
+
+function CreateFile(FName: PChar): TFileHandle;
+begin
+  ErrorCode := DosOpen(FName, Handle, ActionTaken, 0, $20, $12, 1);
+  if ErrorCode <> 0 then
+    OpenFile := -1
+   else begin
+    OpenFile := Handle;
+    ErrorCode := 0;
+  end;
+end;
+
+procedure CloseFile(Handle: TFileHandle);
+begin
+  ErrorCode := DosClose(Handle);
+end;
+
+procedure DeleteFile(FName: PChar);
+begin
+  ErrorCode := DosDelete(FName, 0);
+end;
+
+function ReadFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord;
+var
+  BuffRead: CPUWord;
+begin
+  ErrorCode := DosRead(Handle, Buff, Count, BuffRead);
+  if ErrorCode <> 0 then
+    ReadFile := 0
+   else begin
+    ReadFile := BuffRead;
+  end;
+end;
+
+function WriteFile(Handle: TFileHandle; var Buff; Count: Word): Word;
+var
+  BuffWritten: Word;
+begin
+  ErrorCode := DosWrite(Handle, Buff, Count, BuffWritten);
+  if ErrorCode <> 0 then
+    WriteFile := 0
+   else begin
+    WriteFile := BuffRead;
+  end;
+end;
+
+function SeekFile(Handle: TFileHandle; Pos: TFileInt; SeekType: Word): TFileInt;
+var
+  NewPos: Longint;
+begin
+  ErrorCode := DosSetFilePtr(Handle, Pos, SeekType, NewPos);
+  if ErrorCode <> 0 then
+    SeekFile := -1
+   else begin
+    SeekFile := NewPos;
+  end;
+end;
+
+procedure FlushFile(Handle: TFileHandle);
+begin
+  { not implemented yet }
+end;
+
+procedure TruncateFile(Handle: TFileHandle);
+begin
+  { not implemented yet }
+end;
+
+function EndOfFile(Handle: TFileHandle): Boolean;
+begin
+  EndOfFile := FilePos(Handle) >= FileSize(Handle);
+end;
+
+function FilePos(Handle: TFileHandle): TFileInt;
+begin
+  FilePos := SeekFile(Handle, 0, skCur);
+end;
+
+function FileSize(Handle: TFileHandle): TFileInt;
+var
+  L: Longint;
+begin
+  L := FilePos(Handle);
+  FileSize := SeekFile(Handle, 0, skEnd);
+  SeekFile(Handle, L, skBeg);
+end;
+
+{$ENDIF}
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.1  1998/12/04 12:48:32  peter
+    * moved some dirs
+
+  Revision 1.1  1998/10/26 11:31:49  peter
+    + inital include files
+
+}

api/os2/keyboard.inc

@@ -0,0 +1,44 @@
+{
+  System independent keyboard interface for os2
+
+  $Id$
+}
+procedure InitKeyboard;
+begin
+end;
+
+procedure DoneKeyboard;
+begin
+end;
+
+function GetKeyEvent: TKeyEvent;
+begin
+end;
+
+function PollKeyEvent: TKeyEvent;
+begin
+end;
+
+function TranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+end;
+
+function TranslateKeyEventUniCode(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.1  1998/12/04 12:48:32  peter
+    * moved some dirs
+
+  Revision 1.1  1998/10/26 11:31:49  peter
+    + inital include files
+
+}

api/os2/mouse.inc

@@ -0,0 +1,397 @@
+{
+  System independent mouse interface for OS/2
+}
+
+uses
+ Video,
+{$IFDEF VIRTUALPASCAL}
+ OS2Base;
+{$ELSE}
+ {$IFDEF FPC}
+ MouCalls, DosCalls;
+ {$ELSE}
+  {$IFDEF SPEED}
+ BseSub, BseDos;
+  {$ELSE}
+ OS2Subs, DosProcs;
+  {$ENDIF}
+ {$ENDIF}
+{$ENDIF}
+
+type
+{$IFDEF FPC}
+(* This should disappear as soon as cardinal arithmetics works OK in FPC. *)
+ cardinal = longint;
+{$ELSE}
+ {$IFDEF VIRTUALPASCAL}
+ cardinal = longint;
+ TMouEventInfo = MouEventInfo;
+ TNoPtrRect = NoPtrRect;
+ TPtrLoc = PtrLoc;
+ TMouQueInfo = MouQueInfo;
+ {$ELSE}
+  {$IFDEF SPEED}
+ cardinal = longword;
+ TMouEventInfo = MouEventInfo;
+ TNoPtrRect = NoPtrRect;
+ TPtrLoc = PtrLoc;
+ TMouQueInfo = MouQueInfo;
+  {$ELSE}
+ cardinal = longint;
+  {$ENDIF}
+ {$ENDIF}
+{$ENDIF}
+
+var
+ PendingMouseEventOrder: array [0..MouseEventBufSize-1] of cardinal;
+ MouseEventOrderHead, MouseEventOrderTail: cardinal;
+
+const
+ NoMouse = $FFFF;
+ DefaultMouse = 0;
+ Handle: word = DefaultMouse;
+ HideCounter: cardinal = 0;
+ OldEventMask: longint = -1;
+
+procedure InitMouse;
+var
+ Loc: TPtrLoc;
+ SetPrev: boolean;
+ SysEvent: TMouEventInfo;
+ QI: TMouQueInfo;
+ W: word;
+begin
+ SetPrev := MouGetPtrPos (Loc, DefaultMouse) = 0;
+ if MouGetEventMask (W, DefaultMouse) = 0 then OldEventMask := W;
+ PendingMouseHead := @PendingMouseEvent;
+ PendingMouseTail := @PendingMouseEvent;
+ PendingMouseEvents := 0;
+ FillChar (LastMouseEvent, SizeOf (TMouseEvent), 0);
+ MouseEventOrderTail := 0;
+ MouseEventOrderHead := 0;
+ HideCounter := 0;
+ if MouOpen (nil, Handle) = Error_Mouse_No_Device then Handle := NoMouse else
+ begin
+  W := Mou_NoWait;
+  repeat
+   MouGetNumQueEl (QI, Handle);
+   if QI.cEvents <> 0 then MouReadEventQue (SysEvent, W, Handle);
+  until QI.cEvents = 0;
+  W := $FFFF;
+  MouSetEventMask (W, Handle);
+  if SetPrev then MouSetPtrPos (Loc, Handle);
+
+(*
+ It would be possible to issue a MouRegister call here to hook our own mouse
+ handler, but such handler would have to be in a DLL and it's questionable,
+ whether there would be so many advantages in doing so.
+*)
+
+  MouDrawPtr (Handle);
+ end;
+end;
+
+procedure DoneMouse;
+var
+ W: word;
+begin
+ if (Handle <> NoMouse) and (Handle <> DefaultMouse) then
+ begin
+
+(*
+ If our own mouse handler would be installed in InitMouse, MouDeregister would
+ have appeared here.
+*)
+
+  HideCounter := 0;
+  HideMouse;
+  MouClose (Handle);
+ end;
+ if OldEventMask <> -1 then
+ begin
+  W := OldEventMask;
+  MouSetEventMask (W, 0);
+ end;
+end;
+
+function DetectMouse:byte;
+var
+ Buttons: word;
+begin
+ if MouGetNumButtons (Buttons, DefaultMouse) = 0 then DetectMouse := Buttons
+                                                         else DetectMouse := 0;
+end;
+
+procedure ShowMouse;
+begin
+ if Handle <> NoMouse then
+ begin
+  if HideCounter <> 0 then
+  begin
+   Dec (HideCounter);
+   if HideCounter = 0 then MouDrawPtr (Handle);
+  end;
+ end;
+end;
+
+procedure HideMouse;
+var
+ PtrRect: TNoPtrRect;
+begin
+ if Handle <> NoMouse then
+ begin
+  Inc (HideCounter);
+  case HideCounter of
+   0: Dec (HideCounter); (* HideCounter overflowed - stay at the maximum *)
+   1: begin
+       PtrRect.Row := 0;
+       PtrRect.Col := 0;
+       PtrRect.cRow := Pred (ScreenHeight);
+       PtrRect.cCol := Pred (ScreenWidth);
+       MouRemovePtr (PtrRect, Handle);
+      end;
+  end;
+ end;
+end;
+
+function GetMouseX: word;
+var
+ Event: TMouseEvent;
+begin
+ if Handle = NoMouse then GetMouseX := 0 else
+ begin
+  PollMouseEvent (Event);
+  GetMouseX := Event.X;
+ end;
+end;
+
+function GetMouseY: word;
+var
+ Event: TMouseEvent;
+begin
+ if Handle = NoMouse then GetMouseY := 0 else
+ begin
+  PollMouseEvent (Event);
+  GetMouseY := Event.Y;
+ end;
+end;
+
+procedure GetMouseXY (var X: word; var Y: word);
+var
+ Loc: TPtrLoc;
+begin
+ if Handle = NoMouse then
+ begin
+  X := 0;
+  Y := 0;
+ end else if MouGetPtrPos (Loc, Handle) <> 0 then
+ begin
+  X := $FFFF;
+  Y := $FFFF;
+ end else
+ begin
+  X := Loc.Col;
+  Y := Loc.Row;
+ end;
+end;
+
+procedure SetMouseXY (X, Y: word);
+var
+ Loc: TPtrLoc;
+begin
+ if Handle <> NoMouse then
+ begin
+  Loc.Row := Y;
+  Loc.Col := X;
+  MouSetPtrPos (Loc, Handle);
+ end;
+end;
+
+procedure TranslateEvents (const SysEvent: TMouEventInfo;
+                                                       var Event: TMouseEvent);
+begin
+ Event.Buttons := 0;
+ Event.Action := 0;
+ if SysEvent.fs and (Mouse_Motion_With_BN1_Down or Mouse_BN1_Down) <> 0 then
+                             Event.Buttons := Event.Buttons or MouseLeftButton;
+ if SysEvent.fs and (Mouse_Motion_With_BN2_Down or Mouse_BN2_Down) <> 0 then
+                            Event.Buttons := Event.Buttons or MouseRightButton;
+ if SysEvent.fs and (Mouse_Motion_With_BN3_Down or Mouse_BN3_Down) <> 0 then
+                           Event.Buttons := Event.Buttons or MouseMiddleButton;
+ Event.X := SysEvent.Col;
+ Event.Y := SysEvent.Row;
+ if Event.Buttons <> LastMouseEvent.Buttons then
+  if (Event.Buttons and MouseLeftButton = 0) and
+      (LastMouseEvent.Buttons and MouseLeftButton = MouseLeftButton)
+                                   then Event.Action := MouseActionUp else
+  if (Event.Buttons and MouseRightButton = 0) and
+      (LastMouseEvent.Buttons and MouseRightButton = MouseRightButton)
+                                   then Event.Action := MouseActionUp else
+  if (Event.Buttons and MouseMiddleButton = 0) and
+   (LastMouseEvent.Buttons and MouseMiddleButton = MouseMiddleButton)
+    then Event.Action := MouseActionUp
+     else Event.Action := MouseActionDown
+      else if (Event.X <> LastMouseEvent.X) or (Event.Y <> LastMouseEvent.Y)
+                                          then Event.Action := MouseActionMove;
+ LastMouseEvent := Event;
+end;
+
+procedure NullOrder;
+var
+ I: cardinal;
+begin
+ if PendingMouseEvents > 0 then
+ begin
+  I := MouseEventOrderHead;
+  repeat
+   PendingMouseEventOrder [I] := 0;
+   if I = Pred (MouseEventBufSize) then I := 0 else Inc (I);
+  until (I <> MouseEventOrderTail);
+ end;
+end;
+
+procedure LowerOrder;
+var
+ I: cardinal;
+begin
+ if PendingMouseEvents > 0 then
+ begin
+  I := MouseEventOrderHead;
+  repeat
+   if PendingMouseEventOrder [I] <> 0 then
+   begin
+    Dec (PendingMouseEventOrder [I]);
+    if I = Pred (MouseEventBufSize) then I := 0 else Inc (I);
+   end;
+  until (I <> MouseEventOrderTail) or (PendingMouseEventOrder [I] = 0);
+ end;
+end;
+
+function PollMouseEvent (var MouseEvent: TMouseEvent) :boolean;
+var
+ SysEvent: TMouEventInfo;
+ P, Q: PMouseEvent;
+ Event: TMouseEvent;
+ WF: word;
+ QI: TMouQueInfo;
+begin
+ if (PendingMouseEvents = 0) or
+         (PendingMouseEventOrder [MouseEventOrderHead] <> 0) and
+                                  (PendingMouseEvents < MouseEventBufSize) then
+ begin
+  MouGetNumQueEl (QI, Handle);
+  if QI.cEvents = 0 then NullOrder else
+  begin
+   LowerOrder;
+   WF := Mou_NoWait;
+   if (MouReadEventQue (SysEvent, WF, Handle) = 0) then
+   begin
+    if PendingMouseHead = @PendingMouseEvent then
+                           P := @PendingMouseEvent [MouseEventBufSize - 1] else
+    begin
+     P := PendingMouseHead;
+     Dec (P);
+    end;
+    TranslateEvents (SysEvent, P^);
+    if P^.Action <> 0 then
+    begin
+     if PendingMouseEvents < MouseEventBufSize then
+     begin
+      Q := P;
+      WF := Mou_NoWait;
+      while (P^.Action = MouseActionMove) and
+       (PendingMouseEventOrder [MouseEventOrderHead] <> 0) and
+         (MouReadEventQue (SysEvent, WF, Handle) = 0) and
+                       ((SysEvent.fs <> 0) or (LastMouseEvent.Buttons <> 0)) do
+      begin
+       LowerOrder;
+       TranslateEvents (SysEvent, Event);
+       if Event.Action <> MouseActionMove then
+       begin
+        if Q = @PendingMouseEvent then
+                  Q := @PendingMouseEvent [MouseEventBufSize - 1] else Dec (Q);
+        if MouseEventOrderHead = 0 then
+                  MouseEventOrderHead := MouseEventBufSize - 1 else
+                                                     Dec (MouseEventOrderHead);
+        PendingMouseEventOrder [MouseEventOrderHead] := 0;
+        Q^ := P^;
+        Inc (PendingMouseEvents);
+        if MouseEventOrderHead = 0 then
+               MouseEventOrderHead := MouseEventBufSize - 1 else
+                                                     Dec (MouseEventOrderHead);
+        PendingMouseEventOrder [MouseEventOrderHead] := 0;
+       end else WF := Mou_NoWait;
+       P^ := Event;
+      end;
+      P := Q;
+     end;
+     Inc (PendingMouseEvents);
+     if MouseEventOrderHead = 0 then
+               MouseEventOrderHead := MouseEventBufSize - 1 else
+                                                     Dec (MouseEventOrderHead);
+     PendingMouseEventOrder [MouseEventOrderHead] := 0;
+     PendingMouseHead := P;
+    end;
+   end else NullOrder;
+  end;
+ end;
+ if PendingMouseEvents <> 0 then
+ begin
+  MouseEvent := PendingMouseHead^;
+  LastMouseEvent := MouseEvent;
+  PollMouseEvent := true;
+ end else
+ begin
+  PollMouseEvent := false;
+  MouseEvent := LastMouseEvent;
+  MouseEvent.Action := 0;
+ end;
+end;
+
+function GetMouseButtons: word;
+var
+ Event: TMouseEvent;
+begin
+ PollMouseEvent (Event);
+ GetMouseButtons := Event.Buttons;
+end;
+
+procedure GetMouseEvent (var MouseEvent: TMouseEvent);
+var
+ Event: TMouEventInfo;
+begin
+ if (PendingMouseEvents = 0) or
+                       (PendingMouseEventOrder [MouseEventOrderHead] <> 0) then
+ repeat
+  DosSleep (1);
+  PollMouseEvent (MouseEvent);
+ until (PendingMouseEvents <> 0) and
+                        (PendingMouseEventOrder [MouseEventOrderHead] = 0) else
+ begin
+  MouseEvent := PendingMouseHead^;
+  LastMouseEvent := MouseEvent;
+ end;
+ Inc (PendingMouseHead);
+ if longint (PendingMouseHead) = longint (@PendingMouseEvent)
+      + SizeOf (PendingMouseEvent) then PendingMouseHead := @PendingMouseEvent;
+ Inc (MouseEventOrderHead);
+ if MouseEventOrderHead = MouseEventBufSize then MouseEventOrderHead := 0;
+ Dec (PendingMouseEvents);
+end;
+
+procedure PutMouseEvent (const MouseEvent: TMouseEvent);
+var
+ QI: TMouQueInfo;
+begin
+ if PendingMouseEvents < MouseEventBufSize then
+ begin
+  PendingMouseTail^ := MouseEvent;
+  Inc (PendingMouseTail);
+  if longint (PendingMouseTail) = longint (@PendingMouseEvent) +
+        SizeOf (PendingMouseEvent) then PendingMouseTail := @PendingMouseEvent;
+  MouGetNumQueEl (QI, Handle);
+  PendingMouseEventOrder [MouseEventOrderTail] := QI.cEvents;
+  Inc (MouseEventOrderTail);
+  if MouseEventOrderTail = MouseEventBufSize then MouseEventOrderTail := 0;
+ end;
+end;

api/test/Makefile.api

@@ -0,0 +1 @@
+TESTOBJECTS=testkbd testmous testmou2 testvid1 testvid2 testfsys testfctl testcall

api/test/testcall.pas

@@ -0,0 +1,155 @@
+program testcall;
+uses CallSpec;
+
+{ Testing program for calls of special functions. }
+
+procedure TestLocal;
+var
+  I: Integer;
+
+        procedure VoidLocal; {$ifndef FPC}far;{$endif}
+        begin
+          Write(I)
+        end;
+
+        procedure PointerLocal(J: LongInt); {$ifndef FPC}far;{$endif}
+        begin
+          Write('(', I, ',', J, ')')
+        end;
+
+begin
+  I := 4711;
+  Write('VoidLocal test: ');
+  VoidLocal;
+  Write(' = ');
+  CallVoidLocal(@VoidLocal, CurrentFramePointer);
+  WriteLn;
+
+  Write('PointerLocal test: ');
+  PointerLocal(0815);
+  Write(' = ');
+  CallPointerLocal(@PointerLocal, CurrentFramePointer, pointer(0815));
+  WriteLn
+end;
+
+type
+  TTest = object
+    K: Integer;
+    procedure TestMethodLocal;
+  end;
+
+var
+  Test: TTest;
+
+procedure TTest.TestMethodLocal;
+var
+  I: Integer;
+
+        procedure VoidMethodLocal; {$ifndef FPC}far;{$endif}
+        var
+          t: Integer;
+        begin
+          t := K;
+          Write('(', K, ',', I, ',', t, ')')
+        end;
+
+        procedure PointerMethodLocal(J: LongInt); {$ifndef FPC}far;{$endif}
+        var
+          t: Integer;
+        begin
+          t := K;
+          Write('(', K, ',', I, ',', J, ',', t, ')')
+        end;
+
+begin
+  I := 123;
+  Write('VoidMethodLocal test: ');
+  VoidMethodLocal;
+  Write(' = ');
+  CallVoidMethodLocal(@VoidMethodLocal,
+    CurrentFramePointer, @Self);
+  WriteLn;
+
+  Write('PointerMethodLocal test: ');
+  PointerMethodLocal(987);
+  Write(' = ');
+  CallPointerMethodLocal(@PointerMethodLocal,
+    CurrentFramePointer, @Self, pointer(987));
+  WriteLn
+end;
+
+type
+  PA = ^TA;
+  TA = object
+    I: LongInt;
+    constructor VoidInit;
+    constructor PointerInit(P: Pointer);
+    destructor Done;
+    procedure VoidMethod;
+    procedure PointerMethod(P: Pointer);
+  end;
+
+constructor TA.VoidInit;
+begin
+  I := 2718
+end;
+
+constructor TA.PointerInit(P: Pointer);
+begin
+  I := LongInt(P)
+end;
+
+destructor TA.Done;
+begin
+end;
+
+procedure TestConstructor;
+var
+  P, Q: PA;
+begin
+  P := CallVoidConstructor(@TA.VoidInit, nil, TypeOf(TA));
+  WriteLn('CallVoidConstructor test:  2718 = ', P^.I);
+  Dispose(P,Done);
+  Q := CallPointerConstructor(@TA.PointerInit, nil, TypeOf(TA), pointer(14142));
+  WriteLn('CallPointerConstructor test:  14142 = ', Q^.I);
+  Dispose(Q,Done);
+end;
+
+procedure TA.VoidMethod;
+begin
+  I := 2718;
+end;
+
+procedure TA.PointerMethod(P: Pointer);
+begin
+  I := LongInt(P)
+end;
+
+procedure TestMethod;
+var
+  A: TA;
+begin
+  CallVoidMethod(@TA.VoidMethod, @A);
+  WriteLn('CallVoidMethod test:  2718 = ', A.I);
+  CallPointerMethod(@TA.PointerMethod, @A, pointer(14142));
+  WriteLn('CallPointerMethod test:  14142 = ', A.I);
+end;
+
+begin
+  WriteLn('If the CallSpec unit is implemented properly for your');
+  WriteLn('Pascal compiler, you will see 8 correct equations, and');
+  WriteLn('this program will terminate without error.');
+  WriteLn;
+
+  TestLocal;
+
+  Test.K := 3141;
+  Test.TestMethodLocal;
+
+  TestConstructor;
+
+  TestMethod;
+
+  WriteLn;
+  WriteLn('Finished.');
+end.

api/test/testfctl.pas

@@ -0,0 +1,22 @@
+uses
+  FileCtrl;
+
+var
+  fd: TFileHandle;
+  Tmp: String;
+  I: Integer;
+
+begin
+  fd := CreateFile('Valami.txt');
+  for I := 1 to 255 do Tmp[I] := Chr(I);
+  Tmp[0] := #255;
+  WriteFile(fd, Tmp, 256);
+  SeekFile(fd, 0, skBeg);
+  WriteLn('Filesize = ', FileSize(fd));
+  ReadFile(fd, Tmp, 256);
+  WriteLn(Tmp);
+  WriteFile(fd, Tmp, 256);
+  SeekFile(fd, 256, skBeg);
+  WriteLn('FilePos = ', FilePos(fd));
+  CloseFile(fd);
+end.

api/test/testfsys.pas

@@ -0,0 +1,138 @@
+{ test application for FileSys
+  make sure a file called testfile.txt (here in FName) exists;
+  it will be deleted ! }
+program TestFS;
+
+{$I platform.inc}
+
+uses
+  Common,
+  Filesys;
+
+const
+  Passes = 12;
+  FName  : string[30] = 'testfile.txt';
+  DName  : string[30] = 'test';
+  TestNames : array[0..Passes-1] of string[30] =
+    ('CreateDir',
+     'RenameDir',
+     'ExpandName',
+     'GetCurrentDir',
+     'DeleteDir',
+
+     'Check name',
+     'Set time',
+     'DateToString/TimeToString',
+     'Set attribute',
+     'FileAttrToString',
+     'FileIntToString',
+     'SplitName'
+    );
+
+var
+  i           : byte;
+  n, p, rn, e : TFileName;
+  dt          : TDateTime;
+  attr        : TFileAttr;
+  fi          : TFileInt;
+
+begin
+  WriteLn ('TestFS - tests capabilities of unit FileSys');
+  WriteLn ('---');
+  i := 0;
+  repeat
+    { show topic }
+    case i of
+      0 : WriteLn ('<DIRECTORY>');
+      5 : WriteLn ('<FILE>');
+    end;
+    { show name of action }
+    Write (TestNames[i], ' ');
+    { perform action }
+    case i of
+      0 :
+        begin
+          Write ('"', DName, '"');
+          FileSys.CreateDir (DName);
+        end;
+      1 :
+        begin
+          Write (DName, '=> test2');
+          RenameDir (DName, 'test2');
+          GetErrorCode;
+          RenameDir ('test2', DName);
+        end;
+      2 :
+        begin
+          Write ('"', ExpandName (DName),'"');
+        end;
+      3 :
+        begin
+          Write ('"', GetCurrentDir, '"');
+        end;
+      4 :
+        begin
+          Write ('"', DName, '"');
+          FileSys.DeleteDir (DName);
+        end;
+      { FILE }
+      5 :
+        begin
+          Write ('"', FName, '" : ');
+          if (FileSys.CheckName (FName) = cnUnknown)
+            then Write ('unknown')
+            else Write ('known');
+        end;
+      6 :
+        begin
+          Write (' 22 Jul 1997 12:34:56');
+          with dt do begin
+            Day :=    22;
+            Month :=  7;
+            Year :=   1997;
+            Hour :=   12;
+            Minute := 34;
+            Second := 56;
+            CheckDateTime (dt);
+          end;
+          SetFTime (FName, dt);
+        end;
+      7 :
+        begin
+          Write (DateToString (dt), ' ', TimeToString (dt));
+        end;
+      8 :
+        begin
+          attr := 128;
+          SetFAttr (FName, attr);
+        end;
+      9 :
+        begin
+          Write (FileAttrToString (attr));
+        end;
+     10 :
+        begin
+          fi := 12345678;
+          Write (FileIntToString (fi));
+        end;
+     11 :
+        begin
+          {$ifdef OS_DOS}
+          n := 'c:\sub1\sub3.ext.ext\name.gz';
+          {$ELSE}
+          n := '/sub1/sub3.ext.ext/name.gz';
+          {$endif}
+          SplitName (n, p, rn, e);
+          Write ('"', n, '" => ',
+                 'PATH = "', p, '", RAW NAME = "', rn,
+                 '", EXTENSION = "', e, '"');
+        end;
+
+    end;
+    if (Common.GetErrorCode = errOK)
+      then WriteLn (' <NO ERROR>')
+      else WriteLn (' <ERROR>');
+    inc (i);
+  until (i = Passes);
+  WriteLn ('---');
+end.

api/test/testkbd.pas

@@ -0,0 +1,38 @@
+uses
+  Keyboard;
+
+function hexstr(val : longint;cnt : byte) : string;
+const
+  HexTbl : array[0..15] of char='0123456789ABCDEF';
+var
+  i : longint;
+begin
+  hexstr[0]:=char(cnt);
+  for i:=cnt downto 1 do
+   begin
+     hexstr[i]:=hextbl[val and $f];
+     val:=val shr 4;
+   end;
+end;
+
+var
+  Key: TKeyEvent;
+  Chr: Char;
+
+begin
+  InitKeyboard;
+  Chr := #0;
+  while Chr <> #27 do begin
+    Key := GetKeyEvent;
+    writeln('KeyEvent: ',hexstr(key,8));
+    Key:=translatekeyevent(key);
+    if IsFunctionKey(Key) then begin
+      WriteLn('Function key was pressed, Code: ', GetKeyEventCode(Key));
+     end
+     else begin
+      Chr := GetKeyEventChar(Key);
+      WriteLn('Normal key was pressed, character: ', Chr, ' (', Ord(Chr), ')');
+    end;
+  end;
+  DoneKeyboard;
+end.

api/test/testmou2.pas

@@ -0,0 +1,48 @@
+program MouseTest;
+
+uses
+ Crt, Mouse;
+
+var
+ Event: TMouseEvent;
+
+begin
+ while KeyPressed do ReadKey;
+ WriteLn ('Mouse will be shown after any key');
+ ReadKey;
+ while KeyPressed do ReadKey;
+ WriteLn ('Now generate mouse events or press any key to continue');
+ InitMouse;
+ while not (KeyPressed) do
+ begin
+  repeat until (KeyPressed) or PollMouseEvent (Event);
+  if not (KeyPressed) then
+  begin
+   GetMouseEvent (Event);
+   HideMouse;
+   Write ('Buttons: ', Event.Buttons, ', X: ', Event.X, ', Y: ', Event.Y,
+                                                                 ', action: ');
+   case Event.Action of
+    0: WriteLn ('nothing');
+    MouseActionDown: WriteLn ('down');
+    MouseActionUp: WriteLn ('up');
+    MouseActionMove: WriteLn ('move');
+   else
+    begin
+     WriteLn ('undefined!!!');
+     if ReadKey = #0 then ReadKey;
+    end;
+   end;
+   ShowMouse;
+  end;
+ end;
+ HideMouse;
+ WriteLn ('Mouse will be hidden after any key');
+ while KeyPressed do ReadKey;
+ ShowMouse;
+ if ReadKey = #0 then ReadKey;
+ HideMouse;
+ WriteLn ('Program ends after any key');
+ if ReadKey = #0 then ReadKey;
+ DoneMouse;
+end.

api/test/testmous.pas

@@ -0,0 +1,16 @@
+program testmouse;
+uses mouse;
+
+var
+  quit : boolean;
+  event : TMouseEvent;
+begin
+  initmouse;
+  repeat
+    GetMouseEvent(event);
+    writeln('action : ',event.action,' (',event.x,',',event.y,') [',event.buttons,']');
+    if event.buttons and MouseRightButton<>0 then
+      quit:=true;
+  until quit;
+  donemouse;
+end.

api/test/testterminfo.pas

@@ -0,0 +1,24 @@
+
+uses
+  Terminfo, Linux;
+
+var
+   Error, J : Longint;
+   I: Integer;
+
+begin
+   setupterm(nil, 1, Error);
+   if Error = 1 then begin
+     Write(cur_term^.TType.Strings[clear_screen]);
+     for I := 1 to 15 do begin
+       Write(cur_term^.TType.Strings[cursor_right]);
+       Write(cur_term^.TType.Strings[cursor_down]);
+       for J := 1 to 1000000 do ;
+     end;
+     for I := 1 to 15 do begin
+       Write(cur_term^.TType.Strings[cursor_up]);
+       Write(cur_term^.TType.Strings[cursor_right]);
+       for J := 1 to 1000000 do ;
+     end;
+   end;
+end.

api/test/testvid1.pas

@@ -0,0 +1,43 @@
+uses
+  Video, Keyboard;
+
+procedure FillScreen(W: Word);
+var
+  I: Integer;
+  P: PVideoCell;
+  Mode: TVideoMode;
+begin
+  GetVideoMode(Mode);
+  P := PVideoCell(VideoBuf);
+  for I := 0 to Mode.Row * Mode.Col do begin
+    P^ := W;
+    Inc(P);
+  end;
+  UpdateScreen(True);
+end;
+
+var
+  Mode: TVideoMode;
+
+begin
+  { Video automatically determines the dimensions, so you may want to
+    add "magic" numbers here to identify a given video mode }
+  {$IFDEF FPC}
+    RegisterVideoMode($FF, $FF, True, @DefaultVideoModeSelector, $01094F02);
+  {$ELSE}
+    RegisterVideoMode($FF, $FF, True, DefaultVideoModeSelector, $01094F02);
+  {$ENDIF}
+  InitVideo;
+  FillScreen($1FB0);
+  readln;
+
+  Mode.Col := $FF; Mode.Row := $FF; Mode.Color := True;
+  SetVideoMode(Mode);
+  FillScreen($1FB0);
+  WriteLn('ScreenWidth = ', ScreenWidth);
+  WriteLn('ScreenHeight = ', ScreenHeight);
+  readln;
+  Mode.Row := 25;
+  SetVideoMode(Mode);
+  DoneVideo;
+end.

api/test/testvid2.pas

@@ -0,0 +1,50 @@
+uses
+  Common, Video;
+
+var
+  I, J: CPUInt;
+  Direction: CPUWord;
+
+begin
+  Randomize;
+  InitVideo;
+  I := 1; J := 1;
+  Direction := Random(8);
+  repeat
+    VideoBuf^[I+J*ScreenWidth] := $0720;
+    case Direction of
+      0: Dec(J);
+      1: Inc(I);
+      2: Inc(J);
+      3: Dec(I);
+      4:
+        begin
+          Inc(I);
+          Dec(J);
+        end;
+      5:
+        begin
+          Inc(I);
+          Inc(J);
+        end;
+      6:
+        begin
+          Dec(I);
+          Inc(J);
+        end;
+      7:
+        begin
+          Dec(I);
+          Dec(J);
+        end;
+    end;
+    if (I < 0) then I := 0;
+    if (J < 0) then J := 0;
+    if (I >= ScreenWidth) then I := ScreenWidth-1;
+    if (J >= ScreenHeight) then J := ScreenHeight-1;
+    VideoBuf^[I+J*ScreenWidth] := $1F2A;
+    if Random(100) < 30 then Direction := Random(8);
+    UpdateScreen(False);
+  until False; {KeyPressed;}
+  DoneVideo;
+end.

api/tp/filectrl.inc

@@ -0,0 +1,241 @@
+{
+  System independent filecontrol interface for tp7
+
+  $Id$
+}
+
+{ no known 16 bit compilers support overriding }
+
+function OpenFileStr(FName: PChar; Flags: Longint): TFileHandle; assembler;
+asm
+@@Retry:
+        push    ds
+        lds     dx,FName
+        mov     al,byte ptr Flags
+        mov     ah,3dh
+        int     21h
+        pop     ds
+        jnc     @@1
+        push    ax
+        mov     ax,0
+        push    ax      { ErrorCode: Longint }
+        les     dx,FName
+        push    es
+        push    dx      { FName as ErrorInfo }
+        call    [ErrorHandler]
+        cmp     ax,errRetry
+        je      @@Retry
+        mov     ax,-1
+@@1:
+end;
+
+function CreateFileStr(FName: PChar): TFileHandle; assembler;
+asm
+@@Retry:
+        push    ds
+        lds     dx,FName
+        mov     cl,20h
+        xor     ch,ch
+        mov     ah,3Ch
+        int     21h
+        pop     ds
+        jnc     @@1
+        push    ax
+        mov     ax,0
+        push    ax
+        les     dx,FName
+        push    es
+        push    dx              { FName as errorinfo }
+        call    [ErrorHandler]
+        cmp     ax,errRetry
+        je      @@Retry
+        mov     ax,-1
+@@1:
+end;
+
+procedure DeleteFileStr(FName: PChar); assembler;
+asm
+@@Retry:
+        push    ds
+        lds     dx,FName
+        mov     AH,41h
+        int     21h
+        pop     ds
+        jnc     @@1
+        push    ax
+        mov     ax,0
+        push    ax
+        les     dx,FName
+        push    es
+        push    dx
+        call    [ErrorHandler]
+        cmp     ax,errRetry
+        je      @@Retry
+@@1:
+end;
+
+procedure CloseFile(Handle: TFileHandle); assembler;
+asm
+@@Retry:
+        mov     bx,Handle
+        mov     ah,3eh
+        int     21h
+        jnc     @@1
+        push    ax
+        mov     ax,0
+        push    ax
+        push    ax
+        push    ax
+        call    [ErrorHandler]
+        cmp     ax,errRetry
+        je      @@Retry
+@@1:
+end;
+
+function SeekFile(Handle: TFileHandle; Pos: TFileInt; SeekType: Word): TFileInt; assembler;
+asm
+@@Retry:
+        mov     ah,42H
+        mov     bx,Handle
+        mov     dx,word ptr Pos[0]
+        mov     cx,word ptr Pos[2]
+        mov     al,byte ptr SeekType
+        int     21h
+        jnc     @@1
+        push    ax
+        mov     ax,0
+        push    ax
+        push    ax
+        push    ax
+        call    [ErrorHandler]
+        cmp     ax,errRetry
+        je      @@Retry
+        mov     ax,-1
+        mov     dx,-1
+@@1:
+end;
+
+function ReadFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord; assembler;
+asm
+@@Retry:
+        push    ds
+        lds     dx,Buff
+        mov     cx,Count
+        mov     bx,Handle
+        mov     ah,3fh
+        int     21h
+        pop     ds
+        jnc     @@1
+        push    ax
+        mov     ax,0
+        push    ax
+        push    ax
+        push    ax
+        call    [ErrorHandler]
+        cmp     ax,errRetry
+        je      @@Retry
+        xor     ax,ax
+@@1:
+end;
+
+function WriteFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord; assembler;
+asm
+@@Retry:
+        push    ds
+        lds     dx,Buff
+        mov     cx,Count
+        mov     bx,Handle
+        mov     ah,40h
+        int     21h
+        pop     ds
+        jnc     @@1
+        push    ax
+        mov     ax,0
+        push    ax
+        push    ax
+        push    ax
+        call    [ErrorHandler]
+        cmp     ax,errRetry
+        je      @@Retry
+        xor     ax,ax
+@@1:
+end;
+
+procedure FlushFile(Handle: TFileHandle); assembler;
+asm
+@@Retry:
+        mov     bx,Handle
+        mov     ah,68H
+        int     21h
+        jnc     @@1
+        push    ax
+        mov     ax,0
+        push    ax
+        push    ax
+        push    ax
+        call    [ErrorHandler]
+        cmp     ax,errRetry
+        je      @@Retry
+@@1:
+end;
+
+procedure TruncateFile(Handle: TFileHandle);
+begin
+  WriteFile(Handle, Handle, 0);
+end;
+
+function EndOfFile(Handle: TFileHandle): Boolean; assembler;
+asm
+@@Retry:
+        mov     ax,4400h
+        mov     bx,Handle
+        int     21h
+        jnc     @@1
+        push    ax
+        mov     ax,0
+        push    ax
+        push    ax
+        push    ax
+        call    [ErrorHandler]
+        cmp     ax,errRetry
+        je      @@Retry
+        jmp     @@3      { Set result to 1, though an error has happened }
+@@1:
+        test    ax,40h
+        jz      @@3
+        xor     al,al
+        jmp     @@2
+@@3:
+        mov     al,1
+@@2:
+end;
+
+function FilePos(Handle: TFileHandle): TFileInt;
+begin
+  FilePos := SeekFile(Handle, 0, skCur);
+end;
+
+function FileSize(Handle: TFileHandle): TFileInt;
+var
+  L: Longint;
+begin
+  L := FilePos(Handle);
+  FileSize := SeekFile(Handle, 0, skEnd);
+  SeekFile(Handle, L, skBeg);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.1  1998/12/04 12:48:57  peter
+    * moved some dirs
+
+  Revision 1.1  1998/10/26 11:31:49  peter
+    + inital include files
+
+}

api/tp/keyboard.inc

@@ -0,0 +1,168 @@
+{
+  System independent keyboard interface for tp7
+
+  $Id$
+}
+
+procedure InitKeyboard;
+begin
+end;
+
+procedure DoneKeyboard;
+begin
+end;
+
+function GetKeyEvent: TKeyEvent; assembler;
+asm
+        mov     ax,[word ptr PendingKeyEvent+0]
+        or      ax,[word ptr PendingKeyEvent+2]
+        je      @@1
+        mov     ax,[word ptr PendingKeyEvent+0]
+        mov     dx,[word ptr PendingKeyEvent+2]
+        mov     [word ptr PendingKeyEvent+0],0
+        mov     [word ptr PendingKeyEvent+2],0
+        jmp     @@99
+@@1:
+        mov     ax,40h
+        mov     es,ax
+        mov     ah, 10h         { get extended key }
+        int     16h
+        mov     dh,3
+        mov     dl,[byte ptr es:17h] { shift state }
+        and     dl,0fh
+        cmp     al,0e0h
+        jne     @@2
+        or      ah,ah
+        jz      @@2
+        mov     al,0
+@@2:
+@@99:
+end;
+
+
+function PollKeyEvent: TKeyEvent; assembler;
+asm
+        mov     ax,[word ptr PendingKeyEvent+0]
+        or      ax,[word ptr PendingKeyEvent+2]
+        je      @@1
+        mov     ax,[word ptr PendingKeyEvent+0]
+        mov     dx,[word ptr PendingKeyEvent+2]
+        jmp     @@2
+@@1:
+        mov     ax,40h
+        mov     es,ax
+        mov     ah,11h
+        int     16h
+        jnz     @@2
+        xor     ax,ax
+        xor     dx,dx
+        jmp     @@99
+@@2:    mov     dh,3
+        mov     dl,[byte ptr es:17h] { shift state }
+        and     dl,0fh
+        cmp     al,0e0h
+        jne     @@3
+        or      ah,ah
+        jz      @@3
+        mov     al,0
+@@3:
+@@99:
+end;
+
+
+function PollShiftStateEvent: TKeyEvent;assembler;
+asm
+        mov     ax,40h
+        mov     es,ax
+        xor     dx,dx
+        xor     ax,ax
+        mov     dl,byte ptr es:[17h] { shift state}
+        and     dl,0fh
+end;
+
+
+{ Function key translation }
+type
+  TTranslationEntry = record
+    Min, Max: Byte;
+    Offset: Word;
+  end;
+
+const
+  TranslationTableEntries = 12;
+  TranslationTable: array [1..TranslationTableEntries] of TTranslationEntry =
+    ((Min: $3B; Max: $44; Offset: kbdF1),   { function keys F1-F10 }
+     (Min: $54; Max: $5D; Offset: kbdF1),   { Shift fn keys F1-F10 }
+     (Min: $5E; Max: $67; Offset: kbdF1),   { Ctrl fn keys F1-F10 }
+     (Min: $68; Max: $71; Offset: kbdF1),   { Alt fn keys F1-F10 }
+     (Min: $85; Max: $86; Offset: kbdF11),  { function keys F11-F12 }
+     (Min: $87; Max: $88; Offset: kbdF11),  { Shift+function keys F11-F12 }
+     (Min: $89; Max: $8A; Offset: kbdF11),  { Ctrl+function keys F11-F12 }
+     (Min: $8B; Max: $8C; Offset: kbdF11),  { Alt+function keys F11-F12 }
+     (Min:  71; Max:  73; Offset: kbdHome), { Keypad keys kbdHome-kbdPgUp }
+     (Min:  75; Max:  77; Offset: kbdLeft), { Keypad keys kbdLeft-kbdRight }
+     (Min:  79; Max:  81; Offset: kbdEnd),  { Keypad keys kbdEnd-kbdPgDn }
+     (Min: $52; Max: $53; Offset: kbdInsert));
+
+
+function TranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
+var
+  I: Integer;
+  ScanCode: Byte;
+begin
+  if KeyEvent and $03000000 = $03000000 then
+   begin
+     if KeyEvent and $000000FF <> 0 then
+      begin
+        TranslateKeyEvent := KeyEvent and $00FFFFFF;
+        exit;
+      end
+     else
+      begin
+        { This is a function key }
+        ScanCode := (KeyEvent and $0000FF00) shr 8;
+        for I := 1 to TranslationTableEntries do
+         begin
+           if (TranslationTable[I].Min <= ScanCode) and (ScanCode <= TranslationTable[I].Max) then
+            begin
+              TranslateKeyEvent := $02000000 + (KeyEvent and $00FF0000) +
+                (ScanCode - TranslationTable[I].Min) + TranslationTable[I].Offset;
+              exit;
+            end;
+         end;
+      end;
+   end;
+  TranslateKeyEvent := KeyEvent;
+end;
+
+function TranslateKeyEventUniCode(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+  TranslateKeyEventUniCode := KeyEvent;
+  ErrorHandler(errKbdNotImplemented, nil);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.2  1998/12/12 19:13:13  peter
+    * keyboard updates
+    * make test target, make all only makes units
+
+  Revision 1.1  1998/12/04 12:48:57  peter
+    * moved some dirs
+
+  Revision 1.3  1998/11/01 20:28:25  peter
+    * fixed strange al=$e0 after int $16 call
+
+  Revision 1.2  1998/10/28 21:18:27  peter
+    * more fixes
+
+  Revision 1.1  1998/10/26 11:31:49  peter
+    + inital include files
+
+}

api/tp/mouse.inc

@@ -0,0 +1,209 @@
+{
+  System independent mouse interface for tp7
+
+  $Id$
+}
+
+procedure MouseInt;far;assembler;
+asm
+        mov     si,seg @data
+        mov     ds,si
+        mov     si,cx
+        mov     MouseButtons,bl
+        mov     MouseWhereX,si
+        mov     MouseWhereY,dx
+        cmp     PendingMouseEvents,MouseEventBufSize
+        je      @@20
+        les     di,PendingMouseTail
+        cld
+        xchg    ax,bx
+        stosw
+        xchg    ax,cx
+        shr     ax,3
+        stosw
+        xchg    ax,dx
+        shr     ax,3
+        stosw
+        xor     ax,ax
+        stosw
+        mov     ax,offset PendingMouseEvent
+        add     ax,MouseEventBufSize*8
+        cmp     di,ax
+        jne     @@10
+        mov     di,offset PendingMouseEvent
+@@10:   mov     word ptr PendingMouseTail,di
+        inc     PendingMouseEvents
+@@20:
+end;
+
+
+procedure InitMouse;
+begin
+  PendingMouseHead:=@PendingMouseEvent;
+  PendingMouseTail:=@PendingMouseEvent;
+  PendingMouseEvents:=0;
+  FillChar(LastMouseEvent,sizeof(TMouseEvent),0);
+  asm
+        mov     ax,0ch
+        mov     cx,0ffffh
+        mov     dx,offset MouseInt
+        push    cs
+        pop     es
+        push    bp
+        int     33h
+        pop     bp
+  end;
+  ShowMouse;
+end;
+
+
+procedure DoneMouse;
+begin
+  HideMouse;
+  asm
+        mov     ax,0ch
+        xor     cx,cx
+        xor     dx,dx
+        mov     es,cx
+        push    bp
+        int     33h
+        pop     bp
+  end;
+end;
+
+
+function DetectMouse:byte;assembler;
+asm
+        mov     ax,3533h
+        push    bp
+        int     21h
+        pop     bp
+        mov     ax,es
+        or      ax,bx
+        jz      @@99
+        xor     ax,ax
+        push    bp
+        int     33h
+        pop     bp
+        or      ax,ax
+        jz      @@99
+        mov     ax,bx
+@@99:
+end;
+
+
+procedure ShowMouse;assembler;
+asm
+        mov     ax,1
+        push    bp
+        int     33h
+        pop     bp
+end;
+
+
+procedure HideMouse;assembler;
+asm
+        mov     ax,2
+        push    bp
+        int     33h
+        pop     bp
+end;
+
+
+function GetMouseX:word;assembler;
+asm
+        mov     ax,3
+        push    bp
+        int     33h
+        pop     bp
+        mov     ax,cx
+        shr     ax,3
+        inc     ax
+end;
+
+
+function GetMouseY:word;assembler;
+asm
+        mov     ax,3
+        push    bp
+        int     33h
+        pop     bp
+        mov     ax,dx
+        shr     ax,3
+        inc     ax
+end;
+
+
+function GetMouseButtons:word;assembler;
+asm
+        mov     ax,3
+        push    bp
+        int     33h
+        pop     bp
+        mov     ax,bx
+end;
+
+
+procedure SetMouseXY(x,y:word);assembler;
+asm
+        mov     ax,4
+        mov     cx,x
+        mov     dx,y
+        push    bp
+        int     33h
+        pop     bp
+end;
+
+
+procedure GetMouseEvent(var MouseEvent: TMouseEvent);
+begin
+  repeat until PendingMouseEvents>0;
+  MouseEvent:=PendingMouseHead^;
+  inc(PendingMouseHead);
+  if longint(PendingMouseHead)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+   PendingMouseHead:=@PendingMouseEvent;
+  dec(PendingMouseEvents);
+  if (LastMouseEvent.x<>MouseEvent.x) or (LastMouseEvent.y<>MouseEvent.y) then
+   MouseEvent.Action:=MouseActionMove;
+  if (LastMouseEvent.Buttons<>MouseEvent.Buttons) then
+   begin
+     if (LastMouseEvent.Buttons=0) then
+      MouseEvent.Action:=MouseActionDown
+     else
+      MouseEvent.Action:=MouseActionUp;
+   end;
+  LastMouseEvent:=MouseEvent;
+end;
+
+
+function PollMouseEvent(var MouseEvent: TMouseEvent):boolean;
+begin
+  if PendingMouseEvents>0 then
+   begin
+     MouseEvent:=PendingMouseHead^;
+     PollMouseEvent:=true;
+   end
+  else
+   PollMouseEvent:=false;
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.2  1998/12/11 00:13:21  peter
+    + SetMouseXY
+    * use far for exitproc procedure
+
+  Revision 1.1  1998/12/04 12:48:57  peter
+    * moved some dirs
+
+  Revision 1.1  1998/10/28 00:02:09  peter
+    + mouse
+    + video.clearscreen, video.videobufsize
+
+}

api/tp/video.inc

@@ -0,0 +1,243 @@
+{
+  System independent low-level video interface for tp7
+
+  $Id$
+}
+
+{ use a buffer, just like linux,go32v2 }
+{$define use_buf}
+
+var
+  VideoSeg    : word;
+  OldVideoBuf : PVideoBuf;
+
+{ internal function, which is by default available under FPC }
+procedure fillword(var buf;len,w:word);assembler;
+asm
+        les     di,buf
+        mov     cx,len
+        mov     ax,w
+        rep     stosw
+end;
+
+
+procedure InitVideo;
+begin
+  asm
+        mov     ah,0fh
+        int     10h
+        mov     [ScreenColor],1
+        test    al,1            { even modes are colored }
+        jne     @ColorOn
+        mov     [ScreenColor],0
+@ColorOn:
+        cmp     al,7            { 7 mono mode }
+        mov     dx,SegB800
+        jne     @@1
+        mov     [ScreenColor],0
+        mov     dx,SegB000
+@@1:
+{$ifdef use_buf}
+        mov     videoseg,dx
+{$else}
+        mov     [word ptr VideoBuf+0], 0
+        mov     [word ptr VideoBuf+2], dx
+{$endif}
+        xchg    al,ah
+        xor     ah,ah
+        mov     [ScreenWidth],ax
+        mov     bx,40h
+        mov     cx,ax                   { cx:=ax, pipeline ok }
+        mov     es,bx
+        shl     cx,1
+        mov     ax,[word ptr es:04ch] { Size of videobuf }
+        xor     dx,dx
+        div     cx
+        mov     [ScreenHeight],ax
+        mov     ah,03h
+        xor     bh,bh
+        int     10h
+        mov     [CursorLines], cl
+        xor     ax,ax
+        mov     al,dl
+        mov     [CursorX],ax
+        mov     al,dh
+        mov     [CursorY],ax
+  end;
+{$ifdef use_buf}
+  VideoBufSize:=ScreenWidth*ScreenHeight*2;
+  GetMem(VideoBuf,VideoBufSize);
+  GetMem(OldVideoBuf,VideoBufSize);
+{$endif}
+  ClearScreen;
+end;
+
+
+procedure DoneVideo;
+begin
+  ClearScreen;
+  SetCursorType(crUnderLine);
+  SetCursorPos(0,0);
+{$ifdef use_buf}
+  FreeMem(VideoBuf,VideoBufSize);
+  FreeMem(OldVideoBuf,VideoBufSize);
+  VideoBufSize:=0;
+{$endif}
+end;
+
+
+function GetCapabilities: Word;
+begin
+  GetCapabilities := $3F;
+end;
+
+
+procedure SetCursorPos(NewCursorX, NewCursorY: Word); assembler;
+asm
+        mov     ah,02h
+        xor     bh,bh
+        mov     dh,[byte ptr NewCursorY]
+        mov     dl,[byte ptr NewCursorX]
+        int     10h
+        mov     [byte ptr CursorY],dh
+        mov     [byte ptr CursorX],dl
+end;
+
+
+function GetCursorType: Word; assembler;
+asm
+        mov     ah,03h
+        xor     bh,bh
+        int     10h
+        mov     ax,crHidden
+        cmp     cx,2000h
+        je      @@1
+        mov     ax,crBlock
+        cmp     ch,00h
+        je      @@1
+        mov     ax,crHalfBlock
+        mov     bl,[CursorLines]
+        shr     bl,1
+        cmp     ch,bl
+        jbe     @@1
+        mov     ax,crUnderline
+@@1:
+end;
+
+
+procedure SetCursorType(NewType: Word); assembler;
+asm
+        mov     ah,01h
+        mov     bx,[NewType]
+        mov     cx,2000h
+        cmp     bx,crHidden
+        je      @@1
+        mov     ch,[CursorLines]
+        mov     cl,ch
+        shr     ch,1
+        cmp     bx,crHalfBlock
+        je      @@1
+        mov     ch,0
+        cmp     bx,crBlock
+        je      @@1
+        mov     cl,[CursorLines]
+        mov     ch,cl
+        dec     ch
+@@1:
+        int     10h
+end;
+
+
+procedure ClearScreen;
+begin
+  FillWord(VideoBuf^,VideoBufSize shr 1,$0720);
+{$ifdef use_buf}
+  UpdateScreen(true);
+{$endif}
+end;
+
+
+procedure UpdateScreen(Force: Boolean);
+{$ifdef use_buf}
+var
+  SwapPtr : PVideoBuf;
+{$endif}
+begin
+  if LockUpdateScreen<>0 then
+   exit;
+{$ifdef use_buf}
+  if not force then
+   begin
+     asm
+        mov     cx,word ptr VideoBufSize
+        shr     cx,1
+        les     di,OldVideoBuf
+        push    ds
+        lds     si,VideoBuf
+        repe    cmpsw
+        pop     ds
+        or      cx,cx
+        jz      @@10
+        mov     force,1
+@@10:
+     end;
+   end;
+  if force then
+   begin
+     move(videobuf^,ptr(videoseg,0)^,VideoBufSize);
+     move(videobuf^,oldvideobuf^,VideoBufSize);
+   end;
+{$endif}
+end;
+
+
+function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean; assembler;
+asm
+        mov     ax,[word ptr Params+0]
+        mov     bx,[word ptr Params+2]
+        push    bp
+        int     10h
+        pop     bp
+        mov     al,1
+end;
+
+
+procedure RegisterVideoModes;
+begin
+  RegisterVideoMode(40, 25, False, DefaultVideoModeSelector, $00000000);
+  RegisterVideoMode(40, 25, True, DefaultVideoModeSelector, $00000001);
+  RegisterVideoMode(80, 25, False, DefaultVideoModeSelector, $00000002);
+  RegisterVideoMode(80, 25, True, DefaultVideoModeSelector, $00000003);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.3  1998/12/15 17:17:18  peter
+    + cursor at 1,1 at the end
+
+  Revision 1.2  1998/12/15 10:25:16  peter
+    * Use Segb800 instead of $b800
+
+  Revision 1.1  1998/12/04 12:48:57  peter
+    * moved some dirs
+
+  Revision 1.4  1998/11/01 20:29:13  peter
+    + lockupdatescreen counter to not let updatescreen() update
+
+  Revision 1.3  1998/10/28 21:18:28  peter
+    * more fixes
+
+  Revision 1.2  1998/10/28 00:02:09  peter
+    + mouse
+    + video.clearscreen, video.videobufsize
+
+  Revision 1.1  1998/10/26 11:31:49  peter
+    + inital include files
+
+}

api/tpapi.pas

@@ -0,0 +1,6 @@
+program BuildAPI;
+uses
+  Common, FileSys, FileCtrl, Video, Keyboard, Mouse, CallSpec;
+
+begin
+end.

api/win32/Makefile

@@ -0,0 +1,1074 @@
+#
+# Makefile generated by fpcmake v0.99.13 [2000/01/06]
+#
+
+defaultrule: all
+
+#####################################################################
+# Autodetect OS (Linux or Dos or Windows NT)
+# define inlinux when running under linux
+# define inWinNT when running under WinNT
+#####################################################################
+
+# We need only / in the path
+override PATH:=$(subst \,/,$(PATH))
+
+# Search for PWD and determine also if we are under linux
+PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH)))))
+ifeq ($(PWD),)
+PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH)))))
+ifeq ($(PWD),)
+nopwd:
+	@echo You need the GNU utils package to use this Makefile!
+	@echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip
+	@exit
+else
+inlinux=1
+endif
+else
+PWD:=$(firstword $(PWD))
+endif
+
+# Detect NT - NT sets OS to Windows_NT
+ifndef inlinux
+ifeq ($(OS),Windows_NT)
+inWinNT=1
+endif
+endif
+
+# Detect OS/2 - OS/2 has OS2_SHELL defined
+ifndef inlinux
+ifndef inWinNT
+ifdef OS2_SHELL
+inOS2=1
+endif
+endif
+endif
+
+# The extension of executables
+ifdef inlinux
+EXEEXT=
+else
+EXEEXT=.exe
+endif
+
+# The path which is searched separated by spaces
+ifdef inlinux
+SEARCHPATH=$(subst :, ,$(PATH))
+else
+SEARCHPATH=$(subst ;, ,$(PATH))
+endif
+
+#####################################################################
+# Default target
+#####################################################################
+
+override OS_TARGET:=win32
+
+#####################################################################
+# FPC version/target Detection
+#####################################################################
+
+# What compiler to use ?
+ifndef FPC
+# Compatibility with old makefiles
+ifdef PP
+FPC=$(PP)
+else
+ifdef inOS2
+FPC=ppos2$(EXEEXT)
+else
+FPC=ppc386$(EXEEXT)
+endif
+endif
+endif
+
+# Target OS
+ifndef OS_TARGET
+OS_TARGET:=$(shell $(FPC) -iTO)
+endif
+
+# Source OS
+ifndef OS_SOURCE
+OS_SOURCE:=$(shell $(FPC) -iSO)
+endif
+
+# Target CPU
+ifndef CPU_TARGET
+CPU_TARGET:=$(shell $(FPC) -iTP)
+endif
+
+# Source CPU
+ifndef CPU_SOURCE
+CPU_SOURCE:=$(shell $(FPC) -iSP)
+endif
+
+# FPC version
+ifndef FPC_VERSION
+FPC_VERSION:=$(shell $(FPC) -iV)
+endif
+
+export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION
+
+# Test FPCDIR to look if the RTL dir exists
+ifdef FPCDIR
+override FPCDIR:=$(subst \,/,$(FPCDIR))
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+else
+override FPCDIR=wrong
+endif
+
+# Default FPCDIR
+ifeq ($(FPCDIR),wrong)
+override FPCDIR=../..
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+endif
+
+# Detect FPCDIR
+ifeq ($(FPCDIR),wrong)
+ifdef inlinux
+override FPCDIR=/usr/lib/fpc/$(FPC_VERSION)
+else
+override FPCDIR:=$(subst /$(FPC)$(EXEEXT),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC)$(EXEEXT),$(SEARCHPATH))))))
+endif
+endif
+
+ifndef PACKAGEDIR
+PACKAGEDIR=$(FPCDIR)/packages
+endif
+ifndef COMPONENTDIR
+COMPONENTDIR=$(FPCDIR)/components
+endif
+# Check if packagedir really exists else turn it off
+ifeq ($(wildcard $(PACKAGEDIR)),)
+PACKAGEDIR=
+endif
+ifeq ($(wildcard $(COMPONENTDIR)),)
+COMPONENTDIR=
+endif
+
+# Create rtl,units dir
+ifneq ($(FPCDIR),.)
+override UNITSDIR=$(FPCDIR)/units/$(OS_TARGET)
+ifneq ($(wildcard $(FPCDIR)/rtl),)
+override RTLDIR=$(FPCDIR)/rtl/$(OS_TARGET)
+else
+override RTLDIR=$(UNITSDIR)/rtl
+endif
+endif
+
+#####################################################################
+# Default Settings
+#####################################################################
+
+# Release ? Then force OPT and don't use extra opts via commandline
+ifndef REDIRFILE
+REDIRFILE=log
+endif
+
+ifdef REDIR
+ifndef inlinux
+override FPC=redir -eo $(FPC)
+endif
+# set the verbosity to max
+override OPT+=-va
+override REDIR:= >> $(REDIRFILE)
+endif
+
+#####################################################################
+# User Settings
+#####################################################################
+
+
+# Pre Settings
+
+INC=../inc
+
+# Override defaults
+override PASEXT=.pas
+
+include ../test/Makefile.api
+include $(INC)/Makefile.api
+
+# Targets
+
+override UNITOBJECTS+=event $(APIOBJECTS)
+override EXAMPLEOBJECTS+=$(TESTOBJECTS)
+
+# Clean
+
+
+# Install
+
+UNITSUBDIR=api
+ZIPTARGET=install
+
+# Defaults
+
+
+# Directories
+
+vpath %$(PASEXT) $(INC)
+ifndef TARGETDIR
+TARGETDIR=.
+endif
+
+# Packages
+
+override PACKAGES=rtl
+PACKAGEDIR_RTL=$(FPCDIR)/rtl/$(OS_TARGET)
+
+# Libraries
+
+LIBNAME=fpapi
+
+# Info
+
+INFOTARGET=fpc_infocfg fpc_infoobjects fpc_infoinstall 
+
+#####################################################################
+# Default Directories
+#####################################################################
+
+# Base dir
+ifdef PWD
+BASEDIR:=$(shell $(PWD))
+else
+BASEDIR=.
+endif
+
+# set the prefix directory where to install everything
+ifndef PREFIXINSTALLDIR
+ifdef inlinux
+PREFIXINSTALLDIR=/usr
+else
+PREFIXINSTALLDIR=/pp
+endif
+endif
+export PREFIXINSTALLDIR
+
+#####################################################################
+# Install Directories
+#####################################################################
+
+# set the base directory where to install everything
+ifndef BASEINSTALLDIR
+ifdef inlinux
+BASEINSTALLDIR=$(PREFIXINSTALLDIR)/lib/fpc/$(FPC_VERSION)
+else
+BASEINSTALLDIR=$(PREFIXINSTALLDIR)
+endif
+endif
+
+# set the directory where to install the binaries
+ifndef BININSTALLDIR
+ifdef inlinux
+BININSTALLDIR=$(PREFIXINSTALLDIR)/bin
+else
+BININSTALLDIR=$(BASEINSTALLDIR)/bin/$(OS_TARGET)
+endif
+endif
+
+# set the directory where to install the units.
+ifndef UNITINSTALLDIR
+UNITINSTALLDIR=$(BASEINSTALLDIR)/units/$(OS_TARGET)
+ifdef UNITSUBDIR
+UNITINSTALLDIR:=$(UNITINSTALLDIR)/$(UNITSUBDIR)
+endif
+endif
+
+# Where to install shared libraries
+ifndef LIBINSTALLDIR
+ifdef inlinux
+LIBINSTALLDIR=$(PREFIXINSTALLDIR)/lib
+else
+LIBINSTALLDIR=$(UNITINSTALLDIR)
+endif
+endif
+
+# Where the source files will be stored
+ifndef SOURCEINSTALLDIR
+ifdef inlinux
+SOURCEINSTALLDIR=$(PREFIXINSTALLDIR)/src/fpc-$(FPC_VERSION)
+else
+SOURCEINSTALLDIR=$(BASEINSTALLDIR)/source
+endif
+endif
+
+# Where the doc files will be stored
+ifndef DOCINSTALLDIR
+ifdef inlinux
+DOCINSTALLDIR=$(PREFIXINSTALLDIR)/doc/fpc-$(FPC_VERSION)
+else
+DOCINSTALLDIR=$(BASEINSTALLDIR)/doc
+endif
+endif
+
+# Where the some extra (data)files will be stored
+ifndef DATAINSTALLDIR
+DATAINSTALLDIR=$(BASEINSTALLDIR)
+endif
+
+
+#####################################################################
+# Compiler Command Line
+#####################################################################
+
+# Load commandline OPTDEF and add FPC_CPU define
+override FPCOPTDEF:=-d$(CPU_TARGET)
+
+# Load commandline OPT and add target and unit dir to be sure
+ifneq ($(OS_TARGET),$(OS_SOURCE))
+override FPCOPT+=-T$(OS_TARGET)
+endif
+
+ifdef UNITSDIR
+override FPCOPT+=-Fu$(UNITSDIR)
+endif
+
+ifdef RTLDIR
+override FPCOPT+=-Fu$(RTLDIR)
+endif
+
+# Target dirs
+ifdef TARGETDIR
+override FPCOPT+=-FE$(TARGETDIR)
+endif
+
+# Smartlinking
+ifdef SMARTLINK
+override FPCOPT+=-CX
+endif
+
+# Debug
+ifdef DEBUG
+override FPCOPT+=-g
+endif
+
+# Release mode (strip, optimize and don't load ppc386.cfg)
+ifdef RELEASE
+override FPCOPT+=-Xs -OG2p3 -n
+endif
+
+# Verbose settings (warning,note,info)
+ifdef VERBOSE
+override FPCOPT+=-vwni
+endif
+
+# Add commandline options
+ifdef OPT
+override FPCOPT+=$(OPT)
+endif
+ifdef UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
+endif
+ifdef LIBDIR
+override FPCOPT+=$(addprefix -Fl,$(LIBDIR))
+endif
+ifdef OBJDIR
+override FPCOPT+=$(addprefix -Fo,$(OBJDIR))
+endif
+ifdef INCDIR
+override FPCOPT+=$(addprefix -Fi,$(INCDIR))
+endif
+
+# Add defines from FPCOPTDEF to FPCOPT
+ifdef FPCOPTDEF
+override FPCOPT+=$(FPCOPTDEF)
+endif
+
+# Error file ?
+ifdef ERRORFILE
+override FPCOPT+=-Fr$(ERRORFILE)
+endif
+
+# Was a config file specified ?
+ifdef CFGFILE
+override FPCOPT+=@$(CFGFILE)
+endif
+
+# For win32 the options are passed using the environment variable FPCEXTCMD
+ifeq ($(OS_SOURCE),win32)
+override FPCEXTCMD:=$(FPCOPT)
+override FPCOPT:=!FPCEXTCMD
+export FPCEXTCMD
+endif
+
+# Compiler commandline
+override COMPILER:=$(FPC) $(FPCOPT)
+
+#####################################################################
+# Shell tools
+#####################################################################
+
+# To copy pograms
+ifndef COPY
+COPY:=cp -fp
+endif
+
+# Copy a whole tree
+ifndef COPYTREE
+COPYTREE:=cp -rfp
+endif
+
+# To move pograms
+ifndef MOVE
+MOVE:=mv -f
+endif
+
+# Check delete program
+ifndef DEL
+DEL:=rm -f
+endif
+
+# Check deltree program
+ifndef DELTREE
+DELTREE:=rm -rf
+endif
+
+# To install files
+ifndef INSTALL
+ifdef inlinux
+INSTALL:=install -m 644
+else
+INSTALL:=$(COPY)
+endif
+endif
+
+# To install programs
+ifndef INSTALLEXE
+ifdef inlinux
+INSTALLEXE:=install -m 755
+else
+INSTALLEXE:=$(COPY)
+endif
+endif
+
+# To make a directory.
+ifndef MKDIR
+ifdef inlinux
+MKDIR:=install -m 755 -d
+else
+MKDIR:=ginstall -m 755 -d
+endif
+endif
+
+export COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR
+
+#####################################################################
+# Default Tools
+#####################################################################
+
+# assembler, redefine it if cross compiling
+ifndef AS
+AS=as
+endif
+
+# linker, but probably not used
+ifndef LD
+LD=ld
+endif
+
+# ppas.bat / ppas.sh
+ifdef inlinux
+PPAS=ppas.sh
+else
+ifdef inOS2
+PPAS=ppas.cmd
+else
+PPAS=ppas.bat
+endif
+endif
+
+# also call ppas if with command option -s
+ifeq (,$(findstring -s ,$(COMPILER)))
+EXECPPAS=
+else
+EXECPPAS:=@$(PPAS)
+endif
+
+# ldconfig to rebuild .so cache
+ifdef inlinux
+LDCONFIG=ldconfig
+else
+LDCONFIG=
+endif
+
+# echo
+ifndef ECHO
+ECHO:=$(strip $(wildcard $(addsuffix /echo$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO:=echo
+else
+ECHO:=$(firstword $(ECHO))
+endif
+endif
+export ECHO
+
+# ppdep
+ifndef PPDEP
+PPDEP:=$(strip $(wildcard $(addsuffix /ppdep$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPDEP),)
+PPDEP=
+else
+PPDEP:=$(firstword $(PPDEP))
+endif
+endif
+export PPDEP
+
+# ppumove
+ifndef PPUMOVE
+PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUMOVE),)
+PPUMOVE=
+else
+PPUMOVE:=$(firstword $(PPUMOVE))
+endif
+endif
+export PPUMOVE
+
+# ppufiles
+ifndef PPUFILES
+PPUFILES:=$(strip $(wildcard $(addsuffix /ppufiles$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUFILES),)
+PPUFILES=
+else
+PPUFILES:=$(firstword $(PPUFILES))
+endif
+endif
+export PPUFILES
+
+# Look if UPX is found for go32v2 and win32. We can't use $UPX becuase
+# upx uses that one itself (PFV)
+ifndef UPXPROG
+ifeq ($(OS_TARGET),go32v2)
+UPXPROG:=1
+endif
+ifeq ($(OS_TARGET),win32)
+UPXPROG:=1
+endif
+ifdef UPXPROG
+UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(UPXPROG),)
+UPXPROG=
+else
+UPXPROG:=$(firstword $(UPXPROG))
+endif
+else
+UPXPROG=
+endif
+endif
+export UPXPROG
+
+# gdate/date
+ifndef DATE
+DATE:=$(strip $(wildcard $(addsuffix /date$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE:=$(strip $(wildcard $(addsuffix /gdate$(EXEEXT),$(SEACHPATH))))
+ifeq ($(DATE),)
+DATE=
+else
+DATE:=$(firstword $(DATE))
+endif
+else
+DATE:=$(firstword $(DATE))
+endif
+endif
+export DATE
+
+ifdef DATE
+DATESTR:=$(shell $(DATE) +%Y%m%d)
+else
+DATESTR=
+endif
+
+# ZipProg, you can't use Zip as the var name (PFV)
+ifndef ZIPPROG
+ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(ZIPPROG),)
+ZIPPROG=
+else
+ZIPPROG:=$(firstword $(ZIPPROG)) -D9 -r
+endif
+endif
+export ZIPPROG
+
+ifndef ZIPEXT
+ZIPEXT=.zip
+endif
+
+#####################################################################
+# Default extensions
+#####################################################################
+
+# Default needed extensions (Go32v2,Linux)
+LOADEREXT=.as
+PPLEXT=.ppl
+PPUEXT=.ppu
+OEXT=.o
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.so
+RSTEXT=.rst
+PACKAGESUFFIX=
+FPCMADE=fpcmade
+
+# Go32v1
+ifeq ($(OS_TARGET),go32v1)
+PPUEXT=.pp1
+OEXT=.o1
+ASMEXT=.s1
+SMARTEXT=.sl1
+STATICLIBEXT=.a1
+SHAREDLIBEXT=.so1
+PACKAGESUFFIX=v1
+FPCMADE=fpcmade.v1
+endif
+
+# Go32v2
+ifeq ($(OS_TARGET),go32v2)
+PACKAGESUFFIX=go32
+FPCMADE=fpcmade.dos
+endif
+
+# Linux
+ifeq ($(OS_TARGET),linux)
+PACKAGESUFFIX=linux
+FPCMADE=fpcmade.lnx
+endif
+
+# Win32
+ifeq ($(OS_TARGET),win32)
+PPUEXT=.ppw
+OEXT=.ow
+ASMEXT=.sw
+SMARTEXT=.slw
+STATICLIBEXT=.aw
+SHAREDLIBEXT=.dll
+PACKAGESUFFIX=win32
+FPCMADE=fpcmade.w32
+endif
+
+# OS/2
+ifeq ($(OS_TARGET),os2)
+PPUEXT=.ppo
+ASMEXT=.so2
+OEXT=.oo2
+SMARTEXT=.so
+STATICLIBEXT=.ao2
+SHAREDLIBEXT=.dll
+PACKAGESUFFIX=os2
+FPCMADE=fpcmade.os2
+endif
+
+# library prefix
+LIBPREFIX=lib
+ifeq ($(OS_TARGET),go32v2)
+LIBPREFIX=
+endif
+ifeq ($(OS_TARGET),go32v1)
+LIBPREFIX=
+endif
+
+# determine which .pas extension is used
+ifndef PASEXT
+ifdef EXEOBJECTS
+override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(EXEOBJECTS)))))
+else
+override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(UNITOBJECTS)))))
+endif
+ifeq ($(TESTPAS),)
+PASEXT=.pp
+else
+PASEXT=.pas
+endif
+endif
+
+#####################################################################
+# Standard rules
+#####################################################################
+
+all: fpc_all
+
+debug: fpc_debug
+
+examples: fpc_examples
+
+test: fpc_test
+
+smart: fpc_smart
+
+shared: fpc_shared
+
+showinstall: fpc_showinstall
+
+install: fpc_install
+
+sourceinstall: fpc_sourceinstall
+
+zipinstall: fpc_zipinstall
+
+zipinstalladd: fpc_zipinstalladd
+
+clean: fpc_clean
+
+cleanall: fpc_cleanall
+
+info: fpc_info
+
+.PHONY:  all debug examples test smart shared showinstall install sourceinstall zipinstall zipinstalladd clean cleanall info
+
+
+ifdef PACKAGERTL
+ifneq ($(wildcard $(PACKAGEDIR_RTL)),)
+ifeq ($(wildcard $(PACKAGEDIR_RTL)/$(FPCMADE)),)
+override COMPILEPACKAGES+=rtl
+rtl_package:
+	$(MAKE) -C $(PACKAGEDIR_RTL) all
+endif
+endif
+endif
+
+.PHONY:  rtl_package
+
+#####################################################################
+# Units
+#####################################################################
+
+.PHONY: fpc_units
+
+override ALLTARGET+=fpc_units
+
+override UNITPPUFILES=$(addsuffix $(PPUEXT),$(UNITOBJECTS))
+override INSTALLPPUFILES+=$(UNITPPUFILES)
+override CLEANPPUFILES+=$(UNITPPUFILES)
+
+fpc_units: $(UNITPPUFILES)
+
+#####################################################################
+# Examples
+#####################################################################
+
+.PHONY: fpc_examples fpc_test
+
+override EXAMPLEFILES:=$(addsuffix $(EXEEXT),$(EXAMPLEOBJECTS))
+override EXAMPLEOFILES:=$(addsuffix $(OEXT),$(EXAMPLEOBJECTS))
+
+override CLEANEXEFILES+=$(EXAMPLEFILES) $(EXAMPLEOFILES)
+
+fpc_examples: all $(EXAMPLEFILES)
+
+fpc_test: examples
+
+#####################################################################
+# General compile rules
+#####################################################################
+
+.PHONY: fpc_all fpc_debug
+
+$(FPCMADE):
+	@$(ECHO) Compiled > $(FPCMADE)
+
+fpc_all: $(addsuffix _package,$(COMPILEPACKAGES)) \
+	 $(addsuffix _component,$(COMPILECOMPONENTS)) \
+	 $(ALLTARGET) $(FPCMADE)
+
+fpc_debug:
+	$(MAKE) all DEBUG=1
+
+# General compile rules, available for both possible PASEXT
+
+.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp
+
+%$(PPUEXT): %.pp
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(PPUEXT): %.pas
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(EXEEXT): %.pp
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(EXEEXT): %.pas
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+#####################################################################
+# Library
+#####################################################################
+
+.PHONY: fpc_smart fpc_shared
+
+# Default sharedlib units are all unit objects
+ifndef SHAREDLIBUNITOBJECTS
+SHAREDLIBUNITOBJECTS:=$(UNITOBJECTS)
+endif
+
+fpc_smart:
+	$(MAKE) all SMARTLINK=1
+
+fpc_shared: all
+ifdef inlinux
+ifndef LIBNAME
+	@$(ECHO) "LIBNAME not set"
+else
+	$(PPUMOVE) $(SHAREDLIBUNITOBJECTS) -o$(LIBNAME)
+endif
+else
+	@$(ECHO) "Shared Libraries not supported"
+endif
+
+#####################################################################
+# Install rules
+#####################################################################
+
+.PHONY: fpc_showinstall fpc_install
+
+ifdef EXTRAINSTALLUNITS
+override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRAINSTALLUNITS))
+endif
+
+ifdef INSTALLPPUFILES
+ifdef PPUFILES
+ifdef inlinux
+INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
+INSTALLPPULIBFILES:=$(shell $(PPUFILES) -L $(INSTALLPPUFILES))
+else
+INSTALLPPULINKFILES:=$(shell $(PPUFILES) $(INSTALLPPUFILES))
+endif
+else
+INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
+endif
+endif
+
+fpc_showinstall: $(SHOWINSTALLTARGET)
+ifdef INSTALLEXEFILES
+	@$(ECHO) -e $(addprefix "\n"$(BININSTALLDIR)/,$(INSTALLEXEFILES))
+endif
+ifdef INSTALLPPUFILES
+	@$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPUFILES))
+ifneq ($(INSTALLPPULINKFILES),)
+	@$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPULINKFILES))
+endif
+ifneq ($(INSTALLPPULIBFILES),)
+	@$(ECHO) -e $(addprefix "\n"$(LIBINSTALLDIR)/,$(INSTALLPPULIBFILES))
+endif
+endif
+ifdef EXTRAINSTALLFILES
+	@$(ECHO) -e $(addprefix "\n"$(DATAINSTALLDIR)/,$(EXTRAINSTALLFILES))
+endif
+
+fpc_install: $(INSTALLTARGET)
+# Create UnitInstallFiles
+ifdef INSTALLEXEFILES
+	$(MKDIR) $(BININSTALLDIR)
+# Compress the exes if upx is defined
+ifdef UPXPROG
+	-$(UPXPROG) $(INSTALLEXEFILES)
+endif
+	$(INSTALLEXE) $(INSTALLEXEFILES) $(BININSTALLDIR)
+endif
+ifdef INSTALLPPUFILES
+	$(MKDIR) $(UNITINSTALLDIR)
+	$(INSTALL) $(INSTALLPPUFILES) $(UNITINSTALLDIR)
+ifneq ($(INSTALLPPULINKFILES),)
+	$(INSTALL) $(INSTALLPPULINKFILES) $(UNITINSTALLDIR)
+endif
+ifneq ($(INSTALLPPULIBFILES),)
+	$(MKDIR) $(LIBINSTALLDIR)
+	$(INSTALL) $(INSTALLPPULIBFILES) $(LIBINSTALLDIR)
+endif
+endif
+ifdef EXTRAINSTALLFILES
+	$(MKDIR) $(DATAINSTALLDIR)
+	$(INSTALL) $(EXTRAINSTALLFILES) $(DATAINSTALLDIR)
+endif
+
+#####################################################################
+# Source install rules
+#####################################################################
+
+.PHONY: fpc_sourceinstall
+
+fpc_sourceinstall: clean
+	$(MKDIR) $(SOURCEINSTALLDIR)
+	$(COPYTREE) $(BASEDIR) $(SOURCEINSTALLDIR)
+
+#####################################################################
+# Zip
+#####################################################################
+
+.PHONY: fpc_zipinstall fpc_zipinstalladd
+
+# Temporary path to pack a file
+ifndef PACKDIR
+ifndef inlinux
+PACKDIR=pack_tmp
+else
+PACKDIR=/tmp/fpc-pack
+endif
+endif
+
+# Test dir if none specified
+ifndef DESTZIPDIR
+DESTZIPDIR:=$(BASEDIR)
+endif
+
+# Add .zip/.tar.gz extension
+ifdef ZIPNAME
+ifndef inlinux
+override ZIPNAME:=$(ZIPNAME)$(ZIPEXT)
+endif
+endif
+
+# Note: This will not remove the zipfile first
+fpc_zipinstalladd:
+ifndef ZIPNAME
+	@$(ECHO) "Please specify ZIPNAME!"
+	@exit 1
+else
+	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
+ifdef inlinux
+	gzip -d $(DESTZIPDIR)/$(ZIPNAME).tar.gz
+	cd $(PACKDIR) ; tar rv --file $(DESTZIPDIR)/$(ZIPNAME).tar * ; cd $(BASEDIR)
+	gzip $(DESTZIPDIR)/$(ZIPNAME).tar
+else
+	cd $(PACKDIR) ; $(ZIPPROG) $(DESTZIPDIR)/$(ZIPNAME) * ; cd $(BASEDIR)
+endif
+	$(DELTREE) $(PACKDIR)
+endif
+
+# First remove the zip and then install
+fpc_zipinstall:
+ifndef ZIPNAME
+	@$(ECHO) "Please specify ZIPNAME!"
+	@exit 1
+else
+	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)
+	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
+ifdef inlinux
+	cd $(PACKDIR) ; tar cvz --file $(DESTZIPDIR)/$(ZIPNAME).tar.gz * ; cd $(BASEDIR)
+else
+	cd $(PACKDIR) ; $(ZIPPROG) $(DESTZIPDIR)/$(ZIPNAME) * ; cd $(BASEDIR)
+endif
+	$(DELTREE) $(PACKDIR)
+endif
+
+#####################################################################
+# Clean rules
+#####################################################################
+
+.PHONY: fpc_clean fpc_cleanall
+
+ifdef EXTRACLEANUNITS
+override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRACLEANUNITS))
+endif
+
+ifdef CLEANPPUFILES
+ifdef PPUFILES
+CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
+else
+CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
+endif
+endif
+
+fpc_clean: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+ifdef CLEANPPUFILES
+	-$(DEL) $(CLEANPPUFILES)
+endif
+ifneq ($(CLEANPPULINKFILES),)
+	-$(DEL) $(CLEANPPULINKFILES)
+endif
+ifdef CLEANRSTFILES
+	-$(DEL) $(CLEANRSTFILES)
+endif
+ifdef EXTRACLEANFILES
+	-$(DEL) $(EXTRACLEANFILES)
+endif
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(REDIRFILE)
+
+fpc_cleanall: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+	-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+	-$(DELTREE) *$(SMARTEXT)
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(REDIRFILE)
+
+#####################################################################
+# Info rules
+#####################################################################
+
+.PHONY: fpc_info fpc_cfginfo fpc_objectinfo fpc_toolsinfo fpc_installinfo \
+	fpc_dirinfo
+
+fpc_info: $(INFOTARGET)
+
+fpc_infocfg:
+	@$(ECHO)
+	@$(ECHO)  == Configuration info ==
+	@$(ECHO)
+	@$(ECHO)  FPC....... $(FPC)
+	@$(ECHO)  Version... $(FPC_VERSION)
+	@$(ECHO)  CPU....... $(CPU_TARGET)
+	@$(ECHO)  Source.... $(OS_SOURCE)
+	@$(ECHO)  Target.... $(OS_TARGET)
+	@$(ECHO)
+
+fpc_infoobjects:
+	@$(ECHO)
+	@$(ECHO)  == Object info ==
+	@$(ECHO)
+	@$(ECHO)  LoaderObjects..... $(LOADEROBJECTS)
+	@$(ECHO)  UnitObjects....... $(UNITOBJECTS)
+	@$(ECHO)  ExeObjects........ $(EXEOBJECTS)
+	@$(ECHO)
+	@$(ECHO)  ExtraCleanUnits... $(EXTRACLEANUNITS)
+	@$(ECHO)  ExtraCleanFiles... $(EXTRACLEANFILES)
+	@$(ECHO)
+	@$(ECHO)  ExtraInstallUnits. $(EXTRAINSTALLUNITS)
+	@$(ECHO)  ExtraInstallFiles. $(EXTRAINSTALLFILES)
+	@$(ECHO)
+
+fpc_infoinstall:
+	@$(ECHO)
+	@$(ECHO)  == Install info ==
+	@$(ECHO)
+ifdef DATE
+	@$(ECHO)  DateStr.............. $(DATESTR)
+endif
+	@$(ECHO)  PackageSuffix........ $(PACKAGESUFFIX)
+	@$(ECHO)
+	@$(ECHO)  BaseInstallDir....... $(BASEINSTALLDIR)
+	@$(ECHO)  BinInstallDir........ $(BININSTALLDIR)
+	@$(ECHO)  LibInstallDir........ $(LIBINSTALLDIR)
+	@$(ECHO)  UnitInstallDir....... $(UNITINSTALLDIR)
+	@$(ECHO)  SourceInstallDir..... $(SOURCEINSTALLDIR)
+	@$(ECHO)  DocInstallDir........ $(DOCINSTALLDIR)
+	@$(ECHO)  DataInstallDir....... $(DATAINSTALLDIR)
+	@$(ECHO)
+
+#####################################################################
+# Users rules
+#####################################################################
+
+video$(PPUEXT): $(INC)/video.pas video.inc event$(PPUEXT)
+
+keyboard$(PPUEXT): $(INC)/keyboard.pas keyboard.inc event$(PPUEXT)
+
+mouse$(PPUEXT): $(INC)/mouse.pas mouse.inc event$(PPUEXT)
+
+filectrl$(PPUEXT): $(INC)/filectrl.pas filectrl.inc
+
+event$(PPUEXT): event.pas

api/win32/Makefile.fpc

@@ -0,0 +1,43 @@
+#
+#   Makefile.fpc for Free Pascal API (used by Free Vision) for win32
+#
+
+[defaults]
+defaulttarget=win32
+
+[targets]
+units=event $(APIOBJECTS)
+examples=$(TESTOBJECTS)
+
+[install]
+unitsubdir=api
+
+[libs]
+libname=fpapi
+
+[dirs]
+fpcdir=../..
+targetdir=.
+sourcesdir=$(INC)
+
+
+[presettings]
+INC=../inc
+
+# Override defaults
+override PASEXT=.pas
+
+include ../test/Makefile.api
+include $(INC)/Makefile.api
+
+
+[rules]
+video$(PPUEXT): $(INC)/video.pas video.inc event$(PPUEXT)
+
+keyboard$(PPUEXT): $(INC)/keyboard.pas keyboard.inc event$(PPUEXT)
+
+mouse$(PPUEXT): $(INC)/mouse.pas mouse.inc event$(PPUEXT)
+
+filectrl$(PPUEXT): $(INC)/filectrl.pas filectrl.inc
+
+event$(PPUEXT): event.pas

api/win32/event.pas

@@ -0,0 +1,351 @@
+{
+   $Id$
+   Event handling for the Win32 version of the FPC API
+
+   Copyright (c) 1999 by Florian Klaempfl
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+}
+
+unit Event;
+{
+   We need this unit to implement keyboard and mouse,
+   because win32 uses only one message queue for mouse and key events
+}
+  interface
+
+    type
+       TEventProcedure = Procedure;
+
+    { these procedures must be used to set the event handlers }
+    { these doesn't do something, they signal only the        }
+    { the upper layer that an event occured, this event       }
+    { must be handled with Win32-API function by the upper    }
+    { layer                                                   }
+    Procedure SetMouseEventHandler(p : TEventProcedure);
+    Procedure SetKeyboardEventHandler(p : TEventProcedure);
+    Procedure SetFocusEventHandler(p : TEventProcedure);
+    Procedure SetMenuEventHandler(p : TEventProcedure);
+    Procedure SetResizeEventHandler(p : TEventProcedure);
+    Procedure SetUnknownEventHandler(p : TEventProcedure);
+
+    { these procedures must be used to get the event handlers }
+    Function GetMouseEventHandler : TEventProcedure;
+    Function GetKeyboardEventHandler : TEventProcedure;
+    Function GetFocusEventHandler : TEventProcedure;
+    Function GetMenuEventHandler : TEventProcedure;
+    Function GetResizeEventHandler : TEventProcedure;
+    Function GetUnknownEventHandler : TEventProcedure;
+
+  implementation
+
+    uses
+       windows, dos;
+
+    const
+       { these procedures are called if an event occurs }
+       MouseEventHandler : procedure = nil;
+       KeyboardEventHandler : procedure = nil;
+       FocusEventHandler : procedure = nil;
+       MenuEventHandler : procedure = nil;
+       ResizeEventHandler : procedure = nil;
+       UnknownEventHandler  : procedure = nil;
+
+       { if this counter is zero, the event handler thread is killed }
+       InstalledHandlers : Byte = 0;
+
+    var
+       HandlerChanging : TCriticalSection;
+       OldExitProc : Pointer;
+       EventThreadHandle : Handle;
+       EventThreadID : DWord;
+
+       { true, if the event handler should be stoped }
+       ExitEventHandleThread : boolean;
+
+    Function GetMouseEventHandler : TEventProcedure;
+      begin
+         GetMouseEventHandler:=MouseEventHandler;
+      end;
+
+
+    Function GetKeyboardEventHandler : TEventProcedure;
+      begin
+         GetKeyboardEventHandler:=KeyboardEventHandler;
+      end;
+
+
+    Function GetFocusEventHandler : TEventProcedure;
+      begin
+         GetFocusEventHandler:=FocusEventHandler;
+      end;
+
+
+    Function GetMenuEventHandler : TEventProcedure;
+      begin
+         GetMenuEventHandler:=MenuEventHandler;
+      end;
+
+
+    Function GetResizeEventHandler : TEventProcedure;
+      begin
+         GetResizeEventHandler:=ResizeEventHandler;
+      end;
+
+
+    Function GetUnknownEventHandler : TEventProcedure;
+      begin
+         GetUnknownEventHandler:=UnknownEventHandler;
+      end;
+
+    { removes an event from the event queue }
+    { necessary, if no handler is installed }
+    Procedure DestroyOneEvent;
+      var
+         ir : TInputRecord;
+         dwRead : DWord;
+      begin
+         ReadConsoleInput(TextRec(Input).Handle,ir,1,dwRead);
+      end;
+
+    Function EventHandleThread(p : pointer) : DWord;StdCall;
+      var
+         ir : TInputRecord;
+         dwRead : DWord;
+      begin
+         while not(ExitEventHandleThread) do
+           begin
+              { wait for an event }
+              WaitForSingleObject(TextRec(Input).Handle,INFINITE);
+              { guard this code, else it is doomed to crash, if the
+                thread is switched between the assigned test and
+                the call and the handler is removed
+              }
+              if not(ExitEventHandleThread) then
+                begin
+                   EnterCriticalSection(HandlerChanging);
+                   { read, but don't remove the event }
+                   if (PeekConsoleInput(TextRec(Input).Handle,ir,1,dwRead)) and
+                     (dwRead>0) then
+                     { call the handler }
+                     case ir.EventType of
+                        KEY_EVENT:
+                          begin
+                             if assigned(KeyboardEventHandler) then
+                               KeyboardEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+
+                        _MOUSE_EVENT:
+                          begin
+                             if assigned(MouseEventHandler) then
+                               MouseEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+
+                        WINDOW_BUFFER_SIZE_EVENT:
+                          begin
+                             if assigned(ResizeEventHandler) then
+                               ResizeEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+
+                        MENU_EVENT:
+                          begin
+                             if assigned(MenuEventHandler) then
+                               MenuEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+
+                        FOCUS_EVENT:
+                          begin
+                             if assigned(FocusEventHandler) then
+                               FocusEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+
+                        else
+                          begin
+                             if assigned(UnknownEventHandler) then
+                               UnknownEventHandler
+                             else
+                               DestroyOneEvent;
+                          end;
+                     end;
+                   LeaveCriticalSection(HandlerChanging);
+                end;
+           end;
+      end;
+
+    Procedure NewEventHandlerInstalled(p,oldp : TEventProcedure);
+      var
+         oldcount : Byte;
+         ir : TInputRecord;
+         written : DWord;
+      begin
+         oldcount:=InstalledHandlers;
+         if Pointer(oldp)<>nil then
+           dec(InstalledHandlers);
+         if Pointer(p)<>nil then
+           inc(InstalledHandlers);
+         { start event handler thread }
+         if (oldcount=0) and (InstalledHandlers=1) then
+           begin
+              ExitEventHandleThread:=false;
+              EventThreadHandle:=CreateThread(nil,0,@EventHandleThread,
+                nil,0,EventThreadID);
+           end
+         { stop and destroy event handler thread }
+         else if (oldcount=1) and (InstalledHandlers=0) then
+           begin
+              ExitEventHandleThread:=true;
+              { create a dummy event and sent it to the thread, so
+                we can leave WatiForSingleObject }
+              ir.EventType:=KEY_EVENT;
+              { mouse event can be disabled by mouse.inc code
+                in DoneMouse
+                so use a key event instead PM }
+              WriteConsoleInput(TextRec(Input).Handle,ir,1,written);
+              { wait, til the thread is ready }
+              WaitForSingleObject(EventThreadHandle,INFINITE);
+              CloseHandle(EventThreadHandle);
+           end;
+      end;
+
+
+    Procedure SetMouseEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=MouseEventHandler;
+         MouseEventHandler:=p;
+         NewEventHandlerInstalled(MouseEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure SetKeyboardEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=KeyboardEventHandler;
+         KeyboardEventHandler:=p;
+         NewEventHandlerInstalled(KeyboardEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure SetFocusEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=FocusEventHandler;
+         FocusEventHandler:=p;
+         NewEventHandlerInstalled(FocusEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure SetMenuEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=MenuEventHandler;
+         MenuEventHandler:=p;
+         NewEventHandlerInstalled(MenuEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure SetResizeEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=ResizeEventHandler;
+         ResizeEventHandler:=p;
+         NewEventHandlerInstalled(ResizeEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure SetUnknownEventHandler(p : TEventProcedure);
+      var
+         oldp : TEventProcedure;
+      begin
+         EnterCriticalSection(HandlerChanging);
+         oldp:=UnknownEventHandler;
+         UnknownEventHandler:=p;
+         NewEventHandlerInstalled(UnknownEventHandler,oldp);
+         LeaveCriticalSection(HandlerChanging);
+      end;
+
+
+    Procedure DoExit;
+      begin
+         { Uninstall all handlers                   }
+         { this stops also the event handler thread }
+         SetMouseEventHandler(nil);
+         SetKeyboardEventHandler(nil);
+         SetFocusEventHandler(nil);
+         SetMenuEventHandler(nil);
+         SetResizeEventHandler(nil);
+         SetUnknownEventHandler(nil);
+         { delete the critical section object }
+         DeleteCriticalSection(HandlerChanging);
+         ExitProc:=OldExitProc;
+      end;
+
+begin
+   InitializeCriticalSection(HandlerChanging);
+   OldExitProc:=ExitProc;
+   ExitProc:=@DoExit;
+end.
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.5  1999/09/22 12:55:18  pierre
+   * use KEY_EVENT for Closing Handle Thread
+
+  Revision 1.4  1999/07/17 17:21:35  florian
+    * fixed the win32 keyboard event handling
+
+  Revision 1.3  1999/07/14 08:45:15  florian
+    * commited a new keyboard by Armin Diehl
+    * fixed event handling, mainly the prototype of eventhandlethread was wrong
+
+  Revision 1.2  1999/06/21 16:43:51  peter
+    * win32 updates from Maarten Bekkers
+
+  Revision 1.1  1999/01/08 14:37:03  florian
+    + initial version, not working yet
+
+}

api/win32/filectrl.inc

@@ -0,0 +1,180 @@
+{
+   $Id$
+   System independent low-level file interface for Win32
+
+   Copyright (c) 1999 by Florian Klaempfl
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+}
+
+uses
+  Windows;
+
+function OpenFileStr(FName: PChar; Flags: Longint): TFileHandle;
+begin
+  SetLastError(0);
+
+  OpenFileStr :=
+    Windows.CreateFile(FName,
+               GENERIC_READ OR GENERIC_WRITE,
+               FILE_SHARE_READ OR FILE_SHARE_WRITE,
+               nil,
+               OPEN_EXISTING,
+               FILE_ATTRIBUTE_NORMAL,
+               0);
+
+  ErrorCode := GetLastError;
+end; { func. OpenFileStr }
+
+
+function CreateFileStr(FName: PChar): TFileHandle;
+begin
+  SetLastError(0);
+
+  CreateFileStr :=
+    Windows.CreateFile(FName,
+               GENERIC_READ OR GENERIC_WRITE,
+               FILE_SHARE_READ OR FILE_SHARE_WRITE,
+               nil,
+               CREATE_ALWAYS,
+               FILE_ATTRIBUTE_NORMAL,
+               0);
+
+  ErrorCode := GetLastError;
+end;
+
+
+procedure DeleteFileStr(FName: PChar);
+begin
+   ErrorCode:=0;
+
+  if NOT Windows.DeleteFile(FName) then
+     ErrorCode:=GetLastError;
+end;
+
+
+procedure CloseFile(Handle: TFileHandle);
+
+begin
+   ErrorCode:=0;
+   if NOT CloseHandle(Handle) then
+     ErrorCode:=GetLastError;
+end;
+
+
+function SeekFile(Handle: TFileHandle; Pos: TFileInt; SeekType: Word): TFileInt;
+var tmp: longint;
+begin
+   ErrorCode:=0;
+   Tmp := SetFilePointer(Handle, Pos, nil, SeekType);
+
+   if tmp =$ffffffff then
+     begin
+       ErrorCode:=GetLastError;
+       SeekFile := 0
+     end
+       else SeekFile := tmp;
+end;
+
+
+function ReadFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord;
+var
+  Result : CPUWord;
+begin
+  ErrorCode:=0;
+  if Windows.ReadFile(Handle, @Buff, Count, Result, nil) then
+    ErrorCode:=GetLastError;
+  ReadFile:=result;
+end;
+
+
+function WriteFile(Handle: TFileHandle; var Buff; Count: CPUWord): CPUWord;
+var
+   Written : CPUWord;
+   Size: Longint;
+begin
+  ErrorCode:=0;
+  if Windows.WriteFile(Handle, @Buff, Count, Size, nil) then
+    ErrorCode:=GetLastError;
+  WriteFile:=Written;
+end;
+
+
+procedure FlushFile(Handle: TFileHandle);
+begin
+  ErrorCode:=0;
+  if FlushFileBuffers(Handle) then
+    ErrorCode:=GetLastError;
+end;
+
+
+procedure TruncateFile(Handle: TFileHandle);
+begin
+  ErrorCode:=0;
+  SeekFile(Handle, 0, skEnd);
+  if not(SetEndOfFile(Handle)) then
+    ErrorCode:=GetLastError;
+end;
+
+
+function EndOfFile(Handle: TFileHandle): Boolean;
+begin
+  ErrorCode:=0;
+  EndOfFile := FilePos(Handle) >= FileSize(Handle);
+end;
+
+
+function FilePos(Handle: TFileHandle): TFileInt;
+var
+  l : TFileInt;
+begin
+  ErrorCode:=0;
+  l:=SetFilePointer(Handle, 0, nil, FILE_CURRENT);
+  if l=-1 then
+    begin
+       l:=0;
+       ErrorCode:=GetLastError;
+    end;
+  FilePos:=l;
+end;
+
+
+function FileSize(Handle: TFileHandle): TFileInt;
+var
+  aktfilepos : TFileInt;
+begin
+  SetLastError(0);
+
+  AktFilePos := FilePos(Handle);
+  FileSize := SeekFile(Handle, 0, skEnd);
+  SeekFile(Handle, aktfilepos, skBeg);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.2  1999/06/21 16:43:52  peter
+    * win32 updates from Maarten Bekkers
+
+  Revision 1.1  1999/01/08 14:37:03  florian
+    + initial version, not working yet
+
+}

api/win32/keyboard.inc

@@ -0,0 +1,828 @@
+{
+   $Id$
+   System independent keyboard interface for windows
+
+   Copyright (c) 1999 by Florian Klaempfl
+   Member of the Free Pascal development team
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************}
+
+{ WARNING: Keyboard-Drivers (i.e. german) will only work under WinNT.
+           95 and 98 do not support keyboard-drivers other than us for win32
+           console-apps. So we always get the keys in us-keyboard layout
+           from Win9x.
+}
+
+uses
+{$ifndef DEBUG}
+   Windows,
+{$endif DEBUG}
+   Dos,
+   Event;
+
+const MaxQueueSize = 120;
+      FrenchKeyboard = $040C040C;
+      KeyboardActive : boolean =false;
+var
+   keyboardeventqueue : array[0..maxqueuesize] of TKeyEventRecord;
+   nextkeyevent,nextfreekeyevent : longint;
+   newKeyEvent    : THandle;            {sinaled if key is available}
+   lockVar        : TCriticalSection;   {for queue access}
+   lastShiftState : byte;               {set by handler for PollShiftStateEvent}
+   altNumActive   : boolean;            {for alt+0..9}
+   altNumBuffer   : string [3];
+   { used for keyboard specific stuff }
+   KeyBoardLayout : HKL;
+
+procedure incqueueindex(var l : longint);
+
+  begin
+     inc(l);
+     { wrap around? }
+     if l>maxqueuesize then
+       l:=0;
+  end;
+
+function keyEventsInQueue : boolean;
+begin
+  keyEventsInQueue := (nextkeyevent <> nextfreekeyevent);
+end;
+
+
+{ gets or peeks the next key from the queue, does not wait for new keys }
+function getKeyEventFromQueue (VAR t : TKeyEventRecord; Peek : boolean) : boolean;
+begin
+  EnterCriticalSection (lockVar);
+  if keyEventsInQueue then
+  begin
+    t := keyboardeventqueue[nextkeyevent];
+    if not peek then incqueueindex (nextkeyevent);
+    getKeyEventFromQueue := true;
+    if not keyEventsInQueue then ResetEvent (newKeyEvent);
+  end else
+  begin
+    getKeyEventFromQueue := false;
+    ResetEvent (newKeyEvent);
+  end;
+  LeaveCriticalSection (lockVar);
+end;
+
+
+{ gets the next key from the queue, does wait for new keys }
+function getKeyEventFromQueueWait (VAR t : TKeyEventRecord) : boolean;
+begin
+  WaitForSingleObject (newKeyEvent, INFINITE);
+  getKeyEventFromQueueWait := getKeyEventFromQueue (t, false);
+end;
+
+{ translate win32 shift-state to keyboard shift state }
+function transShiftState (ControlKeyState : dword) : byte;
+var b : byte;
+begin
+  b := 0;
+  if ControlKeyState and SHIFT_PRESSED <> 0 then  { win32 makes no difference between left and right shift }
+    b := b or kbShift;
+  if (ControlKeyState and LEFT_CTRL_PRESSED <> 0) or
+     (ControlKeyState  and RIGHT_CTRL_PRESSED <> 0) then
+    b := b or kbCtrl;
+  if (ControlKeyState and LEFT_ALT_PRESSED <> 0) or
+     (ControlKeyState and RIGHT_ALT_PRESSED <> 0) then
+    b := b or kbAlt;
+  transShiftState := b;
+end;
+
+{ The event-Handler thread from the unit event will call us if a key-event
+  is available }
+
+procedure HandleKeyboard;
+var
+   ir     : INPUT_RECORD;
+   dwRead : DWord;
+   i      : longint;
+   c      : word;
+   addThis: boolean;
+begin
+   dwRead:=1;
+   ReadConsoleInput(TextRec(Input).Handle,ir,1,dwRead);
+   if (dwRead=1) and (ir.EventType=KEY_EVENT) then
+     begin
+         with ir.KeyEvent do
+           begin
+              { key up events are ignored (except alt) }
+              if bKeyDown then
+                begin
+                   EnterCriticalSection (lockVar);
+                   for i:=1 to wRepeatCount do
+                     begin
+                        addThis := true;
+                        if (dwControlKeyState and LEFT_ALT_PRESSED <> 0) or
+                           (dwControlKeyState and RIGHT_ALT_PRESSED <> 0) then            {alt pressed}
+                          if (wVirtualKeyCode >= $60) and (wVirtualKeyCode <= $69) then   {0..9 on NumBlock}
+                          begin
+                            if length (altNumBuffer) = 3 then
+                              delete (altNumBuffer,1,1);
+                            altNumBuffer := altNumBuffer + char (wVirtualKeyCode-48);
+                            altNumActive   := true;
+                            addThis := false;
+                          end else
+                          begin
+                            altNumActive   := false;
+                            altNumBuffer   := '';
+                          end;
+                        if addThis then
+                        begin
+                          keyboardeventqueue[nextfreekeyevent]:=
+                            ir.KeyEvent;
+                          incqueueindex(nextfreekeyevent);
+                        end;
+                     end;
+
+                   lastShiftState := transShiftState (dwControlKeyState);  {save it for PollShiftStateEvent}
+                   SetEvent (newKeyEvent);             {event that a new key is available}
+                   LeaveCriticalSection (lockVar);
+                end else
+                begin
+                  lastShiftState := transShiftState (dwControlKeyState);   {save it for PollShiftStateEvent}
+                  {for alt-number we have to look for alt-key release}
+                  if altNumActive then
+                    if (wVirtualKeyCode = $12) then    {alt-released}
+                    begin
+                      if altNumBuffer <> '' then       {numbers with alt pressed?}
+                      begin
+                        Val (altNumBuffer, c, i);
+                        if (i = 0) and (c <= 255) then {valid number?}
+                        begin                          {add to queue}
+                          fillchar (ir, sizeof (ir), 0);
+                          bKeyDown := true;
+                          AsciiChar := char (c);
+                                                       {and add to queue}
+                          EnterCriticalSection (lockVar);
+                          keyboardeventqueue[nextfreekeyevent]:=
+                            ir.KeyEvent;
+                          incqueueindex(nextfreekeyevent);
+                          SetEvent (newKeyEvent);      {event that a new key is available}
+                          LeaveCriticalSection (lockVar);
+                        end;
+                      end;
+                      altNumActive   := false;         {clear alt-buffer}
+                      altNumBuffer   := '';
+                    end;
+                end;
+           end;
+     end;
+end;
+
+procedure InitKeyboard;
+begin
+   if KeyboardActive then
+     exit;
+   KeyBoardLayout:=GetKeyboardLayout(0);
+   lastShiftState := 0;
+   newKeyEvent := CreateEvent (nil,        // address of security attributes
+                               true,       // flag for manual-reset event
+                               false,      // flag for initial state
+                               nil);       // address of event-object name
+   if newKeyEvent = INVALID_HANDLE_VALUE then
+   begin
+     // what to do here ????
+     RunError (217);
+   end;
+   InitializeCriticalSection (lockVar);
+   altNumActive := false;
+   altNumBuffer := '';
+
+   nextkeyevent:=0;
+   nextfreekeyevent:=0;
+   SetKeyboardEventHandler (@HandleKeyboard);
+   KeyboardActive:=true;
+end;
+
+procedure DoneKeyboard;
+begin
+   if not KeyboardActive then
+     exit;
+   SetKeyboardEventHandler(nil);     {hangs???}
+   DeleteCriticalSection (lockVar);
+   closeHandle (newKeyEvent);
+   KeyboardActive:=false;
+end;
+
+{$define USEKEYCODES}
+
+{Translatetable Win32 -> Dos for Special Keys = Function Key, Cursor Keys
+ and Keys other than numbers on numblock (to make fv happy) }
+{combinations under dos: Shift+Ctrl: same as Ctrl
+                         Shift+Alt : same as alt
+                         Ctrl+Alt  : nothing (here we get it like alt)}
+{$ifdef USEKEYCODES}
+   { use positive values for ScanCode we want to set
+   0 for key where we should leave the scancode
+   -1 for OEM specifc keys
+   -2 for unassigned
+   -3 for Kanji systems ???
+   }
+const
+  Unassigned = -2;
+  Kanji = -3;
+  OEM_specific = -1;
+  KeyToQwertyScan : array [0..255] of integer =
+  (
+  { 00 } 0,
+  { 01 VK_LBUTTON } 0,
+  { 02 VK_RBUTTON } 0,
+  { 03 VK_CANCEL } 0,
+  { 04 VK_MBUTTON } 0,
+  { 05 unassigned } -2,
+  { 06 unassigned } -2,
+  { 07 unassigned } -2,
+  { 08 VK_BACK } $E,
+  { 09 VK_TAB } $F,
+  { 0A unassigned } -2,
+  { 0B unassigned } -2,
+  { 0C VK_CLEAR ?? } 0,
+  { 0D VK_RETURN } 0,
+  { 0E unassigned } -2,
+  { 0F unassigned } -2,
+  { 10 VK_SHIFT } 0,
+  { 11 VK_CONTROL } 0,
+  { 12 VK_MENU (Alt key) } 0,
+  { 13 VK_PAUSE } 0,
+  { 14 VK_CAPITAL (Caps Lock) } 0,
+  { 15 Reserved for Kanji systems} -3,
+  { 16 Reserved for Kanji systems} -3,
+  { 17 Reserved for Kanji systems} -3,
+  { 18 Reserved for Kanji systems} -3,
+  { 19 Reserved for Kanji systems} -3,
+  { 1A unassigned } -2,
+  { 1B VK_ESCAPE } $1,
+  { 1C Reserved for Kanji systems} -3,
+  { 1D Reserved for Kanji systems} -3,
+  { 1E Reserved for Kanji systems} -3,
+  { 1F Reserved for Kanji systems} -3,
+  { 20 VK_SPACE} 0,
+  { 21 VK_PRIOR (PgUp) } 0,
+  { 22 VK_NEXT (PgDown) } 0,
+  { 23 VK_END } 0,
+  { 24 VK_HOME } 0,
+  { 25 VK_LEFT } 0,
+  { 26 VK_UP } 0,
+  { 27 VK_RIGHT } 0,
+  { 28 VK_DOWN } 0,
+  { 29 VK_SELECT ??? } 0,
+  { 2A OEM specific !! } -1,
+  { 2B VK_EXECUTE } 0,
+  { 2C VK_SNAPSHOT } 0,
+  { 2D VK_INSERT } 0,
+  { 2E VK_DELETE } 0,
+  { 2F VK_HELP } 0,
+  { 30 VK_0 '0' } 11,
+  { 31 VK_1 '1' } 2,
+  { 32 VK_2 '2' } 3,
+  { 33 VK_3 '3' } 4,
+  { 34 VK_4 '4' } 5,
+  { 35 VK_5 '5' } 6,
+  { 36 VK_6 '6' } 7,
+  { 37 VK_7 '7' } 8,
+  { 38 VK_8 '8' } 9,
+  { 39 VK_9 '9' } 10,
+  { 3A unassigned } -2,
+  { 3B unassigned } -2,
+  { 3C unassigned } -2,
+  { 3D unassigned } -2,
+  { 3E unassigned } -2,
+  { 3F unassigned } -2,
+  { 40 unassigned } -2,
+  { 41 VK_A 'A' } $1E,
+  { 42 VK_B 'B' } $30,
+  { 43 VK_C 'C' } $2E,
+  { 44 VK_D 'D' } $20,
+  { 45 VK_E 'E' } $12,
+  { 46 VK_F 'F' } $21,
+  { 47 VK_G 'G' } $22,
+  { 48 VK_H 'H' } $23,
+  { 49 VK_I 'I' } $17,
+  { 4A VK_J 'J' } $24,
+  { 4B VK_K 'K' } $25,
+  { 4C VK_L 'L' } $26,
+  { 4D VK_M 'M' } $32,
+  { 4E VK_N 'N' } $31,
+  { 4F VK_O 'O' } $18,
+  { 50 VK_P 'P' } $19,
+  { 51 VK_Q 'Q' } $10,
+  { 52 VK_R 'R' } $13,
+  { 53 VK_S 'S' } $1F,
+  { 54 VK_T 'T' } $14,
+  { 55 VK_U 'U' } $16,
+  { 56 VK_V 'V' } $2F,
+  { 57 VK_W 'W' } $11,
+  { 58 VK_X 'X' } $2D,
+  { 59 VK_Y 'Y' } $15,
+  { 5A VK_Z 'Z' } $2C,
+  { 5B unassigned } -2,
+  { 5C unassigned } -2,
+  { 5D unassigned } -2,
+  { 5E unassigned } -2,
+  { 5F unassigned } -2,
+  { 60 VK_NUMPAD0 NumKeyPad '0' } 11,
+  { 61 VK_NUMPAD1 NumKeyPad '1' } 2,
+  { 62 VK_NUMPAD2 NumKeyPad '2' } 3,
+  { 63 VK_NUMPAD3 NumKeyPad '3' } 4,
+  { 64 VK_NUMPAD4 NumKeyPad '4' } 5,
+  { 65 VK_NUMPAD5 NumKeyPad '5' } 6,
+  { 66 VK_NUMPAD6 NumKeyPad '6' } 7,
+  { 67 VK_NUMPAD7 NumKeyPad '7' } 8,
+  { 68 VK_NUMPAD8 NumKeyPad '8' } 9,
+  { 69 VK_NUMPAD9 NumKeyPad '9' } 10,
+  { 6A VK_MULTIPLY } 0,
+  { 6B VK_ADD } 0,
+  { 6C VK_SEPARATOR } 0,
+  { 6D VK_SUBSTRACT } 0,
+  { 6E VK_DECIMAL } 0,
+  { 6F VK_DIVIDE } 0,
+  { 70 VK_F1 'F1' } $3B,
+  { 71 VK_F2 'F2' } $3C,
+  { 72 VK_F3 'F3' } $3D,
+  { 73 VK_F4 'F4' } $3E,
+  { 74 VK_F5 'F5' } $3F,
+  { 75 VK_F6 'F6' } $40,
+  { 76 VK_F7 'F7' } $41,
+  { 77 VK_F8 'F8' } $42,
+  { 78 VK_F9 'F9' } $43,
+  { 79 VK_F10 'F10' } $44,
+  { 7A VK_F11 'F11' } $57,
+  { 7B VK_F12 'F12' } $58,
+  { 7C VK_F13 } 0,
+  { 7D VK_F14 } 0,
+  { 7E VK_F15 } 0,
+  { 7F VK_F16 } 0,
+  { 80 VK_F17 } 0,
+  { 81 VK_F18 } 0,
+  { 82 VK_F19 } 0,
+  { 83 VK_F20 } 0,
+  { 84 VK_F21 } 0,
+  { 85 VK_F22 } 0,
+  { 86 VK_F23 } 0,
+  { 87 VK_F24 } 0,
+  { 88 unassigned } -2,
+  { 89 VK_NUMLOCK } 0,
+  { 8A VK_SCROLL } 0,
+  { 8B unassigned } -2,
+  { 8C unassigned } -2,
+  { 8D unassigned } -2,
+  { 8E unassigned } -2,
+  { 8F unassigned } -2,
+  { 90 unassigned } -2,
+  { 91 unassigned } -2,
+  { 92 unassigned } -2,
+  { 93 unassigned } -2,
+  { 94 unassigned } -2,
+  { 95 unassigned } -2,
+  { 96 unassigned } -2,
+  { 97 unassigned } -2,
+  { 98 unassigned } -2,
+  { 99 unassigned } -2,
+  { 9A unassigned } -2,
+  { 9B unassigned } -2,
+  { 9C unassigned } -2,
+  { 9D unassigned } -2,
+  { 9E unassigned } -2,
+  { 9F unassigned } -2,
+  { A0 unassigned } -2,
+  { A1 unassigned } -2,
+  { A2 unassigned } -2,
+  { A3 unassigned } -2,
+  { A4 unassigned } -2,
+  { A5 unassigned } -2,
+  { A6 unassigned } -2,
+  { A7 unassigned } -2,
+  { A8 unassigned } -2,
+  { A9 unassigned } -2,
+  { AA unassigned } -2,
+  { AB unassigned } -2,
+  { AC unassigned } -2,
+  { AD unassigned } -2,
+  { AE unassigned } -2,
+  { AF unassigned } -2,
+  { B0 unassigned } -2,
+  { B1 unassigned } -2,
+  { B2 unassigned } -2,
+  { B3 unassigned } -2,
+  { B4 unassigned } -2,
+  { B5 unassigned } -2,
+  { B6 unassigned } -2,
+  { B7 unassigned } -2,
+  { B8 unassigned } -2,
+  { B9 unassigned } -2,
+  { BA OEM specific } 0,
+  { BB OEM specific } 0,
+  { BC OEM specific } 0,
+  { BD OEM specific } 0,
+  { BE OEM specific } 0,
+  { BF OEM specific } 0,
+  { C0 OEM specific } 0,
+  { C1 unassigned } -2,
+  { C2 unassigned } -2,
+  { C3 unassigned } -2,
+  { C4 unassigned } -2,
+  { C5 unassigned } -2,
+  { C6 unassigned } -2,
+  { C7 unassigned } -2,
+  { C8 unassigned } -2,
+  { C9 unassigned } -2,
+  { CA unassigned } -2,
+  { CB unassigned } -2,
+  { CC unassigned } -2,
+  { CD unassigned } -2,
+  { CE unassigned } -2,
+  { CF unassigned } -2,
+  { D0 unassigned } -2,
+  { D1 unassigned } -2,
+  { D2 unassigned } -2,
+  { D3 unassigned } -2,
+  { D4 unassigned } -2,
+  { D5 unassigned } -2,
+  { D6 unassigned } -2,
+  { D7 unassigned } -2,
+  { D8 unassigned } -2,
+  { D9 unassigned } -2,
+  { DA unassigned } -2,
+  { DB OEM specific } 0,
+  { DC OEM specific } 0,
+  { DD OEM specific } 0,
+  { DE OEM specific } 0,
+  { DF OEM specific } 0,
+  { E0 OEM specific } 0,
+  { E1 OEM specific } 0,
+  { E2 OEM specific } 0,
+  { E3 OEM specific } 0,
+  { E4 OEM specific } 0,
+  { E5 unassigned } -2,
+  { E6 OEM specific } 0,
+  { E7 unassigned } -2,
+  { E8 unassigned } -2,
+  { E9 OEM specific } 0,
+  { EA OEM specific } 0,
+  { EB OEM specific } 0,
+  { EC OEM specific } 0,
+  { ED OEM specific } 0,
+  { EE OEM specific } 0,
+  { EF OEM specific } 0,
+  { F0 OEM specific } 0,
+  { F1 OEM specific } 0,
+  { F2 OEM specific } 0,
+  { F3 OEM specific } 0,
+  { F4 OEM specific } 0,
+  { F5 OEM specific } 0,
+  { F6 unassigned } -2,
+  { F7 unassigned } -2,
+  { F8 unassigned } -2,
+  { F9 unassigned } -2,
+  { FA unassigned } -2,
+  { FB unassigned } -2,
+  { FC unassigned } -2,
+  { FD unassigned } -2,
+  { FE unassigned } -2,
+  { FF unassigned } -2
+  );
+{$endif  USEKEYCODES}
+type TTEntryT = packed record
+                  n,s,c,a : byte;   {normal,shift, ctrl, alt, normal only for f11,f12}
+                end;
+
+CONST
+ DosTT : ARRAY [$3B..$58] OF TTEntryT =
+  ((n : $3B; s : $54; c : $5E; a: $68),      {3B F1}
+   (n : $3C; s : $55; c : $5F; a: $69),      {3C F2}
+   (n : $3D; s : $56; c : $60; a: $6A),      {3D F3}
+   (n : $3E; s : $57; c : $61; a: $6B),      {3E F4}
+   (n : $3F; s : $58; c : $62; a: $6C),      {3F F5}
+   (n : $40; s : $59; c : $63; a: $6D),      {40 F6}
+   (n : $41; s : $5A; c : $64; a: $6E),      {41 F7}
+   (n : $42; s : $5B; c : $65; a: $6F),      {42 F8}
+   (n : $43; s : $5C; c : $66; a: $70),      {43 F9}
+   (n : $44; s : $5D; c : $67; a: $71),      {44 F10}
+   (n : $45; s : $00; c : $00; a: $00),      {45 ???}
+   (n : $46; s : $00; c : $00; a: $00),      {46 ???}
+   (n : $47; s : $47; c : $77; a: $97),      {47 Home}
+   (n : $48; s : $00; c : $8D; a: $98),      {48 Up}
+   (n : $49; s : $49; c : $84; a: $99),      {49 PgUp}
+   (n : $4A; s : $00; c : $8E; a: $4A),      {4A -}
+   (n : $4B; s : $4B; c : $73; a: $9B),      {4B Left}
+   (n : $4C; s : $00; c : $00; a: $00),      {4C ???}
+   (n : $4D; s : $4D; c : $74; a: $9D),      {4D Right}
+   (n : $4E; s : $00; c : $90; a: $4E),      {4E +}
+   (n : $4F; s : $4F; c : $75; a: $9F),      {4F End}
+   (n : $50; s : $50; c : $91; a: $A0),      {50 Down}
+   (n : $51; s : $51; c : $76; a: $A1),      {51 PgDown}
+   (n : $52; s : $52; c : $92; a: $A2),      {52 Insert}
+   (n : $53; s : $53; c : $93; a: $A3),      {53 Del}
+   (n : $54; s : $00; c : $00; a: $00),      {54 ???}
+   (n : $55; s : $00; c : $00; a: $00),      {55 ???}
+   (n : $56; s : $00; c : $00; a: $00),      {56 ???}
+   (n : $85; s : $87; c : $89; a: $8B),      {57 F11}
+   (n : $86; s : $88; c : $8A; a: $8C));     {58 F12}
+
+ DosTT09 : ARRAY [$02..$0F] OF TTEntryT =
+  ((n : $00; s : $00; c : $00; a: $78),      {02 1 }
+   (n : $00; s : $00; c : $00; a: $79),      {03 2 }
+   (n : $00; s : $00; c : $00; a: $7A),      {04 3 }
+   (n : $00; s : $00; c : $00; a: $7B),      {05 4 }
+   (n : $00; s : $00; c : $00; a: $7C),      {06 5 }
+   (n : $00; s : $00; c : $00; a: $7D),      {07 6 }
+   (n : $00; s : $00; c : $00; a: $7E),      {08 7 }
+   (n : $00; s : $00; c : $00; a: $7F),      {09 8 }
+   (n : $00; s : $00; c : $00; a: $80),      {0A 9 }
+   (n : $00; s : $00; c : $00; a: $81),      {0B 0 }
+   (n : $00; s : $00; c : $00; a: $82),      {0C ß }
+   (n : $00; s : $00; c : $00; a: $00),      {0D}
+   (n : $00; s : $09; c : $00; a: $00),      {0E Backspace}
+   (n : $00; s : $0F; c : $94; a: $00));     {0F Tab }
+
+
+function translateKey (t : TKeyEventRecord) : TKeyEvent;
+var key : TKeyEvent;
+    ss  : byte;
+{$ifdef  USEKEYCODES}
+    ScanCode  : byte;
+{$endif  USEKEYCODES}
+    b   : byte;
+begin
+  Key := 0;
+  if t.bKeyDown then
+  begin
+    { ascii-char is <> 0 if not a specal key }
+    { we return it here otherwise we have to translate more later }
+    if t.AsciiChar <> #0 then
+    begin
+      {drivers needs scancode, we return it here as under dos and linux
+       with $03000000 = the lowest two bytes is the physical representation}
+{$ifdef  USEKEYCODES}
+      Scancode:=KeyToQwertyScan[t.wVirtualKeyCode AND $00FF];
+      If ScanCode>0 then
+        t.wVirtualScanCode:=ScanCode;
+      Key := byte (t.AsciiChar) + (t.wVirtualScanCode shl 8) + $03000000;
+      ss := transShiftState (t.dwControlKeyState);
+      key := key or (ss shl 16);
+      if (ss and kbAlt <> 0) and (t.dwControlKeyState and RIGHT_ALT_PRESSED = 0) then
+        key := key and $FFFFFF00;
+{$else not USEKEYCODES}
+      Key := byte (t.AsciiChar) + ((t.wVirtualScanCode AND $00FF) shl 8) + $03000000;
+{$endif not USEKEYCODES}
+    end else
+    begin
+{$ifdef  USEKEYCODES}
+      Scancode:=KeyToQwertyScan[t.wVirtualKeyCode AND $00FF];
+      If ScanCode>0 then
+        t.wVirtualScanCode:=ScanCode;
+{$endif not USEKEYCODES}
+      translateKey := 0;
+      { ignore shift,ctrl,alt,numlock,capslock alone }
+      case t.wVirtualKeyCode of
+        $0010,         {shift}
+        $0011,         {ctrl}
+        $0012,         {alt}
+        $0014,         {capslock}
+        $0090,         {numlock}
+        $0091,         {scrollock}
+        { This should be handled !! }
+        { these last two are OEM specific
+          this is not good !!! }
+        $00DC,         {^ : next key i.e. a is modified }
+        { Strange on my keyboard this corresponds to double point over i or u PM }
+        $00DD: exit;   {´ and ` : next key i.e. e is modified }
+      end;
+
+      key := $03000000 + (t.wVirtualScanCode shl 8);  { make lower 8 bit=0 like under dos }
+    end;
+    { Handling of ~ key as AltGr 2 }
+    { This is also French keyboard specific !! }
+    { but without this I can not get a ~ !! PM }
+    if (t.wVirtualKeyCode=$32) and
+       (KeyBoardLayout = FrenchKeyboard) and
+       (t.dwControlKeyState and RIGHT_ALT_PRESSED <> 0) then
+      key:=(key and $ffffff00) or ord('~');
+    { ok, now add Shift-State }
+    ss := transShiftState (t.dwControlKeyState);
+    key := key or (ss shl 16);
+
+    { Reset Ascii-Char if Alt+Key, fv needs that, may be we
+      need it for other special keys too
+      18 Sept 1999 AD: not for right Alt i.e. for AltGr+ß = \ on german keyboard }
+    if ((ss and kbAlt <> 0) and (t.dwControlKeyState and RIGHT_ALT_PRESSED = 0)) or
+    (*
+      { yes, we need it for cursor keys, 25=left, 26=up, 27=right,28=down}
+      {aggg, this will not work because esc is also virtualKeyCode 27!!}
+      {if (t.wVirtualKeyCode >= 25) and (t.wVirtualKeyCode <= 28) then}
+        no VK_ESCAPE is $1B !!
+        there was a mistake :
+         VK_LEFT is $25 not 25 !! *)
+       { not $2E VK_DELETE because its only the Keypad point !! PM }
+      (t.wVirtualKeyCode in [$21..$28,$2C,$2D,$2F]) then
+      { if t.wVirtualScanCode in [$47..$49,$4b,$4d,$4f,$50..$53] then}
+        key := key and $FFFFFF00;
+
+    {and translate to dos-scancodes to make fv happy, we will convert this
+     back in translateKeyEvent}
+
+     if (t.dwControlKeyState and RIGHT_ALT_PRESSED) = 0 then {not for alt-gr}
+     if (t.wVirtualScanCode >= low (DosTT)) and
+        (t.wVirtualScanCode <= high (dosTT)) then
+     begin
+       b := 0;
+       if (ss and kbAlt) <> 0 then
+         b := DosTT[t.wVirtualScanCode].a
+       else
+       if (ss and kbCtrl) <> 0 then
+         b := DosTT[t.wVirtualScanCode].c
+       else
+       if (ss and kbShift) <> 0 then
+         b := DosTT[t.wVirtualScanCode].s
+       else
+         b := DosTT[t.wVirtualScanCode].n;
+       if b <> 0 then
+         key := (key and $FFFF00FF) or (longint (b) shl 8);
+     end;
+
+     {Alt-0 to Alt-9}
+     if (t.dwControlKeyState and RIGHT_ALT_PRESSED) = 0 then {not for alt-gr}
+       if (t.wVirtualScanCode >= low (DosTT09)) and
+          (t.wVirtualScanCode <= high (dosTT09)) then
+       begin
+         b := 0;
+         if (ss and kbAlt) <> 0 then
+           b := DosTT09[t.wVirtualScanCode].a
+         else
+         if (ss and kbCtrl) <> 0 then
+           b := DosTT09[t.wVirtualScanCode].c
+         else
+         if (ss and kbShift) <> 0 then
+           b := DosTT09[t.wVirtualScanCode].s
+         else
+           b := DosTT09[t.wVirtualScanCode].n;
+         if b <> 0 then
+           key := (key and $FFFF0000) or (longint (b) shl 8);
+       end;
+
+     TranslateKey := key;
+  end;
+  translateKey := Key;
+end;
+
+function GetKeyEvent: TKeyEvent;
+var t   : TKeyEventRecord;
+    key : TKeyEvent;
+begin
+  if PendingKeyEvent<>0 then
+  begin
+    GetKeyEvent:=PendingKeyEvent;
+    PendingKeyEvent:=0;
+    exit;
+  end;
+  key := 0;
+  repeat
+     if getKeyEventFromQueueWait (t) then
+       key := translateKey (t);
+  until key <> 0;
+{$ifdef DEBUG}
+  last_ir.KeyEvent:=t;
+{$endif DEBUG}
+  GetKeyEvent := key;
+end;
+
+function PollKeyEvent: TKeyEvent;
+var t   : TKeyEventRecord;
+    k   : TKeyEvent;
+begin
+  if PendingKeyEvent<>0 then
+    exit(PendingKeyEvent);
+  PollKeyEvent := 0;
+  if getKeyEventFromQueue (t, true) then
+  begin
+    { we get an enty for shift, ctrl, alt... }
+    k := translateKey (t);
+    while (k = 0) do
+    begin
+      getKeyEventFromQueue (t, false);  {remove it}
+      if not getKeyEventFromQueue (t, true) then exit;
+      k := translateKey (t)
+    end;
+    PollKeyEvent := k;
+  end;
+end;
+
+
+function TranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+  if KeyEvent and $03000000 = $03000000 then
+   begin
+     if KeyEvent and $000000FF <> 0 then
+     begin
+       TranslateKeyEvent := KeyEvent and $00FFFFFF;
+       exit;
+     end;
+     {translate function-keys and other specials, ascii-codes are already ok}
+     case (KeyEvent AND $0000FF00) shr 8 of
+       {F1..F10}
+       $3B..$44     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $3B + $02000000;
+       {F11,F12}
+       $85..$86     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $85 + $02000000;
+       {Shift F1..F10}
+       $54..$5D     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $54 + $02000000;
+       {Shift F11,F12}
+       $87..$88     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $87 + $02000000;
+       {Alt F1..F10}
+       $68..$71     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $68 + $02000000;
+       {Alt F11,F12}
+       $8B..$8C     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $8B + $02000000;
+       {Ctrl F1..F10}
+       $5E..$67     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF1 + ((KeyEvent AND $0000FF00) SHR 8) - $5E + $02000000;
+       {Ctrl F11,F12}
+       $89..$8A     : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdF11 + ((KeyEvent AND $0000FF00) SHR 8) - $89 + $02000000;
+
+       {normal,ctrl,alt}
+       $47,$77,$97  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdHome + $02000000;
+       $48,$8D,$98  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdUp + $02000000;
+       $49,$84,$99  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdPgUp + $02000000;
+       $4b,$73,$9B  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdLeft + $02000000;
+       $4d,$74,$9D  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdRight + $02000000;
+       $4f,$75,$9F  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdEnd + $02000000;
+       $50,$91,$A0  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdDown + $02000000;
+       $51,$76,$A1  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdPgDn + $02000000;
+       $52,$92,$A2  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdInsert + $02000000;
+       $53,$93,$A3  : TranslateKeyEvent := (KeyEvent AND $FCFF0000) + kbdDelete + $02000000;
+     else
+       TranslateKeyEvent := KeyEvent;
+     end;
+   end else
+     TranslateKeyEvent := KeyEvent;
+end;
+
+function TranslateKeyEventUniCode(KeyEvent: TKeyEvent): TKeyEvent;
+begin
+  exit (KeyEvent);  {???}
+end;
+
+function PollShiftStateEvent: TKeyEvent;
+var t : TKeyEvent;
+begin
+  {may be better to save the last state and return that if no key is in buffer???}
+  t := lastShiftState;
+  PollShiftStateEvent := t shl 16;
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  1999/12/13 14:09:37  pierre
+   + several changes for not standard keyboards
+
+  Revision 1.12  1999/11/24 23:36:59  peter
+    * moved to packages dir
+
+  Revision 1.11  1999/09/22 12:56:53  pierre
+   + added boolean to avoid double done
+
+  Revision 1.10  1999/09/20 20:57:58  florian
+    * from Armin Diehl: fixed altgr+key, Alt 0..9, Shift-Tab for fv
+
+  Revision 1.9  1999/08/01 16:10:26  florian
+    * fixed cursor size
+
+  Revision 1.6  1999/07/15 23:40:00 armin
+    * support for alt + number, cursor keys retuned wrong codes, shift state not ok if i.e. alt released
+
+  Revision 1.5  1999/07/12 22:22:00 armin
+    * used scancodes, not virtual keys, PollKeyEvent works, special keys (shift-state untested)
+
+  Revision 1.4  1999/07/11 18:21:00 armin
+    * win32 implemented most functions
+
+  Revision 1.3  1999/06/21 16:43:53  peter
+    * win32 updates from Maarten Bekkers
+
+  Revision 1.2  1999/01/09 07:30:00  florian
+    * small additions, not completed yet
+
+  Revision 1.1  1998/12/04 12:49:01  peter
+    * moved some dirs
+
+  Revision 1.1  1998/10/26 11:31:49  peter
+    + inital include files
+}

api/win32/mouse.inc

@@ -0,0 +1,232 @@
+{
+   $Id$
+   System independent mouse interface for win32
+
+   Copyright (c) 1999 by Florian Klaempfl
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+}
+
+uses
+   windows,dos,event;
+
+var
+   ChangeMouseEvents : TCriticalSection;
+Const
+  MouseEventActive : Boolean = false;
+
+procedure MouseEventHandler;
+
+  var
+     ir : INPUT_RECORD;
+     dwRead : DWord;
+     i: longint;
+     e : TMouseEvent;
+
+  begin
+     ReadConsoleInput(TextRec(Input).Handle,ir,1,dwRead);
+     if (dwRead=1) and (ir.EventType=_MOUSE_EVENT) then
+       begin
+          EnterCriticalSection(ChangeMouseEvents);
+          e.x:=ir.MouseEvent.dwMousePosition.x;
+          e.y:=ir.MouseEvent.dwMousePosition.y;
+          e.buttons:=0;
+          e.action:=0;
+          if (ir.MouseEvent.dwButtonState and FROM_LEFT_1ST_BUTTON_PRESSED<>0) then
+            e.buttons:=e.buttons or MouseLeftButton;
+          if (ir.MouseEvent.dwButtonState and FROM_LEFT_2ND_BUTTON_PRESSED<>0) then
+            e.buttons:=e.buttons or MouseMiddleButton;
+          if (ir.MouseEvent.dwButtonState and RIGHTMOST_BUTTON_PRESSED<>0) then
+            e.buttons:=e.buttons or MouseRightButton;
+
+          { can we compress the events? }
+          if (PendingMouseEvents>0) and
+            (e.buttons=PendingMouseTail^.buttons) and
+            (e.action=PendingMouseTail^.action) then
+            begin
+               PendingMouseTail^.x:=e.x;
+               PendingMouseTail^.y:=e.y;
+            end
+          else
+            begin
+               PutMouseEvent(e);
+               // this should be done in PutMouseEvent
+               inc(PendingMouseEvents);
+            end;
+          LeaveCriticalSection(ChangeMouseEvents);
+       end;
+  end;
+
+procedure InitMouse;
+
+var
+   mode : dword;
+
+begin
+  if MouseEventActive then
+    exit;
+  // enable mouse events
+  GetConsoleMode(TextRec(Input).Handle,@mode);
+  mode:=mode or ENABLE_MOUSE_INPUT;
+  SetConsoleMode(TextRec(Input).Handle,mode);
+
+  PendingMouseHead:=@PendingMouseEvent;
+  PendingMouseTail:=@PendingMouseEvent;
+  PendingMouseEvents:=0;
+  FillChar(LastMouseEvent,sizeof(TMouseEvent),0);
+  InitializeCriticalSection(ChangeMouseEvents);
+  SetMouseEventHandler(@MouseEventHandler);
+  ShowMouse;
+  MouseEventActive:=true;
+end;
+
+
+procedure DoneMouse;
+var
+   mode : dword;
+begin
+  if not MouseEventActive then
+    exit;
+  HideMouse;
+  // disable mouse events
+  GetConsoleMode(TextRec(Input).Handle,@mode);
+  mode:=mode and (not ENABLE_MOUSE_INPUT);
+  SetConsoleMode(TextRec(Input).Handle,mode);
+
+  SetMouseEventHandler(nil);
+  DeleteCriticalSection(ChangeMouseEvents);
+  MouseEventActive:=false;
+end;
+
+
+function DetectMouse:byte;
+var
+  num : dword;
+begin
+  GetNumberOfConsoleMouseButtons(@num);
+  DetectMouse:=num;
+end;
+
+
+procedure ShowMouse;
+begin
+end;
+
+
+procedure HideMouse;
+begin
+end;
+
+
+function GetMouseX:word;
+begin
+  GetMouseX:=0;
+end;
+
+
+function GetMouseY:word;
+begin
+  GetMouseY:=0;
+end;
+
+
+function GetMouseButtons:word;
+begin
+  GetMouseButtons:=0;
+end;
+
+
+procedure SetMouseXY(x,y:word);
+begin
+end;
+
+
+procedure GetMouseEvent(var MouseEvent: TMouseEvent);
+
+var
+   b : byte;
+
+begin
+  repeat
+    EnterCriticalSection(ChangeMouseEvents);
+    b:=PendingMouseEvents;
+    LeaveCriticalSection(ChangeMouseEvents);
+    if b>0 then
+      break
+    else
+      sleep(50);
+  until false;
+  EnterCriticalSection(ChangeMouseEvents);
+  MouseEvent:=PendingMouseHead^;
+  inc(PendingMouseHead);
+  if longint(PendingMouseHead)=longint(@PendingMouseEvent)+sizeof(PendingMouseEvent) then
+   PendingMouseHead:=@PendingMouseEvent;
+  dec(PendingMouseEvents);
+  if (LastMouseEvent.x<>MouseEvent.x) or (LastMouseEvent.y<>MouseEvent.y) then
+   MouseEvent.Action:=MouseActionMove;
+  if (LastMouseEvent.Buttons<>MouseEvent.Buttons) then
+   begin
+     if (LastMouseEvent.Buttons=0) then
+      MouseEvent.Action:=MouseActionDown
+     else
+      MouseEvent.Action:=MouseActionUp;
+   end;
+  LastMouseEvent:=MouseEvent;
+  LeaveCriticalSection(ChangeMouseEvents);
+end;
+
+
+function PollMouseEvent(var MouseEvent: TMouseEvent):boolean;
+begin
+  EnterCriticalSection(ChangeMouseEvents);
+  if PendingMouseEvents>0 then
+   begin
+     MouseEvent:=PendingMouseHead^;
+     PollMouseEvent:=true;
+   end
+  else
+   PollMouseEvent:=false;
+  LeaveCriticalSection(ChangeMouseEvents);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  1999/11/24 23:36:38  peter
+    * moved to packages dir
+
+  Revision 1.6  1999/09/22 12:56:53  pierre
+   + added boolean to avoid double done
+
+  Revision 1.5  1999/07/18 10:56:39  florian
+    + compressing of MouseMoving in the mouse event queue:
+     this leads to a smoother mouse dragging
+
+  Revision 1.4  1999/07/17 22:37:10  florian
+    * implemented mouse handling
+
+  Revision 1.3  1999/07/17 17:21:37  florian
+    * fixed the win32 keyboard event handling
+
+  Revision 1.2  1999/06/21 16:43:54  peter
+    * win32 updates from Maarten Bekkers
+
+  Revision 1.1  1999/01/08 14:37:03  florian
+    + initial version, not working yet
+
+}

api/win32/video.inc

@@ -0,0 +1,375 @@
+{
+   $Id$
+   System independent low-level video interface for win32
+
+   Copyright (c) 1999 by Florian Klaempfl
+
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Library General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+
+
+   This library 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.  See the GNU
+   Library General Public License for more details.
+
+   You should have received a copy of the GNU Library General Public
+   License along with this library; if not, write to the Free
+   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+}
+
+
+uses
+  windows,dos;
+
+var
+  OldVideoBuf : PVideoBuf;
+  ConsoleInfo : TConsoleScreenBufferInfo;
+  ConsoleCursorInfo : TConsoleCursorInfo;
+  MaxVideoBufSize : DWord;
+
+procedure InitVideo;
+begin
+  ScreenColor:=true;
+  GetConsoleScreenBufferInfo(TextRec(Output).Handle, ConsoleInfo);
+  GetConsoleCursorInfo(TextRec(Output).Handle, ConsoleCursorInfo);
+
+  with ConsoleInfo.srWindow do
+    begin
+       ScreenWidth:=right-left+1;
+       ScreenHeight:=bottom-top+1;
+    end;
+
+  { srWindow is sometimes bigger then dwMaximumWindowSize
+    this led to wrong ScreenWidth and ScreenHeight values PM }
+  { damned: its also sometimes less !! PM }
+  with ConsoleInfo.dwMaximumWindowSize do
+    begin
+       {if ScreenWidth>X then}
+         ScreenWidth:=X;
+       {if ScreenHeight>Y then}
+         ScreenHeight:=Y;
+    end;
+
+  CursorX:=ConsoleInfo.dwCursorPosition.x;
+  CursorY:=ConsoleInfo.dwCursorPosition.y;
+  if not ConsoleCursorInfo.bvisible then
+    CursorLines:=0
+  else
+    CursorLines:=ConsoleCursorInfo.dwSize;
+
+  { allocate back buffer }
+  MaxVideoBufSize:= ScreenWidth * ScreenHeight * 2;
+  VideoBufSize:=ScreenWidth*ScreenHeight*2;
+
+  GetMem(VideoBuf,MaxVideoBufSize);
+  GetMem(OldVideoBuf,MaxVideoBufSize);
+
+  {ClearScreen; not needed PM }
+end;
+
+
+procedure DoneVideo;
+begin
+  { ClearScreen; also not needed PM }
+  SetCursorType(crUnderLine);
+  { SetCursorPos(0,0); also not needed PM }
+  FreeMem(VideoBuf,MaxVideoBufSize);
+  FreeMem(OldVideoBuf,MaxVideoBufSize);
+  VideoBufSize:=0;
+end;
+
+
+function GetCapabilities: Word;
+begin
+  GetCapabilities:=cpColor or cpChangeCursor;
+end;
+
+
+procedure SetCursorPos(NewCursorX, NewCursorY: Word);
+var
+  pos : COORD;
+begin
+   pos.x:=NewCursorX;
+   pos.y:=NewCursorY;
+   SetConsoleCursorPosition(TextRec(Output).Handle,pos);
+   CursorX:=pos.x;
+   CursorY:=pos.y;
+end;
+
+
+function GetCursorType: Word;
+begin
+   GetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
+   if not ConsoleCursorInfo.bvisible then
+     GetCursorType:=crHidden
+   else
+     case ConsoleCursorInfo.dwSize of
+        1..30:
+          GetCursorType:=crUnderline;
+        31..70:
+          GetCursorType:=crHalfBlock;
+        71..100:
+          GetCursorType:=crBlock;
+     end;
+end;
+
+
+procedure SetCursorType(NewType: Word);
+begin
+   GetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
+   if newType=crHidden then
+     ConsoleCursorInfo.bvisible:=false
+   else
+     begin
+        ConsoleCursorInfo.bvisible:=true;
+        case NewType of
+           crUnderline:
+             ConsoleCursorInfo.dwSize:=10;
+
+           crHalfBlock:
+             ConsoleCursorInfo.dwSize:=50;
+
+           crBlock:
+             ConsoleCursorInfo.dwSize:=99;
+        end
+     end;
+   SetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
+end;
+
+
+function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean;
+begin
+end;
+
+
+procedure ClearScreen;
+begin
+  FillWord(VideoBuf^,VideoBufSize div 2,$0720);
+  UpdateScreen(true);
+end;
+
+
+{$IFDEF FPC}
+function WriteConsoleOutput(hConsoleOutput:HANDLE; lpBuffer:pointer; dwBufferSize:COORD; dwBufferCoord:COORD;
+   var lpWriteRegion:SMALL_RECT):WINBOOL; external 'kernel32' name 'WriteConsoleOutputA';
+{$ENDIF}
+
+procedure UpdateScreen(Force: Boolean);
+type TmpRec = Array[0..(1024*32) - 1] of TCharInfo;
+
+type WordRec = record
+                  One, Two: Byte;
+               end; { wordrec }
+
+var
+   BufSize,
+   BufCoord    : COORD;
+   WriteRegion : SMALL_RECT;
+   LineBuf     : ^TmpRec;
+   BufCounter  : Longint;
+   LineCounter,
+   ColCounter  : Longint;
+   smallforce  : boolean;
+{
+begin
+  if LockUpdateScreen<>0 then
+   exit;
+  if not force then
+   begin
+     asm
+        movl    VideoBuf,%esi
+        movl    OldVideoBuf,%edi
+        movl    VideoBufSize,%ecx
+        shrl    $2,%ecx
+        repe
+        cmpsl
+        orl     %ecx,%ecx
+        jz      .Lno_update
+        movb    $1,force
+.Lno_update:
+     end;
+   end;
+  if Force then
+   begin
+      BufSize.X := ScreenWidth;
+      BufSize.Y := ScreenHeight;
+
+      BufCoord.X := 0;
+      BufCoord.Y := 0;
+      with WriteRegion do
+        begin
+           Top :=0;
+           Left :=0;
+           Bottom := ScreenHeight-1;
+           Right := ScreenWidth-1;
+        end;
+      New(LineBuf);
+      BufCounter := 0;
+
+      for LineCounter := 1 to ScreenHeight do
+        begin
+           for ColCounter := 1 to ScreenWidth do
+             begin
+               LineBuf^[BufCounter].UniCodeChar := WordRec(VideoBuf^[BufCounter]).One;
+               LineBuf^[BufCounter].Attributes := WordRec(VideoBuf^[BufCounter]).Two;
+
+               Inc(BufCounter);
+             end; { for }
+        end; { for }
+
+      WriteConsoleOutput(TextRec(Output).Handle, LineBuf, BufSize, BufCoord, WriteRegion);
+      Dispose(LineBuf);
+
+      move(VideoBuf^,OldVideoBuf^,VideoBufSize);
+   end;
+end;
+}
+var
+   x1,y1,x2,y2 : longint;
+
+begin
+  if LockUpdateScreen<>0 then
+   exit;
+  if force then
+   smallforce:=true
+  else
+   begin
+     asm
+        movl    VideoBuf,%esi
+        movl    OldVideoBuf,%edi
+        movl    VideoBufSize,%ecx
+        shrl    $2,%ecx
+        repe
+        cmpsl
+        orl     %ecx,%ecx
+        jz      .Lno_update
+        movb    $1,smallforce
+.Lno_update:
+     end;
+   end;
+  if SmallForce then
+   begin
+      BufSize.X := ScreenWidth;
+      BufSize.Y := ScreenHeight;
+
+      BufCoord.X := 0;
+      BufCoord.Y := 0;
+      with WriteRegion do
+        begin
+           Top :=0;
+           Left :=0;
+           Bottom := ScreenHeight-1;
+           Right := ScreenWidth-1;
+        end;
+      New(LineBuf);
+      BufCounter := 0;
+      x1:=ScreenWidth+1;
+      x2:=-1;
+      y1:=ScreenHeight+1;
+      y2:=-1;
+      for LineCounter := 1 to ScreenHeight do
+        begin
+           for ColCounter := 1 to ScreenWidth do
+             begin
+               if (WordRec(VideoBuf^[BufCounter]).One<>WordRec(OldVideoBuf^[BufCounter]).One) or
+                 (WordRec(VideoBuf^[BufCounter]).Two<>WordRec(OldVideoBuf^[BufCounter]).Two) then
+                 begin
+                    if ColCounter<x1 then
+                      x1:=ColCounter;
+                    if ColCounter>x2 then
+                      x2:=ColCounter;
+                    if LineCounter<y1 then
+                      y1:=LineCounter;
+                    if LineCounter>y2 then
+                      y2:=LineCounter;
+                 end;
+               LineBuf^[BufCounter].UniCodeChar := WordRec(VideoBuf^[BufCounter]).One;
+               { If (WordRec(VideoBuf^[BufCounter]).Two and $80)<>0 then
+                 LineBuf^[BufCounter].Attributes := $100+WordRec(VideoBuf^[BufCounter]).Two
+               else }
+                 LineBuf^[BufCounter].Attributes := WordRec(VideoBuf^[BufCounter]).Two;
+
+               Inc(BufCounter);
+             end; { for }
+        end; { for }
+      BufSize.X := ScreenWidth;
+      BufSize.Y := ScreenHeight;
+
+      with WriteRegion do
+        begin
+           if force then
+             begin
+               Top := 0;
+               Left :=0;
+               Bottom := ScreenHeight-1;
+               Right := ScreenWidth-1;
+               BufCoord.X := 0;
+               BufCoord.Y := 0;
+             end
+           else
+             begin
+               Top := y1-1;
+               Left :=x1-1;
+               Bottom := y2-1;
+               Right := x2-1;
+               BufCoord.X := x1-1;
+               BufCoord.Y := y1-1;
+             end;
+        end;
+      {
+      writeln('X1: ',x1);
+      writeln('Y1: ',y1);
+      writeln('X2: ',x2);
+      writeln('Y2: ',y2);
+      }
+      WriteConsoleOutput(TextRec(Output).Handle, LineBuf, BufSize, BufCoord, WriteRegion);
+      Dispose(LineBuf);
+
+      move(VideoBuf^,OldVideoBuf^,VideoBufSize);
+   end;
+end;
+
+procedure RegisterVideoModes;
+begin
+  { don't know what to do for win32 (FK) }
+  RegisterVideoMode(80, 25, True, @DefaultVideoModeSelector, $00000003);
+end;
+
+{
+  $Log$
+  Revision 1.1  2000-01-06 01:20:31  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  1999/12/09 21:36:47  pierre
+   * freeze screen size
+
+  Revision 1.9  1999/11/24 23:37:00  peter
+    * moved to packages dir
+
+  Revision 1.8  1999/10/14 10:13:57  pierre
+   * Screen size problem solved
+
+  Revision 1.7  1999/09/22 12:57:38  pierre
+   + support for Screen switches : ClearScreen removed
+
+  Revision 1.6  1999/08/01 16:10:27  florian
+    * fixed cursor size
+
+  Revision 1.5  1999/07/14 22:04:04  florian
+    * noch mehr Fehler behoben, TV-Programme laufen nun so lala
+
+  Revision 1.4  1999/07/11 21:57:48  florian
+    * small fixes to get at least some output
+
+  Revision 1.3  1999/06/21 16:43:55  peter
+    * win32 updates from Maarten Bekkers
+
+  Revision 1.2  1999/01/08 16:50:05  florian
+    + complete, but undebugged implementation
+
+  Revision 1.1  1999/01/08 14:37:03  florian
+    + initial version, not working yet
+}

fcl/Makefile

@@ -0,0 +1,510 @@
+#
+# Makefile generated by fpcmake v0.99.13 [2000/01/06]
+#
+
+defaultrule: all
+
+#####################################################################
+# Autodetect OS (Linux or Dos or Windows NT)
+# define inlinux when running under linux
+# define inWinNT when running under WinNT
+#####################################################################
+
+# We need only / in the path
+override PATH:=$(subst \,/,$(PATH))
+
+# Search for PWD and determine also if we are under linux
+PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH)))))
+ifeq ($(PWD),)
+PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH)))))
+ifeq ($(PWD),)
+nopwd:
+	@echo You need the GNU utils package to use this Makefile!
+	@echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip
+	@exit
+else
+inlinux=1
+endif
+else
+PWD:=$(firstword $(PWD))
+endif
+
+# Detect NT - NT sets OS to Windows_NT
+ifndef inlinux
+ifeq ($(OS),Windows_NT)
+inWinNT=1
+endif
+endif
+
+# Detect OS/2 - OS/2 has OS2_SHELL defined
+ifndef inlinux
+ifndef inWinNT
+ifdef OS2_SHELL
+inOS2=1
+endif
+endif
+endif
+
+# The extension of executables
+ifdef inlinux
+EXEEXT=
+else
+EXEEXT=.exe
+endif
+
+# The path which is searched separated by spaces
+ifdef inlinux
+SEARCHPATH=$(subst :, ,$(PATH))
+else
+SEARCHPATH=$(subst ;, ,$(PATH))
+endif
+
+#####################################################################
+# FPC version/target Detection
+#####################################################################
+
+# What compiler to use ?
+ifndef FPC
+# Compatibility with old makefiles
+ifdef PP
+FPC=$(PP)
+else
+ifdef inOS2
+FPC=ppos2$(EXEEXT)
+else
+FPC=ppc386$(EXEEXT)
+endif
+endif
+endif
+
+# Target OS
+ifndef OS_TARGET
+OS_TARGET:=$(shell $(FPC) -iTO)
+endif
+
+# Source OS
+ifndef OS_SOURCE
+OS_SOURCE:=$(shell $(FPC) -iSO)
+endif
+
+# Target CPU
+ifndef CPU_TARGET
+CPU_TARGET:=$(shell $(FPC) -iTP)
+endif
+
+# Source CPU
+ifndef CPU_SOURCE
+CPU_SOURCE:=$(shell $(FPC) -iSP)
+endif
+
+# FPC version
+ifndef FPC_VERSION
+FPC_VERSION:=$(shell $(FPC) -iV)
+endif
+
+export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION
+
+# Test FPCDIR to look if the RTL dir exists
+ifdef FPCDIR
+override FPCDIR:=$(subst \,/,$(FPCDIR))
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+else
+override FPCDIR=wrong
+endif
+
+# Detect FPCDIR
+ifeq ($(FPCDIR),wrong)
+ifdef inlinux
+override FPCDIR=/usr/lib/fpc/$(FPC_VERSION)
+else
+override FPCDIR:=$(subst /$(FPC)$(EXEEXT),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC)$(EXEEXT),$(SEARCHPATH))))))
+endif
+endif
+
+ifndef PACKAGEDIR
+PACKAGEDIR=$(FPCDIR)/packages
+endif
+ifndef COMPONENTDIR
+COMPONENTDIR=$(FPCDIR)/components
+endif
+# Check if packagedir really exists else turn it off
+ifeq ($(wildcard $(PACKAGEDIR)),)
+PACKAGEDIR=
+endif
+ifeq ($(wildcard $(COMPONENTDIR)),)
+COMPONENTDIR=
+endif
+
+# Create rtl,units dir
+ifneq ($(FPCDIR),.)
+override UNITSDIR=$(FPCDIR)/units/$(OS_TARGET)
+ifneq ($(wildcard $(FPCDIR)/rtl),)
+override RTLDIR=$(FPCDIR)/rtl/$(OS_TARGET)
+else
+override RTLDIR=$(UNITSDIR)/rtl
+endif
+endif
+
+#####################################################################
+# Default Settings
+#####################################################################
+
+# Release ? Then force OPT and don't use extra opts via commandline
+ifndef REDIRFILE
+REDIRFILE=log
+endif
+
+ifdef REDIR
+ifndef inlinux
+override FPC=redir -eo $(FPC)
+endif
+# set the verbosity to max
+override OPT+=-va
+override REDIR:= >> $(REDIRFILE)
+endif
+
+#####################################################################
+# User Settings
+#####################################################################
+
+
+# Targets
+
+override DIROBJECTS+=$(wildcard go32v2 linux win32 os2 tests)
+
+# Clean
+
+
+# Install
+
+ZIPTARGET=install
+
+# Defaults
+
+
+# Directories
+
+
+# Packages
+
+override PACKAGES=rtl
+PACKAGEDIR_RTL=$(FPCDIR)/rtl/$(OS_TARGET)
+
+# Libraries
+
+
+#####################################################################
+# Standard rules
+#####################################################################
+
+all: $(addsuffix _all,$(OS_TARGET))
+
+debug: $(addsuffix _debug,$(OS_TARGET))
+
+examples: $(addsuffix _examples,$(OS_TARGET))
+
+test: $(addsuffix _test,$(OS_TARGET))
+
+smart: $(addsuffix _smart,$(OS_TARGET))
+
+shared: $(addsuffix _shared,$(OS_TARGET))
+
+showinstall: $(addsuffix _showinstall,$(OS_TARGET))
+
+install: $(addsuffix _install,$(OS_TARGET))
+
+sourceinstall: $(addsuffix _sourceinstall,$(OS_TARGET))
+
+zipinstall: $(addsuffix _zipinstall,$(OS_TARGET))
+
+zipinstalladd: $(addsuffix _zipinstalladd,$(OS_TARGET))
+
+clean: $(addsuffix _clean,$(OS_TARGET))
+
+cleanall: $(addsuffix _cleanall,$(OS_TARGET))
+
+require: $(addsuffix _require,$(OS_TARGET))
+
+info: $(addsuffix _info,$(OS_TARGET))
+
+.PHONY:  all debug examples test smart shared showinstall install sourceinstall zipinstall zipinstalladd clean cleanall require info
+
+
+ifdef PACKAGERTL
+ifneq ($(wildcard $(PACKAGEDIR_RTL)),)
+ifeq ($(wildcard $(PACKAGEDIR_RTL)/$(FPCMADE)),)
+override COMPILEPACKAGES+=rtl
+rtl_package:
+	$(MAKE) -C $(PACKAGEDIR_RTL) all
+endif
+endif
+endif
+
+.PHONY:  rtl_package
+
+
+# Target Dirs
+
+OBJECTDIRGO32V2=1
+OBJECTDIRLINUX=1
+OBJECTDIRWIN32=1
+OBJECTDIROS2=1
+OBJECTDIRTESTS=1
+
+# Dir go32v2
+
+ifdef OBJECTDIRGO32V2
+.PHONY:  go32v2_all go32v2_debug go32v2_examples go32v2_test go32v2_smart go32v2_shared go32v2_showinstall go32v2_install go32v2_sourceinstall go32v2_zipinstall go32v2_zipinstalladd go32v2_clean go32v2_cleanall go32v2_require go32v2_info
+
+go32v2_all:
+	$(MAKE) -C go32v2 all
+
+go32v2_debug:
+	$(MAKE) -C go32v2 debug
+
+go32v2_examples:
+	$(MAKE) -C go32v2 examples
+
+go32v2_test:
+	$(MAKE) -C go32v2 test
+
+go32v2_smart:
+	$(MAKE) -C go32v2 smart
+
+go32v2_shared:
+	$(MAKE) -C go32v2 shared
+
+go32v2_showinstall:
+	$(MAKE) -C go32v2 showinstall
+
+go32v2_install:
+	$(MAKE) -C go32v2 install
+
+go32v2_sourceinstall:
+	$(MAKE) -C go32v2 sourceinstall
+
+go32v2_zipinstall:
+	$(MAKE) -C go32v2 zipinstall
+
+go32v2_zipinstalladd:
+	$(MAKE) -C go32v2 zipinstalladd
+
+go32v2_clean:
+	$(MAKE) -C go32v2 clean
+
+go32v2_cleanall:
+	$(MAKE) -C go32v2 cleanall
+
+go32v2_require:
+	$(MAKE) -C go32v2 require
+
+go32v2_info:
+	$(MAKE) -C go32v2 info
+endif
+
+# Dir linux
+
+ifdef OBJECTDIRLINUX
+.PHONY:  linux_all linux_debug linux_examples linux_test linux_smart linux_shared linux_showinstall linux_install linux_sourceinstall linux_zipinstall linux_zipinstalladd linux_clean linux_cleanall linux_require linux_info
+
+linux_all:
+	$(MAKE) -C linux all
+
+linux_debug:
+	$(MAKE) -C linux debug
+
+linux_examples:
+	$(MAKE) -C linux examples
+
+linux_test:
+	$(MAKE) -C linux test
+
+linux_smart:
+	$(MAKE) -C linux smart
+
+linux_shared:
+	$(MAKE) -C linux shared
+
+linux_showinstall:
+	$(MAKE) -C linux showinstall
+
+linux_install:
+	$(MAKE) -C linux install
+
+linux_sourceinstall:
+	$(MAKE) -C linux sourceinstall
+
+linux_zipinstall:
+	$(MAKE) -C linux zipinstall
+
+linux_zipinstalladd:
+	$(MAKE) -C linux zipinstalladd
+
+linux_clean:
+	$(MAKE) -C linux clean
+
+linux_cleanall:
+	$(MAKE) -C linux cleanall
+
+linux_require:
+	$(MAKE) -C linux require
+
+linux_info:
+	$(MAKE) -C linux info
+endif
+
+# Dir win32
+
+ifdef OBJECTDIRWIN32
+.PHONY:  win32_all win32_debug win32_examples win32_test win32_smart win32_shared win32_showinstall win32_install win32_sourceinstall win32_zipinstall win32_zipinstalladd win32_clean win32_cleanall win32_require win32_info
+
+win32_all:
+	$(MAKE) -C win32 all
+
+win32_debug:
+	$(MAKE) -C win32 debug
+
+win32_examples:
+	$(MAKE) -C win32 examples
+
+win32_test:
+	$(MAKE) -C win32 test
+
+win32_smart:
+	$(MAKE) -C win32 smart
+
+win32_shared:
+	$(MAKE) -C win32 shared
+
+win32_showinstall:
+	$(MAKE) -C win32 showinstall
+
+win32_install:
+	$(MAKE) -C win32 install
+
+win32_sourceinstall:
+	$(MAKE) -C win32 sourceinstall
+
+win32_zipinstall:
+	$(MAKE) -C win32 zipinstall
+
+win32_zipinstalladd:
+	$(MAKE) -C win32 zipinstalladd
+
+win32_clean:
+	$(MAKE) -C win32 clean
+
+win32_cleanall:
+	$(MAKE) -C win32 cleanall
+
+win32_require:
+	$(MAKE) -C win32 require
+
+win32_info:
+	$(MAKE) -C win32 info
+endif
+
+# Dir os2
+
+ifdef OBJECTDIROS2
+.PHONY:  os2_all os2_debug os2_examples os2_test os2_smart os2_shared os2_showinstall os2_install os2_sourceinstall os2_zipinstall os2_zipinstalladd os2_clean os2_cleanall os2_require os2_info
+
+os2_all:
+	$(MAKE) -C os2 all
+
+os2_debug:
+	$(MAKE) -C os2 debug
+
+os2_examples:
+	$(MAKE) -C os2 examples
+
+os2_test:
+	$(MAKE) -C os2 test
+
+os2_smart:
+	$(MAKE) -C os2 smart
+
+os2_shared:
+	$(MAKE) -C os2 shared
+
+os2_showinstall:
+	$(MAKE) -C os2 showinstall
+
+os2_install:
+	$(MAKE) -C os2 install
+
+os2_sourceinstall:
+	$(MAKE) -C os2 sourceinstall
+
+os2_zipinstall:
+	$(MAKE) -C os2 zipinstall
+
+os2_zipinstalladd:
+	$(MAKE) -C os2 zipinstalladd
+
+os2_clean:
+	$(MAKE) -C os2 clean
+
+os2_cleanall:
+	$(MAKE) -C os2 cleanall
+
+os2_require:
+	$(MAKE) -C os2 require
+
+os2_info:
+	$(MAKE) -C os2 info
+endif
+
+# Dir tests
+
+ifdef OBJECTDIRTESTS
+.PHONY:  tests_all tests_debug tests_examples tests_test tests_smart tests_shared tests_showinstall tests_install tests_sourceinstall tests_zipinstall tests_zipinstalladd tests_clean tests_cleanall tests_require tests_info
+
+tests_all:
+	$(MAKE) -C tests all
+
+tests_debug:
+	$(MAKE) -C tests debug
+
+tests_examples:
+	$(MAKE) -C tests examples
+
+tests_test:
+	$(MAKE) -C tests test
+
+tests_smart:
+	$(MAKE) -C tests smart
+
+tests_shared:
+	$(MAKE) -C tests shared
+
+tests_showinstall:
+	$(MAKE) -C tests showinstall
+
+tests_install:
+	$(MAKE) -C tests install
+
+tests_sourceinstall:
+	$(MAKE) -C tests sourceinstall
+
+tests_zipinstall:
+	$(MAKE) -C tests zipinstall
+
+tests_zipinstalladd:
+	$(MAKE) -C tests zipinstalladd
+
+tests_clean:
+	$(MAKE) -C tests clean
+
+tests_cleanall:
+	$(MAKE) -C tests cleanall
+
+tests_require:
+	$(MAKE) -C tests require
+
+tests_info:
+	$(MAKE) -C tests info
+endif
+

fcl/Makefile.fpc

@@ -0,0 +1,12 @@
+#
+#   Makefile.fpc for Free Component Library
+#
+
+[targets]
+dirs=go32v2 linux win32 os2 tests
+
+[sections]
+none=1
+
+[defaults]
+defaultdir=$(OS_TARGET)

fcl/db/Dataset.txt

@@ -0,0 +1,322 @@
+Contents
+========
+
++ General remarks
++ Fields system
++ The buffers
++ Dataset implementation
++ Scalable Datasets.
+
+===============
+General remarks
+===============
+
+- All fields and descendents implemented.
+- No calculated fields.
+- No Datasource yet. (although DataEvent is implemented in TField)
+- No persistent fields; this must be added later.
+
+
+=============
+Fields system
+=============
+
+Buffers are completely handled by the Dataset. Fields don't handle
+their own buffers. Only during validation, the FValueBuffer of the 
+field is used. 
+
+This allows the dataset to allocate a number of buffers for the current
+record and the N next records. (getnextrecords/getpriorrecords method)
+
+This means that all field mechanisms MUST pass through GetData/SetData,
+since FValueBuffer is only valid during validation.
+
+===========
+The Buffers
+===========
+
+A buffer contains all the data for 1 record of the dataset, and also
+the bookmark information. (bookmarkinformation is REQUIRED)
+
+The dataset allocates by default 'DefultBufferCount+1' records(buffers)
+This constant can be changed, at the beginning of dataset.inc;
+if you know you'll be working with big datasets, you can 
+increase this constant.
+
+The buffers are stored as pchars in the FBuffers array;
+The following constants are userd when handling this array:
+
+FBuffercount : The number of buffers allocated, minus one.
+FRecordCount : The number of buffers that is actually filled in.
+FActiveBuffer : The index of the active record.
+FCurrentRecord : The current Buffer. Should be phased out.
+
+So the following picture follows from this:
+
++---------------+
+|  0            |
++---------------+
+|  1            |
++---------------+
+|               |
+   ...
+|               |
++---------------+
+| FActivebuffer |
++---------------+
+|               |
+    ...
+|               |
++---------------+
+|FRecordCount-1 |
++---------------+
+|               |
+  ...
+|               |
++---------------+
+| FBufferCount  |
++---------------+ 
+
+The array is zero based. 
+
+The following methods are used to manipulate the array:
+
+GetNextRecords: Tries to fill up the entire array, going forward
+GetPriorRecords: tries to fill up the entire array, going backward
+GetNextRecord: gets the next record. Shifts the array if FrecordCount=BufferCount-1
+GetPriorRecord: gets the previous record. Shifts the array if FrecordCount=BufferCount-1
+
+For the last 2 methods: the underlying record pointer must be on the 
+last/first record in the dataset, or it will go wrong.
+
+resync tries to refresh the array from the underlying dataset; it uses the
+bookmarks for that.
+
+=======================
+Dataset implementations
+=======================
+
+TDataset does most of the work associated with fields, buffers and
+navigating/editing/adding/removing records of some source of data. 
+There are, however, some methods that need to be filled in so that 
+a real TDataset can be implemented. 
+
+In order to have a working Dataset, the following Methods  need to be 
+overridden in order to make a dataset descendant:
+
+function AllocRecordBuffer: PChar; virtual; abstract;
+-----------------------------------------------------
+
+Must allocate enough memory to store a complete record in the dataset.
+Optionally, this buffer must contain enough memory to store bookmarkdata.
+The descendent must be able to construct a bookmark from this buffer.
+
+procedure FreeRecordBuffer(var Buffer: PChar); virtual; abstract;
+-----------------------------------------------------------------
+
+Must free the memory allocated in the AllocRecordBuffer call.
+
+procedure GetBookmarkData(Buffer: PChar; Data: Pointer); virtual; abstract;
+---------------------------------------------------------------------------
+
+Puts the bookmarkdata for Buffer into the area pointed to by Data.
+
+function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; virtual; abstract;
+--------------------------------------------------------------------------
+
+Returns the bookmarkflag associated with Buffer.
+
+function GetFieldData(Field: TField; Buffer: Pointer): Boolean; virtual; abstract;
+----------------------------------------------------------------------------------
+
+Puts the data for field Field from the active buffer into Buffer. 
+This is called whenever a field value is demanded, so it must be
+efficient. 
+
+function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; virtual; abstract;
+-----------------------------------------------------------------------------------
+
+This method must do 3 things:
+1) Get the record data for the next/current/previous record, depending
+   on the GetMode value. It should return 
+    grOK    if all was OK.
+    grBOF   if the previous record was requested, and we are at the start. 
+    grEOF   if the next record was requested, and we are at the end.
+    grError if an error occurred.
+   
+2) If DoCheck is True, and the result is grError, then an exception must be
+    raised.
+
+3) It should initialize bookmark data for this record with flag 'bfCurrent'
+   This data can be stored in the bufer, if space was allocated for it with
+   AllocRecordBuffer.
+ 
+function GetRecordSize: Word; virtual; abstract;
+------------------------------------------------
+
+Should return the record size; this includes ONLY the data portion
+of teh buffer; it excludes any bookmark or housekeeping info you may
+have put in the buffer.
+
+procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); virtual; abstract;
+---------------------------------------------------------------------------------
+
+Adds a record to the dataset. The record's data is in Buffer and Append
+indicates whether the record should be appended (True) or Inserted (False).
+Note that for SQL based datasets, this has no meaning.
+
+procedure InternalClose; virtual; abstract;
+-------------------------------------------
+
+Closes the dataset. Any resources allocated in InternalOpen should be freed
+here.
+
+procedure InternalDelete; virtual; abstract;
+--------------------------------------------
+
+Deletes the current Record.
+
+procedure InternalFirst; virtual; abstract;
+-------------------------------------------
+
+This is called when 'First' is called; After this method, getrecord
+should return 'grBOF' if the previous record is requested, and it should
+return the next record if the next record is requested.
+
+procedure InternalGotoBookmark(ABookmark: Pointer); virtual; abstract;
+----------------------------------------------------------------------
+
+Set the record position on the position that is associated with the
+ABookMark data. The ABookMark data is the data that is acquired through
+the GetBookMarkData call, and should be kept for each record.
+
+procedure InternalHandleException; virtual; abstract;
+-----------------------------------------------------
+
+Not needed yet. Just implement an empty call.
+
+procedure InternalInitFieldDefs; virtual; abstract;
+---------------------------------------------------
+
+This method should be called from InternalOpen, and should
+initialize FieldDef definitions for all fields in a record.
+It should add these definitions to the FFielddefs object.
+
+
+procedure InternalInitRecord(Buffer: PChar); virtual; abstract;
+---------------------------------------------------------------
+
+This method is called to initialize a field buffer when the dataset
+is put into edit or append mode. Mostly,you'll want to zero out the 
+buffer.
+
+procedure InternalLast; virtual; abstract;
+------------------------------------------
+
+This is called when 'Last' is called; After this method, getrecord
+should return 'grEOF' if the next record is requested, and it should
+return the last record if the previous record is requested.
+
+procedure InternalOpen; virtual; abstract;
+------------------------------------------
+
+Open the dataset. You must call internalinitfielddefs; 
+if DefaultFields is True, then you must call CreateFields,
+which will create the necessary TFields from the fielddefs.
+
+procedure InternalPost; virtual; abstract;
+------------------------------------------
+
+Post the data in the active buffer to the underlying dataset.
+
+procedure InternalSetToRecord(Buffer: PChar); virtual; abstract;
+----------------------------------------------------------------
+
+Set the current record to the record in Buffer; if bookmark data 
+is specified in this buffer, that data can be used to determine which 
+record this should be.
+
+function IsCursorOpen: Boolean; virtual; abstract;
+--------------------------------------------------
+
+This function should return True if data is available, even if the dataset
+is not active.
+
+procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); virtual; abstract;
+----------------------------------------------------------------------------------
+
+Set the bookmarkflag 'Value' on the data in Buffer.
+
+procedure SetBookmarkData(Buffer: PChar; Data: Pointer); virtual; abstract;
+---------------------------------------------------------------------------
+
+Move the bookmarkdata in 'Data' to the bookmarkdata associated with Buffer
+
+procedure SetFieldData(Field: TField; Buffer: Pointer); virtual; abstract;
+--------------------------------------------------------------------------
+
+Move the data in associated with Field from Buffer to the activebuffer.
+
+=================
+Scalable datasets
+=================
+
+In order to have Scalable database access, the concept of TDatabase and
+TDBDataset is introduced. The idea is that, in a visual IDE, the change
+from one database to another is achieved by simply removing one TDatabase
+descendent (Say, TMySqlDatabase) with another (Say, TPostGreSQLDatabase)
+and that the Datasets remain untouched.
+
+In order to make this possible, the following scheme is used:
+
+when a TDBdataset descendant is put on Active, it requests a TRecordSet
+from the TDatabase. The TRecordSet is an abstract object that should be
+implemented together with each database. The TDBDataset then uses the
+TRecordSet to navigate through the records and edit/add/modify them.
+The TDBdataset implements the abstract methods of Tdataset in order to
+achive this.
+
+There will be 2 descendants of TDBdataset: TTable and TQuery; both will
+implement the last abstract methods of TDataset in order to achieve a
+complete TDataset implementation.
+
+TDBDataset implements most of the initialization of fields, so the
+implementation of TRecordSet will be as bare bones as possible.
+
+What is needed:
+---------------
+
+Some properties describing the data:
+
+FieldCount : Number of fields in a record;
+FieldTypes[Index] : Types of the fields (TFieldType), zero based.
+FieldNames[Index] : Names of the fields. Zero based.
+FieldSizes[index] : Size of the fields, zero based.
+BookmarkSize        : Size of a bookmark.
+
+Some properties with the data content:
+
+FieldBuffers[Index] : Buffers containing the actual data of the current record.
+                      (Nil if the field is empty)
+                      This data should be of size indicated FieldSizes, and 
+                      in a format that matches the fieldtype.
+BookMarkBuffer      : Buffer with the current bookmark.
+
+Some methods
+------------
+
+
+OpenRecordSet : Opens the recordset; it should initialize the FieldCount 
+                and FieldTypes, FieldNames, and FieldSizes array data.
+
+CloseRecordSet : Do whatever is needed to close the recordset.
+
+GotoBookMark : go to the record described by the bookmark. Returns True
+               if successfull, false if not.
+
+Next  : Goto the next record. Returns true or false 
+Prior : Goto previous record. Returns true or false
+First : Goto the first record. Returns True or false
+Last  : Goto the last record. Returns True or False
+
+AppendBuffer : Append a buffer to the records.

fcl/db/Makefile

@@ -0,0 +1,1154 @@
+#
+# Makefile generated by fpcmake v0.99.13 [2000/01/06]
+#
+
+defaultrule: all
+
+#####################################################################
+# Autodetect OS (Linux or Dos or Windows NT)
+# define inlinux when running under linux
+# define inWinNT when running under WinNT
+#####################################################################
+
+# We need only / in the path
+override PATH:=$(subst \,/,$(PATH))
+
+# Search for PWD and determine also if we are under linux
+PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH)))))
+ifeq ($(PWD),)
+PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH)))))
+ifeq ($(PWD),)
+nopwd:
+	@echo You need the GNU utils package to use this Makefile!
+	@echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip
+	@exit
+else
+inlinux=1
+endif
+else
+PWD:=$(firstword $(PWD))
+endif
+
+# Detect NT - NT sets OS to Windows_NT
+ifndef inlinux
+ifeq ($(OS),Windows_NT)
+inWinNT=1
+endif
+endif
+
+# Detect OS/2 - OS/2 has OS2_SHELL defined
+ifndef inlinux
+ifndef inWinNT
+ifdef OS2_SHELL
+inOS2=1
+endif
+endif
+endif
+
+# The extension of executables
+ifdef inlinux
+EXEEXT=
+else
+EXEEXT=.exe
+endif
+
+# The path which is searched separated by spaces
+ifdef inlinux
+SEARCHPATH=$(subst :, ,$(PATH))
+else
+SEARCHPATH=$(subst ;, ,$(PATH))
+endif
+
+#####################################################################
+# Default target
+#####################################################################
+
+override CPU_TARGET:=i386
+
+#####################################################################
+# FPC version/target Detection
+#####################################################################
+
+# What compiler to use ?
+ifndef FPC
+# Compatibility with old makefiles
+ifdef PP
+FPC=$(PP)
+else
+ifdef inOS2
+FPC=ppos2$(EXEEXT)
+else
+FPC=ppc386$(EXEEXT)
+endif
+endif
+endif
+
+# Target OS
+ifndef OS_TARGET
+OS_TARGET:=$(shell $(FPC) -iTO)
+endif
+
+# Source OS
+ifndef OS_SOURCE
+OS_SOURCE:=$(shell $(FPC) -iSO)
+endif
+
+# Target CPU
+ifndef CPU_TARGET
+CPU_TARGET:=$(shell $(FPC) -iTP)
+endif
+
+# Source CPU
+ifndef CPU_SOURCE
+CPU_SOURCE:=$(shell $(FPC) -iSP)
+endif
+
+# FPC version
+ifndef FPC_VERSION
+FPC_VERSION:=$(shell $(FPC) -iV)
+endif
+
+export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION
+
+# Test FPCDIR to look if the RTL dir exists
+ifdef FPCDIR
+override FPCDIR:=$(subst \,/,$(FPCDIR))
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+else
+override FPCDIR=wrong
+endif
+
+# Default FPCDIR
+ifeq ($(FPCDIR),wrong)
+override FPCDIR=../..
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+endif
+
+# Detect FPCDIR
+ifeq ($(FPCDIR),wrong)
+ifdef inlinux
+override FPCDIR=/usr/lib/fpc/$(FPC_VERSION)
+else
+override FPCDIR:=$(subst /$(FPC)$(EXEEXT),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC)$(EXEEXT),$(SEARCHPATH))))))
+endif
+endif
+
+ifndef PACKAGEDIR
+PACKAGEDIR=$(FPCDIR)/packages
+endif
+ifndef COMPONENTDIR
+COMPONENTDIR=$(FPCDIR)/components
+endif
+# Check if packagedir really exists else turn it off
+ifeq ($(wildcard $(PACKAGEDIR)),)
+PACKAGEDIR=
+endif
+ifeq ($(wildcard $(COMPONENTDIR)),)
+COMPONENTDIR=
+endif
+
+# Create rtl,units dir
+ifneq ($(FPCDIR),.)
+override UNITSDIR=$(FPCDIR)/units/$(OS_TARGET)
+ifneq ($(wildcard $(FPCDIR)/rtl),)
+override RTLDIR=$(FPCDIR)/rtl/$(OS_TARGET)
+else
+override RTLDIR=$(UNITSDIR)/rtl
+endif
+endif
+
+#####################################################################
+# Default Settings
+#####################################################################
+
+# Release ? Then force OPT and don't use extra opts via commandline
+ifndef REDIRFILE
+REDIRFILE=log
+endif
+
+ifdef REDIR
+ifndef inlinux
+override FPC=redir -eo $(FPC)
+endif
+# set the verbosity to max
+override OPT+=-va
+override REDIR:= >> $(REDIRFILE)
+endif
+
+#####################################################################
+# User Settings
+#####################################################################
+
+
+# Targets
+
+override UNITOBJECTS+=db ddg_ds ddg_rec mysqldb
+override EXAMPLEOBJECTS+=testds createds mtest tested
+
+# Clean
+
+
+# Install
+
+ZIPTARGET=install
+
+# Defaults
+
+override NEEDOPT=-S2
+
+# Directories
+
+ifndef TARGETDIR
+TARGETDIR=.
+endif
+
+# Packages
+
+override PACKAGES=rtl
+PACKAGEDIR_RTL=$(FPCDIR)/rtl/$(OS_TARGET)
+override PACKAGES+=fcl mysql
+ifneq ($(wildcard $(FPCDIR)/fcl),)
+ifneq ($(wildcard $(FPCDIR)/fcl/$(OS_TARGET)),)
+PACKAGEDIR_FCL=$(FPCDIR)/fcl/$(OS_TARGET)
+else
+PACKAGEDIR_FCL=$(FPCDIR)/fcl
+endif
+UNITDIR_FCL=$(PACKAGEDIR_FCL)
+else
+PACKAGEDIR_FCL=
+ifneq ($(wildcard $(UNITSDIR)/fcl),)
+ifneq ($(wildcard $(UNITSDIR)/fcl/$(OS_TARGET)),)
+UNITDIR_FCL=$(UNITSDIR)/fcl/$(OS_TARGET)
+else
+UNITDIR_FCL=$(UNITSDIR)/fcl
+endif
+else
+UNITDIR_FCL=
+endif
+endif
+ifdef UNITDIR_FCL
+override NEEDUNITDIR+=$(UNITDIR_FCL)
+endif
+ifneq ($(wildcard $(PACKAGEDIR)/mysql),)
+ifneq ($(wildcard $(PACKAGEDIR)/mysql/$(OS_TARGET)),)
+PACKAGEDIR_MYSQL=$(PACKAGEDIR)/mysql/$(OS_TARGET)
+else
+PACKAGEDIR_MYSQL=$(PACKAGEDIR)/mysql
+endif
+UNITDIR_MYSQL=$(PACKAGEDIR_MYSQL)
+else
+PACKAGEDIR_MYSQL=
+ifneq ($(wildcard $(UNITSDIR)/mysql),)
+ifneq ($(wildcard $(UNITSDIR)/mysql/$(OS_TARGET)),)
+UNITDIR_MYSQL=$(UNITSDIR)/mysql/$(OS_TARGET)
+else
+UNITDIR_MYSQL=$(UNITSDIR)/mysql
+endif
+else
+UNITDIR_MYSQL=
+endif
+endif
+ifdef UNITDIR_MYSQL
+override NEEDUNITDIR+=$(UNITDIR_MYSQL)
+endif
+
+# Libraries
+
+override NEEDGCCLIB=1
+
+# Info
+
+INFOTARGET=fpc_infocfg fpc_infoobjects fpc_infoinstall 
+
+#####################################################################
+# Default Directories
+#####################################################################
+
+# Base dir
+ifdef PWD
+BASEDIR:=$(shell $(PWD))
+else
+BASEDIR=.
+endif
+
+# set the prefix directory where to install everything
+ifndef PREFIXINSTALLDIR
+ifdef inlinux
+PREFIXINSTALLDIR=/usr
+else
+PREFIXINSTALLDIR=/pp
+endif
+endif
+export PREFIXINSTALLDIR
+
+# On linux, try to find where libgcc.a is.
+ifdef inlinux
+ifndef GCCLIBDIR
+GCCLIBDIR:=$(shell dirname `(gcc -v 2>&1)| head -n 1| awk '{ print $$4 } '`)
+endif
+endif
+export GCCLIBDIR
+
+#####################################################################
+# Install Directories
+#####################################################################
+
+# set the base directory where to install everything
+ifndef BASEINSTALLDIR
+ifdef inlinux
+BASEINSTALLDIR=$(PREFIXINSTALLDIR)/lib/fpc/$(FPC_VERSION)
+else
+BASEINSTALLDIR=$(PREFIXINSTALLDIR)
+endif
+endif
+
+# set the directory where to install the binaries
+ifndef BININSTALLDIR
+ifdef inlinux
+BININSTALLDIR=$(PREFIXINSTALLDIR)/bin
+else
+BININSTALLDIR=$(BASEINSTALLDIR)/bin/$(OS_TARGET)
+endif
+endif
+
+# set the directory where to install the units.
+ifndef UNITINSTALLDIR
+UNITINSTALLDIR=$(BASEINSTALLDIR)/units/$(OS_TARGET)
+ifdef UNITSUBDIR
+UNITINSTALLDIR:=$(UNITINSTALLDIR)/$(UNITSUBDIR)
+endif
+endif
+
+# Where to install shared libraries
+ifndef LIBINSTALLDIR
+ifdef inlinux
+LIBINSTALLDIR=$(PREFIXINSTALLDIR)/lib
+else
+LIBINSTALLDIR=$(UNITINSTALLDIR)
+endif
+endif
+
+# Where the source files will be stored
+ifndef SOURCEINSTALLDIR
+ifdef inlinux
+SOURCEINSTALLDIR=$(PREFIXINSTALLDIR)/src/fpc-$(FPC_VERSION)
+else
+SOURCEINSTALLDIR=$(BASEINSTALLDIR)/source
+endif
+endif
+
+# Where the doc files will be stored
+ifndef DOCINSTALLDIR
+ifdef inlinux
+DOCINSTALLDIR=$(PREFIXINSTALLDIR)/doc/fpc-$(FPC_VERSION)
+else
+DOCINSTALLDIR=$(BASEINSTALLDIR)/doc
+endif
+endif
+
+# Where the some extra (data)files will be stored
+ifndef DATAINSTALLDIR
+DATAINSTALLDIR=$(BASEINSTALLDIR)
+endif
+
+
+#####################################################################
+# Compiler Command Line
+#####################################################################
+
+# Load commandline OPTDEF and add FPC_CPU define
+override FPCOPTDEF:=-d$(CPU_TARGET)
+
+# Load commandline OPT and add target and unit dir to be sure
+ifneq ($(OS_TARGET),$(OS_SOURCE))
+override FPCOPT+=-T$(OS_TARGET)
+endif
+
+ifdef NEEDOPT
+override FPCOPT+=$(NEEDOPT)
+endif
+
+ifdef UNITSDIR
+override FPCOPT+=-Fu$(UNITSDIR)
+endif
+
+ifdef RTLDIR
+override FPCOPT+=-Fu$(RTLDIR)
+endif
+
+ifdef NEEDUNITDIR
+override FPCOPT+=$(addprefix -Fu,$(NEEDUNITDIR))
+endif
+
+# Add GCC lib path if asked
+ifdef GCCLIBDIR
+override FPCOPT+=-Fl$(GCCLIBDIR)
+endif
+
+# Target dirs
+ifdef TARGETDIR
+override FPCOPT+=-FE$(TARGETDIR)
+endif
+
+# Smartlinking
+ifdef SMARTLINK
+override FPCOPT+=-CX
+endif
+
+# Debug
+ifdef DEBUG
+override FPCOPT+=-g
+endif
+
+# Release mode (strip, optimize and don't load ppc386.cfg)
+ifdef RELEASE
+override FPCOPT+=-Xs -OG2p3 -n
+endif
+
+# Verbose settings (warning,note,info)
+ifdef VERBOSE
+override FPCOPT+=-vwni
+endif
+
+# Add commandline options
+ifdef OPT
+override FPCOPT+=$(OPT)
+endif
+ifdef UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
+endif
+ifdef LIBDIR
+override FPCOPT+=$(addprefix -Fl,$(LIBDIR))
+endif
+ifdef OBJDIR
+override FPCOPT+=$(addprefix -Fo,$(OBJDIR))
+endif
+ifdef INCDIR
+override FPCOPT+=$(addprefix -Fi,$(INCDIR))
+endif
+
+# Add defines from FPCOPTDEF to FPCOPT
+ifdef FPCOPTDEF
+override FPCOPT+=$(FPCOPTDEF)
+endif
+
+# Error file ?
+ifdef ERRORFILE
+override FPCOPT+=-Fr$(ERRORFILE)
+endif
+
+# Was a config file specified ?
+ifdef CFGFILE
+override FPCOPT+=@$(CFGFILE)
+endif
+
+# For win32 the options are passed using the environment variable FPCEXTCMD
+ifeq ($(OS_SOURCE),win32)
+override FPCEXTCMD:=$(FPCOPT)
+override FPCOPT:=!FPCEXTCMD
+export FPCEXTCMD
+endif
+
+# Compiler commandline
+override COMPILER:=$(FPC) $(FPCOPT)
+
+#####################################################################
+# Shell tools
+#####################################################################
+
+# To copy pograms
+ifndef COPY
+COPY:=cp -fp
+endif
+
+# Copy a whole tree
+ifndef COPYTREE
+COPYTREE:=cp -rfp
+endif
+
+# To move pograms
+ifndef MOVE
+MOVE:=mv -f
+endif
+
+# Check delete program
+ifndef DEL
+DEL:=rm -f
+endif
+
+# Check deltree program
+ifndef DELTREE
+DELTREE:=rm -rf
+endif
+
+# To install files
+ifndef INSTALL
+ifdef inlinux
+INSTALL:=install -m 644
+else
+INSTALL:=$(COPY)
+endif
+endif
+
+# To install programs
+ifndef INSTALLEXE
+ifdef inlinux
+INSTALLEXE:=install -m 755
+else
+INSTALLEXE:=$(COPY)
+endif
+endif
+
+# To make a directory.
+ifndef MKDIR
+ifdef inlinux
+MKDIR:=install -m 755 -d
+else
+MKDIR:=ginstall -m 755 -d
+endif
+endif
+
+export COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR
+
+#####################################################################
+# Default Tools
+#####################################################################
+
+# assembler, redefine it if cross compiling
+ifndef AS
+AS=as
+endif
+
+# linker, but probably not used
+ifndef LD
+LD=ld
+endif
+
+# ppas.bat / ppas.sh
+ifdef inlinux
+PPAS=ppas.sh
+else
+ifdef inOS2
+PPAS=ppas.cmd
+else
+PPAS=ppas.bat
+endif
+endif
+
+# also call ppas if with command option -s
+ifeq (,$(findstring -s ,$(COMPILER)))
+EXECPPAS=
+else
+EXECPPAS:=@$(PPAS)
+endif
+
+# ldconfig to rebuild .so cache
+ifdef inlinux
+LDCONFIG=ldconfig
+else
+LDCONFIG=
+endif
+
+# echo
+ifndef ECHO
+ECHO:=$(strip $(wildcard $(addsuffix /echo$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO:=echo
+else
+ECHO:=$(firstword $(ECHO))
+endif
+endif
+export ECHO
+
+# ppdep
+ifndef PPDEP
+PPDEP:=$(strip $(wildcard $(addsuffix /ppdep$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPDEP),)
+PPDEP=
+else
+PPDEP:=$(firstword $(PPDEP))
+endif
+endif
+export PPDEP
+
+# ppumove
+ifndef PPUMOVE
+PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUMOVE),)
+PPUMOVE=
+else
+PPUMOVE:=$(firstword $(PPUMOVE))
+endif
+endif
+export PPUMOVE
+
+# ppufiles
+ifndef PPUFILES
+PPUFILES:=$(strip $(wildcard $(addsuffix /ppufiles$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUFILES),)
+PPUFILES=
+else
+PPUFILES:=$(firstword $(PPUFILES))
+endif
+endif
+export PPUFILES
+
+# Look if UPX is found for go32v2 and win32. We can't use $UPX becuase
+# upx uses that one itself (PFV)
+ifndef UPXPROG
+ifeq ($(OS_TARGET),go32v2)
+UPXPROG:=1
+endif
+ifeq ($(OS_TARGET),win32)
+UPXPROG:=1
+endif
+ifdef UPXPROG
+UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(UPXPROG),)
+UPXPROG=
+else
+UPXPROG:=$(firstword $(UPXPROG))
+endif
+else
+UPXPROG=
+endif
+endif
+export UPXPROG
+
+# gdate/date
+ifndef DATE
+DATE:=$(strip $(wildcard $(addsuffix /date$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE:=$(strip $(wildcard $(addsuffix /gdate$(EXEEXT),$(SEACHPATH))))
+ifeq ($(DATE),)
+DATE=
+else
+DATE:=$(firstword $(DATE))
+endif
+else
+DATE:=$(firstword $(DATE))
+endif
+endif
+export DATE
+
+ifdef DATE
+DATESTR:=$(shell $(DATE) +%Y%m%d)
+else
+DATESTR=
+endif
+
+# ZipProg, you can't use Zip as the var name (PFV)
+ifndef ZIPPROG
+ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(ZIPPROG),)
+ZIPPROG=
+else
+ZIPPROG:=$(firstword $(ZIPPROG)) -D9 -r
+endif
+endif
+export ZIPPROG
+
+ifndef ZIPEXT
+ZIPEXT=.zip
+endif
+
+#####################################################################
+# Default extensions
+#####################################################################
+
+# Default needed extensions (Go32v2,Linux)
+LOADEREXT=.as
+PPLEXT=.ppl
+PPUEXT=.ppu
+OEXT=.o
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.so
+RSTEXT=.rst
+PACKAGESUFFIX=
+FPCMADE=fpcmade
+
+# Go32v1
+ifeq ($(OS_TARGET),go32v1)
+PPUEXT=.pp1
+OEXT=.o1
+ASMEXT=.s1
+SMARTEXT=.sl1
+STATICLIBEXT=.a1
+SHAREDLIBEXT=.so1
+PACKAGESUFFIX=v1
+FPCMADE=fpcmade.v1
+endif
+
+# Go32v2
+ifeq ($(OS_TARGET),go32v2)
+PACKAGESUFFIX=go32
+FPCMADE=fpcmade.dos
+endif
+
+# Linux
+ifeq ($(OS_TARGET),linux)
+PACKAGESUFFIX=linux
+FPCMADE=fpcmade.lnx
+endif
+
+# Win32
+ifeq ($(OS_TARGET),win32)
+PPUEXT=.ppw
+OEXT=.ow
+ASMEXT=.sw
+SMARTEXT=.slw
+STATICLIBEXT=.aw
+SHAREDLIBEXT=.dll
+PACKAGESUFFIX=win32
+FPCMADE=fpcmade.w32
+endif
+
+# OS/2
+ifeq ($(OS_TARGET),os2)
+PPUEXT=.ppo
+ASMEXT=.so2
+OEXT=.oo2
+SMARTEXT=.so
+STATICLIBEXT=.ao2
+SHAREDLIBEXT=.dll
+PACKAGESUFFIX=os2
+FPCMADE=fpcmade.os2
+endif
+
+# library prefix
+LIBPREFIX=lib
+ifeq ($(OS_TARGET),go32v2)
+LIBPREFIX=
+endif
+ifeq ($(OS_TARGET),go32v1)
+LIBPREFIX=
+endif
+
+# determine which .pas extension is used
+ifndef PASEXT
+ifdef EXEOBJECTS
+override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(EXEOBJECTS)))))
+else
+override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(UNITOBJECTS)))))
+endif
+ifeq ($(TESTPAS),)
+PASEXT=.pp
+else
+PASEXT=.pas
+endif
+endif
+
+#####################################################################
+# Standard rules
+#####################################################################
+
+all: fpc_all
+
+debug: fpc_debug
+
+examples: fpc_examples
+
+test: fpc_test
+
+smart: fpc_smart
+
+shared: fpc_shared
+
+showinstall: fpc_showinstall
+
+install: fpc_install
+
+sourceinstall: fpc_sourceinstall
+
+zipinstall: fpc_zipinstall
+
+zipinstalladd: fpc_zipinstalladd
+
+clean: fpc_clean
+
+cleanall: fpc_cleanall
+
+info: fpc_info
+
+.PHONY:  all debug examples test smart shared showinstall install sourceinstall zipinstall zipinstalladd clean cleanall info
+
+
+ifdef PACKAGERTL
+ifneq ($(wildcard $(PACKAGEDIR_RTL)),)
+ifeq ($(wildcard $(PACKAGEDIR_RTL)/$(FPCMADE)),)
+override COMPILEPACKAGES+=rtl
+rtl_package:
+	$(MAKE) -C $(PACKAGEDIR_RTL) all
+endif
+endif
+endif
+
+PACKAGEFCL=1
+PACKAGEMYSQL=1
+ifdef PACKAGEFCL
+ifneq ($(wildcard $(PACKAGEDIR_FCL)),)
+ifeq ($(wildcard $(PACKAGEDIR_FCL)/$(FPCMADE)),)
+override COMPILEPACKAGES+=fcl
+fcl_package:
+	$(MAKE) -C $(PACKAGEDIR_FCL) all
+endif
+endif
+endif
+ifdef PACKAGEMYSQL
+ifneq ($(wildcard $(PACKAGEDIR_MYSQL)),)
+ifeq ($(wildcard $(PACKAGEDIR_MYSQL)/$(FPCMADE)),)
+override COMPILEPACKAGES+=mysql
+mysql_package:
+	$(MAKE) -C $(PACKAGEDIR_MYSQL) all
+endif
+endif
+endif
+
+.PHONY:  rtl_package fcl_package mysql_package
+
+#####################################################################
+# Units
+#####################################################################
+
+.PHONY: fpc_units
+
+override ALLTARGET+=fpc_units
+
+override UNITPPUFILES=$(addsuffix $(PPUEXT),$(UNITOBJECTS))
+override INSTALLPPUFILES+=$(UNITPPUFILES)
+override CLEANPPUFILES+=$(UNITPPUFILES)
+
+fpc_units: $(UNITPPUFILES)
+
+#####################################################################
+# Examples
+#####################################################################
+
+.PHONY: fpc_examples fpc_test
+
+override EXAMPLEFILES:=$(addsuffix $(EXEEXT),$(EXAMPLEOBJECTS))
+override EXAMPLEOFILES:=$(addsuffix $(OEXT),$(EXAMPLEOBJECTS))
+
+override CLEANEXEFILES+=$(EXAMPLEFILES) $(EXAMPLEOFILES)
+
+fpc_examples: all $(EXAMPLEFILES)
+
+fpc_test: examples
+
+#####################################################################
+# General compile rules
+#####################################################################
+
+.PHONY: fpc_all fpc_debug
+
+$(FPCMADE):
+	@$(ECHO) Compiled > $(FPCMADE)
+
+fpc_all: $(addsuffix _package,$(COMPILEPACKAGES)) \
+	 $(addsuffix _component,$(COMPILECOMPONENTS)) \
+	 $(ALLTARGET) $(FPCMADE)
+
+fpc_debug:
+	$(MAKE) all DEBUG=1
+
+# General compile rules, available for both possible PASEXT
+
+.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp
+
+%$(PPUEXT): %.pp
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(PPUEXT): %.pas
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(EXEEXT): %.pp
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(EXEEXT): %.pas
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+#####################################################################
+# Library
+#####################################################################
+
+.PHONY: fpc_smart fpc_shared
+
+# Default sharedlib units are all unit objects
+ifndef SHAREDLIBUNITOBJECTS
+SHAREDLIBUNITOBJECTS:=$(UNITOBJECTS)
+endif
+
+fpc_smart:
+	$(MAKE) all SMARTLINK=1
+
+fpc_shared: all
+ifdef inlinux
+ifndef LIBNAME
+	@$(ECHO) "LIBNAME not set"
+else
+	$(PPUMOVE) $(SHAREDLIBUNITOBJECTS) -o$(LIBNAME)
+endif
+else
+	@$(ECHO) "Shared Libraries not supported"
+endif
+
+#####################################################################
+# Install rules
+#####################################################################
+
+.PHONY: fpc_showinstall fpc_install
+
+ifdef EXTRAINSTALLUNITS
+override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRAINSTALLUNITS))
+endif
+
+ifdef INSTALLPPUFILES
+ifdef PPUFILES
+ifdef inlinux
+INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
+INSTALLPPULIBFILES:=$(shell $(PPUFILES) -L $(INSTALLPPUFILES))
+else
+INSTALLPPULINKFILES:=$(shell $(PPUFILES) $(INSTALLPPUFILES))
+endif
+else
+INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
+endif
+endif
+
+fpc_showinstall: $(SHOWINSTALLTARGET)
+ifdef INSTALLEXEFILES
+	@$(ECHO) -e $(addprefix "\n"$(BININSTALLDIR)/,$(INSTALLEXEFILES))
+endif
+ifdef INSTALLPPUFILES
+	@$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPUFILES))
+ifneq ($(INSTALLPPULINKFILES),)
+	@$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPULINKFILES))
+endif
+ifneq ($(INSTALLPPULIBFILES),)
+	@$(ECHO) -e $(addprefix "\n"$(LIBINSTALLDIR)/,$(INSTALLPPULIBFILES))
+endif
+endif
+ifdef EXTRAINSTALLFILES
+	@$(ECHO) -e $(addprefix "\n"$(DATAINSTALLDIR)/,$(EXTRAINSTALLFILES))
+endif
+
+fpc_install: $(INSTALLTARGET)
+# Create UnitInstallFiles
+ifdef INSTALLEXEFILES
+	$(MKDIR) $(BININSTALLDIR)
+# Compress the exes if upx is defined
+ifdef UPXPROG
+	-$(UPXPROG) $(INSTALLEXEFILES)
+endif
+	$(INSTALLEXE) $(INSTALLEXEFILES) $(BININSTALLDIR)
+endif
+ifdef INSTALLPPUFILES
+	$(MKDIR) $(UNITINSTALLDIR)
+	$(INSTALL) $(INSTALLPPUFILES) $(UNITINSTALLDIR)
+ifneq ($(INSTALLPPULINKFILES),)
+	$(INSTALL) $(INSTALLPPULINKFILES) $(UNITINSTALLDIR)
+endif
+ifneq ($(INSTALLPPULIBFILES),)
+	$(MKDIR) $(LIBINSTALLDIR)
+	$(INSTALL) $(INSTALLPPULIBFILES) $(LIBINSTALLDIR)
+endif
+endif
+ifdef EXTRAINSTALLFILES
+	$(MKDIR) $(DATAINSTALLDIR)
+	$(INSTALL) $(EXTRAINSTALLFILES) $(DATAINSTALLDIR)
+endif
+
+#####################################################################
+# Source install rules
+#####################################################################
+
+.PHONY: fpc_sourceinstall
+
+fpc_sourceinstall: clean
+	$(MKDIR) $(SOURCEINSTALLDIR)
+	$(COPYTREE) $(BASEDIR) $(SOURCEINSTALLDIR)
+
+#####################################################################
+# Zip
+#####################################################################
+
+.PHONY: fpc_zipinstall fpc_zipinstalladd
+
+# Temporary path to pack a file
+ifndef PACKDIR
+ifndef inlinux
+PACKDIR=pack_tmp
+else
+PACKDIR=/tmp/fpc-pack
+endif
+endif
+
+# Test dir if none specified
+ifndef DESTZIPDIR
+DESTZIPDIR:=$(BASEDIR)
+endif
+
+# Add .zip/.tar.gz extension
+ifdef ZIPNAME
+ifndef inlinux
+override ZIPNAME:=$(ZIPNAME)$(ZIPEXT)
+endif
+endif
+
+# Note: This will not remove the zipfile first
+fpc_zipinstalladd:
+ifndef ZIPNAME
+	@$(ECHO) "Please specify ZIPNAME!"
+	@exit 1
+else
+	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
+ifdef inlinux
+	gzip -d $(DESTZIPDIR)/$(ZIPNAME).tar.gz
+	cd $(PACKDIR) ; tar rv --file $(DESTZIPDIR)/$(ZIPNAME).tar * ; cd $(BASEDIR)
+	gzip $(DESTZIPDIR)/$(ZIPNAME).tar
+else
+	cd $(PACKDIR) ; $(ZIPPROG) $(DESTZIPDIR)/$(ZIPNAME) * ; cd $(BASEDIR)
+endif
+	$(DELTREE) $(PACKDIR)
+endif
+
+# First remove the zip and then install
+fpc_zipinstall:
+ifndef ZIPNAME
+	@$(ECHO) "Please specify ZIPNAME!"
+	@exit 1
+else
+	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)
+	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
+ifdef inlinux
+	cd $(PACKDIR) ; tar cvz --file $(DESTZIPDIR)/$(ZIPNAME).tar.gz * ; cd $(BASEDIR)
+else
+	cd $(PACKDIR) ; $(ZIPPROG) $(DESTZIPDIR)/$(ZIPNAME) * ; cd $(BASEDIR)
+endif
+	$(DELTREE) $(PACKDIR)
+endif
+
+#####################################################################
+# Clean rules
+#####################################################################
+
+.PHONY: fpc_clean fpc_cleanall
+
+ifdef EXTRACLEANUNITS
+override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRACLEANUNITS))
+endif
+
+ifdef CLEANPPUFILES
+ifdef PPUFILES
+CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
+else
+CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
+endif
+endif
+
+fpc_clean: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+ifdef CLEANPPUFILES
+	-$(DEL) $(CLEANPPUFILES)
+endif
+ifneq ($(CLEANPPULINKFILES),)
+	-$(DEL) $(CLEANPPULINKFILES)
+endif
+ifdef CLEANRSTFILES
+	-$(DEL) $(CLEANRSTFILES)
+endif
+ifdef EXTRACLEANFILES
+	-$(DEL) $(EXTRACLEANFILES)
+endif
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(REDIRFILE)
+
+fpc_cleanall: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+	-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+	-$(DELTREE) *$(SMARTEXT)
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(REDIRFILE)
+
+#####################################################################
+# Info rules
+#####################################################################
+
+.PHONY: fpc_info fpc_cfginfo fpc_objectinfo fpc_toolsinfo fpc_installinfo \
+	fpc_dirinfo
+
+fpc_info: $(INFOTARGET)
+
+fpc_infocfg:
+	@$(ECHO)
+	@$(ECHO)  == Configuration info ==
+	@$(ECHO)
+	@$(ECHO)  FPC....... $(FPC)
+	@$(ECHO)  Version... $(FPC_VERSION)
+	@$(ECHO)  CPU....... $(CPU_TARGET)
+	@$(ECHO)  Source.... $(OS_SOURCE)
+	@$(ECHO)  Target.... $(OS_TARGET)
+	@$(ECHO)
+
+fpc_infoobjects:
+	@$(ECHO)
+	@$(ECHO)  == Object info ==
+	@$(ECHO)
+	@$(ECHO)  LoaderObjects..... $(LOADEROBJECTS)
+	@$(ECHO)  UnitObjects....... $(UNITOBJECTS)
+	@$(ECHO)  ExeObjects........ $(EXEOBJECTS)
+	@$(ECHO)
+	@$(ECHO)  ExtraCleanUnits... $(EXTRACLEANUNITS)
+	@$(ECHO)  ExtraCleanFiles... $(EXTRACLEANFILES)
+	@$(ECHO)
+	@$(ECHO)  ExtraInstallUnits. $(EXTRAINSTALLUNITS)
+	@$(ECHO)  ExtraInstallFiles. $(EXTRAINSTALLFILES)
+	@$(ECHO)
+
+fpc_infoinstall:
+	@$(ECHO)
+	@$(ECHO)  == Install info ==
+	@$(ECHO)
+ifdef DATE
+	@$(ECHO)  DateStr.............. $(DATESTR)
+endif
+	@$(ECHO)  PackageSuffix........ $(PACKAGESUFFIX)
+	@$(ECHO)
+	@$(ECHO)  BaseInstallDir....... $(BASEINSTALLDIR)
+	@$(ECHO)  BinInstallDir........ $(BININSTALLDIR)
+	@$(ECHO)  LibInstallDir........ $(LIBINSTALLDIR)
+	@$(ECHO)  UnitInstallDir....... $(UNITINSTALLDIR)
+	@$(ECHO)  SourceInstallDir..... $(SOURCEINSTALLDIR)
+	@$(ECHO)  DocInstallDir........ $(DOCINSTALLDIR)
+	@$(ECHO)  DataInstallDir....... $(DATAINSTALLDIR)
+	@$(ECHO)
+
+#####################################################################
+# Users rules
+#####################################################################
+
+db$(PPUEXT): db.pp fields.inc dataset.inc dbs.inc
+
+ddg_ds$(PPUEXT): db$(PPUEXT) ddg_rec$(PPUEXT) ddg_ds$(PASEXT)
+
+testds$(EXEEXT): ddg_ds$(PPUEXT) testds$(PASEXT)
+
+tested$(EXEEXT): ddg_ds$(PPUEXT) tested$(PASEXT)
+
+createds$(EXEEXT): createds$(PASEXT) ddg_rec$(PPUEXT)
+
+mysqldb$(PPUEXT): db$(PPUEXT) mysqldb$(PASEXT)
+
+mtest$(EXEEXT): mysqldb$(PPUEXT) mtest$(PASEXT)

fcl/db/Makefile.fpc

@@ -0,0 +1,37 @@
+#
+#   Makefile.fpc for TDataSet for FCL
+#
+
+[targets]
+units=db ddg_ds ddg_rec mysqldb
+examples=testds createds mtest tested
+
+[defaults]
+defaultcpu=i386
+
+[require]
+options=-S2
+packages=fcl mysql
+
+[dirs]
+fpcdir=../..
+targetdir=.
+
+[libs]
+libgcc=1
+
+
+[rules]
+db$(PPUEXT): db.pp fields.inc dataset.inc dbs.inc
+
+ddg_ds$(PPUEXT): db$(PPUEXT) ddg_rec$(PPUEXT) ddg_ds$(PASEXT)
+
+testds$(EXEEXT): ddg_ds$(PPUEXT) testds$(PASEXT)
+
+tested$(EXEEXT): ddg_ds$(PPUEXT) tested$(PASEXT)
+
+createds$(EXEEXT): createds$(PASEXT) ddg_rec$(PPUEXT)
+
+mysqldb$(PPUEXT): db$(PPUEXT) mysqldb$(PASEXT)
+
+mtest$(EXEEXT): mysqldb$(PPUEXT) mtest$(PASEXT)

fcl/db/README

@@ -0,0 +1,57 @@
+This is the Database directory of the Free Component Library.
+
+At the moment, there is a read/write implementation of TDataset.
+The blob support is not tested yet.
+
+Compiling the units:
+
+Just run 'make all' and all should go fine, provided
+1) The mysql unit is in the compiler path (the makefile will try to compile
+   it in the packages mysql subdirectory)
+2) the mysqlclient library is in /usr/lib (if you want to compile the mtest 
+   program)
+if these conditions are not satisfied, you should edit the makefile
+and add -Fl/path/to/libmysqlclient to NEEDOPTS as well as
+the -Fu/path/to/mysql/unit option.
+
+Compiling the examples:
+
+If the units compile fine, then the examples can be compiled by doing
+'make examples'. see also the above remarks.
+
+there are 2 descendents of TDataset to demonstrate/test the 
+TDataset implementation.
+
+TddgDataset : 
+
+  Implemented in ddg_ds and ddg_rec. The dataset as
+  implemented in the Delphi 4 Developers Guide.
+  To test it, do a 
+   createds filename
+   testds filename
+   tested filename
+  the first creates a flat file, filled with 100 records;
+  the second tests the navigation methods of TDataset on this file.
+  the third tests the editing methods of TDataset (Append,Insert 
+  and edit)
+
+TMySQLdataset :
+  Implemented in mysqldb. You need the mysql units for this.
+  This is a temporary implementation based on the code from
+     Rangel Gustavo Reale ([email protected]) 
+  it will be used as a base for the DBdataset scalable dataset
+  implementation.
+  To test it, do a 
+     mtest db user pwd SQL
+  this will run the query SQL on the database db with user
+  'user' and password 'pwd', and dump the result. Take care
+  that you don't specify blob fields.
+  To test it on the table created by the mkdb shell script
+  that comes with the Free Pascal mysql unit, I did a
+      mtest test michael pwd 'select * from FPdev'
+
+I haven't implemented/tested blob fields yet.
+
+Enjoy !
+
+Michael.              

fcl/db/createds.pp

@@ -0,0 +1,82 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999 by Michael Van Canneyt, member of the 
+    Free Pascal development team
+
+    Creates a flat datafile for use with testds.
+    
+    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.
+
+ **********************************************************************}
+program createds;
+
+{$mode delphi}
+
+uses ddg_rec,sysutils;
+
+Type IndexFile = File Of Longint;
+
+Var F : TDDGDataFile;
+    I : Integer;
+    S : String;
+    L : IndexFile;
+    TableName : String;
+    IndexName : String;
+    ARec : TDDGData;
+    
+begin
+  If ParamCount<>1 then
+    begin
+    Writeln('Usage: createds tablename');
+    Halt(1);
+    end;
+  TableName:=ChangeFileExt(paramstr(1),'.ddg');
+  IndexName:=ChangeFileExt(TableName,'.ddx');
+  Assign(F,TableName);
+  Rewrite(F);
+  For I:=1 to 100 do
+    begin
+    S:=Format('This is person %d.',[i]);
+    With Arec Do 
+      begin
+      Name:=S; 
+      height:=I*0.001;
+      LongField:=i*4;
+      ShoeSize:=I;
+      WordField:=i*2;
+      DateTimeField:=Now;
+      TimeField:=Time;
+      DateField:=Date;
+      Even:=(I mod 2) = 0
+      end;
+    Write(F,ARec);
+    end;
+  Close(F);
+  Assign(L,IndexName);
+  Rewrite(L);
+  For I:=0 to 100-1 do
+    Write(L,I);
+  Close(L);  
+end.
+{
+  $Log$
+  Revision 1.5  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:05  peter
+    * moved to packages dir
+
+  Revision 1.3  1999/11/11 17:31:09  michael
+  + Added Checks for all simple field types.
+  + Initial implementation of Insert/Append
+
+  Revision 1.2  1999/10/24 17:07:54  michael
+  + Added copyright header
+
+}

fcl/db/database.inc

@@ -0,0 +1,187 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999 by Michael Van Canneyt, member of the 
+    Free Pascal development team
+
+    TDatabase and related objects 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.
+
+ **********************************************************************}
+
+{ ---------------------------------------------------------------------
+    TDatabase
+  ---------------------------------------------------------------------}
+
+Procedure TDatabase.CheckConnected;
+
+begin
+  If Not Connected Then
+    DatabaseError(SNotConnected,Self);
+end;
+
+
+Procedure TDatabase.CheckDisConnected;
+begin
+  If Connected Then
+    DatabaseError(SConnected,Self);
+end;
+  
+procedure TDataBase.Loaded;
+
+begin
+  //!! To be implemented.
+end;
+
+procedure TDataBase.SetConnected (Value : boolean);
+
+begin
+  If Value<>FConnected then
+    begin
+    If Value then 
+      DoInternalConnect
+    else
+      begin
+      Closedatasets;
+      DoInternalDisConnect;
+      end;
+    FConnected:=Value;
+    end;
+end;
+
+
+procedure TDatabase.Notification(AComponent: TComponent; Operation: TOperation);
+
+begin
+  //!! To be implemented.
+end;
+
+constructor TDatabase.Create(AOwner: TComponent);
+
+begin
+  Inherited Create(AOwner);
+end;
+
+destructor TDatabase.Destroy;
+
+begin
+  Connected:=False;
+  RemoveDatasets;
+  FDatasets.Free;
+  Inherited Destroy;
+end;
+
+procedure TDatabase.Close;
+
+begin
+  Connected:=False;
+end;
+
+procedure TDatabase.CloseDataSets;
+
+Var I : longint;
+
+begin
+  If Assigned(FDatasets) then 
+    begin
+    For I:=FDatasets.Count-1 downto 0 do
+      TDBDataset(FDatasets[i]).Close;
+    end;
+end;
+
+procedure TDatabase.RemoveDataSets;
+
+Var I : longint;
+
+begin
+  If Assigned(FDatasets) then 
+    For I:=FDataSets.Count-1 downto 0 do
+      TDBDataset(FDataSets[i]).Database:=Nil;
+end;
+
+procedure TDatabase.Open;
+
+begin
+  Connected:=True;
+end;
+
+
+Function TDatabase.GetDataSetCount : Longint;
+
+begin
+  If Assigned(FDatasets) Then
+    Result:=FDatasets.Count
+  else
+    Result:=0;
+end;
+
+
+Function TDatabase.GetDataset(Index : longint) : TDBDataset;
+
+begin
+  If Assigned(FDatasets) then
+    Result:=TDBDataset(FDatasets[Index])
+  else
+    DatabaseError(SNoDatasets);
+end;
+
+procedure TDatabase.RegisterDataset (DS : TDBDataset);
+
+Var I : longint;
+
+begin
+  I:=FDatasets.IndexOf(DS);
+  If I=-1 then
+    FDatasets.Add(DS)
+  else
+    DatabaseErrorFmt(SDatasetRegistered,[DS.Name]);
+end;
+
+procedure TDatabase.UnRegisterDataset (DS : TDBDataset);
+
+Var I : longint;
+
+begin
+  I:=FDatasets.IndexOf(DS);
+  If I<>-1 then
+    FDatasets.Delete(I)
+  else
+    DatabaseErrorFmt(SNoDatasetRegistered,[DS.Name]);
+end;
+
+{ ---------------------------------------------------------------------
+    TDBdataset
+  ---------------------------------------------------------------------}
+
+Procedure TDBDataset.SetDatabase (Value : TDatabase);
+
+begin
+  CheckInactive;
+  If Value<>FDatabase then
+    begin
+    If Assigned(FDatabase) then
+      FDatabase.UnregisterDataset(Self);
+    If Value<>Nil Then
+      Value.RegisterDataset(Self);
+    FDatabase:=Value; 
+    end;
+end;  
+
+{
+  $Log$
+  Revision 1.4  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:05  peter
+    * moved to packages dir
+
+  Revision 1.2  1999/10/24 17:07:54  michael
+  + Added copyright header
+
+}

fcl/db/dataset.inc

@@ -0,0 +1,1500 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999 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);
+end;
+
+
+
+destructor TDataSet.Destroy;
+
+begin
+  Active:=False;
+  FFieldDefs.Free;
+  FFieldList.Free;
+  Inherited Destroy;
+end;
+
+
+Procedure TDataset.ActivateBuffers;
+
+begin
+  FBOF:=False;
+  FEOF:=False;
+  FRecordCount:=1;
+  FActiveRecord:=0;
+end;
+
+Procedure TDataset.UpdateFieldDefs;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.BindFields(Binding: Boolean);
+
+Var I : longint;
+
+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.
+  }
+  For I:=0 to FFieldList.Count-1 do
+    FFieldList[i].FFieldNo:=I;
+end;
+
+Function TDataset.BookmarkAvailable: Boolean;
+
+Const BookmarkStates = [dsBrowse,dsEdit,dsInsert];
+
+begin
+  Result:=(Not IsEmpty) and (State in BookmarkStates)
+          and (getBookMarkFlag(ActiveBuffer)=bfCurrent);
+end;
+
+Procedure TDataset.CalculateFields(Buffer: PChar);
+
+begin
+  //!! To be implemented
+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
+  //!! To be implemented
+end;
+
+Procedure TDataset.CloseBlob(Field: TField);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.CloseCursor;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.CreateFields;
+
+Var I : longint;
+
+begin
+{$ifdef DSDebug}
+  Writeln ('Creating fields');
+{$endif}
+  For I:=0 to fielddefs.Count-1 do
+    With Fielddefs.Items[I] do
+      If DataType<>ftUnknown then
+        CreateField(self);
+end;
+
+Procedure TDataset.DataEvent(Event: TDataEvent; Info: Longint);
+
+begin
+  //!! To be implemented
+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) 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.DoBeforeCancel;
+
+begin
+ If assigned(FBeforeCancel) then
+   FBeforeCancel(Self);
+end;
+
+Procedure TDataset.DoBeforeClose;
+
+begin
+ If assigned(FBeforeClose) 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.DoInternalOpen;
+
+begin
+  FBufferCount:=0;
+  FDefaultFields:=FieldCount=0;
+  DoBeforeOpen;
+  Try
+    {$ifdef dsdebug}
+    Writeln ('Calling internal open');
+    {$endif}
+    InternalOpen;
+    FBOF:=True;
+    {$ifdef dsdebug}
+    Writeln ('Setting state to browse');
+    {$endif}
+    SetState(dsBrowse);
+    {$ifdef dsdebug}
+    Writeln ('Setting buffer size');
+    {$endif}
+    SetBufListSize(DefaultBufferCount);
+    {$ifdef dsdebug}
+    Writeln ('Getting next records');
+    {$endif}
+    GetNextRecords;
+    DoAfterOpen;
+    DoAfterScroll;
+  except
+    SetState(dsInactive);
+    DoInternalClose;
+    raise;
+  end;
+end;
+
+Function TDataset.RequiredBuffers : longint;
+{
+  If later some datasource requires more buffers (grids etc)
+  then it should be taken into account here...
+}
+
+begin
+  Result:=0;
+end;
+
+Procedure TDataset.DoInternalClose;
+
+begin
+  FreeFieldBuffers;
+  ClearBuffers;
+  SetState(dsInactive);
+  InternalClose;
+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);
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.GetCanModify: Boolean;
+
+begin
+  Result:=True;
+end;
+
+Procedure TDataset.GetChildren(Proc: TGetChildProc; Root: TComponent);
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.GetField (Index : Longint) : TField;
+
+begin
+  Result:=FFIeldList[index];
+end;
+
+{
+  This is not yet allowed, FPC doesn't allow typed consts of Classes...
+
+Const
+  DefFieldClasses : Array [TFieldType] of TFieldClass =
+    ( { ftUnknown} Tfield,
+      { ftString} TStringField,
+      { ftSmallint} TLongIntField,
+      { ftInteger} TLongintField,
+      { ftWord} TLongintField,
+      { ftBoolean} TBooleanField,
+      { ftFloat} TFloatField,
+      { ftDate} TDateField,
+      { ftTime} TTimeField,
+      { ftDateTime} TDateTimeField,
+      { ftBytes} TBytesField,
+      { ftVarBytes} TVarBytesField,
+      { ftAutoInc} TAutoIncField,
+      { ftBlob} TBlobField,
+      { ftMemo} TMemoField,
+      { ftGraphic} TGraphicField,
+      { ftFmtMemo} TMemoField,
+      { ftParadoxOle} Nil,
+      { ftDBaseOle} Nil,
+      { ftTypedBinary} Nil,
+      { ftCursor} Nil
+    );
+}
+
+Function TDataset.GetFieldClass(FieldType: TFieldType): TFieldClass;
+
+begin
+  Case FieldType of
+     ftUnknown : Result:=Tfield;
+     ftString: Result := TStringField;
+     ftSmallint: Result := TSmallIntField;
+     ftInteger: Result := TLongintField;
+     ftWord: Result := TWordField;
+     ftBoolean: Result := TBooleanField;
+     ftFloat: Result := TFloatField;
+     ftDate: Result := TDateField;
+     ftTime: Result := TTimeField;
+     ftDateTime: Result := TDateTimeField;
+     ftBytes: Result := TBytesField;
+     ftVarBytes: Result := TVarBytesField;
+     ftAutoInc: Result := TAutoIncField;
+     ftBlob: Result := TBlobField;
+     ftMemo: Result := TMemoField;
+     ftGraphic: Result := TGraphicField;
+     ftFmtMemo: Result := TMemoField;
+     ftParadoxOle: Result := Nil;
+     ftDBaseOle: Result := Nil;
+     ftTypedBinary: Result := Nil;
+     ftCursor: Result := Nil;
+  end;
+end;
+
+Function TDataset.GetIsIndexField(Field: TField): Boolean;
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.GetNextRecord: Boolean;
+
+Var Shifted : Boolean;
+
+begin
+{$ifdef dsdebug}
+  Writeln ('Getting next record. Internal RecordCount : ',FRecordCount);
+{$endif}
+  Shifted:=FRecordCount=FBufferCount;
+  If Shifted then
+    begin
+    ShiftBuffers(0,1);
+    Dec(FRecordCount);
+    end;
+{$ifdef dsdebug}
+  Writeln ('Getting data into buffer : ',FRecordCount);
+{$endif}
+  Result:=GetRecord(FBuffers[FRecordCount],gmNext,True)=grOK;
+  If Result then
+    begin
+    If FRecordCount=0 then
+      ActivateBuffers
+    else
+      If FRecordCount<FBufferCount then
+        Inc(FRecordCount);
+    FCurrentRecord:=FRecordCount;
+    end
+  else
+    begin
+    if shifted then
+      begin
+      ShiftBuffers(0,-1);
+      inc(FRecordCount);
+      end;
+    CursorPosChanged;
+    end;
+{$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;
+
+Var Shifted : boolean;
+
+begin
+{$ifdef dsdebug}
+  Writeln ('Getting previous record');
+{$endif}
+  Shifted:=FRecordCount>0;
+  If Shifted Then
+    begin
+    SetCurrentRecord(0);
+    ShiftBuffers(0,-1);
+    end;
+  Result:=GetRecord(FBuffers[0],gmPrior,True)=grOK;
+  If Result then
+    begin
+    If FRecordCount=0 then
+      ActivateBuffers
+    else
+      begin
+      If FrecordCount<FBufferCount then
+        Inc(FRecordCount);
+      end;
+    FCurrentRecord:=0;
+    end
+  else
+    begin
+    If Shifted then
+      begin
+      ShiftBuffers(0,1);
+      end;
+    CursorPosChanged;
+    end;
+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
+  //!! To be implemented
+end;
+
+Function TDataset.GetRecordCount: Longint;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.InitFieldDefs;
+
+begin
+  //!! To be implemented
+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.Loaded;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.OpenCursor(InfoQuery: Boolean);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.RefreshInternalCalcFields(Buffer: PChar);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.RestoreState(const Value: TDataSetState);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetActive (Value : Boolean);
+
+begin
+  If Value<>Factive then
+    If Value then
+      DoInternalOpen
+    else
+      DoInternalClose;
+  FActive:=Value;
+end;
+
+Procedure TDataset.SetBookmarkStr(const Value: TBookmarkStr);
+
+begin
+  GotoBookMark(Pointer(Value))
+end;
+
+Procedure TDataset.SetBufListSize(Value: Longint);
+
+Var I : longint;
+
+begin
+  If Value=FBufferCount Then exit;
+  I:=RequiredBuffers; // Save 1 call.
+  If Value<I Then
+    Value:=I;
+  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-FBufferCount)*SizeOf(PChar));
+   {$endif}
+    FillChar(FBuffers[FBufferCount],(Value+1-FBufferCount)*SizeOF(Pchar),#0);
+   {$ifdef dsdebug}
+    Writeln ('Filled memory :');
+   {$endif}
+    Try
+     {$ifdef dsdebug}
+      Writeln ('Assigning buffers :',(Value+1)*SizeOf(PChar));
+     {$endif}
+      For I:=FBufferCount to Value do
+        FBuffers[i]:=AllocRecordBuffer;
+     {$ifdef dsdebug}
+      Writeln ('Assigned buffers :',(Value+1)*SizeOf(PChar));
+     {$endif}
+    except
+      I:=FBufferCount;
+      While (I<=Value) and (FBuffers[i]<>Nil) do
+        begin
+        FreeRecordBuffer(FBuffers[i]);
+        Inc(i);
+        end;
+      raise;
+    end;
+    end
+  else
+    begin
+    For I:=Value+1 to FBufferCount do
+      FreeRecordBuffer(FBuffers[i]);
+    ReAllocMem(FBuffers,Value*SizeOf(Pchar));
+    end;
+  FBufferCount:=Value;
+end;
+
+Procedure TDataset.SetChildOrder(Component: TComponent; Order: Longint);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetCurrentRecord(Index: Longint);
+
+begin
+  If FCurrentRecord<>Index then
+    begin
+    {$ifdef DSdebug}
+    Writeln ('Setting current record to',index);
+    {$endif}
+    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.SetFilterOptions(Value: TFilterOptions);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetFilterText(const Value: string);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetFiltered(Value: Boolean);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetFound(const Value: Boolean);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetModified(Value: Boolean);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetName(const Value: TComponentName);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetOnFilterRecord(const Value: TFilterRecordEvent);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetRecNo(Value: Longint);
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.SetState(Value: TDataSetState);
+
+begin
+  If Value<>FState then
+    begin
+    FState:=Value;
+    end;
+end;
+
+Function TDataset.SetTempState(const Value: TDataSetState): TDataSetState;
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.TempBuffer: PChar;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.UpdateIndexDefs;
+
+begin
+  //!! To be implemented
+end;
+
+
+
+Function TDataset.ControlsDisabled: Boolean;
+
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.ActiveBuffer: PChar;
+
+
+begin
+{$ifdef dsdebug}
+//  Writeln ('Active buffer requested. Returning:',ActiveRecord);
+{$endif}
+  Result:=FBuffers[ActiveRecord];
+end;
+
+Procedure TDataset.Append;
+
+begin
+  DoInsertAppend(True);
+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
+    DoBeforeCancel;
+    UpdateCursorPos;
+    InternalCancel;
+    FreeFieldBuffers;
+    SetState(dsBrowse);
+    Resync([]);
+    DoAfterCancel;
+    end;
+end;
+
+Procedure TDataset.CheckBrowseMode;
+
+begin
+  CheckActive;
+  If State In [dsedit,dsinsert] then
+    begin
+    UpdateRecord;
+    If Modified then
+      Post
+    else
+      Cancel;
+    end;
+end;
+
+Procedure TDataset.ClearFields;
+
+
+begin
+  //!! To be implemented
+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
+  //!! To be implemented
+end;
+
+Procedure TDataset.DisableControls;
+
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.DoInsertAppend(DoAppend : Boolean);
+
+Var Buffer : PChar;
+    BookBeforeInsert : TBookmarkStr;
+    
+begin
+  If Not CanModify then
+    DatabaseError(SDatasetReadOnly,Self);
+  CheckBrowseMode;
+  DoBeforeInsert;
+  DoBeforeScroll;
+  If Not DoAppend then 
+    begin
+    {$ifdef dsdebug}
+    Writeln ('going to insert mode');
+    {$endif}
+    // need to scroll up al buffers after current one,
+    // but copy current bookmark to insert buffer.
+    BookBeforeInsert:=Bookmark;
+    ShiftBuffers(1,FActiveRecord);
+    // Active buffer is now edit buffer. Initialize.
+    InitRecord(ActiveBuffer);
+    // Put bookmark in edit buffer.
+    if FRecordCount=0 then
+      SetBookmarkFlag(ActiveBuffer,bfBOF)
+    else
+      SetBookMarkData(ActiveBuffer,Pointer(BookBeforeInsert));
+    // update buffer count.
+    If FRecordCount<FBufferCount then 
+      Inc(FRecordCount);
+    end
+  else
+    // Tricky, need to get last record and scroll down.
+    begin
+    {$ifdef dsdebug}
+    Writeln ('going to append mode');
+    {$endif}
+    Buffer:=FBuffers[0];
+    InitRecord(Buffer);
+    // just mark buffer as last. GetPreviousrecords will do an internallast
+    // Because of this...
+    SetBookMarkFlag(Buffer,bfEOF);
+    FRecordCount:=1;
+    {$ifdef dsdebug}
+    Writeln ('getting prior records');
+    {$endif}
+    GetPriorRecords;
+    // update active record.
+    FactiveRecord:=FRecordCount-1;
+    end;
+  SetState(dsInsert);
+  try 
+    DoOnNewRecord;
+  except
+    UpdateCursorPos;
+    resync([]);
+    raise;
+  end;
+  // mark as not modified.
+  FModified:=False;
+  // Final events.
+  DoAfterInsert;
+  DoAfterScroll;
+  {$ifdef dsdebug}
+  Writeln ('Done with append');
+  {$endif}
+end;
+
+Procedure TDataset.Edit;
+
+begin
+  If Not CanModify then
+    DatabaseError(SDatasetReadOnly,Self);
+  If State in [dsedit,dsinsert] then exit;
+  If FRecordCount = 0 then
+    begin
+    Insert;
+    Exit;
+    end;
+  CheckBrowseMode;
+  DoBeforeEdit;
+  If Not TryDoing(@InternalEdit,OnEditError) then 
+    exit;
+  SetState(dsedit);
+  DoAfterEdit;
+end;
+
+Procedure TDataset.EnableControls;
+
+
+begin
+  //!! To be implemented
+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
+  //!! To be implemented
+end;
+
+Function TDataset.FindLast: Boolean;
+
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.FindNext: Boolean;
+
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.FindPrior: Boolean;
+
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.First;
+
+
+begin
+  CheckBrowseMode;
+  DoBeforeScroll;
+  ClearBuffers;
+  try
+    InternalFirst;
+    GetNextRecords;
+  finally
+    FBOF:=True;
+    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);
+
+
+begin
+
+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:=(Bof and Eof);
+end;
+
+Function TDataset.IsSequenced: Boolean;
+
+begin
+  //!! To be implemented
+end;
+
+Procedure TDataset.Last;
+
+begin
+  CheckBrowseMode;
+  DoBeforeScroll;
+  ClearBuffers;
+  try
+    InternalLast;
+    GetPriorRecords;
+    FActiveRecord:=FRecordCount-1;
+  finally
+    FEOF:=true;
+    DoAfterScroll;
+  end;
+end;
+
+Function TDataset.MoveBy(Distance: Longint): Longint;
+
+  Procedure Scrollforward;
+
+  begin
+{$ifdef dsdebug}
+    Writeln('Scrolling forward :',Distance);
+    Writeln('Active buffer : ',FActiveRecord);
+    Writeln('RecordCunt    : ',FRecordCount);
+{$endif}
+    While (Distance>0) and not FEOF do
+      begin
+      If FActiveRecord<FRecordCount-1 then
+        begin
+        Inc(FActiveRecord);
+        Dec(Distance)
+        end
+      else
+        begin
+       {$ifdef dsdebug}
+           Writeln('Moveby : need next record');
+       {$endif}
+        If GetNextRecord then
+          Dec(Distance)
+        else
+          FEOF:=true;
+        end;
+      end
+  end;
+
+  Procedure ScrollBackward;
+
+  begin
+
+{$ifdef dsdebug}
+    Writeln('Scrolling backward:',Abs(Distance));
+    Writeln('Active buffer : ',FActiveRecord);
+    Writeln('RecordCunt    : ',FRecordCount);
+{$endif}
+    While (Distance<0) and not FBOF do
+      begin
+      If FActiveRecord>0 then
+        begin
+        Dec(FActiveRecord);
+        Inc(Distance)
+        end
+      else
+        begin
+       {$ifdef dsdebug}
+           Writeln('Moveby : need next record');
+       {$endif}
+        If GetPriorRecord then
+          Inc(Distance)
+        else
+          FBOF:=true;
+        end;
+      end
+  end;
+
+begin
+  CheckBrowseMode;
+  Result:=0;
+  DoBeforeScroll;
+  If ((Distance>0) and FEOF) or
+     ((Distance<0) and FBOF) then
+    exit;
+  Try
+    If Distance>0 then
+      ScrollForward
+    else
+      ScrollBackward;
+  finally
+     DoAfterScroll;
+  end;
+end;
+
+Procedure TDataset.Next;
+
+begin
+  MoveBy(1);
+end;
+
+Procedure TDataset.Open;
+
+begin
+  Active:=True;
+end;
+
+Procedure TDataset.Post;
+  
+  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) then
+          DatabaseErrorFmt(SNeedField,[DisplayName],Self);
+  end;  
+
+begin
+  if State in [dsEdit,dsInsert] then
+    begin
+{$ifdef dsdebug}    
+    writeln ('Post: checking required fields');
+{$endif}
+    CheckRequired;
+    DoBeforePost;
+    If Not TryDoing(@InternalPost,OnPostError) then exit;
+{$ifdef dsdebug}    
+    writeln ('Post: Internalpost succeeded');
+{$endif}
+    FreeFieldBuffers;
+{$ifdef dsdebug}    
+    writeln ('Post: Freeing field buffers');
+{$endif}
+    SetState(dsBrowse);
+{$ifdef dsdebug}    
+    writeln ('Post: Browse mode set');
+{$endif}
+    Resync([]);
+    DoAfterPost;
+    end;
+end;
+
+Procedure TDataset.Prior;
+
+begin
+  MoveBy(-1);
+end;
+
+Procedure TDataset.Refresh;
+
+begin
+  CheckbrowseMode;
+  UpdateCursorPos;
+  InternalRefresh;
+  Resync([]);
+end;
+
+Procedure TDataset.Resync(Mode: TResyncMode);
+
+Var Count,ShiftCount : Longint;
+
+begin
+  // See if we can find the requested record.
+  If rmExact in Mode then
+    begin
+    { throw an exception if not found.
+      Normally the descendant should do this if DoCheck is true. }
+    If GetRecord(Fbuffers[FRecordCount-1],gmcurrent,True)<>grOk Then
+      DatabaseError(SNoSuchRecord,Self);
+    end
+  else
+    { Can we find a record in the neighbourhood ?
+      Use Shortcut evaluation for this, or we'll have some funny results. }
+    If (GetRecord(Fbuffers[FRecordCount-1],gmcurrent,True)<>grOk) and
+       (GetRecord(Fbuffers[FRecordCount-1],gmprior,True)<>grOk) and
+       (GetRecord(Fbuffers[FRecordCount-1],gmprior,True)<>grOk) then
+       begin
+       // nothing found, invalidate buffer and bail out.
+       ClearBuffers;
+       Exit;
+       end;
+  If (rmCenter in Mode) then
+    ShiftCount:=FbufferCount div 2
+  else
+    // keep current position.
+    ShiftCount:=FActiveRecord;
+  // Reposition on 0
+  ShiftBuffers(0,FRecordCount-1);
+  ActivateBuffers;
+  Count:=0;
+  Writeln ('Getting previous',ShiftCount,' records');
+  While (Count<ShiftCount) and GetPriorRecord do Inc(Count);
+  FActiveRecord:=Count;
+  // fill rest of buffers, adjust ActiveBuffer.
+  SetCurrentRecord(FRecordCount-1);
+  GetNextRecords;
+  Inc(FActiveRecord,GetPriorRecords);
+end;
+
+Procedure TDataset.SetFields(const Values: array of const);
+
+Var I  : longint;
+
+begin
+  For I:=0 to high(Values) do
+    Case Values[I].vtype of
+      vtInteger : FieldByNumber(i).AsLongInt:=Values[I].VInteger;
+      // needs Completion..
+    end;
+end;
+
+Procedure TDataset.Translate(Src, Dest: PChar; ToOem: Boolean);
+
+begin
+  //!! To be implemented
+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
+  //!! To be implemented
+end;
+
+Procedure TDataset.RemoveField (Field : TField);
+
+begin
+  //!! To be implemented
+end;
+
+Function TDataset.Getfieldcount : Longint;
+
+begin
+  Result:=FFieldList.Count;
+end;
+
+Procedure TDataset.ShiftBuffers (Offset, Distance : longint);
+
+Var Temp : Pointer;
+    MoveSize : Longint;
+
+  Procedure ShiftBuffersUp;
+  begin
+    {$ifdef DSDEBUG}
+    writeln ('Shifting buffers up from ',OffSet,' with distance :',Distance);
+    writeln ('Moving ',(FBufferCount-Distance), ' Buffers at ',Distance);
+    {$endif}
+    Move(FBuffers[Offset],Temp^,MoveSize);
+    Move(FBuffers[Offset+Distance],FBuffers[Offset],(FBufferCount-Distance-Offset)*SizeOf(Pchar));
+    Move(Temp^,FBuffers[FBufferCount-Distance-Offset],MoveSize);
+  end;
+
+  Procedure ShiftBuffersDown;
+
+  begin
+    // Distance is NEGATIVE
+    {$ifdef DSDEBUG}
+    writeln ('Shifting buffers down with distance :',Abs(Distance));
+    writeln ('Moving ',Movesize div 4,' Buffers at ',FBufferCount+Distance);
+    {$endif}
+    Move(FBuffers[FbufferCount+Distance],Temp^ ,MoveSize);
+    Move(FBuffers[0],FBuffers[Abs(Distance)],(FBufferCount+Distance)*SizeOf(Pchar));
+    Move(Temp^ ,FBuffers[0],MoveSize);
+  end;
+
+begin
+  If Abs(Distance)>=BufferCount then Exit;
+  try
+    MoveSize:=SizeOf(Pchar)*Abs(Distance);
+    GetMem(Temp,MoveSize);
+    If Distance<0 Then
+      ShiftBuffersDown
+    else If Distance>0 then
+      ShiftBuffersUp;
+  Finally
+    FreeMem(temp);
+  end;
+end;
+
+{
+  $Log$
+  Revision 1.8  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:05  peter
+    * moved to packages dir
+
+  Revision 1.6  1999/12/01 22:11:02  michael
+  + tested edit and insert methods
+
+  Revision 1.5  1999/11/12 22:53:32  michael
+  + Added append() insert() tested append. Datetime as string works now
+
+  Revision 1.4  1999/11/11 17:31:09  michael
+  + Added Checks for all simple field types.
+  + Initial implementation of Insert/Append
+
+  Revision 1.3  1999/11/09 13:33:47  peter
+    * reallocmem fixes
+
+  Revision 1.2  1999/10/24 17:07:54  michael
+  + Added copyright header
+
+}

fcl/db/db.pp

@@ -0,0 +1,1282 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999 by Michael Van Canneyt, member of the
+    Free Pascal development team
+
+
+    DB header file with interface section.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit db;
+
+{$mode objfpc}
+{$h+}
+
+interface
+
+uses Classes,Sysutils;
+
+const
+
+  dsMaxBufferCount = MAXINT div 8;
+  dsMaxStringSize = 8192;
+
+  // Used in AsBoolean for string fields to determine
+  // whether it's true or false.
+  YesNoChars : Array[Boolean] of char = ('Y','N');
+
+type
+
+{ Auxiliary type }
+  TStringFieldBuffer = Array[0..dsMaxStringSize] of Char;
+
+{ Misc Dataset types }
+
+  TDataSetState = (dsInactive, dsBrowse, dsEdit, dsInsert, dsSetKey,
+    dsCalcFields, dsFilter, dsNewValue, dsOldValue, dsCurValue);
+
+  TDataEvent = (deFieldChange, deRecordChange, deDataSetChange,
+    deDataSetScroll, deLayoutChange, deUpdateRecord, deUpdateState,
+    deCheckBrowseMode, dePropertyChange, deFieldListChange, deFocusControl);
+
+  TUpdateStatus = (usUnmodified, usModified, usInserted, usDeleted);
+
+{ Forward declarations }
+
+  TFieldDef = class;
+  TFieldDefs = class;
+  TField = class;
+  TFields = Class;
+  TDataSet = class;
+  TDataBase = Class;
+
+{ Exception classes }
+
+  EDatabaseError = class(Exception);
+
+{ TFieldDef }
+
+  TFieldClass = class of TField;
+
+  TFieldType = (ftUnknown, ftString, ftSmallint, ftInteger, ftWord,
+    ftBoolean, ftFloat, ftDate, ftTime, ftDateTime,
+    ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic,
+    ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor);
+
+  TFieldDef = class(TComponent)
+  Private
+    FDataType : TFieldType;
+    FFieldNo : Longint;
+    FInternalCalcField : Boolean;
+    FPrecision : Longint;
+    FRequired : Boolean;
+    FSize : Word;
+    FName : String;
+    Function GetFieldClass : TFieldClass;
+  public
+    constructor Create(AOwner: TFieldDefs; const AName: string;
+      ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo: Longint);
+    destructor Destroy; override;
+    function CreateField(AOwner: TComponent): TField;
+    property InternalCalcField: Boolean read FInternalCalcField write FInternalCalcField;
+    property DataType: TFieldType read FDataType;
+    property FieldClass: TFieldClass read GetFieldClass;
+    property FieldNo: Longint read FFieldNo;
+    property Name: string read FName;
+    property Precision: Longint read FPrecision write FPrecision;
+    property Required: Boolean read FRequired;
+    property Size: Word read FSize;
+  end;
+
+{ TFieldDefs }
+
+  TFieldDefs = class(TComponent)
+  private
+    FDataSet: TDataSet;
+    FItems: TList;
+    FUpdated: Boolean;
+    function GetCount: Longint;
+    function GetItem(Index: Longint): TFieldDef;
+  public
+    constructor Create(ADataSet: TDataSet);
+    destructor Destroy; override;
+    procedure Add(const AName: string; ADataType: TFieldType; ASize: Word;
+      ARequired: Boolean);
+    procedure Assign(FieldDefs: TFieldDefs);
+    procedure Clear;
+    function Find(const AName: string): TFieldDef;
+    function IndexOf(const AName: string): Longint;
+    procedure Update;
+    property Count: Longint read GetCount;
+    property Items[Index: Longint]: TFieldDef read GetItem; default;
+  end;
+
+{ TField }
+
+  TFieldKind = (fkData, fkCalculated, fkLookup, fkInternalCalc);
+  TFieldKinds = Set of TFieldKind;
+
+  TFieldNotifyEvent = procedure(Sender: TField) of object;
+  TFieldGetTextEvent = procedure(Sender: TField; var Text: string;
+    DisplayText: Boolean) of object;
+  TFieldSetTextEvent = procedure(Sender: TField; const Text: string) of object;
+  TFieldRef = ^TField;
+  TFieldChars = set of Char;
+  { TAlignment may need to come from somewhere else }
+  TAlignMent = (taLeftjustify,taCenter,taRightJustify);
+
+  TField = class(TComponent)
+  Private
+    FAlignMent : TAlignment;
+    FAttributeSet : String;
+    FBuffers : ppchar;
+    FCalculated : Boolean;
+    FCanModify : Boolean;
+    FConstraintErrorMessage : String;
+    FCustomConstraint : String;
+    FDataSet : TDataSet;
+    FDataSize : Word;
+    FDataType : TFieldType;
+    FDefaultExpression : String;
+    FDisplayLabel : String;
+    FDisplayWidth : Longint;
+    FEditText : String;
+    FFieldKind : TFieldKind;
+    FFieldName : String;
+    FFieldNo : Longint;
+    FFields : TFields;
+    FHasConstraints : Boolean;
+    FImportedConstraint : String;
+    FIsIndexField : Boolean;
+    FKeyFields : String;
+    FLookupCache : Boolean;
+    FLookupDataSet : TDataSet;
+    FLookupKeyfields : String;
+    FLookupresultField : String;
+    FOffset : Word;
+    FOnChange : TFieldNotifyEvent;
+    FOnGetText: TFieldGetTextEvent;
+    FOnSetText: TFieldSetTextEvent;
+    FOnValidate: TFieldNotifyEvent;
+    FOrigin : String;
+    FReadOnly : Boolean;
+    FRequired : Boolean;
+    FSize : Word;
+    FValidChars : TFieldChars;
+    FValueBuffer : Pointer;
+    FValidating : Boolean;
+    FVisible : Boolean;
+    Function GetIndex : longint;
+    Procedure SetDataset(VAlue : TDataset);
+  protected
+    function AccessError(const TypeName: string): EDatabaseError;
+    procedure CheckInactive;
+    class procedure CheckTypeSize(AValue: Longint); virtual;
+    procedure Change; virtual;
+    procedure DataChanged;
+    procedure FreeBuffers; virtual;
+    function GetAsBoolean: Boolean; virtual;
+    function GetAsDateTime: TDateTime; virtual;
+    function GetAsFloat: Extended; virtual;
+    function GetAsLongint: Longint; virtual;
+    function GetAsString: string; virtual;
+    function GetCanModify: Boolean; virtual;
+    function GetDataSize: Word; virtual;
+    function GetDefaultWidth: Longint; virtual;
+    function GetDisplayName : String; 
+    function GetIsNull: Boolean; virtual;
+    function GetParentComponent: TComponent; override;
+    procedure GetText(var AText: string; ADisplayText: Boolean); virtual;
+    function HasParent: Boolean; override;
+    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    procedure PropertyChanged(LayoutAffected: Boolean);
+    procedure ReadState(Reader: TReader); override;
+    procedure SetAsBoolean(AValue: Boolean); virtual;
+    procedure SetAsDateTime(AValue: TDateTime); virtual;
+    procedure SetAsFloat(AValue: Extended); virtual;
+    procedure SetAsLongint(AValue: Longint); virtual;
+    procedure SetAsString(const AValue: string); virtual;
+    procedure SetDataType(AValue: TFieldType);
+    procedure SetSize(AValue: Word); virtual;
+    procedure SetParentComponent(AParent: TComponent); override;
+    procedure SetText(const AValue: string); virtual;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Assign(Source: TPersistent); override;
+    procedure Clear; virtual;
+    procedure FocusControl;
+    function GetData(Buffer: Pointer): Boolean;
+    class function IsBlob: Boolean; virtual;
+    function IsValidChar(InputChar: Char): Boolean; virtual;
+    procedure SetData(Buffer: Pointer);
+    procedure SetFieldType(AValue: TFieldType); virtual;
+    procedure Validate(Buffer: Pointer);
+    property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
+    property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
+    property AsFloat: Extended read GetAsFloat write SetAsFloat;
+    property AsLongint: Longint read GetAsLongint write SetAsLongint;
+    property AsString: string read GetAsString write SetAsString;
+    property AttributeSet: string read FAttributeSet write FAttributeSet;
+    property Calculated: Boolean read FCalculated write FCalculated;
+    property CanModify: Boolean read FCanModify;
+    property DataSet: TDataSet read FDataSet write SetDataSet;
+    property DataSize: Word read GetDataSize;
+    property DataType: TFieldType read FDataType;
+    property FieldNo: Longint read FFieldNo;
+    property IsIndexField: Boolean read FIsIndexField;
+    property IsNull: Boolean read GetIsNull;
+    property Offset: word read FOffset;
+    property Size: Word read FSize write FSize;
+    property Text: string read FEditText write FEditText;
+    property ValidChars : TFieldChars Read FValidChars;
+  published
+    property AlignMent : TAlignMent Read FAlignMent write FAlignment;
+    property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
+    property ConstraintErrorMessage: string read FConstraintErrorMessage write FConstraintErrorMessage;
+    property DefaultExpression: string read FDefaultExpression write FDefaultExpression;
+    property DisplayLabel : string read FDisplayLabel write FDisplayLabel;
+    property DisplayName : String Read GetDisplayName; 
+    property DisplayWidth: Longint read FDisplayWidth write FDisplayWidth;
+    property FieldKind: TFieldKind read FFieldKind write FFieldKind;
+    property FieldName: string read FFieldName write FFieldName;
+    property HasConstraints: Boolean read FHasConstraints;
+    property Index: Longint read GetIndex;
+    property ImportedConstraint: string read FImportedConstraint write FImportedConstraint;
+    property LookupDataSet: TDataSet read FLookupDataSet write FLookupDataSet;
+    property LookupKeyFields: string read FLookupKeyFields write FLookupKeyFields;
+    property LookupResultField: string read FLookupResultField write FLookupResultField;
+    property KeyFields: string read FKeyFields write FKeyFields;
+    property LookupCache: Boolean read FLookupCache write FLookupCache;
+    property Origin: string read FOrigin write FOrigin;
+    property ReadOnly: Boolean read FReadOnly write FReadOnly;
+    property Required: Boolean read FRequired write FRequired;
+    property Visible: Boolean read FVisible write FVisible;
+    property OnChange: TFieldNotifyEvent read FOnChange write FOnChange;
+    property OnGetText: TFieldGetTextEvent read FOnGetText write FOnGetText;
+    property OnSetText: TFieldSetTextEvent read FOnSetText write FOnSetText;
+    property OnValidate: TFieldNotifyEvent read FOnValidate write FOnValidate;
+  end;
+
+{ TStringField }
+
+  TStringField = class(TField)
+  protected
+    class procedure CheckTypeSize(AValue: Longint); override;
+    function GetAsBoolean: Boolean; override;
+    function GetAsDateTime: TDateTime; override;
+    function GetAsFloat: Extended; override;
+    function GetAsLongint: Longint; override;
+    function GetAsString: string; override;
+    function GetDataSize: Word; override;
+    function GetDefaultWidth: Longint; override;
+    procedure GetText(var AText: string; DisplayText: Boolean); override;
+    function GetValue(var AValue: string): Boolean;
+    procedure SetAsBoolean(AValue: Boolean); override;
+    procedure SetAsDateTime(AValue: TDateTime); override;
+    procedure SetAsFloat(AValue: Extended); override;
+    procedure SetAsLongint(AValue: Longint); override;
+    procedure SetAsString(const AValue: string); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    property Value: string read GetAsString write SetAsString;
+  published
+    property Size default 20;
+  end;
+
+{ TNumericField }
+  TNumericField = class(TField)
+  Private
+    FDisplayFormat : String;
+    FEditFormat : String;
+  protected
+    procedure RangeError(AValue, Min, Max: Extended);
+    procedure SetDisplayFormat(const AValue: string);
+    procedure SetEditFormat(const AValue: string);
+  public
+    constructor Create(AOwner: TComponent); override;
+  published
+    property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
+    property EditFormat: string read FEditFormat write SetEditFormat;
+  end;
+
+{ TLongintField }
+
+  TLongintField = class(TNumericField)
+  private
+    FMinValue,
+    FMaxValue,
+    FMinRange,
+    FMAxRange  : Longint;
+    Procedure SetMinValue (AValue : longint);
+    Procedure SetMaxValue (AValue : longint);
+  protected
+    function GetAsFloat: Extended; override;
+    function GetAsLongint: Longint; override;
+    function GetAsString: string; override;
+    function GetDataSize: Word; override;
+    procedure GetText(var AText: string; DisplayText: Boolean); override;
+    function GetValue(var AValue: Longint): Boolean;
+    procedure SetAsFloat(AValue: Extended); override;
+    procedure SetAsLongint(AValue: Longint); override;
+    procedure SetAsString(const AValue: string); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    Function CheckRange(AValue : longint) : Boolean;
+    property Value: Longint read GetAsLongint write SetAsLongint;
+  published
+    property MaxValue: Longint read FMaxValue write SetMaxValue default 0;
+    property MinValue: Longint read FMinValue write SetMinValue default 0;
+  end;
+  TIntegerField = TLongintField;
+
+{ TSmallintField }
+
+  TSmallintField = class(TLongintField)
+  protected
+    function GetDataSize: Word; override;
+  public
+    constructor Create(AOwner: TComponent); override;
+  end;
+
+{ TWordField }
+
+  TWordField = class(TLongintField)
+  protected
+    function GetDataSize: Word; override;
+  public
+    constructor Create(AOwner: TComponent); override;
+  end;
+
+{ TAutoIncField }
+
+  TAutoIncField = class(TLongintField)
+  Protected
+    Procedure SetAsLongInt(AValue : Longint); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+  end;
+
+{ TFloatField }
+
+  TFloatField = class(TNumericField)
+  private
+    FMaxValue : Extended;
+    FMinValue : Extended;
+    FPrecision : Longint;
+  protected
+    function GetAsFloat: Extended; override;
+    function GetAsLongint: Longint; override;
+    function GetAsString: string; override;
+    function GetDataSize: Word; override;
+    procedure GetText(var theText: string; DisplayText: Boolean); override;
+    procedure SetAsFloat(AValue: Extended); override;
+    procedure SetAsLongint(AValue: Longint); override;
+    procedure SetAsString(const AValue: string); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    Function CheckRange(AValue : Extended) : Boolean;
+    property Value: Extended read GetAsFloat write SetAsFloat;
+
+  published
+    property MaxValue: Extended read FMaxValue write FMaxValue;
+    property MinValue: Extended read FMinValue write FMinValue;
+    property Precision: Longint read FPrecision write FPrecision default 15;
+  end;
+
+
+{ TBooleanField }
+
+  TBooleanField = class(TField)
+  private
+    FDisplayValues : String;
+    // First byte indicates uppercase or not.
+    FDisplays : Array[Boolean,Boolean] of string;
+    Procedure SetDisplayValues(AValue : String);
+  protected
+    function GetAsBoolean: Boolean; override;
+    function GetAsString: string; override;
+    function GetDataSize: Word; override;
+    function GetDefaultWidth: Longint; override;
+    procedure SetAsBoolean(AValue: Boolean); override;
+    procedure SetAsString(const AValue: string); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    property Value: Boolean read GetAsBoolean write SetAsBoolean;
+  published
+    property DisplayValues: string read FDisplayValues write SetDisplayValues;
+  end;
+
+{ TDateTimeField }
+
+  TDateTimeField = class(TField)
+  private
+    FDisplayFormat : String;
+  protected
+    function GetAsDateTime: TDateTime; override;
+    function GetAsFloat: Extended; override;
+    function GetAsString: string; override;
+    function GetDataSize: Word; override;
+    procedure GetText(var theText: string; DisplayText: Boolean); override;
+    procedure SetAsDateTime(AValue: TDateTime); override;
+    procedure SetAsFloat(AValue: Extended); override;
+    procedure SetAsString(const AValue: string); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    property Value: TDateTime read GetAsDateTime write SetAsDateTime;
+  published
+    property DisplayFormat: string read FDisplayFormat write FDisplayFormat;
+  end;
+
+{ TDateField }
+
+  TDateField = class(TDateTimeField)
+  protected
+    function GetDataSize: Word; override;
+  public
+    constructor Create(AOwner: TComponent); override;
+  end;
+
+{ TTimeField }
+
+  TTimeField = class(TDateTimeField)
+  protected
+    function GetDataSize: Word; override;
+  public
+    constructor Create(AOwner: TComponent); override;
+  end;
+
+{ TBinaryField }
+
+  TBinaryField = class(TField)
+  protected
+    class procedure CheckTypeSize(AValue: Longint); override;
+    function GetAsString: string; override;
+    procedure GetText(var TheText: string; DisplayText: Boolean); override;
+    procedure SetAsString(const AValue: string); override;
+    procedure SetText(const AValue: string); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+  published
+    property Size default 16;
+  end;
+
+{ TBytesField }
+
+  TBytesField = class(TBinaryField)
+  protected
+    function GetDataSize: Word; override;
+  public
+    constructor Create(AOwner: TComponent); override;
+  end;
+
+{ TVarBytesField }
+
+  TVarBytesField = class(TBytesField)
+  protected
+    function GetDataSize: Word; override;
+  public
+    constructor Create(AOwner: TComponent); override;
+  end;
+
+{ TBCDField }
+
+  TBCDField = class(TNumericField)
+  private
+  protected
+    class procedure CheckTypeSize(AValue: Longint); override;
+    function GetAsFloat: Extended; override;
+    function GetAsLongint: Longint; override;
+    function GetAsString: string; override;
+    function GetDataSize: Word; override;
+    function GetDefaultWidth: Longint; override;
+    procedure GetText(var TheText: string; DisplayText: Boolean); override;
+    procedure SetAsFloat(AValue: Extended); override;
+    procedure SetAsLongint(AValue: Longint); override;
+    procedure SetAsString(const AValue: string); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+  published
+    property Size default 4;
+  end;
+
+{ TBlobField }
+  TBlobStreamMode = (bmRead, bmWrite, bmReadWrite);
+  TBlobType = ftBlob..ftTypedBinary;
+
+  TBlobField = class(TField)
+  private
+    FBlobSize : Longint;
+    FBlobType : TBlobType;
+    FModified : Boolean;
+    FTransliterate : Boolean;
+    Function GetBlobStream (Mode : TBlobStreamMode) : TStream;
+  protected
+    procedure AssignTo(Dest: TPersistent); override;
+    procedure FreeBuffers; override;
+    function GetAsString: string; override;
+    function GetBlobSize: Longint; virtual;
+    function GetIsNull: Boolean; override;
+    procedure GetText(var TheText: string; DisplayText: Boolean); override;
+    procedure SetAsString(const AValue: string); override;
+    procedure SetText(const AValue: string); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    procedure Assign(Source: TPersistent); override;
+    procedure Clear; override;
+    class function IsBlob: Boolean; override;
+    procedure LoadFromFile(const FileName: string);
+    procedure LoadFromStream(Stream: TStream);
+    procedure SaveToFile(const FileName: string);
+    procedure SaveToStream(Stream: TStream);
+    procedure SetFieldType(AValue: TFieldType); override;
+    property BlobSize: Longint read FBlobSize;
+    property Modified: Boolean read FModified write FModified;
+    property Value: string read GetAsString write SetAsString;
+    property Transliterate: Boolean read FTransliterate write FTransliterate;
+  published
+    property BlobType: TBlobType read FBlobType write FBlobType;
+    property Size default 0;
+  end;
+
+{ TMemoField }
+
+  TMemoField = class(TBlobField)
+  public
+    constructor Create(AOwner: TComponent); override;
+  published
+    property Transliterate default True;
+  end;
+
+{ TGraphicField }
+
+  TGraphicField = class(TBlobField)
+  public
+    constructor Create(AOwner: TComponent); override;
+  end;
+
+{ TIndexDef }
+
+  TIndexDefs = class;
+
+  TIndexOptions = set of (ixPrimary, ixUnique, ixDescending,
+    ixCaseInsensitive, ixExpression);
+
+  TIndexDef = class
+  Private
+    FExpression : String;
+    FFields : String;
+    FName : String;
+    FOptions : TIndexOptions;
+    FSource : String;
+  public
+    constructor Create(Owner: TIndexDefs; const AName, TheFields: string;
+      TheOptions: TIndexOptions);
+    destructor Destroy; override;
+    property Expression: string read FExpression;
+    property Fields: string read FFields;
+    property Name: string read FName;
+    property Options: TIndexOptions read FOptions;
+    property Source: string read FSource write FSource;
+  end;
+
+{ TIndexDefs }
+
+  TIndexDefs = class
+  Private
+    FCount : Longint;
+    FUpDated : Boolean;
+    Function GetItem (Index : longint) : TindexDef;
+  public
+    constructor Create(DataSet: TDataSet);
+    destructor Destroy; override;
+    procedure Add(const Name, Fields: string; Options: TIndexOptions);
+    procedure Assign(IndexDefs: TIndexDefs);
+    procedure Clear;
+    function FindIndexForFields(const Fields: string): TIndexDef;
+    function GetIndexForFields(const Fields: string;
+      CaseInsensitive: Boolean): TIndexDef;
+    function IndexOf(const Name: string): Longint;
+    procedure Update;
+    property Count: Longint read FCount;
+    property Items[Index: Longint]: TIndexDef read GetItem; default;
+    property Updated: Boolean read FUpdated write FUpdated;
+  end;
+
+{ TCheckConstraint }
+
+  TCheckConstraint = class(TCollectionItem)
+  Private
+    FCustomConstraint : String;
+    FErrorMessage : String;
+    FFromDictionary : Boolean;
+    FImportedConstraint : String;
+  public
+    procedure Assign(Source: TPersistent); override;
+  //  function GetDisplayName: string; override;
+  published
+    property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
+    property ErrorMessage: string read FErrorMessage write FErrorMessage;
+    property FromDictionary: Boolean read FFromDictionary write FFromDictionary;
+    property ImportedConstraint: string read FImportedConstraint write FImportedConstraint;
+  end;
+
+{ TCheckConstraints }
+
+  TCheckConstraints = class(TCollection)
+  Private
+   Function GetItem(Index : Longint) : TCheckConstraint;
+   Procedure SetItem(index : Longint; Value : TCheckConstraint);
+  protected
+    function GetOwner: TPersistent; override;
+  public
+    constructor Create(Owner: TPersistent);
+    function Add: TCheckConstraint;
+    property Items[Index: Longint]: TCheckConstraint read GetItem write SetItem; default;
+  end;
+
+{ TFields }
+
+  Tfields = Class(TObject)
+    Private
+      FDataset : TDataset;
+      FFieldList : TList;
+      FOnChange : TNotifyEvent;
+      FValidFieldKinds : TFieldKinds;
+    Protected
+      Procedure Changed;
+      Procedure CheckfieldKind(Fieldkind : TFieldKind; Field : TField);
+      Function GetCount : Longint;
+      Function GetField (Index : longint) : TField;
+      Procedure SetFieldIndex (Field : TField;Value : Integer);
+      Property OnChange : TNotifyEvent Read FOnChange Write FOnChange;
+      Property ValidFieldKinds : TFieldKinds Read FValidFieldKinds;
+    Public
+      Constructor Create(ADataset : TDataset);
+      Destructor Destroy;override;
+      Procedure Add(Field : TField);
+      Procedure CheckFieldName (Const Value : String);
+      Procedure CheckFieldNames (Const Value : String);
+      Procedure Clear;
+      Function FindField (Const Value : String) : TField;
+      Function FieldByName (Const Value : String) : TField;
+      Function FieldByNumber(FieldNo : Integer) : TField;
+      Procedure GetFieldNames (Values : TStrings);
+      Function IndexOf(Field : TField) : Longint;
+      procedure Remove(Value : TField);
+      Property Count : Integer Read GetCount;
+      Property Dataset : TDataset Read FDataset;
+      Property Fields [Index : Integer] : TField Read GetField; default;
+    end;
+
+
+{ TDataSet }
+
+  TBookmark = Pointer;
+  TBookmarkStr = string;
+
+  PBookmarkFlag = ^TBookmarkFlag;
+  TBookmarkFlag = (bfCurrent, bfBOF, bfEOF, bfInserted);
+
+  PBufferList = ^TBufferList;
+  TBufferList = array[0..dsMaxBufferCount - 1] of PChar;
+
+  TGetMode = (gmCurrent, gmNext, gmPrior);
+
+  TGetResult = (grOK, grBOF, grEOF, grError);
+
+  TResyncMode = set of (rmExact, rmCenter);
+
+  TDataAction = (daFail, daAbort, daRetry);
+
+  TUpdateKind = (ukModify, ukInsert, ukDelete);
+
+
+  TLocateOption = (loCaseInsensitive, loPartialKey);
+  TLocateOptions = set of TLocateOption;
+
+  TDataOperation = procedure of object;
+
+  TDataSetNotifyEvent = procedure(DataSet: TDataSet) of object;
+  TDataSetErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
+    var Action: TDataAction) of object;
+
+  TFilterOption = (foCaseInsensitive, foNoPartialCompare);
+  TFilterOptions = set of TFilterOption;
+
+  TFilterRecordEvent = procedure(DataSet: TDataSet;
+    var Accept: Boolean) of object;
+
+  TDatasetClass = Class of TDataset;
+  TBufferArray = ^pchar;
+
+  TDataSet = class(TComponent)
+  Private
+    FActive: Boolean;
+    FActiveRecord: Longint;
+    FAfterCancel: TDataSetNotifyEvent;
+    FAfterClose: TDataSetNotifyEvent;
+    FAfterDelete: TDataSetNotifyEvent;
+    FAfterEdit: TDataSetNotifyEvent;
+    FAfterInsert: TDataSetNotifyEvent;
+    FAfterOpen: TDataSetNotifyEvent;
+    FAfterPost: TDataSetNotifyEvent;
+    FAfterScroll: TDataSetNotifyEvent;
+    FAutoCalcFields: Boolean;
+    FBOF: Boolean;
+    FBeforeCancel: TDataSetNotifyEvent;
+    FBeforeClose: TDataSetNotifyEvent;
+    FBeforeDelete: TDataSetNotifyEvent;
+    FBeforeEdit: TDataSetNotifyEvent;
+    FBeforeInsert: TDataSetNotifyEvent;
+    FBeforeOpen: TDataSetNotifyEvent;
+    FBeforePost: TDataSetNotifyEvent;
+    FBeforeScroll: TDataSetNotifyEvent;
+    FBlobFieldCount: Longint;
+    FBookmark: TBookmarkStr;
+    FBookmarkSize: Longint;
+    FBuffers : TBufferArray;
+    FBufferCount: Longint;
+    FCalcBuffer: PChar;
+    FCalcFieldsSize: Longint;
+    FCanModify: Boolean;
+    FConstraints: TCheckConstraints;
+    FCurrentRecord: Longint;
+    FDefaultFields: Boolean;
+    FEOF: Boolean;
+    FFieldList : TFields;
+    FFieldCount : Longint;
+    FFieldDefs: TFieldDefs;
+    FFilterOptions: TFilterOptions;
+    FFilterText: string;
+    FFiltered: Boolean;
+    FFound: Boolean;
+    FInternalCalcFields: Boolean;
+    FModified: Boolean;
+    FOnCalcFields: TDataSetNotifyEvent;
+    FOnDeleteError: TDataSetErrorEvent;
+    FOnEditError: TDataSetErrorEvent;
+    FOnFilterRecord: TFilterRecordEvent;
+    FOnNewRecord: TDataSetNotifyEvent;
+    FOnPostError: TDataSetErrorEvent;
+    FRecNo: Longint;
+    FRecordCount: Longint;
+    FRecordSize: Word;
+    FState: TDataSetState;
+    Procedure DoInsertAppend(DoAppend : Boolean);
+    Procedure DoInternalOpen;
+    Procedure DoInternalClose;
+    Function  GetBuffer (Index : longint) : Pchar;
+    Function  GetField (Index : Longint) : TField;
+    Procedure RemoveField (Field : TField);
+    Procedure SetActive (Value : Boolean);
+    Procedure SetField (Index : Longint;Value : TField);
+    Procedure ShiftBuffers (Offset,Distance : Longint);
+    Function  TryDoing (P : TDataOperation; Ev : TDatasetErrorEvent) : Boolean;
+    Procedure UpdateFieldDefs;
+  protected
+    procedure ActivateBuffers; virtual;
+    procedure BindFields(Binding: Boolean);
+    function  BookmarkAvailable: Boolean;
+    procedure CalculateFields(Buffer: PChar); virtual;
+    procedure CheckActive; virtual;
+    procedure CheckInactive; virtual;
+    procedure ClearBuffers; virtual;
+    procedure ClearCalcFields(Buffer: PChar); virtual;
+    procedure CloseBlob(Field: TField); virtual;
+    procedure CloseCursor; virtual;
+    procedure CreateFields;
+    procedure DataEvent(Event: TDataEvent; Info: Longint); virtual;
+    procedure DestroyFields; virtual;
+    procedure DoAfterCancel; virtual;
+    procedure DoAfterClose; virtual;
+    procedure DoAfterDelete; virtual;
+    procedure DoAfterEdit; virtual;
+    procedure DoAfterInsert; virtual;
+    procedure DoAfterOpen; virtual;
+    procedure DoAfterPost; virtual;
+    procedure DoAfterScroll; virtual;
+    procedure DoBeforeCancel; virtual;
+    procedure DoBeforeClose; virtual;
+    procedure DoBeforeDelete; virtual;
+    procedure DoBeforeEdit; virtual;
+    procedure DoBeforeInsert; virtual;
+    procedure DoBeforeOpen; virtual;
+    procedure DoBeforePost; virtual;
+    procedure DoBeforeScroll; virtual;
+    procedure DoOnCalcFields; virtual;
+    procedure DoOnNewRecord; virtual;
+    function  FieldByNumber(FieldNo: Longint): TField;
+    function  FindRecord(Restart, GoForward: Boolean): Boolean; virtual;
+    procedure FreeFieldBuffers; virtual;
+    function  GetBookmarkStr: TBookmarkStr; virtual;
+    procedure GetCalcFields(Buffer: PChar); virtual;
+    function  GetCanModify: Boolean; virtual;
+    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
+    function  GetFieldClass(FieldType: TFieldType): TFieldClass; virtual;
+    Function  GetfieldCount : Integer;
+    function  GetIsIndexField(Field: TField): Boolean; virtual;
+    function  GetNextRecords: Longint; virtual;
+    function  GetNextRecord: Boolean; virtual;
+    function  GetPriorRecords: Longint; virtual;
+    function  GetPriorRecord: Boolean; virtual;
+    function  GetRecordCount: Longint; virtual;
+    function  GetRecNo: Longint; virtual;
+    procedure InitFieldDefs; virtual;
+    procedure InitRecord(Buffer: PChar); virtual;
+    procedure InternalCancel; virtual;
+    procedure InternalEdit; virtual;
+    procedure InternalRefresh; virtual;
+    procedure Loaded; override;
+    procedure OpenCursor(InfoQuery: Boolean); virtual;
+    procedure RefreshInternalCalcFields(Buffer: PChar); virtual;
+    Function  RequiredBuffers : longint;
+    procedure RestoreState(const Value: TDataSetState);
+    procedure SetBookmarkStr(const Value: TBookmarkStr); virtual;
+    procedure SetBufListSize(Value: Longint);
+    procedure SetChildOrder(Component: TComponent; Order: Longint); override;
+    procedure SetCurrentRecord(Index: Longint); virtual;
+    procedure SetFiltered(Value: Boolean); virtual;
+    procedure SetFilterOptions(Value: TFilterOptions); virtual;
+    procedure SetFilterText(const Value: string); virtual;
+    procedure SetFound(const Value: Boolean);
+    procedure SetModified(Value: Boolean);
+    procedure SetName(const Value: TComponentName); override;
+    procedure SetOnFilterRecord(const Value: TFilterRecordEvent); virtual;
+    procedure SetRecNo(Value: Longint); virtual;
+    procedure SetState(Value: TDataSetState);
+    function SetTempState(const Value: TDataSetState): TDataSetState;
+    function TempBuffer: PChar;
+    procedure UpdateIndexDefs; virtual;
+    property ActiveRecord: Longint read FActiveRecord;
+    property CurrentRecord: Longint read FCurrentRecord;
+    property BlobFieldCount: Longint read FBlobFieldCount;
+    property BookmarkSize: Longint read FBookmarkSize write FBookmarkSize;
+    property Buffers[Index: Longint]: PChar read GetBuffer;
+    property BufferCount: Longint read FBufferCount;
+    property CalcBuffer: PChar read FCalcBuffer;
+    property CalcFieldsSize: Longint read FCalcFieldsSize;
+    property InternalCalcFields: Boolean read FInternalCalcFields;
+    property Constraints: TCheckConstraints read FConstraints write FConstraints;
+  protected { abstract methods }
+    function AllocRecordBuffer: PChar; virtual; abstract;
+    procedure FreeRecordBuffer(var Buffer: PChar); virtual; abstract;
+    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); virtual; abstract;
+    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; virtual; abstract;
+    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; virtual; abstract;
+    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; virtual; abstract;
+    function GetRecordSize: Word; virtual; abstract;
+    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); virtual; abstract;
+    procedure InternalClose; virtual; abstract;
+    procedure InternalDelete; virtual; abstract;
+    procedure InternalFirst; virtual; abstract;
+    procedure InternalGotoBookmark(ABookmark: Pointer); virtual; abstract;
+    procedure InternalHandleException; virtual; abstract;
+    procedure InternalInitFieldDefs; virtual; abstract;
+    procedure InternalInitRecord(Buffer: PChar); virtual; abstract;
+    procedure InternalLast; virtual; abstract;
+    procedure InternalOpen; virtual; abstract;
+    procedure InternalPost; virtual; abstract;
+    procedure InternalSetToRecord(Buffer: PChar); virtual; abstract;
+    function IsCursorOpen: Boolean; virtual; abstract;
+    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); virtual; abstract;
+    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); virtual; abstract;
+    procedure SetFieldData(Field: TField; Buffer: Pointer); virtual; abstract;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    function ActiveBuffer: PChar;
+    procedure Append;
+    procedure AppendRecord(const Values: array of const);
+    function BookmarkValid(ABookmark: TBookmark): Boolean; virtual;
+    procedure Cancel; virtual;
+    procedure CheckBrowseMode;
+    procedure ClearFields;
+    procedure Close;
+    function  ControlsDisabled: Boolean;
+    function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint; virtual;
+    function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; virtual;
+    procedure CursorPosChanged;
+    procedure Delete;
+    procedure DisableControls;
+    procedure Edit;
+    procedure EnableControls;
+    function FieldByName(const FieldName: string): TField;
+    function FindField(const FieldName: string): TField;
+    function FindFirst: Boolean;
+    function FindLast: Boolean;
+    function FindNext: Boolean;
+    function FindPrior: Boolean;
+    procedure First;
+    procedure FreeBookmark(ABookmark: TBookmark); virtual;
+    function GetBookmark: TBookmark; virtual;
+    function GetCurrentRecord(Buffer: PChar): Boolean; virtual;
+    procedure GetFieldList(List: TList; const FieldNames: string);
+    procedure GetFieldNames(List: TStrings);
+    procedure GotoBookmark(ABookmark: TBookmark);
+    procedure Insert;
+    procedure InsertRecord(const Values: array of const);
+    function IsEmpty: Boolean;
+    function IsSequenced: Boolean; virtual;
+    procedure Last;
+    function MoveBy(Distance: Longint): Longint;
+    procedure Next;
+    procedure Open;
+    procedure Post; virtual;
+    procedure Prior;
+    procedure Refresh;
+    procedure Resync(Mode: TResyncMode); virtual;
+    procedure SetFields(const Values: array of const);
+    procedure Translate(Src, Dest: PChar; ToOem: Boolean); virtual;
+    procedure UpdateCursorPos;
+    procedure UpdateRecord;
+    property BOF: Boolean read FBOF;
+    property Bookmark: TBookmarkStr read GetBookmarkStr write SetBookmarkStr;
+    property CanModify: Boolean read GetCanModify;
+    property DefaultFields: Boolean read FDefaultFields;
+    property EOF: Boolean read FEOF;
+    property FieldCount: Longint read GetFieldCount;
+    property FieldDefs: TFieldDefs read FFieldDefs write FFieldDefs;
+    property Fields[Index: Longint]: TField read GetField write SetField;
+    property Found: Boolean read FFound;
+    property Modified: Boolean read FModified;
+    property RecordCount: Longint read GetRecordCount;
+    property RecNo: Longint read FRecNo write FRecNo;
+    property RecordSize: Word read FRecordSize;
+    property State: TDataSetState read FState;
+    property Fields : TFields Read FFieldList;
+    property Filter: string read FFilterText write FFilterText;
+    property Filtered: Boolean read FFiltered write FFiltered default False;
+    property FilterOptions: TFilterOptions read FFilterOptions write FFilterOptions;
+    property Active: Boolean read FActive write SetActive default False;
+    property AutoCalcFields: Boolean read FAutoCalcFields write FAutoCalcFields;
+    property BeforeOpen: TDataSetNotifyEvent read FBeforeOpen write FBeforeOpen;
+    property AfterOpen: TDataSetNotifyEvent read FAfterOpen write FAfterOpen;
+    property BeforeClose: TDataSetNotifyEvent read FBeforeClose write FBeforeClose;
+    property AfterClose: TDataSetNotifyEvent read FAfterClose write FAfterClose;
+    property BeforeInsert: TDataSetNotifyEvent read FBeforeInsert write FBeforeInsert;
+    property AfterInsert: TDataSetNotifyEvent read FAfterInsert write FAfterInsert;
+    property BeforeEdit: TDataSetNotifyEvent read FBeforeEdit write FBeforeEdit;
+    property AfterEdit: TDataSetNotifyEvent read FAfterEdit write FAfterEdit;
+    property BeforePost: TDataSetNotifyEvent read FBeforePost write FBeforePost;
+    property AfterPost: TDataSetNotifyEvent read FAfterPost write FAfterPost;
+    property BeforeCancel: TDataSetNotifyEvent read FBeforeCancel write FBeforeCancel;
+    property AfterCancel: TDataSetNotifyEvent read FAfterCancel write FAfterCancel;
+    property BeforeDelete: TDataSetNotifyEvent read FBeforeDelete write FBeforeDelete;
+    property AfterDelete: TDataSetNotifyEvent read FAfterDelete write FAfterDelete;
+    property BeforeScroll: TDataSetNotifyEvent read FBeforeScroll write FBeforeScroll;
+    property AfterScroll: TDataSetNotifyEvent read FAfterScroll write FAfterScroll;
+    property OnCalcFields: TDataSetNotifyEvent read FOnCalcFields write FOnCalcFields;
+    property OnDeleteError: TDataSetErrorEvent read FOnDeleteError write FOnDeleteError;
+    property OnEditError: TDataSetErrorEvent read FOnEditError write FOnEditError;
+    property OnFilterRecord: TFilterRecordEvent read FOnFilterRecord write SetOnFilterRecord;
+    property OnNewRecord: TDataSetNotifyEvent read FOnNewRecord write FOnNewRecord;
+    property OnPostError: TDataSetErrorEvent read FOnPostError write FOnPostError;
+  end;
+
+ { TDBDataset }
+
+  TDBDatasetClass = Class of TDBDataset;
+  TDBDataset = Class(TDataset)
+    Private
+      FDatabase : TDatabase;
+      Procedure SetDatabase (Value : TDatabase);
+    Published
+      Property DataBase : TDatabase Read FDatabase Write SetDatabase;
+    end;
+
+  { TDatabase }
+
+  TLoginEvent = procedure(Database: TDatabase;
+    LoginParams: TStrings) of object;
+
+  TDatabaseClass = Class Of TDatabase;
+
+  TDatabase = class(TComponent)
+  private
+    FConnected : Boolean;
+    FDataBaseName : String;
+    FDataSets : TList;
+    FDirectOry : String;
+    FKeepConnection : Boolean;
+    FLoginPrompt : Boolean;
+    FOnLogin : TLoginEvent;
+    FParams : TStrings;
+    FSQLBased : Boolean;
+    Function GetDataSetCount : Longint;
+    Function GetDataset(Index : longint) : TDBDataset;
+    procedure SetConnected (Value : boolean);
+    procedure RegisterDataset (DS : TDBDataset);
+    procedure UnRegisterDataset (DS : TDBDataset);
+    procedure RemoveDataSets;
+  protected
+    Procedure CheckConnected;
+    Procedure CheckDisConnected;
+    procedure Loaded; override;
+    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    Procedure DoInternalConnect; Virtual;Abstract;
+    Procedure DoInternalDisConnect; Virtual;Abstract;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Close;
+    procedure Open;
+    procedure CloseDataSets;
+    procedure StartTransaction; virtual; abstract;
+    procedure EndTransaction; virtual; abstract;
+    property DataSetCount: Longint read GetDataSetCount;
+    property DataSets[Index: Longint]: TDBDataSet read GetDataSet;
+    property Directory: string read FDirectory write FDirectory;
+    property IsSQLBased: Boolean read FSQLBased;
+  published
+    property Connected: Boolean read FConnected write SetConnected;
+    property DatabaseName: string read FDatabaseName write FDatabaseName;
+    property KeepConnection: Boolean read FKeepConnection write FKeepConnection;
+    property LoginPrompt: Boolean read FLoginPrompt write FLoginPrompt;
+    property Params : TStrings read FParams Write FParams;
+    property OnLogin: TLoginEvent read FOnLogin write FOnLogin;
+  end;
+
+Const
+  Fieldtypenames : Array [TFieldType] of String[15] =
+    ( 'Unknown',
+      'String',
+      'Smallint',
+      'Integer',
+      'Word',
+      'Boolean',
+      'Float',
+      'Date',
+      'Time',
+      'DateTime',
+      'Bytes',
+      'VarBytes',
+      'AutoInc',
+      'Blob',
+      'Memo',
+      'Graphic',
+      'FmtMemo',
+      'ParadoxOle',
+      'DBaseOle',
+      'TypedBinary',
+      'Cursor'
+    );
+{ Auxiliary functions }
+
+Procedure DatabaseError (Const Msg : String);
+Procedure DatabaseError (Const Msg : String; Comp : TComponent);
+Procedure DatabaseErrorFmt (Const Fmt : String; Args : Array Of Const);
+Procedure DatabaseErrorFmt (Const Fmt : String; Args : Array Of const;
+                            Comp : TComponent);
+
+implementation
+
+{ ---------------------------------------------------------------------
+    Auxiliary functions
+  ---------------------------------------------------------------------}
+
+
+
+Procedure DatabaseError (Const Msg : String);
+
+begin
+  Raise EDataBaseError.Create(Msg);
+end;
+
+Procedure DatabaseError (Const Msg : String; Comp : TComponent);
+
+begin
+  Raise EDatabaseError.CreateFmt('%s : %s',[Comp.Name,Msg]);
+end;
+
+Procedure DatabaseErrorFmt (Const Fmt : String; Args : Array Of Const);
+
+begin
+  Raise EDatabaseError.CreateFmt(Fmt,Args);
+end;
+
+Procedure DatabaseErrorFmt (Const Fmt : String; Args : Array Of const;
+                            Comp : TComponent);
+begin
+  Raise EDatabaseError.CreateFmt(Format('%s : %s',[Comp.Name,Fmt]),Args);
+end;
+
+
+{$i dbs.inc}
+
+{ TIndexDef }
+
+constructor TIndexDef.Create(Owner: TIndexDefs; const AName, TheFields: string;
+      TheOptions: TIndexOptions);
+
+begin
+  //!! To be implemented
+end;
+
+
+
+destructor TIndexDef.Destroy;
+
+begin
+  //!! To be implemented
+end;
+
+
+{ TIndexDefs }
+
+Function TIndexDefs.GetItem (Index : longint) : TindexDef;
+
+begin
+  //!! To be implemented
+end;
+
+
+constructor TIndexDefs.Create(DataSet: TDataSet);
+
+begin
+  //!! To be implemented
+end;
+
+
+destructor TIndexDefs.Destroy;
+
+begin
+  //!! To be implemented
+end;
+
+
+procedure TIndexDefs.Add(const Name, Fields: string; Options: TIndexOptions);
+
+begin
+  //!! To be implemented
+end;
+
+
+procedure TIndexDefs.Assign(IndexDefs: TIndexDefs);
+
+begin
+  //!! To be implemented
+end;
+
+
+procedure TIndexDefs.Clear;
+
+begin
+  //!! To be implemented
+end;
+
+
+function TIndexDefs.FindIndexForFields(const Fields: string): TIndexDef;
+
+begin
+  //!! To be implemented
+end;
+
+
+function TIndexDefs.GetIndexForFields(const Fields: string;
+  CaseInsensitive: Boolean): TIndexDef;
+
+begin
+  //!! To be implemented
+end;
+
+
+function TIndexDefs.IndexOf(const Name: string): Longint;
+
+begin
+  //!! To be implemented
+end;
+
+
+procedure TIndexDefs.Update;
+
+begin
+  //!! To be implemented
+end;
+
+
+
+{ TCheckConstraint }
+
+procedure TCheckConstraint.Assign(Source: TPersistent);
+
+begin
+  //!! To be implemented
+end;
+
+
+
+{ TCheckConstraints }
+
+Function TCheckConstraints.GetItem(Index : Longint) : TCheckConstraint;
+
+begin
+  //!! To be implemented
+end;
+
+
+Procedure TCheckConstraints.SetItem(index : Longint; Value : TCheckConstraint);
+
+begin
+  //!! To be implemented
+end;
+
+
+function TCheckConstraints.GetOwner: TPersistent;
+
+begin
+  //!! To be implemented
+end;
+
+
+constructor TCheckConstraints.Create(Owner: TPersistent);
+
+begin
+  //!! To be implemented
+end;
+
+
+function TCheckConstraints.Add: TCheckConstraint;
+
+begin
+  //!! To be implemented
+end;
+
+
+
+{$i dataset.inc}
+{$i fields.inc}
+{$i database.inc}
+
+end.
+
+{
+  $Log$
+  Revision 1.7  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:05  peter
+    * moved to packages dir
+
+  Revision 1.5  1999/11/12 22:53:32  michael
+  + Added append() insert() tested append. Datetime as string works now
+
+  Revision 1.4  1999/11/11 17:31:09  michael
+  + Added Checks for all simple field types.
+  + Initial implementation of Insert/Append
+
+  Revision 1.3  1999/11/09 13:33:47  peter
+    * reallocmem fixes
+
+  Revision 1.2  1999/10/24 17:07:54  michael
+  + Added copyright header
+
+}

fcl/db/dbs.inc

@@ -0,0 +1,64 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999 by Michael Van Canneyt, member of the
+    Free Pascal development team
+
+    Constants used for displaying messages in DB unit
+    
+    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.
+
+ **********************************************************************}
+
+Const
+  SUnknownFieldType = 'Unknown field type : %s';
+  SUnknownField = 'No field named "%s" was found in dataset "%s"';
+  SNeedFieldName = 'Field needs a name';  
+  SInvalidTypeConversion = 'Invalid type conversion to %s in field %s';
+  SReadOnlyField = 'Field %s cannot be modified, it is read-only.';
+  SInvalidFieldSize = 'Invalid field size : %d';
+  SNoDataset = 'No dataset asssigned for field : "%s"';
+  SDuplicateFieldName = 'Duplicate fieldname : "%s"';
+  SFieldNotFound = 'Field not found : "%s"';
+  SInvalidFieldKind = '%s : invalid field kind : ';
+  SRangeError = '%f is not between %f and %f for %s';
+  SNotAninteger = '"%s" is not a valid integer';
+  SCantSetAutoIncFields = 'AutoInc Fields are read-only';
+  SNotAFloat = '"%s" is not a valid float';
+  SInvalidDisplayValues = '"%s" are not valid boolean displayvalues';
+  SNotABoolean = '"%s" is not a valid boolean';
+  SInactiveDataset = 'Operation cannot be performed on an inactive dataset';
+  SActiveDataset = 'Operation cannot be performed on an active dataset';
+  SNoDatasets = 'No datasets are attached to the database';
+  SDatasetRegistered = 'Dataset already registered : "%s"';
+  SNoDatasetRegistered = 'No such dataset registered : "%s"';
+  SNotConnected = 'Operation cannot be performed on an disconnected database';
+  SConnected = 'Operation cannot be performed on an connected database';
+  SNoSuchRecord = 'Could not find the requested record.';  
+  SDatasetReadOnly = 'Dataset is read-only.';
+  SNeedField = 'Field %s is required, but not supplied.';
+  
+{
+  $Log$
+  Revision 1.6  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:06  peter
+    * moved to packages dir
+
+  Revision 1.4  1999/11/12 22:53:32  michael
+  + Added append() insert() tested append. Datetime as string works now
+
+  Revision 1.3  1999/11/11 17:31:09  michael
+  + Added Checks for all simple field types.
+  + Initial implementation of Insert/Append
+
+  Revision 1.2  1999/10/24 17:07:54  michael
+  + Added copyright header
+
+}  

fcl/db/ddg_ds.pp

@@ -0,0 +1,529 @@
+unit DDG_DS;
+
+{$define dsdebug}
+
+interface
+
+uses Db, Classes, DDG_Rec;
+
+type
+
+  PInteger =  ^Integer;
+  
+  // Bookmark information record to support TDataset bookmarks:
+  PDDGBookmarkInfo = ^TDDGBookmarkInfo;
+  TDDGBookmarkInfo = record
+    BookmarkData: Integer;
+    BookmarkFlag: TBookmarkFlag;
+  end;
+
+  // List used to maintain access to file of record:
+  TIndexList = class(TList)
+  public
+    procedure LoadFromFile(const FileName: string); virtual;
+    procedure LoadFromStream(Stream: TStream); virtual;
+    procedure SaveToFile(const FileName: string); virtual;
+    procedure SaveToStream(Stream: TStream); virtual;
+  end;
+
+  // Specialized DDG TDataset descendant for our "table" data:
+  TDDGDataSet = class(TDataSet)
+  private
+    function GetDataFileSize: Integer;
+  public
+    FDataFile: TDDGDataFile;
+    FIdxName: string;
+    FIndexList: TIndexList;
+    FTableName: string;
+    FRecordPos: Integer;
+    FRecordSize: Integer;
+    FBufferSize: Integer;
+    procedure SetTableName(const Value: string);
+  protected
+    { Mandatory overrides }
+    // Record buffer methods:
+    function AllocRecordBuffer: PChar; override;
+    procedure FreeRecordBuffer(var Buffer: PChar); override;
+    procedure InternalInitRecord(Buffer: PChar); override;
+    function GetRecord(Buffer: PChar; GetMode: TGetMode;
+      DoCheck: Boolean): TGetResult; override;
+    function GetRecordSize: Word; override;
+    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
+    // Bookmark methods:
+    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
+    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
+    procedure InternalGotoBookmark(ABookmark: Pointer); override;
+    procedure InternalSetToRecord(Buffer: PChar); override;
+    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
+    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
+    // Navigational methods:
+    procedure InternalFirst; override;
+    procedure InternalLast; override;
+    // Editing methods:
+    procedure InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); override;
+    procedure InternalDelete; override;
+    procedure InternalPost; override;
+    // Misc methods:
+    procedure InternalClose; override;
+    procedure InternalHandleException; override;
+    procedure InternalInitFieldDefs; override;
+    procedure InternalOpen; override;
+    function IsCursorOpen: Boolean; override;
+    { Optional overrides }
+    function GetRecordCount: Integer; override;
+    function GetRecNo: Integer; override;
+    procedure SetRecNo(Value: Integer); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
+
+    // Additional procedures
+    procedure EmptyTable;
+  published
+    property Active;
+    property TableName: string read FTableName write SetTableName;
+    property BeforeOpen;
+    property AfterOpen;
+    property BeforeClose;
+    property AfterClose;
+    property BeforeInsert;
+    property AfterInsert;
+    property BeforeEdit;
+    property AfterEdit;
+    property BeforePost;
+    property AfterPost;
+    property BeforeCancel;
+    property AfterCancel;
+    property BeforeDelete;
+    property AfterDelete;
+    property BeforeScroll;
+    property AfterScroll;
+    property OnDeleteError;
+    property OnEditError;
+
+    // Additional Properties
+    property DataFileSize: Integer read GetDataFileSize;
+  end;
+
+implementation
+
+uses SysUtils;
+
+const
+  feDDGTable = '.ddg';
+  feDDGIndex = '.ddx';
+  // note that file is not being locked!
+
+{ TIndexList }
+
+procedure TIndexList.LoadFromFile(const FileName: string);
+var
+  F: TFileStream;
+begin
+  F := TFileStream.Create(FileName, fmOpenRead);
+  try
+    LoadFromStream(F);
+  finally
+    F.Free;
+  end;
+end;
+
+procedure TIndexList.LoadFromStream(Stream: TStream);
+var
+  Value: Integer;
+begin
+  while Stream.Position < Stream.Size do
+  begin
+    Stream.Read(Value, SizeOf(Value));
+    Add(Pointer(Value));
+  end;
+end;
+
+procedure TIndexList.SaveToFile(const FileName: string);
+var
+  F: TFileStream;
+begin
+  F := TFileStream.Create(FileName, fmCreate);
+  try
+    SaveToStream(F);
+  finally
+    F.Free;
+  end;
+end;
+
+procedure TIndexList.SaveToStream(Stream: TStream);
+var
+  i: Integer;
+  Value: Integer;
+begin
+  for i := 0 to Count - 1 do
+  begin
+    Value := Integer(Items[i]);
+    Stream.Write(Value, SizeOf(Value));
+  end;
+end;
+
+{ TDDGDataSet }
+
+constructor TDDGDataSet.Create(AOwner: TComponent);
+begin
+  FIndexList := TIndexList.Create;
+  FRecordSize := SizeOf(TDDGData);
+  FBufferSize := FRecordSize + SizeOf(TDDGBookmarkInfo);
+  inherited Create(AOwner);
+end;
+
+destructor TDDGDataSet.Destroy;
+begin
+  inherited Destroy;
+  FIndexList.Free;
+end;
+
+function TDDGDataSet.AllocRecordBuffer: PChar;
+begin
+  Result := AllocMem(FBufferSize);
+end;
+
+procedure TDDGDataSet.FreeRecordBuffer(var Buffer: PChar);
+begin
+  FreeMem(Buffer);
+end;
+
+procedure TDDGDataSet.InternalInitRecord(Buffer: PChar);
+begin
+  FillChar(Buffer^, FBufferSize, 0);
+end;
+
+function TDDGDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
+  DoCheck: Boolean): TGetResult;
+var
+  IndexPos: Integer;
+begin
+ if FIndexList.Count < 1 then
+    Result := grEOF
+  else begin
+    Result := grOk;
+    case GetMode of
+      gmPrior:
+        if FRecordPos <= 0 then
+        begin
+          Result := grBOF;
+          FRecordPos := -1;
+        end
+        else
+          Dec(FRecordPos);
+      gmCurrent:
+        if (FRecordPos < 0) or (FRecordPos >= RecordCount) then
+           Result := grError;
+      gmNext:
+        if FRecordPos >= RecordCount-1 then
+          Result := grEOF
+        else
+          Inc(FRecordPos);
+    end;
+    if Result = grOk then
+    begin
+      IndexPos := Integer(FIndexList[FRecordPos]);
+      Seek(FDataFile, IndexPos);
+      BlockRead(FDataFile, PDDGData(Buffer)^, 1);
+      with PDDGBookmarkInfo(Buffer + FRecordSize)^ do
+      begin
+        BookmarkData := FRecordPos;
+        BookmarkFlag := bfCurrent;
+      end;
+    end
+    else if (Result = grError) and DoCheck then
+      DatabaseError('No records');
+  end;
+end;
+
+function TDDGDataSet.GetRecordSize: Word;
+begin
+  Result := FRecordSize;
+end;
+
+function TDDGDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
+begin
+  Result := True;
+  case Field.Index of
+    0:
+      begin
+        Move(ActiveBuffer^, Buffer^, Field.Size);
+        Result := PChar(Buffer)^ <> #0;
+      end;
+    1: Move(PDDGData(ActiveBuffer)^.Height, Buffer^, Field.DataSize);
+    2: Move(PDDGData(ActiveBuffer)^.LongField, Buffer^, Field.DataSize);
+    3: Move(PDDGData(ActiveBuffer)^.ShoeSize, Buffer^, Field.DataSize);
+    4: Move(PDDGData(ActiveBuffer)^.WordField, Buffer^, Field.DataSize);
+    5: Move(PDDGData(ActiveBuffer)^.DateTimeField, Buffer^, Field.DataSize);
+    6: Move(PDDGData(ActiveBuffer)^.TimeField, Buffer^, Field.DataSize);
+    7: Move(PDDGData(ActiveBuffer)^.DateField, Buffer^, Field.DataSize);
+    8: Move(PDDGData(ActiveBuffer)^.Even, Buffer^, Field.DataSize);
+  end;
+end;
+
+procedure TDDGDataSet.SetFieldData(Field: TField; Buffer: Pointer);
+begin
+  case Field.Index of
+    0: Move(Buffer^, ActiveBuffer^, Field.Size);
+    1: Move(Buffer^, PDDGData(ActiveBuffer)^.Height, Field.DataSize);
+    2: Move(Buffer^, PDDGData(ActiveBuffer)^.LongField, Field.DataSize);
+    3: Move(Buffer^, PDDGData(ActiveBuffer)^.ShoeSize, Field.DataSize);
+    4: Move(Buffer^, PDDGData(ActiveBuffer)^.WordField, Field.DataSize);
+    5: Move(Buffer^, PDDGData(ActiveBuffer)^.DateTimeField, Field.DataSize);
+    6: Move(Buffer^, PDDGData(ActiveBuffer)^.TimeField, Field.DataSize);
+    7: Move(Buffer^, PDDGData(ActiveBuffer)^.DateField, Field.DataSize);
+    8: Move(Buffer^, PDDGData(ActiveBuffer)^.Even, Field.DataSize);
+  end;
+  DataEvent(deFieldChange, Longint(Field));
+end;
+
+procedure TDDGDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
+begin
+  PInteger(Data)^ := PDDGBookmarkInfo(Buffer + FRecordSize)^.BookmarkData;
+end;
+
+function TDDGDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
+begin
+  Result := PDDGBookmarkInfo(Buffer + FRecordSize)^.BookmarkFlag;
+end;
+
+procedure TDDGDataSet.InternalGotoBookmark(ABookmark: Pointer);
+begin
+  FRecordPos := PInteger(ABookmark)^;
+  Writeln ('Bookmark : Setting record position to : ',FrecordPos);
+end;
+
+procedure TDDGDataSet.InternalSetToRecord(Buffer: PChar);
+begin
+  // bookmark value is the same as an offset into the file
+  FRecordPos := PDDGBookmarkInfo(Buffer + FRecordSize)^.Bookmarkdata;
+end;
+
+procedure TDDGDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
+begin
+  PDDGBookmarkInfo(Buffer + FRecordSize)^.BookmarkData := PInteger(Data)^;
+end;
+
+procedure TDDGDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
+begin
+  PDDGBookmarkInfo(Buffer + FRecordSize)^.BookmarkFlag := Value;
+end;
+
+procedure TDDGDataSet.InternalFirst;
+begin
+  FRecordPos := -1;
+end;
+
+procedure TDDGDataSet.InternalInitFieldDefs;
+begin
+  // create FieldDefs which map to each field in the data record
+  FieldDefs.Clear;
+  TFieldDef.Create(FieldDefs, 'Name', ftString, SizeOf(TNameStr), False, 1);
+  TFieldDef.Create(FieldDefs, 'Height', ftFloat, 0, False, 2);
+  TFieldDef.Create(FieldDefs, 'LongField',ftInteger, 0, False, 3);
+  TFieldDef.Create(FieldDefs, 'ShoeSize', ftSmallint, 0, False, 4);
+  TFieldDef.Create(FieldDefs, 'WordField', ftword, 0, false, 5);
+  TFieldDef.Create(FieldDefs, 'DateTimeField', ftDateTime, 0, false, 6);
+  TFieldDef.Create(FieldDefs, 'TimeField',ftTime, 0, false, 7);
+  TFieldDef.Create(FieldDefs, 'DateField',ftDate, 0, false, 8);
+  TFieldDef.Create(FieldDefs, 'Booleanfield',ftboolean, 0, False, 9); 
+end;
+
+procedure TDDGDataSet.InternalLast;
+begin
+  FRecordPos := FIndexList.Count;
+end;
+
+procedure TDDGDataSet.InternalClose;
+begin
+  if FileRec(FDataFile).Mode <> 0 then
+    CloseFile(FDataFile);
+  FIndexList.SaveToFile(FIdxName);
+  FIndexList.Clear;
+  if DefaultFields then
+    DestroyFields;
+  FRecordPos := -1;
+  FillChar(FDataFile, SizeOf(FDataFile), 0);
+end;
+
+procedure TDDGDataSet.InternalHandleException;
+begin
+  // standard implementation for this method:
+  // Application.HandleException(Self);
+end;
+
+procedure TDDGDataSet.InternalDelete;
+begin
+  FIndexList.Delete(FRecordPos);
+  if FRecordPos >= FIndexList.Count then Dec(FRecordPos);
+end;
+
+procedure TDDGDataSet.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean);
+var
+  RecPos: Integer;
+begin
+  Seek(FDataFile, FileSize(FDataFile));
+  BlockWrite(FDataFile, PDDGData(Buffer)^, 1);
+  if DoAppend then
+  begin
+    FIndexList.Add(Pointer(FileSize(FDataFile) - 1));
+    InternalLast;
+  end
+  else begin
+    if FRecordPos = -1 then RecPos := 0
+    else RecPos := FRecordPos;
+    FIndexList.Insert(RecPos, Pointer(FileSize(FDataFile) - 1));
+  end;
+  FIndexList.SaveToFile(FIdxName);
+end;
+
+procedure TDDGDataSet.InternalOpen;
+var
+  HFile: THandle;
+begin
+  // make sure table and index files exist
+  FIdxName := ChangeFileExt(FTableName, feDDGIndex);
+  if not (FileExists(FTableName) and FileExists(FIdxName)) then
+    begin
+ {
+    if MessageDlg('Table or index file not found.  Create new table?',
+      mtConfirmation, [mbYes, mbNo], 0) = mrYes then
+    begin
+      HFile := FileCreate(FTableName);
+      if HFile = -1 then
+        DatabaseError('Error creating table file');
+      FileClose(HFile);
+      HFile := FileCreate(FIdxName);
+      if HFile = -1 then
+        DatabaseError('Error creating index file');
+      FileClose(HFile);
+    end
+   else
+ }  
+      DatabaseError('Could not open table');
+  end;
+  // open data file
+  FileMode := fmOpenReadWrite;
+  Writeln ('OPening data file');
+  AssignFile(FDataFile, FTableName);
+  Reset(FDataFile);  
+  try
+    writeln ('Loading index file');
+    FIndexList.LoadFromFile(FIdxName); // initialize index TList from file
+    FRecordPos := -1;                  // initial record pos before BOF
+    BookmarkSize := SizeOf(Integer);   // initialize bookmark size for VCL
+    InternalInitFieldDefs;             // initialize FieldDef objects
+    // Create TField components when no persistent fields have been created
+    {$ifdef dsdebug}
+    writeln ('Creating Fields');
+    {$endif}
+    if DefaultFields then CreateFields;
+    {$ifdef dsdebug}
+    writeln ('Binding Fields');
+    {$endif}
+    BindFields(True);                  // bind FieldDefs to actual data
+  except
+    {$ifdef dsdebug}
+    Writeln ('Caught Exception !!');
+    {$endif}
+    CloseFile(FDataFile);
+    FillChar(FDataFile, SizeOf(FDataFile), 0);
+    raise;
+  end;
+ {$ifdef dsdebug}
+  Writeln ('End of internalopen');
+ {$endif}
+end;
+
+procedure TDDGDataSet.InternalPost;
+var
+  RecPos, InsPos: Integer;
+begin
+ {$ifdef dsdebug}
+  Writeln ('Starting internal post.');
+ {$endif}
+  if FRecordPos = -1 then
+    RecPos := 0
+  else begin
+    if State = dsEdit then RecPos := Integer(FIndexList[FRecordPos])
+    else RecPos := FileSize(FDataFile);
+  end;
+  Seek(FDataFile, RecPos);
+ {$ifdef dsdebug}
+  Writeln ('Writing record to disk.');
+ {$endif}
+  BlockWrite(FDataFile, PDDGData(ActiveBuffer)^, 1);
+  if State <> dsEdit then
+  begin
+    if FRecordPos = -1 then InsPos := 0
+    else InsPos := FRecordPos;
+    FIndexList.Insert(InsPos, Pointer(RecPos));
+  end;
+ {$ifdef dsdebug}
+  Writeln ('Writing index to disk.');
+ {$endif}
+  FIndexList.SaveToFile(FIdxName);
+end;
+
+function TDDGDataSet.IsCursorOpen: Boolean;
+begin
+  Result := FileRec(FDataFile).Mode <> 0;
+end;
+
+function TDDGDataSet.GetRecordCount: Integer;
+begin
+  Result := FIndexList.Count;
+end;
+
+function TDDGDataSet.GetRecNo: Integer;
+begin
+  UpdateCursorPos;
+  if (FRecordPos = -1) and (RecordCount > 0) then
+    Result := 1
+  else
+    Result := FRecordPos + 1;
+end;
+
+procedure TDDGDataSet.SetRecNo(Value: Integer);
+begin
+  if (Value >= 0) and (Value <= FIndexList.Count-1) then
+  begin
+    FRecordPos := Value - 1;
+    Resync([]);
+  end;
+end;
+
+procedure TDDGDataSet.SetTableName(const Value: string);
+begin
+  CheckInactive;
+  FTableName := Value;
+  if ExtractFileExt(FTableName) = '' then
+    FTableName := FTableName + feDDGTable;
+  FIdxName := ChangeFileExt(FTableName, feDDGIndex);
+end;
+
+function TDDGDataSet.GetDataFileSize: Integer;
+begin
+  Result := FileSize(FDataFile);
+end;
+
+procedure TDDGDataSet.EmptyTable;
+var
+  HFile: THandle;
+begin
+  Close;
+
+  DeleteFile(FTableName);
+  HFile := FileCreate(FTableName);
+  FileClose(HFile);
+
+  DeleteFile(FIdxName);
+  HFile := FileCreate(FIdxName);
+  FileClose(HFile);
+
+  Open;
+end;
+
+end.

fcl/db/ddg_rec.pp

@@ -0,0 +1,32 @@
+unit DDG_Rec;
+
+interface
+
+uses sysutils;
+
+type
+
+  // arbitary-length array of char used for name field
+  TNameStr = array[0..31] of char;
+
+  // this record info represents the "table" structure:
+  PDDGData = ^TDDGData;
+  TDDGData = record
+    Name: TNameStr;
+    Height: Extended;
+    LongField : Longint;
+    ShoeSize: SmallInt;
+    WordField : Word;
+    DatetimeField : TDateTime;
+    TimeField : TDateTime;
+    DateField : TDateTime;
+    Even : Boolean;
+  end;
+
+  // Pascal file of record which holds "table" data:
+  TDDGDataFile = file of TDDGData;
+
+
+implementation
+
+end.

fcl/db/fields.inc

@@ -0,0 +1,1771 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999 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);
+
+Type PByte = ^Byte;
+
+Var i : longint;
+
+begin
+  Write ('Memory dump : ');
+  For I:=0 to Size-1 do
+    Write (Pbyte(P)[i],' ');
+  Writeln;  
+end;
+
+{ ---------------------------------------------------------------------
+    TFieldDef
+  ---------------------------------------------------------------------}
+     
+Constructor TFieldDef.Create(AOwner: TFieldDefs; const AName: string;
+      ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo: Longint);
+
+begin
+  Inherited Create(AOwner);
+  FName:=Aname;
+  FDatatype:=ADatatype;
+  FSize:=ASize;
+  FRequired:=ARequired;
+  FPrecision:=-1;
+  // Correct sizes.
+  If FDataType=ftFloat then
+    begin
+    If Not FSize in [4,8,10] then FSize:=10
+    end
+  else If FDataType in [ftWord,ftsmallint,ftinteger] Then
+    If Not FSize in [1,2,4] then FSize:=4;
+  FFieldNo:=AFieldNo;
+  AOwner.FItems.Add(Self);
+end;
+
+Destructor TFieldDef.Destroy;
+
+Var I : longint;
+
+begin
+  Inherited destroy;
+end;
+
+Function TFieldDef.CreateField(AOwner: TComponent): TField;
+
+Var TheField : TFieldClass;
+
+begin
+  Writeln ('Creating field');
+  TheField:=GetFieldClass;
+  if TheField=Nil then
+    DatabaseErrorFmt(SUnknownFieldType,[FName]);
+  Result:=Thefield.Create(AOwner);
+  Try
+    Result.Size:=FSize;
+    Result.Required:=FRequired;
+    Result.FieldName:=FName;
+    Result.SetFieldType(DataType);
+    Writeln ('Trying to set dataset');
+    Result.Dataset:=TFieldDefs(Owner).FDataset;
+    If Result is TFloatField then
+      TFloatField(Result).Precision:=FPrecision;
+  except
+    Result.Free;
+    Raise;
+  end;
+end;
+
+Function TFieldDef.GetFieldClass : TFieldClass;
+
+begin
+  //!! Should be owner as tdataset but that doesn't work ??
+  
+  If Assigned(Owner) then
+    Result:=TFieldDefs(Owner).FDataSet.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; ASize: Word;
+  ARequired: Boolean);
+
+begin
+  Writeln ('Adding fielddef');
+  If Length(Name)=0 Then 
+    DatabaseError(SNeedFieldName);
+  // the fielddef will register itself here as a owned component.
+  // fieldno is 1 based !
+  FItems.Add(TFieldDef.Create(Self,AName,ADataType,ASize,Arequired,FItems.Count+1));
+end;
+
+function TFieldDefs.GetCount: Longint;
+
+begin
+  Result:=FItems.Count;
+end;
+
+function TFieldDefs.GetItem(Index: Longint): TFieldDef;
+
+begin
+  Result:=TFieldDef(FItems[Index]);
+end;
+
+constructor TFieldDefs.Create(ADataSet: TDataSet);
+
+begin
+  Inherited Create(ADataSet);
+  FItems:=TList.Create;
+  FDataset:=ADataset;
+end;
+
+procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
+
+Var I : longint;
+
+begin
+  Clear;
+  For i:=1 to FieldDefs.Count-1 do
+    With FieldDefs[i] do 
+      Add(Name,DataType,Size,Required);
+end;
+
+procedure TFieldDefs.Clear;
+
+Var I : longint;
+
+begin
+  For I:=FItems.Count-1 downto 0 do
+    TFieldDef(Fitems[i]).Free;
+end;
+
+function TFieldDefs.Find(const AName: string): TFieldDef;
+
+Var I : longint;
+
+begin
+  I:=IndexOf(AName);
+  If I=-1 Then
+    DataBaseErrorFmt(SUnknownField,[AName,FDataSet.Name]);
+  Result:=TFieldDef(Fitems[i]);
+end;
+
+function TFieldDefs.IndexOf(const AName: string): Longint;
+
+Var I : longint;
+
+begin
+  For I:=0 to Fitems.Count-1 do
+    If AnsiCompareText(TFieldDef(FItems[I]).Name,AName)=0 then
+      begin
+      Result:=I;
+      Exit;
+      end;
+  Result:=-1;
+end;
+
+procedure TFieldDefs.Update;
+
+begin
+  FDataSet.UpdateFieldDefs;
+end;
+
+{ ---------------------------------------------------------------------
+    TField
+  ---------------------------------------------------------------------}
+
+Const 
+  SBoolean = 'Boolean';
+  SDateTime = 'TDateTime';
+  SFloat = 'Float';
+  SInteger = 'Integer';
+  SString = 'String';
+
+constructor TField.Create(AOwner: TComponent); 
+
+begin
+  Inherited Create(AOwner);
+  FVisible:=True;
+  FValidChars:=[#0..#155];
+end;
+
+destructor TField.Destroy; 
+
+begin
+  IF Assigned(FDataSet) then
+    begin
+    FDataSet.Active:=False;
+    FDataSet.RemoveField(Self);
+    end;
+  Inherited Destroy;
+end;
+
+function TField.AccessError(const TypeName: string): EDatabaseError;
+
+begin
+  Result:=EDatabaseError.CreateFmt(SinvalidTypeConversion,[TypeName,FFieldName]);
+end;
+
+procedure TField.Assign(Source: TPersistent); 
+
+begin
+  //!! To be implemented
+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
+  SetData(Nil);
+end;
+
+procedure TField.DataChanged;
+
+begin
+  FDataset.DataEvent(deFieldChange,longint(Self));
+end;
+
+procedure TField.FocusControl;
+
+begin
+  FDataSet.DataEvent(deFocusControl,longint(Self));
+end;
+
+procedure TField.FreeBuffers; 
+
+begin
+  // Empty. Provided for backward compatibiliy;
+  // TDataset manages the buffers.
+end;
+
+function TField.GetAsBoolean: Boolean; 
+
+begin
+  AccessError(SBoolean);
+end;
+
+function TField.GetAsDateTime: TDateTime; 
+
+begin
+  AccessError(SdateTime);
+end;
+
+function TField.GetAsFloat: Extended; 
+
+begin
+  AccessError(SDateTime);
+end;
+
+function TField.GetAsLongint: Longint; 
+
+begin
+  AccessError(SInteger);
+end;
+
+function TField.GetAsString: string; 
+
+begin
+  AccessError(SString);
+end;
+
+function TField.GetCanModify: Boolean; 
+
+begin
+  Result:=Not ReadOnly;
+  If Result then 
+    begin
+    Result:=Assigned(DataSet);
+    If Result then
+      Result:=Not(DataSet.CanModify);
+    end;
+end;
+
+function TField.GetData(Buffer: Pointer): 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);
+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.getIndex : longint;
+
+begin
+  If Assigned(FDataset) then
+    Result:=FDataset.FFieldList.IndexOf(Self)
+  else
+    Result:=-1;
+end;
+
+function TField.GetIsNull: Boolean; 
+
+begin
+  Result:=Not(GetData (Nil));
+end;
+
+function TField.GetParentComponent: TComponent; 
+
+begin
+  //!! To be implemented
+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.Notification(AComponent: TComponent; Operation: TOperation); 
+
+begin
+  Inherited Notification(AComponent,Operation);
+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
+  //!! To be implemented
+end;
+
+procedure TField.SetAsBoolean(AValue: Boolean); 
+
+begin
+  AccessError(SBoolean);
+end;
+
+procedure TField.SetAsDateTime(AValue: TDateTime); 
+
+begin
+  AccessError(SDateTime);
+end;
+
+procedure TField.SetAsFloat(AValue: Extended); 
+
+begin
+  AccessError(SFloat);
+end;
+
+procedure TField.SetAsLongint(AValue: Longint); 
+
+begin
+  AccessError(SInteger);
+end;
+
+procedure TField.SetAsString(const AValue: string); 
+
+begin
+  AccessError(SString);
+end;
+
+procedure TField.SetData(Buffer: Pointer);
+
+begin
+  If Not Assigned(FDataset) then
+    EDatabaseError.CreateFmt(SNoDataset,[FieldName]);
+  FDataSet.SetFieldData(Self,Buffer);  
+end;
+
+Procedure TField.SetDataset (Value : TDataset);
+
+begin
+  Writeln ('Setting dataset');
+  If Value=FDataset then exit;
+  If Assigned(FDataset) Then FDataset.CheckInactive;
+  If Assigned(Value) then
+    begin
+    Value.CheckInactive;
+// ?? Identifier idents no member ??
+    Value.FFieldList.CheckFieldName(FFieldName);
+    end;
+  If Assigned(FDataset) then
+    FDataset.FFieldList.Remove(Self);
+  If Assigned(Value) then 
+    begin
+    Writeln('Adding field to list..');
+    Value.FFieldList.Add(Self);
+    end;
+  FDataset:=Value;    
+end;
+
+procedure TField.SetDataType(AValue: TFieldType);
+
+begin
+  FDataType := AValue;
+end;
+
+procedure TField.SetFieldType(AValue: TFieldType); 
+
+begin
+  //!! To be implemented
+end;
+
+procedure TField.SetParentComponent(AParent: TComponent); 
+
+begin
+  //!! To be implemented
+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.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;
+
+{ ---------------------------------------------------------------------
+    TStringField
+  ---------------------------------------------------------------------}
+  
+
+constructor TStringField.Create(AOwner: TComponent); 
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftString);
+  Size:=20;
+end;
+
+class procedure TStringField.CheckTypeSize(AValue: Longint); 
+
+begin
+  If (AValue<1) 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: Extended; 
+
+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.GetDataSize: Word; 
+
+begin
+  Result:=Size+1;
+end;
+
+function TStringField.GetDefaultWidth: Longint; 
+
+begin
+  result:=Size;
+end;
+
+Procedure TStringField.GetText(var AText: string; DisplayText: Boolean); 
+
+begin
+    AText:=GetAsString;
+end;
+
+function TStringField.GetValue(var AValue: string): Boolean;
+
+Var Buf : TStringFieldBuffer;
+
+begin
+  Result:=GetData(@Buf);
+  If Result then
+    AValue:=Buf;
+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: Extended); 
+
+begin
+  SetAsString(FloatToStr(AValue));
+end;
+
+procedure TStringField.SetAsLongint(AValue: Longint); 
+
+begin
+  SetAsString(intToStr(AValue));
+end;
+
+procedure TStringField.SetAsString(const AValue: string); 
+
+Const NullByte : char = #0;
+
+begin
+  IF Length(AValue)=0 then
+    SetData(@NullByte)
+  else
+    SetData(@AValue[1]);  
+end;
+
+{ ---------------------------------------------------------------------
+    TNumericField
+  ---------------------------------------------------------------------}
+
+
+constructor TNumericField.Create(AOwner: TComponent); 
+
+begin
+  Inherited Create(AOwner);
+  AlignMent:=taRightJustify;
+end;
+
+procedure TNumericField.RangeError(AValue, Min, Max: Extended);
+
+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:=$80000000;
+  FMaxRange:=$7fffffff;
+  FValidchars:=['+','-','0'..'9'];
+end;
+
+function TLongintField.GetAsFloat: Extended; 
+
+begin
+  Result:=GetAsLongint;
+end;
+
+function TLongintField.GetAsLongint: Longint; 
+
+begin
+  If Not GetValue(Result) then 
+    Result:=0;
+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; DisplayText: Boolean); 
+
+var l : longint;
+    fmt : string;
+
+begin
+  Atext:='';
+  If Not GetData(@l) then exit;
+  If DisplayText or (FEditFormat='') then
+    fmt:=FDisplayFormat
+  else
+    fmt:=FEditFormat;
+{  // no formatFloat yet
+  If length(fmt)<>0 then
+    AText:=FormatFloat(fmt,L)
+  else
+}
+    Str(L,AText);
+end;
+
+function TLongintField.GetValue(var AValue: Longint): Boolean;
+
+Type 
+  PSmallint = ^SmallInt;
+  PLongint = ^Longint;
+  PWord = ^Word;
+
+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: Extended); 
+
+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.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
+  if FMaxValue=0 Then
+    Result:=(AValue<=FMaxRange) and (AValue>=FMinRange)
+  else
+    Result:=(AValue<=FMaxValue) and (AValue>=FMinValue);
+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;
+
+{ 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);
+end;
+
+Procedure TAutoIncField.SetAsLongint(AValue : Longint); 
+
+begin
+  DataBaseError(SCantSetAutoIncfields);
+end;
+
+{ TFloatField }
+
+function TFloatField.GetAsFloat: Extended; 
+
+begin
+  If Not GetData(@Result) Then 
+    Result:=0.0;
+end;
+
+function TFloatField.GetAsLongint: Longint; 
+
+begin
+  Result:=Round(GetAsFloat);
+end;
+
+function TFloatField.GetAsString: string; 
+
+Var R : Extended;
+   
+begin
+  If GetData(@R) then 
+    Result:=FloatToStr(R)
+  else
+    Result:='';
+end;
+
+function TFloatField.GetDataSize: Word; 
+
+begin
+  Result:=SizeOf(Extended);
+end;
+
+procedure TFloatField.GetText(var TheText: string; DisplayText: Boolean); 
+
+Var 
+    fmt : string;
+    E : Extended;
+    
+begin
+  text:='';
+  If Not GetData(@E) then exit;
+  If DisplayText or (Length(FEditFormat) = 0) Then
+    Fmt:=FDisplayFormat 
+  else
+    Fmt:=FEditFormat;
+{  // No formatfloat yet
+  If fmt<>'' then
+    TheText:=FormatFloat(fmt,E)
+  else
+}
+    Text:=FloatToStrF(E,ffgeneral,FPrecision,0);
+end;
+
+procedure TFloatField.SetAsFloat(AValue: Extended); 
+
+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 : Extended;
+    Code : longint;
+
+begin
+  Val(AVAlue,R,Code);
+  If Code<>0 then
+    DatabaseErrorFmt(SNotAFloat,[AVAlue])
+  Else
+    SetAsFloat(R);
+end;
+
+constructor TFloatField.Create(AOwner: TComponent); 
+
+begin
+  Inherited Create(AOwner);
+  SetDatatype(ftfloat);
+end;
+
+Function TFloatField.CheckRange(AValue : Extended) : Boolean;
+
+begin
+  If (FMinValue<>0) or (FmaxValue<>0) then
+    Result:=(AValue>=FMinValue) and (AVAlue<=FMAxValue)
+  else
+    Result:=True;
+end;
+
+
+{ TBooleanField }
+
+function TBooleanField.GetAsBoolean: Boolean; 
+
+begin
+  If not GetData(@Result) then 
+    Result:=False;
+end;
+
+function TBooleanField.GetAsString: string; 
+
+Var B : boolean;
+
+begin
+  If Getdata(@B) then
+    Result:=FDisplays[False,B]
+  else
+    result:='';
+end;
+
+function TBooleanField.GetDataSize: Word; 
+
+begin
+  Result:=SizeOf(Boolean);
+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); 
+
+begin
+  SetData(@AValue);
+end;
+
+procedure TBooleanField.SetAsString(const AValue: string); 
+
+Var Temp : string;
+
+begin
+  Temp:=UpperCase(AValue);
+  If Temp=FDisplays[True,True] Then
+    SetAsBoolean(True)
+  else If Temp=FDisplays[True,False] then
+    SetAsBoolean(False)
+  else
+    DatabaseErrorFmt(SNotABoolean,[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 }
+
+
+function TDateTimeField.GetAsDateTime: TDateTime; 
+
+begin
+  If Not GetData(@Result) then
+    Result:=0;
+end;
+
+
+function TDateTimeField.GetAsFloat: Extended; 
+
+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; DisplayText: Boolean); 
+
+Var R : TDateTime;
+    F : String;
+
+begin
+  If Not Getdata(@R) then
+    TheText:=''
+  else
+    begin
+    If (DisplayText) 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);
+end;
+
+
+procedure TDateTimeField.SetAsFloat(AValue: Extended); 
+
+begin
+  SetAsDateTime(AValue);
+end;
+
+
+procedure TDateTimeField.SetAsString(const AValue: string); 
+
+Var R : TDateTime;
+
+begin
+  R:=StrToDateTime(AVAlue);
+  SetData(@R);
+end;
+
+
+constructor TDateTimeField.Create(AOwner: TComponent); 
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftDateTime);
+end;
+
+{ TDateField }
+
+function TDateField.GetDataSize: Word; 
+
+begin
+  Result:=SizeOf(TDateTime);
+end;
+
+
+constructor TDateField.Create(AOwner: TComponent); 
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftDate);
+end;
+
+
+
+{ TTimeField }
+
+function TTimeField.GetDataSize: Word; 
+
+begin
+  Result:=SizeOf(TDateTime);
+end;
+
+
+constructor TTimeField.Create(AOwner: TComponent); 
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftTime);
+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; DisplayText: 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;
+
+
+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
+  //!! To be implemented
+end;
+
+
+function TBCDField.GetAsFloat: Extended; 
+
+begin
+  //!! To be implemented
+end;
+
+
+function TBCDField.GetAsLongint: Longint; 
+
+begin
+  //!! To be implemented
+end;
+
+
+function TBCDField.GetAsString: string; 
+
+begin
+  //!! To be implemented
+end;
+
+
+function TBCDField.GetDataSize: Word; 
+
+begin
+  //!! To be implemented
+end;
+
+
+function TBCDField.GetDefaultWidth: Longint; 
+
+begin
+  //!! To be implemented
+end;
+
+
+procedure TBCDField.GetText(var TheText: string; DisplayText: Boolean); 
+
+begin
+  //!! To be implemented
+end;
+
+
+procedure TBCDField.SetAsFloat(AValue: Extended); 
+
+begin
+  //!! To be implemented
+end;
+
+
+procedure TBCDField.SetAsLongint(AValue: Longint); 
+
+begin
+  //!! To be implemented
+end;
+
+
+procedure TBCDField.SetAsString(const AValue: string); 
+
+begin
+  //!! To be implemented
+end;
+
+
+constructor TBCDField.Create(AOwner: TComponent); 
+
+begin
+  DatabaseError('BCD fields not supported yet. Sorry !');
+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; 
+
+begin
+  With GetBlobStream(bmRead) do
+    try
+      SetLength(Result,Size);
+      ReadBuffer(Pointer(Result)^,Size);
+    finally
+      Free
+    end;
+end;
+
+
+function TBlobField.GetBlobSize: Longint;
+
+begin
+  With GetBlobStream(bmread) do
+    try
+      Result:=Size;
+    finally
+      Free;
+    end;
+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; DisplayText: Boolean); 
+
+begin
+  TheText:=GetAsString;
+end;
+
+
+procedure TBlobField.SetAsString(const AValue: string); 
+
+begin
+  With GetBlobStream(bmwrite) do
+    try
+      WriteBuffer(Pointer(Avalue)^,Length(Avalue));
+    finally
+      Free;
+    end;
+end;
+
+
+procedure TBlobField.SetText(const AValue: string); 
+
+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;
+
+
+{ TGraphicField }
+
+constructor TGraphicField.Create(AOwner: TComponent); 
+
+begin
+  Inherited Create(AOwner);
+  SetDataType(ftGraphic);
+end;
+
+
+{ TFields }
+
+Constructor TFields.Create(ADataset : TDataset);
+
+begin
+  FDataSet:=ADataset;
+  FFieldList:=TList.Create;
+  FValidFieldKinds:=[fkData..fkInternalcalc];
+end;
+
+Destructor TFields.Destroy;
+
+begin
+  FFieldList.Free;
+end;
+
+Procedure Tfields.Changed;
+
+begin
+  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.SetFieldIndex (Field : TField;Value : Integer);
+
+Var Old : Longint;
+
+begin
+  Old := FFieldList.indexOf(Field);
+  If Old=-1 then
+    Exit;
+  // Check value
+  If Value<FFieldList.Count 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);
+
+Var I : longint;
+    S : String;
+    
+begin
+  If FindField(Value)<>Nil then
+    begin
+    S:=UpperCase(Value);
+    For I:=0 To FFieldList.Count-1 do
+      If S=UpperCase(TField(FFieldList[i]).FieldName) Then
+        DataBaseErrorFmt(SDuplicateFieldName,[Value],FDataset);
+    end;
+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);
+    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
+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;
+
+Var i : longint;
+
+begin
+  Result:=-1;
+  For I:=0 To FFieldList.Count-1 do
+    If Pointer(Field)=FFieldList[i] Then
+      Exit(I);
+end;
+
+procedure TFields.Remove(Value : TField);
+
+Var I : longint;
+
+begin
+  I:=IndexOf(Value);
+  If I<>0 then 
+    FFieldList.Delete(I); 
+end;
+
+{
+  $Log$
+  Revision 1.6  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:06  peter
+    * moved to packages dir
+
+  Revision 1.4  1999/11/12 22:53:32  michael
+  + Added append() insert() tested append. Datetime as string works now
+
+  Revision 1.3  1999/11/11 17:31:09  michael
+  + Added Checks for all simple field types.
+  + Initial implementation of Insert/Append
+
+  Revision 1.2  1999/10/24 17:07:54  michael
+  + Added copyright header
+
+}

fcl/db/mtest.pp

@@ -0,0 +1,194 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1998 by the Free Pascal development team
+
+    <What does this file>
+    
+    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.
+
+ **********************************************************************}
+program mtest;
+
+uses db,sysutils,mysqldb;
+
+Procedure Log(Const Msg : String);
+begin
+  Writeln(Msg);
+end;
+
+Procedure DumpFieldDef(F : TfieldDef);
+
+begin
+  With F do
+    begin
+    Writeln ('Name              : ',Name); 
+    Writeln ('FieldNo           : ',FieldNo);
+    Writeln ('Size              : ',Size);
+    Writeln ('FieldClass        : ',FieldClass.ClassName); 
+    Writeln ('Required          : ',required);
+    Writeln ('Precision         : ',Precision); 
+    Writeln ('DataType          : ',FieldTypeNames[DataType]);
+    Writeln ('InternalCalcField : ',Internalcalcfield);
+    end;
+end;
+
+Procedure DumpField(F : Tfield);
+
+begin
+  With F do
+    begin
+    Writeln ('FieldName : ',FieldName); 
+    Writeln ('FieldNo   : ',FieldNo);
+    Writeln ('Index     : ',Index);
+    Writeln ('DataSize  : ',DataSize);
+    Writeln ('Size      : ',Size);
+    Writeln ('DataType  : ',FieldTypeNames[DataType]);
+    Writeln ('Class     : ',ClassName); 
+    Writeln ('Required  : ',required);
+    Writeln ('ReadOnly  : ',ReadOnly);
+    Writeln ('Visible   : ',Visible);
+    end;
+end;
+
+Procedure DumpFieldData (F : TField);
+
+begin
+  With F Do 
+    begin
+    Writeln ('Field     : ',FieldName);
+    Writeln ('Data type : ',FieldTypeNames[DataType]);
+    Writeln ('As String : ',Asstring);
+    Case Datatype of
+      ftSmallint, ftInteger, ftWord : Writeln ('As longint : ',AsLongint);
+      ftBoolean : Writeln ('As Boolean : ',AsBoolean);
+      ftFloat : Writeln ('As Float : ',AsFloat); 
+      ftDate, ftTime, ftDateTime : Writeln ('As DateTime : ',DateTimeToStr(AsDateTime));
+    end;
+    end;
+end;
+
+Var 
+  Data : TMysqldataset;
+  I,Count : longint;
+  Bookie : TBookMarkStr;
+  
+Procedure ScrollForward;
+
+begin
+  Writeln ('Browsing Forward:');
+  Writeln ('------------------');
+  With Data do
+    While NOT EOF do
+      begin
+      For I:=0 to FieldCount-1 do
+        DumpFieldData(Fields[I]);
+      Next;  
+      end;  
+end;
+
+Procedure ScrollBackWard;
+
+begin
+  Writeln ('Browsing Backward:');
+  Writeln ('-------------------');
+  With Data do
+    While NOT BOF do
+      begin
+      For I:=0 to FieldCount-1 do
+        DumpFieldData(Fields[I]);
+      Prior;
+      end;
+end;
+
+begin
+  if paramcount<>4 then
+    begin
+    Writeln ('Usage : mtest db user pwd sql');
+    Halt(1);
+    end;
+  Log ('Creating Dataset');
+  Data:=TMysqlDataset.Create(Nil);  
+  With Data do
+    begin
+    Log('Setting database');
+    Database:=Paramstr(1);
+    Log('Setting user');
+    User:=Paramstr(2);
+    Log('Setting password');
+    PassWord := Paramstr(3);
+    Log('Setting SQL');
+    SQL.text := Paramstr(4);
+    Log('Opening Dataset');
+    Open;
+    Log('Dumping fielddefs : ');
+    Writeln ('Fielddefs count : ',FieldDefs.Count);
+    For I:=0 to FieldDefs.Count-1 do
+      DumpFieldDef(FieldDefs.Items[i]);
+    Writeln ('Fields count : ',FieldCount);
+    For I:=0 to FieldCount-1 do
+      DumpField(Fields[i]);
+    ScrollForward;
+    ScrollBackWard;
+    Writeln ('Going to last :');
+    writeln ('---------------');
+    Last;
+    ScrollBackWard;
+    ScrollForward;
+    Writeln ('Going to first:');
+    First;
+    Count:=0;
+    Writeln ('Browsing Forward:');
+    Writeln ('------------------');
+    With Data do
+      While NOT EOF do
+        begin
+        Inc(Count);
+        If Count=recordCount div 2 then 
+          begin
+          Writeln ('Setting bookmark on record');
+          Bookie:=Bookmark;
+          Writeln ('Got data : "',Bookie,'"');
+          end;
+        For I:=0 to FieldCount-1 do
+          DumpFieldData(Fields[I]);
+        Next;  
+        end;
+    Writeln ('Jumping to bookmark',Bookie);
+    BookMark:=Bookie;
+    Writeln ('Dumping Record : ');
+      For I:=0 to FieldCount-1 do
+        DumpFieldData(Fields[I]);
+    Next;
+    Writeln ('Dumping Next Record : ');
+    For I:=0 to FieldCount-1 do
+      DumpFieldData(Fields[I]);
+    Prior;
+    Prior;
+    Writeln ('Dumping Previous Record : ');
+    For I:=0 to FieldCount-1 do
+      DumpFieldData(Fields[I]);
+    Log('Closing Dataset');
+    Close;
+    Log('End.');
+    Free;
+    end;    
+end.
+
+{
+   $Log$
+   Revision 1.4  2000-01-06 01:20:32  peter
+     * moved out of packages/ back to topdir
+
+   Revision 1.1  2000/01/03 19:33:06  peter
+     * moved to packages dir
+
+   Revision 1.2  1999/10/24 17:07:54  michael
+   + Added copyright header
+
+}

fcl/db/mysqldb.pp

@@ -0,0 +1,791 @@
+unit MySQLDB;
+
+{$H+}
+
+interface
+
+uses
+  SysUtils, Classes, db, mysql,mysql_com;
+
+type
+  PMySQLDatasetBookmark = ^TMySQLDatasetBookmark;
+  TMySQLDatasetBookmark = record
+                          BookmarkData: Integer;
+                          BookmarkFlag: TBookmarkFlag;
+                          end;
+
+  Pinteger = ^Integer;
+  
+  TMySQLDataset = class(TDataSet)
+  private
+    FSQL: TStrings;
+    FDatabase: string;
+    FHost: string;
+    FPort: Integer;
+    FUser: string;
+    FPassword: string;
+
+    FRecordSize: Integer;
+    FBufferSize: Integer;
+
+    // MySQL data
+    FMYSQL: PMYSQL;
+    FMYSQLRES: PMYSQL_RES;
+
+    FCurrentRecord: Integer;              { Record pointer }
+
+    FServerInfo: string;
+    FHostInfo: string;
+
+    FAffectedRows: Integer;
+    FLastInsertID: Integer;
+    FLoadingFieldDefs: Boolean;
+
+    procedure DoOpen;
+    procedure DoClose;
+    procedure DoQuery;
+    procedure DoGetResult;
+
+    procedure CalculateSizes;
+    procedure LoadBufferFromData(Buffer: PChar);
+    function GetServerStatus: string;
+  protected
+    procedure SetDatabase(const Value: string);
+    procedure SetSQL(const Value: TStrings);
+    function GetClientInfo: string;
+
+    function InternalStrToFloat(S: string): Extended;
+    function InternalStrToDate(S: string): TDateTime;
+    function InternalStrToTime(S: string): TDateTime;
+    function InternalStrToDateTime(S: string): TDateTime;
+    function InternalStrToTimeStamp(S: string): TDateTime;
+
+    function MySQLFieldToFieldType(AType: enum_field_types; ASize: Integer;
+         var NewType: TFieldType; var NewSize: Integer): Boolean;
+    function MySQLDataSize(AType: enum_field_types; ASize: Integer): Integer;
+    function MySQLWriteFieldData(AType: enum_field_types; ASize: Integer; Source: PChar;
+       Dest: PChar): Integer;
+
+
+    function GetCanModify: Boolean; override;
+    { Mandatory overrides }
+    // Record buffer methods:
+    function AllocRecordBuffer: PChar; override;
+    procedure FreeRecordBuffer(var Buffer: PChar); override;
+    procedure InternalInitRecord(Buffer: PChar); override;
+    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
+    function GetRecordSize: Word; override;
+    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
+    // Bookmark methods:
+    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
+    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
+    procedure InternalGotoBookmark(ABookmark: Pointer); override;
+    procedure InternalSetToRecord(Buffer: PChar); override;
+    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
+    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
+    // Navigational methods:
+    procedure InternalFirst; override;
+    procedure InternalLast; override;
+    // Editing methods:
+    procedure InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); override;
+    procedure InternalDelete; override;
+    procedure InternalPost; override;
+    // Misc methods:
+    procedure InternalClose; override;
+    procedure InternalHandleException; override;
+    procedure InternalInitFieldDefs; override;
+    procedure InternalOpen; override;
+    function IsCursorOpen: Boolean; override;
+    { Optional overrides }
+    function GetRecordCount: Integer; override;
+    function GetRecNo: Integer; override;
+    procedure SetRecNo(Value: Integer); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+
+    procedure ExecSQL;
+
+    // TDataset method
+    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
+
+    property ServerInfo: string read FServerInfo;
+    property ClientInfo: string read GetClientInfo;
+    property HostInfo: string read FHostInfo;
+    property AffectedRows: Integer read FAffectedRows;
+    property LastInsertID: Integer read FLastInsertID;
+    property ServerStatus: string read GetServerStatus;
+  published
+    property Active;
+    property SQL: TStrings read FSQL write SetSQL;
+    property Database: string read FDatabase write SetDatabase;
+    property Host: string read FHost write FHost;
+    property Port: Integer read FPort write FPort;
+    property User: string read FUser write FUser;
+    property Password: string read FPassword write FPassword;
+
+    property BeforeOpen;
+    property AfterOpen;
+    property BeforeClose;
+    property AfterClose;
+    property BeforeInsert;
+    property AfterInsert;
+    property BeforeEdit;
+    property AfterEdit;
+    property BeforePost;
+    property AfterPost;
+    property BeforeCancel;
+    property AfterCancel;
+    property BeforeDelete;
+    property AfterDelete;
+    property BeforeScroll;
+    property AfterScroll;
+    property OnDeleteError;
+    property OnEditError;
+  end;
+
+implementation
+
+{ TMySQLDataset }
+
+constructor TMySQLDataset.Create(AOwner: TComponent);
+begin
+     inherited Create(AOwner);
+     FSQL := TStringList.Create;
+     FHost := '';
+     FPort := 0;
+     FUser := '';
+     FPassword := '';
+
+     FBufferSize := 0;
+     FRecordSize := 0;
+     FCurrentRecord := -1;
+     FLoadingFieldDefs := False;
+
+     FAffectedRows := 0;
+     FLastInsertID := -1;
+
+     FMYSQL := nil;
+     FMYSQLRES := nil;
+end;
+
+destructor TMySQLDataset.Destroy;
+begin
+     FSQL.Free;
+     inherited destroy;
+end;
+
+function TMySQLDataset.AllocRecordBuffer: PChar;
+begin
+     Result := AllocMem(FBufferSize);
+end;
+
+procedure TMySQLDataset.FreeRecordBuffer(var Buffer: PChar);
+begin
+     FreeMem(Buffer);
+end;
+
+procedure TMySQLDataset.GetBookmarkData(Buffer: PChar; Data: Pointer);
+begin
+     PInteger(Data)^ := PMySQLDatasetBookmark(Buffer + FRecordSize)^.BookmarkData;
+end;
+
+function TMySQLDataset.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
+begin
+     Result := PMySQLDatasetBookmark(Buffer + FRecordSize)^.BookmarkFlag;
+end;
+
+function TMySQLDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
+var
+  I, FC: Integer;
+  fld: TMYSQL_FIELD;
+  CurBuf: PChar;
+begin
+     Result := False;
+
+     CurBuf := ActiveBuffer;
+     
+     FC := mysql_num_fields(FMYSQLRES);
+     for I := 0 to FC-1 do
+     begin
+          fld := mysql_fetch_field_direct(FMYSQLRES, I);
+
+          //if Field.FieldNo = I+1 then
+          if Field.FieldName = fld.name then
+          begin
+               Move(CurBuf^, PChar(Buffer)^, MySQLDataSize(fld.ftype, fld.length));
+
+               if Field.DataType in [ftString{, ftWideString}] then
+                  Result := PChar(buffer)^ <> #0
+               else
+                   Result := True;
+               break; 
+          end
+          else
+              Inc(CurBuf, MySQLDataSize(fld.ftype, fld.length));
+     end;
+end;
+
+function TMySQLDataset.GetRecNo: Integer;
+begin
+     UpdateCursorPos;
+     if (FCurrentRecord = -1) and (RecordCount > 0) then
+        Result := 1
+     else
+         Result := FCurrentRecord + 1;
+end;
+
+function TMySQLDataset.GetRecord(Buffer: PChar; GetMode: TGetMode;
+  DoCheck: Boolean): TGetResult;
+begin
+     if RecordCount < 1 then
+        Result := grEOF
+     else
+     begin
+          Result := grOk;
+          case GetMode of
+            gmPrior:
+              if FCurrentRecord <= 0 then
+              begin
+                   Result := grBOF;
+                   FCurrentRecord := -1;
+              end
+              else
+                  Dec(FCurrentRecord);
+            gmCurrent:
+              if (FCurrentRecord < 0) or (FCurrentRecord >= RecordCount) then
+                 Result := grError;
+            gmNext:
+              if FCurrentRecord >= RecordCount-1 then
+                 Result := grEOF
+              else
+                  Inc(FCurrentRecord);
+          end;
+
+          if Result = grOK then
+          begin
+               LoadBufferFromData(Buffer);
+               with PMySQLDatasetBookmark(Buffer + FRecordSize)^ do
+               begin
+                    BookmarkData := FCurrentRecord;
+                    BookmarkFlag := bfCurrent;
+               end;               
+          end
+          else
+              if (Result = grError) and (DoCheck) then
+                 DatabaseError('No record');
+     end;
+end;
+
+function TMySQLDataset.GetRecordCount: Integer;
+begin
+     Result := mysql_num_rows(FMYSQLRES);
+end;
+
+function TMySQLDataset.GetRecordSize: Word;
+begin
+     Result := FRecordSize;
+end;
+
+procedure TMySQLDataset.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean);
+begin
+
+end;
+
+procedure TMySQLDataset.InternalClose;
+begin
+     FCurrentRecord := -1;
+
+     DoClose;
+    
+     if DefaultFields then
+        DestroyFields;
+end;
+
+procedure TMySQLDataset.InternalDelete;
+begin
+
+end;
+
+procedure TMySQLDataset.InternalFirst;
+begin
+     FCurrentRecord := -1;
+end;
+
+procedure TMySQLDataset.InternalGotoBookmark(ABookmark: Pointer);
+begin
+     FCurrentRecord := PInteger(ABookmark)^;
+end;
+
+procedure TMySQLDataset.InternalHandleException;
+begin
+//     Application.HandleException(self);
+end;
+
+procedure TMySQLDataset.InternalInitFieldDefs;
+var
+  I, FC: Integer;
+  field: TMYSQL_FIELD;
+  DFT: TFieldType;
+  DFS: Integer;
+  WasClosed: Boolean;
+begin
+     if FLoadingFieldDefs then Exit;
+
+     FLoadingFieldDefs := True;
+     try
+        WasClosed := not IsCursorOpen;
+        if WasClosed then
+        begin
+             DoOpen;
+             DoQuery;
+             DoGetResult;
+        end;
+        try
+           FieldDefs.Clear;
+           FC := mysql_num_fields(FMYSQLRES);
+           for I := 0 to FC-1 do
+           begin
+                field := mysql_fetch_field_direct(FMYSQLRES, I);
+                if MySQLFieldToFieldType(field.ftype, field.length, DFT, DFS) then
+                   TFieldDef.Create(FieldDefs, field.name, DFT, DFS, False, I+1);
+           end;
+        finally
+           if WasClosed then
+           begin
+                DoClose;
+           end;
+        end;
+     finally
+        FLoadingFieldDefs := False;
+     end;
+end;
+
+procedure TMySQLDataset.InternalInitRecord(Buffer: PChar);
+begin
+     FillChar(Buffer^, FBufferSize, 0);
+end;
+
+procedure TMySQLDataset.InternalLast;
+begin
+     FCurrentRecord := RecordCount;
+end;
+
+procedure TMySQLDataset.InternalOpen;
+begin
+     FMYSQL := nil;
+     FMYSQLRES := nil;
+     try
+        DoOpen;
+        DoQuery;
+        DoGetResult;
+
+        FCurrentRecord := -1;
+
+        InternalInitFieldDefs;
+
+        if DefaultFields then
+           CreateFields;
+        CalculateSizes;
+
+        BindFields(True);
+     except
+        DoClose;
+        FMYSQL := nil;
+        FMYSQLRES := nil;
+        raise;
+     end;
+     FServerInfo := mysql_get_server_info(FMYSQL);
+     FHostInfo := mysql_get_host_info(FMYSQL);
+     BookMarkSize:=SizeOf(Longint);
+end;
+
+procedure TMySQLDataset.InternalSetToRecord(Buffer: PChar);
+begin
+     FCurrentRecord := PMySQLDatasetBookmark(Buffer + FRecordSize)^.BookmarkData;
+end;
+
+function TMySQLDataset.IsCursorOpen: Boolean;
+begin
+     Result := FMYSQL <> nil;
+end;
+
+procedure TMySQLDataset.SetBookmarkData(Buffer: PChar; Data: Pointer);
+begin
+     PMySQLDatasetBookmark(Buffer + FRecordSize)^.BookmarkData := PInteger(Data)^;
+end;
+
+procedure TMySQLDataset.SetBookmarkFlag(Buffer: PChar;
+  Value: TBookmarkFlag);
+begin
+     PMySQLDatasetBookmark(Buffer + FRecordSize)^.BookmarkFlag := Value;
+end;
+
+procedure TMySQLDataset.SetFieldData(Field: TField; Buffer: Pointer);
+begin
+
+end;
+
+procedure TMySQLDataset.SetRecNo(Value: Integer);
+begin
+     if (Value >= 0) and (Value <= RecordCount-1) then
+     begin
+          FCurrentRecord := Value-1;
+          Resync([]);
+     end;
+end;
+
+procedure TMySQLDataset.SetSQL(const Value: TStrings);
+begin
+     FSQL.Assign(Value);
+     FieldDefs.Clear;
+end;
+
+procedure TMySQLDataset.ExecSQL;
+begin
+     try
+        DoOpen;
+        try
+           DoQuery;
+        finally
+           DoClose;
+        end;
+     finally
+        FMYSQLRES := nil;
+        FMYSQL := nil;
+     end;
+end;
+
+procedure TMySQLDataset.SetDatabase(const Value: string);
+begin
+     FDatabase := Value;
+end;
+
+procedure TMySQLDataset.InternalPost;
+begin
+
+end;
+
+function TMySQLDataset.GetClientInfo: string;
+begin
+     Result := mysql_get_client_info;
+end;
+
+function TMySQLDataset.MySQLFieldToFieldType(AType: enum_field_types; ASize: Integer;
+   var NewType: TFieldType; var NewSize: Integer): Boolean;
+begin
+     Result := True;
+     case AType of
+       FIELD_TYPE_TINY, FIELD_TYPE_SHORT, FIELD_TYPE_LONG, FIELD_TYPE_LONGLONG,
+       FIELD_TYPE_INT24:
+         begin
+              NewType := ftInteger;
+              NewSize := 0;
+         end;
+       FIELD_TYPE_DECIMAL, FIELD_TYPE_FLOAT, FIELD_TYPE_DOUBLE:
+         begin
+              NewType := ftFloat;
+              NewSize := 0;
+         end;
+       FIELD_TYPE_TIMESTAMP, FIELD_TYPE_DATETIME:
+         begin
+              NewType := ftDateTime;
+              NewSize := 0;
+         end;
+       FIELD_TYPE_DATE:
+         begin
+              NewType := ftDate;
+              NewSize := 0;
+         end;
+       FIELD_TYPE_TIME:
+         begin
+              NewType := ftTime;
+              NewSize := 0;
+         end;
+       FIELD_TYPE_VAR_STRING, FIELD_TYPE_STRING, FIELD_TYPE_ENUM, FIELD_TYPE_SET:
+         begin
+              NewType := ftString;
+              NewSize := ASize;
+         end;
+     else
+       Result := False;
+     end;
+end;
+
+procedure TMySQLDataset.CalculateSizes;
+var
+  I, FC: Integer;
+  field: TMYSQL_FIELD;
+begin
+     FRecordSize := 0;
+     FC := mysql_num_fields(FMYSQLRES);
+     for I := 0 to FC-1 do
+     begin
+          field := mysql_fetch_field_direct(FMYSQLRES, I);
+          FRecordSize := FRecordSize + MySQLDataSize(field.ftype, field.length);
+     end;
+     FBufferSize := FRecordSize + SizeOf(TMySQLDatasetBookmark);
+end;
+
+procedure TMySQLDataset.LoadBufferFromData(Buffer: PChar);
+var
+  I, FC, CT: Integer;
+  field: TMYSQL_FIELD;
+  row: TMYSQL_ROW;
+begin
+     mysql_data_seek(FMYSQLRES, FCurrentRecord);
+
+     row := mysql_fetch_row(FMYSQLRES);
+     if row = nil then
+        DatabaseError(mysql_error(FMYSQL));
+
+     FC := mysql_num_fields(FMYSQLRES);
+     for I := 0 to FC-1 do
+     begin
+          field := mysql_fetch_field_direct(FMYSQLRES, I);
+          CT := MySQLWriteFieldData(field.ftype, field.length, row^, Buffer);
+          Inc(Buffer, CT);
+          Inc(row); 
+     end;
+end;
+
+
+function TMySQLDataset.MySQLDataSize(AType: enum_field_types;
+  ASize: Integer): Integer;
+begin
+     Result := 0;
+     case AType of
+       FIELD_TYPE_TINY, FIELD_TYPE_SHORT, FIELD_TYPE_LONG, FIELD_TYPE_LONGLONG,
+       FIELD_TYPE_INT24:
+         begin
+              Result := SizeOf(Integer);
+         end;
+       FIELD_TYPE_DECIMAL, FIELD_TYPE_FLOAT, FIELD_TYPE_DOUBLE:
+         begin
+              Result := SizeOf(Double);
+         end;
+       FIELD_TYPE_TIMESTAMP, FIELD_TYPE_DATE, FIELD_TYPE_TIME, FIELD_TYPE_DATETIME:
+         begin
+              Result := SizeOf(TDateTime);
+         end;
+       FIELD_TYPE_VAR_STRING, FIELD_TYPE_STRING, FIELD_TYPE_ENUM, FIELD_TYPE_SET:
+         begin
+              Result := ASize;
+         end;
+     end;
+end;
+
+function TMySQLDataset.MySQLWriteFieldData(AType: enum_field_types;
+  ASize: Integer; Source, Dest: PChar): Integer;
+var
+  VI: Integer;
+  VF: Double;
+  VD: TDateTime;  
+begin
+     Result := 0;
+     case AType of
+       FIELD_TYPE_TINY, FIELD_TYPE_SHORT, FIELD_TYPE_LONG, FIELD_TYPE_LONGLONG,
+       FIELD_TYPE_INT24:
+         begin
+              Result := SizeOf(Integer);
+              if Source <> '' then
+                 VI := StrToInt(Source)
+              else
+                  VI := 0;
+              Move(VI, Dest^, Result);              
+         end;
+       FIELD_TYPE_DECIMAL, FIELD_TYPE_FLOAT, FIELD_TYPE_DOUBLE:
+         begin
+              Result := SizeOf(Double);
+              if Source <> '' then
+                 VF := InternalStrToFloat(Source)
+              else
+                  VF := 0;
+              Move(VF, Dest^, Result);
+         end;
+       FIELD_TYPE_TIMESTAMP:
+         begin
+              Result := SizeOf(TDateTime);
+              if Source <> '' then
+                 VD := InternalStrToTimeStamp(Source)
+              else
+                  VD := 0;
+              Move(VD, Dest^, Result);
+         end;
+       FIELD_TYPE_DATETIME:
+         begin
+              Result := SizeOf(TDateTime);
+              if Source <> '' then
+                 VD := InternalStrToDateTime(Source)
+              else
+                  VD := 0;
+              Move(VD, Dest^, Result);
+         end;
+       FIELD_TYPE_DATE:
+         begin
+              Result := SizeOf(TDateTime);
+              if Source <> '' then
+                 VD := InternalStrToDate(Source)
+              else
+                  VD := 0;
+              Move(VD, Dest^, Result);
+         end;
+       FIELD_TYPE_TIME:
+         begin
+              Result := SizeOf(TDateTime);
+              if Source <> '' then
+                 VD := InternalStrToTime(Source)
+              else
+                  VD := 0;
+              Move(VD, Dest^, Result);
+         end;
+       FIELD_TYPE_VAR_STRING, FIELD_TYPE_STRING, FIELD_TYPE_ENUM, FIELD_TYPE_SET:
+         begin
+              Result := ASize;
+              if Source <> '' then
+                 Move(Source^, Dest^, Result)
+              else
+                  Dest^ := #0;
+         end;
+     end;
+end;
+
+function TMySQLDataset.InternalStrToFloat(S: string): Extended;
+var
+  I: Integer;
+  Tmp: string;
+begin
+     Tmp := '';
+
+     for I := 1 to Length(S) do
+     begin
+          if not (S[I] in ['0'..'9', '+', '-', 'E', 'e']) then
+             Tmp := Tmp + DecimalSeparator
+          else
+              Tmp := Tmp + S[I];
+     end;
+     Result := StrToFloat(Tmp);
+end;
+
+function TMySQLDataset.InternalStrToDate(S: string): TDateTime;
+var
+  EY, EM, ED: Word;
+begin
+     EY := StrToInt(Copy(S, 1, 4));
+     EM := StrToInt(Copy(S, 6, 2));
+     ED := StrToInt(Copy(S, 9, 2));
+     if (EY = 0) or (EM = 0) or (ED = 0) then
+        Result := 0
+     else
+         Result := EncodeDate(EY, EM, ED);
+end;
+
+function TMySQLDataset.InternalStrToDateTime(S: string): TDateTime;
+var
+  EY, EM, ED: Word;
+  EH, EN, ES: Word;
+begin
+     EY := StrToInt(Copy(S, 1, 4));
+     EM := StrToInt(Copy(S, 6, 2));
+     ED := StrToInt(Copy(S, 9, 2));
+
+     EH := StrToInt(Copy(S, 11, 2));
+     EN := StrToInt(Copy(S, 14, 2));
+     ES := StrToInt(Copy(S, 17, 2));
+
+     if (EY = 0) or (EM = 0) or (ED = 0) then
+        Result := 0
+     else
+         Result := EncodeDate(EY, EM, ED);
+
+     Result := Result + EncodeTime(EH, EN, ES, 0);
+end;
+
+function TMySQLDataset.InternalStrToTime(S: string): TDateTime;
+var
+  EH, EM, ES: Word;
+begin
+     EH := StrToInt(Copy(S, 1, 2));
+     EM := StrToInt(Copy(S, 4, 2));
+     ES := StrToInt(Copy(S, 7, 2));
+     Result := EncodeTime(EH, EM, ES, 0);
+end;
+
+function TMySQLDataset.InternalStrToTimeStamp(S: string): TDateTime;
+var
+  EY, EM, ED: Word;
+  EH, EN, ES: Word;
+begin
+     EY := StrToInt(Copy(S, 1, 4));
+     EM := StrToInt(Copy(S, 5, 2));
+     ED := StrToInt(Copy(S, 7, 2));
+
+     EH := StrToInt(Copy(S, 9, 2));
+     EN := StrToInt(Copy(S, 11, 2));
+     ES := StrToInt(Copy(S, 13, 2));
+
+     if (EY = 0) or (EM = 0) or (ED = 0) then
+        Result := 0
+     else
+         Result := EncodeDate(EY, EM, ED);
+
+     Result := Result + EncodeTime(EH, EN, ES, 0);;
+end;
+
+procedure TMySQLDataset.DoClose;
+begin
+     try
+        if FMYSQLRES <> nil then
+           mysql_free_result(FMYSQLRES);
+        if FMYSQL <> nil then
+           mysql_close(FMYSQL);
+     finally
+        FMYSQLRES := nil;
+        FMYSQL := nil;
+     end;
+end;
+
+procedure TMySQLDataset.DoOpen;
+begin
+     FMYSQL := mysql_connect(nil, PChar(FHost), PChar(FUser), PChar(FPassword));
+     if FMYSQL = nil then
+        DatabaseError('Error connecting to MySQL server');
+
+     if FDatabase <> '' then
+        if mysql_select_db(FMYSQL, PChar(FDatabase)) <> 0 then
+           DatabaseError(mysql_error(FMYSQL));
+end;
+
+procedure TMySQLDataset.DoQuery;
+var
+  Query: string;
+begin
+     Query := FSQL.GetText;
+     if mysql_query(FMYSQL, PChar(Query)) <> 0 then
+        DatabaseError(mysql_error(FMYSQL));
+
+     FAffectedRows := mysql_affected_rows(FMYSQL);
+     FLastInsertID := mysql_insert_id(FMYSQL);
+end;
+
+function TMySQLDataset.GetCanModify: Boolean;
+begin
+     Result := False;
+end;
+
+procedure TMySQLDataset.DoGetResult;
+begin
+     FMYSQLRES := mysql_store_result(FMYSQL);
+     if FMYSQLRES = nil then
+        DatabaseError(mysql_error(FMYSQL));
+
+     FAffectedRows := mysql_affected_rows(FMYSQL);
+end;
+
+function TMySQLDataset.GetServerStatus: string;
+begin
+     CheckActive;
+     Result := mysql_stat(FMYSQL);
+end;
+
+end.

fcl/db/testds.pp

@@ -0,0 +1,194 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999 by Michael Van Canneyt, member of the 
+    Free Pascal development team
+
+    Tests the TDDGDataset component.
+    
+    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.
+
+ **********************************************************************}
+program testds;
+
+uses db,ddg_ds,sysutils;
+
+Procedure Log(Const Msg : String);
+begin
+  Writeln(Msg);
+end;
+
+Procedure DumpFieldDef(F : TfieldDef);
+
+begin
+  With F do
+    begin
+    Writeln ('Name              : ',Name); 
+    Writeln ('FieldNo           : ',FieldNo);
+    Writeln ('Size              : ',Size);
+    Writeln ('FieldClass        : ',FieldClass.ClassName); 
+    Writeln ('Required          : ',required);
+    Writeln ('Precision         : ',Precision); 
+    Writeln ('DataType          : ',FieldTypeNames[DataType]);
+    Writeln ('InternalCalcField : ',Internalcalcfield);
+    end;
+end;
+
+Procedure DumpField(F : Tfield);
+
+begin
+  With F do
+    begin
+    writeln ('-------------------------------------');
+    Writeln ('FieldName : ',FieldName); 
+    Writeln ('FieldNo   : ',FieldNo);
+    Writeln ('Index     : ',Index);
+    Writeln ('DataSize  : ',DataSize);
+    Writeln ('Size      : ',Size);
+    Writeln ('DataType  : ',FieldTypeNames[DataType]);
+    Writeln ('Class     : ',ClassName); 
+    Writeln ('Required  : ',required);
+    Writeln ('ReadOnly  : ',ReadOnly);
+    Writeln ('Visible   : ',Visible);
+    end;
+end;
+
+Procedure DumpFieldData (F : TField);
+
+begin
+  With F Do 
+    begin
+    Writeln ('Field     : ',FieldName);
+    Writeln ('Data type : ',FieldTypeNames[DataType]);
+    Writeln ('As String : ',Asstring);
+    Case Datatype of
+      ftSmallint, ftInteger, ftWord : Writeln ('As longint : ',AsLongint);
+      ftBoolean : Writeln ('As Boolean : ',AsBoolean);
+      ftFloat : Writeln ('As Float : ',AsFloat); 
+      ftDate, ftTime, ftDateTime : Writeln ('As DateTime : ',DateTimeToStr(AsDateTime));
+    end;
+    end;
+end;
+
+Var 
+  Data : TDDGdataset;
+  I,Count : longint;
+  Bookie : TBookMarkStr;
+  
+Procedure ScrollForward;
+
+begin
+  Writeln ('Browsing Forward:');
+  Writeln ('------------------');
+  With Data do
+    While NOT EOF do
+      begin
+      Writeln ('================================================');
+      For I:=0 to FieldCount-1 do
+        DumpFieldData(Fields[I]);
+      Next;  
+      end;  
+end;
+
+Procedure ScrollBackWard;
+
+begin
+  Writeln ('Browsing Backward:');
+  Writeln ('-------------------');
+  With Data do
+    While NOT BOF do
+      begin
+      For I:=0 to FieldCount-1 do
+        DumpFieldData(Fields[I]);
+      Prior;
+      end;
+end;
+
+begin
+  if paramcount<>1 then
+    begin
+    Writeln ('Usage : testds tablename');
+    Halt(1);
+    end;
+  Log ('Creating Dataset');
+  Data:=TDDGDataset.Create(Nil);  
+  With Data do
+    begin
+    Log('Setting Tablename');
+    TableName:=Paramstr(1);
+    Log('Opening Dataset');
+    Open;
+    Log('Dumping fielddefs : ');
+    Writeln ('Fielddefs count : ',FieldDefs.Count);
+    For I:=0 to FieldDefs.Count-1 do
+      DumpFieldDef(FieldDefs.Items[i]);
+    Writeln ('Fields count : ',FieldCount);
+    For I:=0 to FieldCount-1 do
+      DumpField(Fields[i]);
+    ScrollForward;
+    ScrollBackWard;
+    Writeln ('Going to last :');
+    writeln ('---------------');
+    Last;
+    ScrollBackWard;
+    ScrollForward;
+    Writeln ('Going to first:');
+    First;
+    Count:=0;
+    Writeln ('Browsing Forward:');
+    Writeln ('------------------');
+    With Data do
+      While NOT EOF do
+        begin
+        Inc(Count);
+        If Count=50 then 
+          begin
+          Writeln ('Setting bookmark on record');
+          Bookie:=Bookmark;
+          Writeln ('Got data : "',Bookie,'"');
+          end;
+        For I:=0 to FieldCount-1 do
+          DumpFieldData(Fields[I]);
+        Next;  
+        end;
+    Writeln ('Jumping to bookmark',Bookie);
+    BookMark:=Bookie;
+    Writeln ('Dumping Record : ');
+      For I:=0 to FieldCount-1 do
+        DumpFieldData(Fields[I]);
+    Next;
+    Writeln ('Dumping Next Record : ');
+    For I:=0 to FieldCount-1 do
+      DumpFieldData(Fields[I]);
+    Prior;
+    Prior;
+    Writeln ('Dumping Previous Record : ');
+    For I:=0 to FieldCount-1 do
+      DumpFieldData(Fields[I]);
+    Log('Closing Dataset');
+    Close;
+    Log('End.');
+    Free;
+    end;    
+end.
+{
+  $Log$
+  Revision 1.5  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:06  peter
+    * moved to packages dir
+
+  Revision 1.3  1999/11/11 17:31:09  michael
+  + Added Checks for all simple field types.
+  + Initial implementation of Insert/Append
+
+  Revision 1.2  1999/10/24 17:07:54  michael
+  + Added copyright header
+
+}

fcl/db/tested.pp

@@ -0,0 +1,261 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999 by Michael Van Canneyt, member of the 
+    Free Pascal development team
+
+    Tests the TDDGDataset component.
+    
+    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.
+
+ **********************************************************************}
+program testds;
+
+uses db,ddg_ds,sysutils;
+
+Procedure Log(Const Msg : String);
+begin
+  Writeln(Msg);
+end;
+
+Procedure DumpFieldDef(F : TfieldDef);
+
+begin
+  With F do
+    begin
+    Writeln ('Name              : ',Name); 
+    Writeln ('FieldNo           : ',FieldNo);
+    Writeln ('Size              : ',Size);
+    Writeln ('FieldClass        : ',FieldClass.ClassName); 
+    Writeln ('Required          : ',required);
+    Writeln ('Precision         : ',Precision); 
+    Writeln ('DataType          : ',FieldTypeNames[DataType]);
+    Writeln ('InternalCalcField : ',Internalcalcfield);
+    end;
+end;
+
+Procedure DumpField(F : Tfield);
+
+begin
+  With F do
+    begin
+    writeln ('-------------------------------------');
+    Writeln ('FieldName : ',FieldName); 
+    Writeln ('FieldNo   : ',FieldNo);
+    Writeln ('Index     : ',Index);
+    Writeln ('DataSize  : ',DataSize);
+    Writeln ('Size      : ',Size);
+    Writeln ('DataType  : ',FieldTypeNames[DataType]);
+    Writeln ('Class     : ',ClassName); 
+    Writeln ('Required  : ',required);
+    Writeln ('ReadOnly  : ',ReadOnly);
+    Writeln ('Visible   : ',Visible);
+    end;
+end;
+
+Procedure DumpFieldData (F : TField);
+
+begin
+  With F Do 
+    begin
+    Writeln ('Field     : ',FieldName);
+    Writeln ('Data type : ',FieldTypeNames[DataType]);
+    Writeln ('As String : ',Asstring);
+    Case Datatype of
+      ftSmallint, ftInteger, ftWord : Writeln ('As longint : ',AsLongint);
+      ftBoolean : Writeln ('As Boolean : ',AsBoolean);
+      ftFloat : Writeln ('As Float : ',AsFloat); 
+      ftDate, ftTime, ftDateTime : Writeln ('As DateTime : ',DateTimeToStr(AsDateTime));
+    end;
+    end;
+end;
+
+procedure DumpFields (DS : TDataset);
+
+Var I : longint;
+
+begin
+  With DS do 
+    begin
+    Writeln('Dumping fields');
+    For I:=0 to FieldCount-1 do
+      DumpFieldData(Fields[i]);
+    end;
+end;
+
+Var 
+  Data : TDDGdataset;
+  I,Count : longint;
+  Bookie : TBookMarkStr;
+  
+Procedure ScrollForward;
+
+begin
+  Writeln ('Browsing Forward:');
+  Writeln ('------------------');
+  With Data do
+    While NOT EOF do
+      begin
+      Writeln ('================================================');
+      For I:=0 to FieldCount-1 do
+        DumpFieldData(Fields[I]);
+      Next;  
+      end;  
+end;
+
+Procedure ScrollBackWard;
+
+begin
+  Writeln ('Browsing Backward:');
+  Writeln ('-------------------');
+  With Data do
+    While NOT BOF do
+      begin
+      For I:=0 to FieldCount-1 do
+        DumpFieldData(Fields[I]);
+      Prior;
+      end;
+end;
+
+begin
+  if paramcount<>1 then
+    begin
+    Writeln ('Usage : testds tablename');
+    Halt(1);
+    end;
+  Log ('Creating Dataset');
+  Data:=TDDGDataset.Create(Nil);  
+  With Data do
+    begin
+    Log('Setting Tablename');
+    TableName:=Paramstr(1);
+    Log('Opening Dataset');
+    Open;
+    Log('Dumping fielddefs : ');
+    Writeln ('Fielddefs count : ',FieldDefs.Count);
+    For I:=0 to FieldDefs.Count-1 do
+      DumpFieldDef(FieldDefs.Items[i]);
+    Writeln ('Fields count : ',FieldCount);
+    For I:=0 to FieldCount-1 do
+      DumpField(Fields[i]);
+    ScrollForward;
+    ScrollBackWard;
+    Writeln ('Doing append');
+    writeln ('------------');
+    Append;
+    FieldByName('Name').AsString:='AppendName';
+    FieldByName('Height').AsFloat:=9.99E9;
+    FieldByName('LongField').AsLongInt:=999;
+    FieldByName('ShoeSize').AsLongInt:=999;
+    FieldByName('WordField').AsLongInt:=999;
+    FieldByName('BooleanField').AsBoolean:=False;
+    FieldByName('DateTimeField').AsDateTime:=Now;
+    FieldByName('DateField').AsDateTime:=Date;
+    FieldByName('TimeField').AsDateTime:=Time;
+    Writeln ('End of append, going to post');
+    Post;
+    DumpFields(Data);
+    Writeln ('Doing Last');
+    Writeln ('----------');
+    Last;
+    DumpFields(Data);
+    Writeln ('Doing Prior');
+    Writeln ('----------');
+    Prior;
+    DumpFields(Data);
+    Writeln ('Doing Insert at position 8');
+    writeln ('--------------------------');
+    first;
+    for I:=1 to 7 do 
+      Next;
+    Insert;
+    FieldByName('Name').AsString:='Insertname';
+    FieldByName('Height').AsFloat:=8.99E8;
+    FieldByName('LongField').AsLongInt:=888;
+    FieldByName('ShoeSize').AsLongInt:=888;
+    FieldByName('WordField').AsLongInt:=888;
+    FieldByName('BooleanField').AsBoolean:=True;
+    FieldByName('DateTimeField').AsDateTime:=Now;
+    FieldByName('DateField').AsDateTime:=Date;
+    FieldByName('TimeField').AsDateTime:=Time;
+    Post;
+    Writeln ('Doing field dump');
+    writeln ('----------------');
+    DumpFields(Data);
+    Writeln ('Doing Prior');
+    Writeln ('-----------');
+    Prior;
+    DumpFields(Data);
+    Writeln ('Doing Next');
+    Writeln ('----------');
+    Next;
+    DumpFields(Data);
+    Writeln ('Doing Next');
+    Writeln ('----------');
+    Next;
+    DumpFields(Data);
+    Writeln ('Doing Edit at position 5');
+    writeln ('-------------------------');
+    first;
+    for I:=1 to 4 do 
+      Next;
+    Edit;
+    FieldByName('Name').AsString:='Editname';
+    FieldByName('Height').AsFloat:=3.33E3;
+    FieldByName('LongField').AsLongInt:=333;
+    FieldByName('ShoeSize').AsLongInt:=333;
+    FieldByName('WordField').AsLongInt:=333;
+    FieldByName('BooleanField').AsBoolean:=False;
+    FieldByName('DateTimeField').AsDateTime:=Now;
+    FieldByName('DateField').AsDateTime:=Date;
+    FieldByName('TimeField').AsDateTime:=Time;
+    Post;
+    Writeln ('Doing field dump');
+    writeln ('----------------');
+    DumpFields(Data);
+    Writeln ('Doing Prior');
+    Writeln ('-----------');
+    Prior;
+    DumpFields(Data);
+    Writeln ('Doing Next');
+    Writeln ('----------');
+    Next;
+    DumpFields(Data);
+    Writeln ('Doing Next');
+    Writeln ('----------');
+    Next;
+    DumpFields(Data);
+    Writeln ('Closing.');   
+    Close;
+    end;
+end.
+{
+  $Log$
+  Revision 1.5  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:06  peter
+    * moved to packages dir
+
+  Revision 1.3  1999/12/01 22:11:02  michael
+  + tested edit and insert methods
+
+  Revision 1.2  1999/12/01 10:11:58  michael
+  + test of insert works now
+
+  Revision 1.1  1999/11/14 19:26:17  michael
+  + Initial implementation
+
+  Revision 1.3  1999/11/11 17:31:09  michael
+  + Added Checks for all simple field types.
+  + Initial implementation of Insert/Append
+
+  Revision 1.2  1999/10/24 17:07:54  michael
+  + Added copyright header
+
+}

fcl/go32v2/Makefile

@@ -0,0 +1,1105 @@
+#
+# Makefile generated by fpcmake v0.99.13 [2000/01/06]
+#
+
+defaultrule: all
+
+#####################################################################
+# Autodetect OS (Linux or Dos or Windows NT)
+# define inlinux when running under linux
+# define inWinNT when running under WinNT
+#####################################################################
+
+# We need only / in the path
+override PATH:=$(subst \,/,$(PATH))
+
+# Search for PWD and determine also if we are under linux
+PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH)))))
+ifeq ($(PWD),)
+PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH)))))
+ifeq ($(PWD),)
+nopwd:
+	@echo You need the GNU utils package to use this Makefile!
+	@echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip
+	@exit
+else
+inlinux=1
+endif
+else
+PWD:=$(firstword $(PWD))
+endif
+
+# Detect NT - NT sets OS to Windows_NT
+ifndef inlinux
+ifeq ($(OS),Windows_NT)
+inWinNT=1
+endif
+endif
+
+# Detect OS/2 - OS/2 has OS2_SHELL defined
+ifndef inlinux
+ifndef inWinNT
+ifdef OS2_SHELL
+inOS2=1
+endif
+endif
+endif
+
+# The extension of executables
+ifdef inlinux
+EXEEXT=
+else
+EXEEXT=.exe
+endif
+
+# The path which is searched separated by spaces
+ifdef inlinux
+SEARCHPATH=$(subst :, ,$(PATH))
+else
+SEARCHPATH=$(subst ;, ,$(PATH))
+endif
+
+#####################################################################
+# Default target
+#####################################################################
+
+override OS_TARGET:=go32v2
+
+#####################################################################
+# FPC version/target Detection
+#####################################################################
+
+# What compiler to use ?
+ifndef FPC
+# Compatibility with old makefiles
+ifdef PP
+FPC=$(PP)
+else
+ifdef inOS2
+FPC=ppos2$(EXEEXT)
+else
+FPC=ppc386$(EXEEXT)
+endif
+endif
+endif
+
+# Target OS
+ifndef OS_TARGET
+OS_TARGET:=$(shell $(FPC) -iTO)
+endif
+
+# Source OS
+ifndef OS_SOURCE
+OS_SOURCE:=$(shell $(FPC) -iSO)
+endif
+
+# Target CPU
+ifndef CPU_TARGET
+CPU_TARGET:=$(shell $(FPC) -iTP)
+endif
+
+# Source CPU
+ifndef CPU_SOURCE
+CPU_SOURCE:=$(shell $(FPC) -iSP)
+endif
+
+# FPC version
+ifndef FPC_VERSION
+FPC_VERSION:=$(shell $(FPC) -iV)
+endif
+
+export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION
+
+# Test FPCDIR to look if the RTL dir exists
+ifdef FPCDIR
+override FPCDIR:=$(subst \,/,$(FPCDIR))
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+else
+override FPCDIR=wrong
+endif
+
+# Default FPCDIR
+ifeq ($(FPCDIR),wrong)
+override FPCDIR=../..
+ifeq ($(wildcard $(FPCDIR)/rtl),)
+override FPCDIR=wrong
+endif
+endif
+
+# Detect FPCDIR
+ifeq ($(FPCDIR),wrong)
+ifdef inlinux
+override FPCDIR=/usr/lib/fpc/$(FPC_VERSION)
+else
+override FPCDIR:=$(subst /$(FPC)$(EXEEXT),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC)$(EXEEXT),$(SEARCHPATH))))))
+endif
+endif
+
+ifndef PACKAGEDIR
+PACKAGEDIR=$(FPCDIR)/packages
+endif
+ifndef COMPONENTDIR
+COMPONENTDIR=$(FPCDIR)/components
+endif
+# Check if packagedir really exists else turn it off
+ifeq ($(wildcard $(PACKAGEDIR)),)
+PACKAGEDIR=
+endif
+ifeq ($(wildcard $(COMPONENTDIR)),)
+COMPONENTDIR=
+endif
+
+# Create rtl,units dir
+ifneq ($(FPCDIR),.)
+override UNITSDIR=$(FPCDIR)/units/$(OS_TARGET)
+ifneq ($(wildcard $(FPCDIR)/rtl),)
+override RTLDIR=$(FPCDIR)/rtl/$(OS_TARGET)
+else
+override RTLDIR=$(UNITSDIR)/rtl
+endif
+endif
+
+#####################################################################
+# Default Settings
+#####################################################################
+
+# Release ? Then force OPT and don't use extra opts via commandline
+ifndef REDIRFILE
+REDIRFILE=log
+endif
+
+ifdef REDIR
+ifndef inlinux
+override FPC=redir -eo $(FPC)
+endif
+# set the verbosity to max
+override OPT+=-va
+override REDIR:= >> $(REDIRFILE)
+endif
+
+#####################################################################
+# User Settings
+#####################################################################
+
+
+# Pre Settings
+
+# Include files
+INC=../inc
+XML=../xml
+SHEDIT=../shedit
+
+# INCUNITS,XMLUNITS is defined in makefile.inc
+# They are default units for all platforms.
+include $(INC)/Makefile.inc
+include $(XML)/Makefile.inc
+include $(SHEDIT)/Makefile.inc
+
+# Targets
+
+override UNITOBJECTS+=classes $(INCUNITS) $(XMLUNITS) $(SHEDITUNITS)
+
+# Clean
+
+
+# Install
+
+UNITSUBDIR=fcl
+ZIPTARGET=install
+
+# Defaults
+
+override NEEDOPT=-S2
+
+# Directories
+
+vpath %$(PASEXT) $(INC) $(XML) $(SHEDIT)
+override NEEDINCDIR=$(INC)
+ifndef TARGETDIR
+TARGETDIR=.
+endif
+
+# Packages
+
+override PACKAGES=rtl
+PACKAGEDIR_RTL=$(FPCDIR)/rtl/$(OS_TARGET)
+override PACKAGES+=paszlib
+ifneq ($(wildcard $(PACKAGEDIR)/paszlib),)
+ifneq ($(wildcard $(PACKAGEDIR)/paszlib/$(OS_TARGET)),)
+PACKAGEDIR_PASZLIB=$(PACKAGEDIR)/paszlib/$(OS_TARGET)
+else
+PACKAGEDIR_PASZLIB=$(PACKAGEDIR)/paszlib
+endif
+UNITDIR_PASZLIB=$(PACKAGEDIR_PASZLIB)
+else
+PACKAGEDIR_PASZLIB=
+ifneq ($(wildcard $(UNITSDIR)/paszlib),)
+ifneq ($(wildcard $(UNITSDIR)/paszlib/$(OS_TARGET)),)
+UNITDIR_PASZLIB=$(UNITSDIR)/paszlib/$(OS_TARGET)
+else
+UNITDIR_PASZLIB=$(UNITSDIR)/paszlib
+endif
+else
+UNITDIR_PASZLIB=
+endif
+endif
+ifdef UNITDIR_PASZLIB
+override NEEDUNITDIR+=$(UNITDIR_PASZLIB)
+endif
+
+# Libraries
+
+LIBNAME=fpfcl
+
+# Info
+
+INFOTARGET=fpc_infocfg fpc_infoobjects fpc_infoinstall 
+
+#####################################################################
+# Default Directories
+#####################################################################
+
+# Base dir
+ifdef PWD
+BASEDIR:=$(shell $(PWD))
+else
+BASEDIR=.
+endif
+
+# set the prefix directory where to install everything
+ifndef PREFIXINSTALLDIR
+ifdef inlinux
+PREFIXINSTALLDIR=/usr
+else
+PREFIXINSTALLDIR=/pp
+endif
+endif
+export PREFIXINSTALLDIR
+
+#####################################################################
+# Install Directories
+#####################################################################
+
+# set the base directory where to install everything
+ifndef BASEINSTALLDIR
+ifdef inlinux
+BASEINSTALLDIR=$(PREFIXINSTALLDIR)/lib/fpc/$(FPC_VERSION)
+else
+BASEINSTALLDIR=$(PREFIXINSTALLDIR)
+endif
+endif
+
+# set the directory where to install the binaries
+ifndef BININSTALLDIR
+ifdef inlinux
+BININSTALLDIR=$(PREFIXINSTALLDIR)/bin
+else
+BININSTALLDIR=$(BASEINSTALLDIR)/bin/$(OS_TARGET)
+endif
+endif
+
+# set the directory where to install the units.
+ifndef UNITINSTALLDIR
+UNITINSTALLDIR=$(BASEINSTALLDIR)/units/$(OS_TARGET)
+ifdef UNITSUBDIR
+UNITINSTALLDIR:=$(UNITINSTALLDIR)/$(UNITSUBDIR)
+endif
+endif
+
+# Where to install shared libraries
+ifndef LIBINSTALLDIR
+ifdef inlinux
+LIBINSTALLDIR=$(PREFIXINSTALLDIR)/lib
+else
+LIBINSTALLDIR=$(UNITINSTALLDIR)
+endif
+endif
+
+# Where the source files will be stored
+ifndef SOURCEINSTALLDIR
+ifdef inlinux
+SOURCEINSTALLDIR=$(PREFIXINSTALLDIR)/src/fpc-$(FPC_VERSION)
+else
+SOURCEINSTALLDIR=$(BASEINSTALLDIR)/source
+endif
+endif
+
+# Where the doc files will be stored
+ifndef DOCINSTALLDIR
+ifdef inlinux
+DOCINSTALLDIR=$(PREFIXINSTALLDIR)/doc/fpc-$(FPC_VERSION)
+else
+DOCINSTALLDIR=$(BASEINSTALLDIR)/doc
+endif
+endif
+
+# Where the some extra (data)files will be stored
+ifndef DATAINSTALLDIR
+DATAINSTALLDIR=$(BASEINSTALLDIR)
+endif
+
+
+#####################################################################
+# Compiler Command Line
+#####################################################################
+
+# Load commandline OPTDEF and add FPC_CPU define
+override FPCOPTDEF:=-d$(CPU_TARGET)
+
+# Load commandline OPT and add target and unit dir to be sure
+ifneq ($(OS_TARGET),$(OS_SOURCE))
+override FPCOPT+=-T$(OS_TARGET)
+endif
+
+ifdef NEEDOPT
+override FPCOPT+=$(NEEDOPT)
+endif
+
+ifdef UNITSDIR
+override FPCOPT+=-Fu$(UNITSDIR)
+endif
+
+ifdef RTLDIR
+override FPCOPT+=-Fu$(RTLDIR)
+endif
+
+ifdef NEEDUNITDIR
+override FPCOPT+=$(addprefix -Fu,$(NEEDUNITDIR))
+endif
+
+ifdef NEEDINCDIR
+override FPCOPT+=$(addprefix -Fi,$(NEEDINCDIR))
+endif
+
+
+# Target dirs
+ifdef TARGETDIR
+override FPCOPT+=-FE$(TARGETDIR)
+endif
+
+# Smartlinking
+ifdef SMARTLINK
+override FPCOPT+=-CX
+endif
+
+# Debug
+ifdef DEBUG
+override FPCOPT+=-g
+endif
+
+# Release mode (strip, optimize and don't load ppc386.cfg)
+ifdef RELEASE
+override FPCOPT+=-Xs -OG2p3 -n
+endif
+
+# Verbose settings (warning,note,info)
+ifdef VERBOSE
+override FPCOPT+=-vwni
+endif
+
+# Add commandline options
+ifdef OPT
+override FPCOPT+=$(OPT)
+endif
+ifdef UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
+endif
+ifdef LIBDIR
+override FPCOPT+=$(addprefix -Fl,$(LIBDIR))
+endif
+ifdef OBJDIR
+override FPCOPT+=$(addprefix -Fo,$(OBJDIR))
+endif
+ifdef INCDIR
+override FPCOPT+=$(addprefix -Fi,$(INCDIR))
+endif
+
+# Add defines from FPCOPTDEF to FPCOPT
+ifdef FPCOPTDEF
+override FPCOPT+=$(FPCOPTDEF)
+endif
+
+# Error file ?
+ifdef ERRORFILE
+override FPCOPT+=-Fr$(ERRORFILE)
+endif
+
+# Was a config file specified ?
+ifdef CFGFILE
+override FPCOPT+=@$(CFGFILE)
+endif
+
+# For win32 the options are passed using the environment variable FPCEXTCMD
+ifeq ($(OS_SOURCE),win32)
+override FPCEXTCMD:=$(FPCOPT)
+override FPCOPT:=!FPCEXTCMD
+export FPCEXTCMD
+endif
+
+# Compiler commandline
+override COMPILER:=$(FPC) $(FPCOPT)
+
+#####################################################################
+# Shell tools
+#####################################################################
+
+# To copy pograms
+ifndef COPY
+COPY:=cp -fp
+endif
+
+# Copy a whole tree
+ifndef COPYTREE
+COPYTREE:=cp -rfp
+endif
+
+# To move pograms
+ifndef MOVE
+MOVE:=mv -f
+endif
+
+# Check delete program
+ifndef DEL
+DEL:=rm -f
+endif
+
+# Check deltree program
+ifndef DELTREE
+DELTREE:=rm -rf
+endif
+
+# To install files
+ifndef INSTALL
+ifdef inlinux
+INSTALL:=install -m 644
+else
+INSTALL:=$(COPY)
+endif
+endif
+
+# To install programs
+ifndef INSTALLEXE
+ifdef inlinux
+INSTALLEXE:=install -m 755
+else
+INSTALLEXE:=$(COPY)
+endif
+endif
+
+# To make a directory.
+ifndef MKDIR
+ifdef inlinux
+MKDIR:=install -m 755 -d
+else
+MKDIR:=ginstall -m 755 -d
+endif
+endif
+
+export COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR
+
+#####################################################################
+# Default Tools
+#####################################################################
+
+# assembler, redefine it if cross compiling
+ifndef AS
+AS=as
+endif
+
+# linker, but probably not used
+ifndef LD
+LD=ld
+endif
+
+# ppas.bat / ppas.sh
+ifdef inlinux
+PPAS=ppas.sh
+else
+ifdef inOS2
+PPAS=ppas.cmd
+else
+PPAS=ppas.bat
+endif
+endif
+
+# also call ppas if with command option -s
+ifeq (,$(findstring -s ,$(COMPILER)))
+EXECPPAS=
+else
+EXECPPAS:=@$(PPAS)
+endif
+
+# ldconfig to rebuild .so cache
+ifdef inlinux
+LDCONFIG=ldconfig
+else
+LDCONFIG=
+endif
+
+# echo
+ifndef ECHO
+ECHO:=$(strip $(wildcard $(addsuffix /echo$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO:=echo
+else
+ECHO:=$(firstword $(ECHO))
+endif
+endif
+export ECHO
+
+# ppdep
+ifndef PPDEP
+PPDEP:=$(strip $(wildcard $(addsuffix /ppdep$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPDEP),)
+PPDEP=
+else
+PPDEP:=$(firstword $(PPDEP))
+endif
+endif
+export PPDEP
+
+# ppumove
+ifndef PPUMOVE
+PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUMOVE),)
+PPUMOVE=
+else
+PPUMOVE:=$(firstword $(PPUMOVE))
+endif
+endif
+export PPUMOVE
+
+# ppufiles
+ifndef PPUFILES
+PPUFILES:=$(strip $(wildcard $(addsuffix /ppufiles$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUFILES),)
+PPUFILES=
+else
+PPUFILES:=$(firstword $(PPUFILES))
+endif
+endif
+export PPUFILES
+
+# Look if UPX is found for go32v2 and win32. We can't use $UPX becuase
+# upx uses that one itself (PFV)
+ifndef UPXPROG
+ifeq ($(OS_TARGET),go32v2)
+UPXPROG:=1
+endif
+ifeq ($(OS_TARGET),win32)
+UPXPROG:=1
+endif
+ifdef UPXPROG
+UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(UPXPROG),)
+UPXPROG=
+else
+UPXPROG:=$(firstword $(UPXPROG))
+endif
+else
+UPXPROG=
+endif
+endif
+export UPXPROG
+
+# gdate/date
+ifndef DATE
+DATE:=$(strip $(wildcard $(addsuffix /date$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE:=$(strip $(wildcard $(addsuffix /gdate$(EXEEXT),$(SEACHPATH))))
+ifeq ($(DATE),)
+DATE=
+else
+DATE:=$(firstword $(DATE))
+endif
+else
+DATE:=$(firstword $(DATE))
+endif
+endif
+export DATE
+
+ifdef DATE
+DATESTR:=$(shell $(DATE) +%Y%m%d)
+else
+DATESTR=
+endif
+
+# ZipProg, you can't use Zip as the var name (PFV)
+ifndef ZIPPROG
+ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(ZIPPROG),)
+ZIPPROG=
+else
+ZIPPROG:=$(firstword $(ZIPPROG)) -D9 -r
+endif
+endif
+export ZIPPROG
+
+ifndef ZIPEXT
+ZIPEXT=.zip
+endif
+
+#####################################################################
+# Default extensions
+#####################################################################
+
+# Default needed extensions (Go32v2,Linux)
+LOADEREXT=.as
+PPLEXT=.ppl
+PPUEXT=.ppu
+OEXT=.o
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.so
+RSTEXT=.rst
+PACKAGESUFFIX=
+FPCMADE=fpcmade
+
+# Go32v1
+ifeq ($(OS_TARGET),go32v1)
+PPUEXT=.pp1
+OEXT=.o1
+ASMEXT=.s1
+SMARTEXT=.sl1
+STATICLIBEXT=.a1
+SHAREDLIBEXT=.so1
+PACKAGESUFFIX=v1
+FPCMADE=fpcmade.v1
+endif
+
+# Go32v2
+ifeq ($(OS_TARGET),go32v2)
+PACKAGESUFFIX=go32
+FPCMADE=fpcmade.dos
+endif
+
+# Linux
+ifeq ($(OS_TARGET),linux)
+PACKAGESUFFIX=linux
+FPCMADE=fpcmade.lnx
+endif
+
+# Win32
+ifeq ($(OS_TARGET),win32)
+PPUEXT=.ppw
+OEXT=.ow
+ASMEXT=.sw
+SMARTEXT=.slw
+STATICLIBEXT=.aw
+SHAREDLIBEXT=.dll
+PACKAGESUFFIX=win32
+FPCMADE=fpcmade.w32
+endif
+
+# OS/2
+ifeq ($(OS_TARGET),os2)
+PPUEXT=.ppo
+ASMEXT=.so2
+OEXT=.oo2
+SMARTEXT=.so
+STATICLIBEXT=.ao2
+SHAREDLIBEXT=.dll
+PACKAGESUFFIX=os2
+FPCMADE=fpcmade.os2
+endif
+
+# library prefix
+LIBPREFIX=lib
+ifeq ($(OS_TARGET),go32v2)
+LIBPREFIX=
+endif
+ifeq ($(OS_TARGET),go32v1)
+LIBPREFIX=
+endif
+
+# determine which .pas extension is used
+ifndef PASEXT
+ifdef EXEOBJECTS
+override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(EXEOBJECTS)))))
+else
+override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(UNITOBJECTS)))))
+endif
+ifeq ($(TESTPAS),)
+PASEXT=.pp
+else
+PASEXT=.pas
+endif
+endif
+
+#####################################################################
+# Standard rules
+#####################################################################
+
+all: fpc_all
+
+debug: fpc_debug
+
+smart: fpc_smart
+
+shared: fpc_shared
+
+showinstall: fpc_showinstall
+
+install: fpc_install
+
+sourceinstall: fpc_sourceinstall
+
+zipinstall: fpc_zipinstall
+
+zipinstalladd: fpc_zipinstalladd
+
+clean: fpc_clean
+
+cleanall: fpc_cleanall
+
+info: fpc_info
+
+.PHONY:  all debug smart shared showinstall install sourceinstall zipinstall zipinstalladd clean cleanall info
+
+
+ifdef PACKAGERTL
+ifneq ($(wildcard $(PACKAGEDIR_RTL)),)
+ifeq ($(wildcard $(PACKAGEDIR_RTL)/$(FPCMADE)),)
+override COMPILEPACKAGES+=rtl
+rtl_package:
+	$(MAKE) -C $(PACKAGEDIR_RTL) all
+endif
+endif
+endif
+
+PACKAGEPASZLIB=1
+ifdef PACKAGEPASZLIB
+ifneq ($(wildcard $(PACKAGEDIR_PASZLIB)),)
+ifeq ($(wildcard $(PACKAGEDIR_PASZLIB)/$(FPCMADE)),)
+override COMPILEPACKAGES+=paszlib
+paszlib_package:
+	$(MAKE) -C $(PACKAGEDIR_PASZLIB) all
+endif
+endif
+endif
+
+.PHONY:  rtl_package paszlib_package
+
+#####################################################################
+# Units
+#####################################################################
+
+.PHONY: fpc_units
+
+override ALLTARGET+=fpc_units
+
+override UNITPPUFILES=$(addsuffix $(PPUEXT),$(UNITOBJECTS))
+override INSTALLPPUFILES+=$(UNITPPUFILES)
+override CLEANPPUFILES+=$(UNITPPUFILES)
+
+fpc_units: $(UNITPPUFILES)
+
+#####################################################################
+# General compile rules
+#####################################################################
+
+.PHONY: fpc_all fpc_debug
+
+$(FPCMADE):
+	@$(ECHO) Compiled > $(FPCMADE)
+
+fpc_all: $(addsuffix _package,$(COMPILEPACKAGES)) \
+	 $(addsuffix _component,$(COMPILECOMPONENTS)) \
+	 $(ALLTARGET) $(FPCMADE)
+
+fpc_debug:
+	$(MAKE) all DEBUG=1
+
+# General compile rules, available for both possible PASEXT
+
+.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp
+
+%$(PPUEXT): %.pp
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(PPUEXT): %.pas
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(EXEEXT): %.pp
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+%$(EXEEXT): %.pas
+	$(COMPILER) $< $(REDIR)
+	$(EXECPASS)
+
+#####################################################################
+# Library
+#####################################################################
+
+.PHONY: fpc_smart fpc_shared
+
+# Default sharedlib units are all unit objects
+ifndef SHAREDLIBUNITOBJECTS
+SHAREDLIBUNITOBJECTS:=$(UNITOBJECTS)
+endif
+
+fpc_smart:
+	$(MAKE) all SMARTLINK=1
+
+fpc_shared: all
+ifdef inlinux
+ifndef LIBNAME
+	@$(ECHO) "LIBNAME not set"
+else
+	$(PPUMOVE) $(SHAREDLIBUNITOBJECTS) -o$(LIBNAME)
+endif
+else
+	@$(ECHO) "Shared Libraries not supported"
+endif
+
+#####################################################################
+# Install rules
+#####################################################################
+
+.PHONY: fpc_showinstall fpc_install
+
+ifdef EXTRAINSTALLUNITS
+override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRAINSTALLUNITS))
+endif
+
+ifdef INSTALLPPUFILES
+ifdef PPUFILES
+ifdef inlinux
+INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
+INSTALLPPULIBFILES:=$(shell $(PPUFILES) -L $(INSTALLPPUFILES))
+else
+INSTALLPPULINKFILES:=$(shell $(PPUFILES) $(INSTALLPPUFILES))
+endif
+else
+INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
+endif
+endif
+
+fpc_showinstall: $(SHOWINSTALLTARGET)
+ifdef INSTALLEXEFILES
+	@$(ECHO) -e $(addprefix "\n"$(BININSTALLDIR)/,$(INSTALLEXEFILES))
+endif
+ifdef INSTALLPPUFILES
+	@$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPUFILES))
+ifneq ($(INSTALLPPULINKFILES),)
+	@$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPULINKFILES))
+endif
+ifneq ($(INSTALLPPULIBFILES),)
+	@$(ECHO) -e $(addprefix "\n"$(LIBINSTALLDIR)/,$(INSTALLPPULIBFILES))
+endif
+endif
+ifdef EXTRAINSTALLFILES
+	@$(ECHO) -e $(addprefix "\n"$(DATAINSTALLDIR)/,$(EXTRAINSTALLFILES))
+endif
+
+fpc_install: $(INSTALLTARGET)
+# Create UnitInstallFiles
+ifdef INSTALLEXEFILES
+	$(MKDIR) $(BININSTALLDIR)
+# Compress the exes if upx is defined
+ifdef UPXPROG
+	-$(UPXPROG) $(INSTALLEXEFILES)
+endif
+	$(INSTALLEXE) $(INSTALLEXEFILES) $(BININSTALLDIR)
+endif
+ifdef INSTALLPPUFILES
+	$(MKDIR) $(UNITINSTALLDIR)
+	$(INSTALL) $(INSTALLPPUFILES) $(UNITINSTALLDIR)
+ifneq ($(INSTALLPPULINKFILES),)
+	$(INSTALL) $(INSTALLPPULINKFILES) $(UNITINSTALLDIR)
+endif
+ifneq ($(INSTALLPPULIBFILES),)
+	$(MKDIR) $(LIBINSTALLDIR)
+	$(INSTALL) $(INSTALLPPULIBFILES) $(LIBINSTALLDIR)
+endif
+endif
+ifdef EXTRAINSTALLFILES
+	$(MKDIR) $(DATAINSTALLDIR)
+	$(INSTALL) $(EXTRAINSTALLFILES) $(DATAINSTALLDIR)
+endif
+
+#####################################################################
+# Source install rules
+#####################################################################
+
+.PHONY: fpc_sourceinstall
+
+fpc_sourceinstall: clean
+	$(MKDIR) $(SOURCEINSTALLDIR)
+	$(COPYTREE) $(BASEDIR) $(SOURCEINSTALLDIR)
+
+#####################################################################
+# Zip
+#####################################################################
+
+.PHONY: fpc_zipinstall fpc_zipinstalladd
+
+# Temporary path to pack a file
+ifndef PACKDIR
+ifndef inlinux
+PACKDIR=pack_tmp
+else
+PACKDIR=/tmp/fpc-pack
+endif
+endif
+
+# Test dir if none specified
+ifndef DESTZIPDIR
+DESTZIPDIR:=$(BASEDIR)
+endif
+
+# Add .zip/.tar.gz extension
+ifdef ZIPNAME
+ifndef inlinux
+override ZIPNAME:=$(ZIPNAME)$(ZIPEXT)
+endif
+endif
+
+# Note: This will not remove the zipfile first
+fpc_zipinstalladd:
+ifndef ZIPNAME
+	@$(ECHO) "Please specify ZIPNAME!"
+	@exit 1
+else
+	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
+ifdef inlinux
+	gzip -d $(DESTZIPDIR)/$(ZIPNAME).tar.gz
+	cd $(PACKDIR) ; tar rv --file $(DESTZIPDIR)/$(ZIPNAME).tar * ; cd $(BASEDIR)
+	gzip $(DESTZIPDIR)/$(ZIPNAME).tar
+else
+	cd $(PACKDIR) ; $(ZIPPROG) $(DESTZIPDIR)/$(ZIPNAME) * ; cd $(BASEDIR)
+endif
+	$(DELTREE) $(PACKDIR)
+endif
+
+# First remove the zip and then install
+fpc_zipinstall:
+ifndef ZIPNAME
+	@$(ECHO) "Please specify ZIPNAME!"
+	@exit 1
+else
+	$(DEL) $(DESTZIPDIR)/$(ZIPNAME)
+	$(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR)
+ifdef inlinux
+	cd $(PACKDIR) ; tar cvz --file $(DESTZIPDIR)/$(ZIPNAME).tar.gz * ; cd $(BASEDIR)
+else
+	cd $(PACKDIR) ; $(ZIPPROG) $(DESTZIPDIR)/$(ZIPNAME) * ; cd $(BASEDIR)
+endif
+	$(DELTREE) $(PACKDIR)
+endif
+
+#####################################################################
+# Clean rules
+#####################################################################
+
+.PHONY: fpc_clean fpc_cleanall
+
+ifdef EXTRACLEANUNITS
+override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRACLEANUNITS))
+endif
+
+ifdef CLEANPPUFILES
+ifdef PPUFILES
+CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
+else
+CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
+endif
+endif
+
+fpc_clean: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+ifdef CLEANPPUFILES
+	-$(DEL) $(CLEANPPUFILES)
+endif
+ifneq ($(CLEANPPULINKFILES),)
+	-$(DEL) $(CLEANPPULINKFILES)
+endif
+ifdef CLEANRSTFILES
+	-$(DEL) $(CLEANRSTFILES)
+endif
+ifdef EXTRACLEANFILES
+	-$(DEL) $(EXTRACLEANFILES)
+endif
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(REDIRFILE)
+
+fpc_cleanall: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+	-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+	-$(DELTREE) *$(SMARTEXT)
+	-$(DEL) $(FPCMADE) $(PPAS) link.res $(REDIRFILE)
+
+#####################################################################
+# Info rules
+#####################################################################
+
+.PHONY: fpc_info fpc_cfginfo fpc_objectinfo fpc_toolsinfo fpc_installinfo \
+	fpc_dirinfo
+
+fpc_info: $(INFOTARGET)
+
+fpc_infocfg:
+	@$(ECHO)
+	@$(ECHO)  == Configuration info ==
+	@$(ECHO)
+	@$(ECHO)  FPC....... $(FPC)
+	@$(ECHO)  Version... $(FPC_VERSION)
+	@$(ECHO)  CPU....... $(CPU_TARGET)
+	@$(ECHO)  Source.... $(OS_SOURCE)
+	@$(ECHO)  Target.... $(OS_TARGET)
+	@$(ECHO)
+
+fpc_infoobjects:
+	@$(ECHO)
+	@$(ECHO)  == Object info ==
+	@$(ECHO)
+	@$(ECHO)  LoaderObjects..... $(LOADEROBJECTS)
+	@$(ECHO)  UnitObjects....... $(UNITOBJECTS)
+	@$(ECHO)  ExeObjects........ $(EXEOBJECTS)
+	@$(ECHO)
+	@$(ECHO)  ExtraCleanUnits... $(EXTRACLEANUNITS)
+	@$(ECHO)  ExtraCleanFiles... $(EXTRACLEANFILES)
+	@$(ECHO)
+	@$(ECHO)  ExtraInstallUnits. $(EXTRAINSTALLUNITS)
+	@$(ECHO)  ExtraInstallFiles. $(EXTRAINSTALLFILES)
+	@$(ECHO)
+
+fpc_infoinstall:
+	@$(ECHO)
+	@$(ECHO)  == Install info ==
+	@$(ECHO)
+ifdef DATE
+	@$(ECHO)  DateStr.............. $(DATESTR)
+endif
+	@$(ECHO)  PackageSuffix........ $(PACKAGESUFFIX)
+	@$(ECHO)
+	@$(ECHO)  BaseInstallDir....... $(BASEINSTALLDIR)
+	@$(ECHO)  BinInstallDir........ $(BININSTALLDIR)
+	@$(ECHO)  LibInstallDir........ $(LIBINSTALLDIR)
+	@$(ECHO)  UnitInstallDir....... $(UNITINSTALLDIR)
+	@$(ECHO)  SourceInstallDir..... $(SOURCEINSTALLDIR)
+	@$(ECHO)  DocInstallDir........ $(DOCINSTALLDIR)
+	@$(ECHO)  DataInstallDir....... $(DATAINSTALLDIR)
+	@$(ECHO)
+
+#####################################################################
+# Users rules
+#####################################################################
+
+classes$(PPUEXT): $(addprefix $(INC)/,$(INCNAMES)) classes$(PASEXT)
+
+inifiles$(PPUEXT): classes$(PPUEXT) $(INC)/inifiles$(PASEXT)
+
+ezcgi$(PPUEXT): $(INC)/ezcgi$(PASEXT)
+
+shedit$(PPUEXT): $(SHEDIT)/shedit$(PASEXT)
+	$(COMPILER) $(SHEDIT)/shedit$(PASEXT) -I$(SHEDIT) $(REDIR)

fcl/go32v2/Makefile.fpc

@@ -0,0 +1,49 @@
+#
+#   Makefile.fpc for Free Component Library for Go32v2
+#
+
+[targets]
+units=classes $(INCUNITS) $(XMLUNITS) $(SHEDITUNITS)
+
+[defaults]
+defaulttarget=go32v2
+
+[require]
+options=-S2
+packages=paszlib
+
+[install]
+unitsubdir=fcl
+
+[libs]
+libname=fpfcl
+
+[dirs]
+fpcdir=../..
+targetdir=.
+incdir=$(INC)
+sourcesdir=$(INC) $(XML) $(SHEDIT)
+
+
+[presettings]
+# Include files
+INC=../inc
+XML=../xml
+SHEDIT=../shedit
+
+# INCUNITS,XMLUNITS is defined in makefile.inc
+# They are default units for all platforms.
+include $(INC)/Makefile.inc
+include $(XML)/Makefile.inc
+include $(SHEDIT)/Makefile.inc
+
+
+[rules]
+classes$(PPUEXT): $(addprefix $(INC)/,$(INCNAMES)) classes$(PASEXT)
+
+inifiles$(PPUEXT): classes$(PPUEXT) $(INC)/inifiles$(PASEXT)
+
+ezcgi$(PPUEXT): $(INC)/ezcgi$(PASEXT)
+
+shedit$(PPUEXT): $(SHEDIT)/shedit$(PASEXT)
+	$(COMPILER) $(SHEDIT)/shedit$(PASEXT) -I$(SHEDIT) $(REDIR)

fcl/go32v2/classes.pp

@@ -0,0 +1,55 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 by Michael Van Canneyt and Florian Klaempfl
+
+    Classes unit for win32
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$mode objfpc}
+
+{ determine the type of the resource/form file }
+{$define Win16Res}
+
+unit Classes;
+
+interface
+
+uses
+  strings,
+  sysutils;
+
+{$i classesh.inc}
+
+implementation
+
+
+uses typinfo;
+
+{ OS - independent class implementations are in /inc directory. }
+{$i classes.inc}
+
+end.
+{
+  $Log$
+  Revision 1.6  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  2000/01/04 18:09:29  michael
+  + Added typinfo unit
+
+  Revision 1.1  2000/01/03 19:33:06  peter
+    * moved to packages dir
+
+  Revision 1.4  1999/05/30 10:46:37  peter
+    * start of tthread for linux,win32
+
+}

fcl/go32v2/ezcgi.inc

@@ -0,0 +1,9 @@
+Uses Dos;
+
+{ Declared EXPLICITLY with Ansistring, so NO mistaking is possible }
+
+Function Getenv (Var EnvVar  : AnsiString): AnsiString;
+
+begin
+  Result:=Dos.Getenv(EnvVar); 
+end;

fcl/go32v2/pipes.inc

@@ -0,0 +1,23 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1998 by Michael Van Canneyt
+
+    DOS/go32v2 specific part of pipe stream.
+    
+    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.
+
+ **********************************************************************}
+
+// No pipes under dos, sorry...
+
+Function CreatePipeHandles (Var Inhandle,OutHandle : Longint) : Boolean;
+
+begin
+  Result := False;
+end;

fcl/go32v2/thread.inc

@@ -0,0 +1,107 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+{****************************************************************************}
+{*                             TThread                                      *}
+{****************************************************************************}
+
+
+procedure TThread.CallOnTerminate;
+
+begin
+end;
+
+
+function TThread.GetPriority: TThreadPriority;
+
+begin
+  GetPriority:=tpNormal;
+end;
+
+
+procedure TThread.SetPriority(Value: TThreadPriority);
+
+begin
+end;
+
+
+procedure TThread.SetSuspended(Value: Boolean);
+
+begin
+end;
+
+
+procedure TThread.DoTerminate;
+
+begin
+end;
+
+
+procedure TThread.Synchronize(Method: TThreadMethod);
+
+begin
+end;
+
+
+constructor TThread.Create(CreateSuspended: Boolean);
+
+begin
+end;
+
+
+destructor TThread.Destroy;
+
+begin
+end;
+
+
+procedure TThread.Resume;
+
+begin
+end;
+
+
+procedure TThread.Suspend;
+
+begin
+end;
+
+
+procedure TThread.Terminate;
+
+begin
+end;
+
+
+function TThread.WaitFor: Integer;
+
+begin
+  WaitFor:=0;
+end;
+
+
+{
+  $Log$
+  Revision 1.3  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:06  peter
+    * moved to packages dir
+
+  Revision 1.1  1999/05/30 10:46:39  peter
+    * start of tthread for linux,win32
+
+  Revision 1.2  1999/04/08 10:18:57  peter
+    * makefile updates
+
+}

fcl/inc/Makefile.inc

@@ -0,0 +1,9 @@
+#
+# This makefile sets some needed variable, common to all targets
+#
+
+INCNAMES=classes.inc classesh.inc bits.inc collect.inc compon.inc filer.inc \
+         lists.inc parser.inc persist.inc reader.inc streams.inc stringl.inc \
+         writer.inc cregist.inc
+
+INCUNITS=inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream

fcl/inc/base64.pp

@@ -0,0 +1,308 @@
+// $Id$
+
+// Encoding and decoding streams for base64 data as described in RFC2045
+
+{$MODE objfpc}
+{$H+}
+
+unit base64;
+
+interface
+
+uses classes;
+
+type
+
+  TBase64EncodingStream = class(TStream)
+  protected
+    OutputStream: TStream;
+    TotalBytesProcessed, BytesWritten: LongWord;
+    Buf: array[0..2] of Byte;
+    BufSize: Integer;    // # of bytes used in Buf
+  public
+    constructor Create(AOutputStream: TStream);
+    destructor Destroy; override;
+
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+  end;
+
+
+  TBase64DecodingStream = class(TStream)
+  protected
+    InputStream: TStream;
+    CurPos, InputStreamSize: LongInt;
+    Buf: array[0..2] of Byte;
+    BufPos: Integer;    // Offset of byte which is to be read next
+    fEOF: Boolean;
+  public
+    constructor Create(AInputStream: TStream);
+    procedure Reset;
+
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+    property EOF: Boolean read fEOF;
+  end;
+
+
+
+implementation
+
+const
+
+  EncodingTable: PChar =
+    'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
+
+  DecTable: array[Byte] of Byte =
+    (99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,  // 0-15
+     99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,  // 16-31
+     99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 62, 99, 99, 99, 63,  // 32-47
+     52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 99, 99, 99, 00, 99, 99,  // 48-63
+     99, 00, 01, 02, 03, 04, 05, 06, 07, 08, 09, 10, 11, 12, 13, 14,  // 64-79
+     15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 99, 99, 99, 99, 99,  // 80-95
+     99, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,  // 96-111
+     41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 99, 99, 99, 99, 99,  // 112-127
+     99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
+     99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
+     99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
+     99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
+     99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
+     99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
+     99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
+     99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99);
+
+
+constructor TBase64EncodingStream.Create(AOutputStream: TStream);
+begin
+  inherited Create;
+  OutputStream := AOutputStream;
+end;
+
+destructor TBase64EncodingStream.Destroy;
+var
+  WriteBuf: array[0..3] of Char;
+begin
+  // Fill output to multiple of 4
+  case (TotalBytesProcessed mod 3) of
+    1: begin
+        WriteBuf[0] := EncodingTable[Buf[0] shr 2];
+        WriteBuf[1] := EncodingTable[(Buf[0] and 3) shl 4];
+	WriteBuf[2] := '=';
+	WriteBuf[3] := '=';
+        OutputStream.Write(WriteBuf, 4);
+      end;
+    2: begin
+        WriteBuf[0] := EncodingTable[Buf[0] shr 2];
+	WriteBuf[1] := EncodingTable[(Buf[0] and 3) shl 4 or (Buf[1] shr 4)];
+	WriteBuf[2] := EncodingTable[(Buf[1] and 15) shl 2];
+	WriteBuf[3] := '=';
+	OutputStream.Write(WriteBuf, 4);
+      end;
+  end;
+  inherited Destroy;
+end;
+
+function TBase64EncodingStream.Read(var Buffer; Count: Longint): Longint;
+begin
+  raise EStreamError.Create('Invalid stream operation');
+end;
+
+function TBase64EncodingStream.Write(const Buffer; Count: Longint): Longint;
+var
+  ReadNow: LongInt;
+  p: Pointer;
+  WriteBuf: array[0..3] of Char;
+begin
+  Inc(TotalBytesProcessed, Count);
+  Result := Count;
+
+  p := @Buffer;
+  while count > 0 do begin
+    // Fetch data into the Buffer
+    ReadNow := 3 - BufSize;
+    if ReadNow > Count then break;    // Not enough data available
+    Move(p^, Buf[BufSize], ReadNow);
+    Inc(p, ReadNow);
+    Dec(Count, ReadNow);
+
+    // Encode the 3 bytes in Buf
+    WriteBuf[0] := EncodingTable[Buf[0] shr 2];
+    WriteBuf[1] := EncodingTable[(Buf[0] and 3) shl 4 or (Buf[1] shr 4)];
+    WriteBuf[2] := EncodingTable[(Buf[1] and 15) shl 2 or (Buf[2] shr 6)];
+    WriteBuf[3] := EncodingTable[Buf[2] and 63];
+    OutputStream.Write(WriteBuf, 4);
+    Inc(BytesWritten, 4);
+    BufSize := 0;
+  end;
+  Move(p^, Buf[BufSize], count);
+  Inc(BufSize, count);
+end;
+
+function TBase64EncodingStream.Seek(Offset: Longint; Origin: Word): Longint;
+begin
+  Result := BytesWritten;
+  if BufSize > 0 then
+    Inc(Result, 4);
+
+  // This stream only supports the Seek modes needed for determining its size
+  if not ((((Origin = soFromCurrent) or (Origin = soFromEnd)) and (Offset = 0))
+     or ((Origin = soFromBeginning) and (Offset = Result))) then
+    raise EStreamError.Create('Invalid stream operation');
+end;
+
+
+
+
+constructor TBase64DecodingStream.Create(AInputStream: TStream);
+begin
+  inherited Create;
+  InputStream := AInputStream;
+  Reset;
+end;
+
+procedure TBase64DecodingStream.Reset;
+begin
+  InputStreamSize := -1;
+  BufPos := 3;
+  fEOF := False;
+end;
+
+function TBase64DecodingStream.Read(var Buffer; Count: Longint): Longint;
+var
+  p: PChar;
+  b: Char;
+  ReadBuf: array[0..3] of Byte;
+  ToRead, OrgToRead, HaveRead, ReadOK, i, j: Integer;
+begin
+  if Count <= 0 then exit(0);
+  if InputStreamSize <> -1 then begin
+    if CurPos + Count > InputStreamSize then
+      Count := InputStreamSize - CurPos;
+    if Count <= 0 then exit(0);
+  end;
+
+  Result := 0;
+  p := PChar(@Buffer);
+  while (Count > 0) and not fEOF do begin
+    if BufPos > 2 then begin
+      BufPos := 0;
+      // Read the next 4 valid bytes
+      ToRead := 4;
+      ReadOK := 0;
+      while ToRead > 0 do begin
+        OrgToRead := ToRead;
+        HaveRead := InputStream.Read(ReadBuf[ReadOK], ToRead);
+	//WriteLn('ToRead = ', ToRead, ', HaveRead = ', HaveRead, ', ReadOK=', ReadOk);
+	if HaveRead > 0 then begin
+	  i := ReadOk;
+	  while i <= HaveRead do begin
+	    ReadBuf[i] := DecTable[ReadBuf[i]];
+	    if ReadBuf[i] = 99 then
+	      for j := i to 3 do
+	        ReadBuf[i] := ReadBuf[i + 1]
+	    else begin
+	      Inc(i);
+	      Inc(ReadOK);
+	      Dec(ToRead);
+	    end;
+	  end;
+	end;
+	if HaveRead <> OrgToRead then begin
+	  //WriteLn('Ende? ReadOK=', ReadOK, ', count=', Count);
+	  for i := ReadOK to 3 do
+	    ReadBuf[i] := Ord('=');
+	  fEOF := True;
+	  if ReadOK < 2 then exit;    // Not enough data available in input stream
+	  break;
+	end;
+      end;
+
+      // Check for fill bytes
+      if (Count >= 2) and (ReadBuf[3] = Ord('=')) then begin
+        //WriteLn('Endemarkierung!');
+	fEOF := True;
+	if ReadBuf[2] = Ord('=') then
+	  Count := 1
+	else
+	  Count := 2;
+      end;
+
+      // Decode the 4 bytes in the buffer to 3 undecoded bytes
+      Buf[0] := ReadBuf[0] shl 2 or ReadBuf[1] shr 4;
+      Buf[1] := (ReadBuf[1] and 15) shl 4 or ReadBuf[2] shr 2;
+      Buf[2] := (ReadBuf[2] and 3) shl 6 or ReadBuf[3];
+    end;
+
+    p[0] := Chr(Buf[BufPos]);
+    Inc(p);
+    Inc(BufPos);
+    Inc(CurPos);
+    Dec(Count);
+    Inc(Result);
+  end;
+end;
+
+function TBase64DecodingStream.Write(const Buffer; Count: Longint): Longint;
+begin
+  raise EStreamError.Create('Invalid stream operation');
+end;
+
+function TBase64DecodingStream.Seek(Offset: Longint; Origin: Word): Longint;
+var
+  ipos: LongInt;
+  endbytes: array[0..1] of Char;
+begin
+  {This will work only if the input stream supports seeking / Size. If not, the
+   input stream will raise an exception; we don't handle them here but pass them
+   to the caller.}
+  if InputStreamSize = -1 then begin
+    ipos := InputStream.Position;
+    InputStreamSize := ((InputStream.Size - ipos + 3) div 4) * 3;
+    InputStream.Seek(-2, soFromEnd);
+    InputStream.Read(endbytes, 2);
+    InputStream.Position := ipos;
+    if endbytes[1] = '=' then begin
+      Dec(InputStreamSize);
+    if endbytes[0] = '=' then
+      Dec(InputStreamSize);
+    end;
+  end;
+
+  // This stream only supports the Seek modes needed for determining its size
+  if (Origin = soFromCurrent) and (Offset = 0) then
+    Result := CurPos
+  else if (Origin = soFromEnd) and (Offset = 0) then
+    Result := InputStreamSize
+  else if (Origin = soFromBeginning) and (Offset = CurPos) then
+    Result := CurPos
+  else
+    raise EStreamError.Create('Invalid stream operation');
+end;
+
+
+end.
+
+
+{
+  $Log$
+  Revision 1.6  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:06  peter
+    * moved to packages dir
+
+  Revision 1.4  1999/08/13 22:14:40  peter
+    * removed email separator at the bottom ;)
+
+  Revision 1.3  1999/08/13 16:31:41  michael
+  + Patch to support sizeless streams by Sebastian Guenter
+
+  Revision 1.2  1999/08/09 16:12:28  michael
+  * Fixes and new examples from Sebastian Guenther
+
+  Revision 1.1  1999/08/03 17:02:38  michael
+  * Base64 en/de cdeing streams added
+
+}

fcl/inc/bits.inc

@@ -0,0 +1,377 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+{****************************************************************************}
+{*                               TBits                                      *}
+{****************************************************************************}
+
+{ ************* functions to match TBits class ************* }
+
+function TBits.getSize : longint;
+begin
+   result := (FSize shl BITSHIFT) - 1;
+end;
+
+procedure TBits.setSize(value : longint);
+begin
+   grow(value - 1);
+end;
+
+procedure TBits.SetBit(bit : longint; value : Boolean);
+begin
+   if value = True then
+      seton(bit)
+   else
+      clear(bit);
+end;
+
+function TBits.OpenBit : longint;
+var
+   loop : longint;
+   loop2 : longint;
+   startIndex : longint;
+begin
+   result := -1; {should only occur if the whole array is set}
+   for loop := 0 to FSize - 1 do
+   begin
+      if FBits^[loop] <> $FFFFFFFF then
+      begin
+         startIndex := loop * 32;
+         for loop2 := startIndex to startIndex + 31 do
+         begin
+            if get(loop2) = False then
+            begin
+               result := loop2;
+               break; { use this as the index to return }
+            end;
+         end;
+         break;  {stop looking for empty bit in records }
+      end;
+   end;
+
+   if result = -1 then
+      if FSize < MaxBitRec then
+          result := FSize * 32;  {first bit of next record}
+end;
+
+{ ******************** TBits ***************************** }
+
+constructor TBits.Create(theSize : longint);
+begin
+   FSize := 0;
+   FBits := nil;
+   findIndex := -1;
+   findState := True;  { no reason just setting it to something }
+   grow(theSize);
+end;
+
+destructor TBits.Destroy;
+begin
+   if FBits <> nil then
+      FreeMem(FBits, FSize * SizeOf(longint));
+   FBits := nil;
+
+   inherited Destroy;
+end;
+
+procedure TBits.grow(nbit : longint);
+var
+   newSize : longint;
+   loop : longint;
+begin
+
+   if nbit >= MaxBitFlags then
+      Raise EBitsError.Create('Bit index exceeds array limit');
+
+   newSize :=  (nbit shr BITSHIFT) + 1;
+
+   if newSize > FSize then
+   begin
+      ReAllocMem(FBits, newSize * SizeOf(longint));
+      if FBits <> nil then
+      begin
+         if newSize > FSize then
+            for loop := FSize to newSize - 1 do
+               FBits^[loop] := 0;
+
+         FSize := newSize;
+      end;
+   end;
+end;
+
+function TBits.getFSize : longint;
+begin
+   result := FSize;
+end;
+
+procedure TBits.seton(bit : longint);
+var
+   n : longint;
+begin
+   n := bit shr BITSHIFT;
+
+   grow(bit);
+
+   FBits^[n] := FBits^[n] or (longint(1) shl (bit and MASK));
+end;
+
+procedure TBits.clear(bit : longint);
+var
+   n : longint;
+begin
+   n := bit shr BITSHIFT;
+
+   grow(bit);
+
+   FBits^[n] := FBits^[n] and not(longint(1) shl (bit and MASK));
+end;
+
+procedure TBits.clearall;
+var
+   loop : longint;
+begin
+   for loop := 0 to FSize - 1 do
+      FBits^[loop] := 0;
+end;
+
+function TBits.get(bit : longint) : Boolean;
+var
+   n : longint;
+begin
+   result := False;
+
+   if bit >= MaxBitFlags then
+      Raise EBitsError.Create('Bit index exceeds array limit');
+
+   n := bit shr BITSHIFT;
+
+   if (n < FSize) then
+      result := (FBits^[n] and (longint(1) shl (bit and MASK))) <> 0;
+end;
+
+procedure TBits.andbits(bitset : TBits);
+var
+   n : longint;
+   loop : longint;
+begin
+   if FSize < bitset.getFSize then
+      n := FSize - 1
+   else
+      n := bitset.getFSize - 1;
+
+   for loop := 0 to n do
+      FBits^[loop] := FBits^[loop] and bitset.FBits^[loop];
+
+   for loop := n + 1 to FSize - 1 do
+      FBits^[loop] := 0;
+end;
+
+procedure TBits.notbits(bitset : TBits);
+var
+   n : longint;
+   jj : longint;
+   loop : longint;
+begin
+   if FSize < bitset.getFSize then
+      n := FSize - 1
+   else
+      n := bitset.getFSize - 1;
+
+   for loop := 0 to n do
+   begin
+      jj := FBits^[loop];
+      FBits^[loop] := FBits^[loop] and (jj xor bitset.FBits^[loop]);
+   end;
+end;
+
+procedure TBits.orbits(bitset : TBits);
+var
+   n : longint;
+   loop : longint;
+begin
+   if FSize < bitset.getFSize then
+      n := bitset.getFSize - 1
+   else
+      n := FSize - 1;
+
+   grow(n shl BITSHIFT);
+
+   for loop := 0 to n do
+      FBits^[loop] := FBits^[loop] or bitset.FBits^[loop];
+end;
+
+procedure TBits.xorbits(bitset : TBits);
+var
+   n : longint;
+   loop : longint;
+begin
+   if FSize < bitset.getFSize then
+      n := bitset.getFSize - 1
+   else
+      n := FSize - 1;
+
+   grow(n shl BITSHIFT);
+
+   for loop := 0 to n do
+      FBits^[loop] := FBits^[loop] xor bitset.FBits^[loop];
+end;
+
+function TBits.equals(bitset : TBits) : Boolean;
+var
+   n : longint;
+   loop : longint;
+begin
+   result := False;
+
+   if FSize < bitset.getFSize then
+      n := FSize - 1
+   else
+      n := bitset.getFSize - 1;
+
+   for loop := 0 to n do
+      if FBits^[loop] <> bitset.FBits^[loop] then exit;
+
+   if FSize - 1 > n then
+   begin
+      for loop := n to FSize - 1 do
+         if FBits^[loop] <> 0 then exit;
+   end
+   else if bitset.getFSize - 1 > n then
+      for loop := n to bitset.getFSize - 1 do
+         if bitset.FBits^[loop] <> 0 then exit;
+
+   result := True;  {passed all tests}
+end;
+
+
+{ us this in place of calling FindFirstBit. It sets the current }
+{ index used by FindNextBit and FindPrevBit                     }
+
+procedure TBits.SetIndex(index : longint);
+begin
+   findIndex := index;
+end;
+
+
+{ When state is set to True it looks for bits that are turned On (1) }
+{ and when it is set to False it looks for bits that are turned      }
+{ off (0).                                                           }
+
+function TBits.FindFirstBit(state : boolean) : longint;
+var
+   loop : longint;
+   loop2 : longint;
+   startIndex : longint;
+   compareVal : longint;
+begin
+   result := -1; {should only occur if none are set}
+
+   findState := state;
+
+   if state = False then
+      compareVal := $FFFFFFFF  { looking for off bits }
+   else
+      compareVal := $00000000; { looking for on bits }
+
+   for loop := 0 to FSize - 1 do
+   begin
+      if FBits^[loop] <> compareVal then
+      begin
+         startIndex := loop * 32;
+         for loop2 := startIndex to startIndex + 31 do
+         begin
+            if get(loop2) = state then
+            begin
+               result := loop2;
+               break; { use this as the index to return }
+            end;
+         end;
+         break;  {stop looking for bit in records }
+      end;
+   end;
+
+   findIndex := result;
+end;
+
+function TBits.FindNextBit : longint;
+var
+   loop : longint;
+   maxVal : longint;
+begin
+   result := -1;  { will occur only if no other bits set to }
+                  { current findState                        }
+
+   if findIndex > -1 then { must have called FindFirstBit first }
+   begin                  { or set the start index              }
+      maxVal := (FSize * 32) - 1;
+
+      for loop := findIndex + 1 to maxVal  do
+      begin
+         if get(loop) = findState then
+         begin
+            result := loop;
+            break;
+         end;
+      end;
+
+      findIndex := result;
+   end;
+end;
+
+function TBits.FindPrevBit : longint;
+var
+   loop : longint;
+begin
+   result := -1;  { will occur only if no other bits set to }
+                  { current findState                        }
+
+   if findIndex > -1 then { must have called FindFirstBit first }
+   begin                  { or set the start index              }
+      for loop := findIndex - 1 downto 0  do
+      begin
+         if get(loop) = findState then
+         begin
+            result := loop;
+            break;
+         end;
+      end;
+
+      findIndex := result;
+   end;
+end;
+
+
+{
+  $Log$
+  Revision 1.7  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:06  peter
+    * moved to packages dir
+
+  Revision 1.5  1999/11/01 13:56:58  peter
+    * adapted for new reallocmem
+
+  Revision 1.4  1999/04/09 12:13:31  michael
+  + Changed TBits to TbitsPlus from Michael A. Hess (renamed to Tbits)
+
+  Revision 1.3  1998/11/04 14:36:29  michael
+  Error handling always with exceptions
+
+  Revision 1.2  1998/11/04 10:46:42  peter
+    * exceptions work
+
+  Revision 1.1  1998/05/04 14:30:11  michael
+  * Split file according to Class; implemented dummys for all methods, so unit compiles.
+
+}

fcl/inc/classes.inc

@@ -0,0 +1,782 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.                 *
+ **********************************************************************}
+
+{
+ 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}
+{$ELSE}
+{$i constse.inc}
+{$ENDIF}
+{$ENDIF}
+
+{ Utility routines }
+{$i util.inc}
+
+{ TBits implementation }
+{$i bits.inc}
+
+{ TReader implementation }
+{ $i reader.inc}
+
+{ TWriter implementations }
+{$i writer.inc}
+{$i twriter.inc}
+
+{ TFiler implementation }
+{$i filer.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 }
+{$i thread.inc}
+
+{ TPersistent implementation }
+{$i persist.inc }
+
+{ TComponent implementation }
+{$i compon.inc}
+
+{ Class and component registration routines }
+{$I cregist.inc}
+
+
+{**********************************************************************
+ *       Miscellaneous procedures and functions                       *
+ **********************************************************************}
+
+{ 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;
+
+
+
+
+
+{ Object filing routines }
+
+procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
+  IntToIdent: TIntToIdent);
+
+begin
+end;
+
+
+function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
+
+begin
+  IdentToInt:=false;
+end;
+
+
+function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
+
+begin
+  IntToIdent:=false;
+end;
+
+
+function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
+
+begin
+  InitInheritedComponent:=false;
+end;
+
+
+function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
+
+begin
+  InitComponentRes:=false;
+end;
+
+
+function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
+
+begin
+  ReadComponentRes:=nil;
+end;
+
+
+function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
+
+begin
+  ReadComponentResEx:=nil;
+end;
+
+
+function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
+
+begin
+  ReadComponentResFile:=nil;
+end;
+
+
+procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
+
+begin
+end;
+
+
+
+procedure GlobalFixupReferences;
+
+begin
+end;
+
+
+procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
+
+begin
+end;
+
+
+procedure GetFixupInstanceNames(Root: TComponent;
+  const ReferenceRootName: string; Names: TStrings);
+
+begin
+end;
+
+
+procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
+  NewRootName: string);
+
+begin
+end;
+
+
+procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
+
+begin
+end;
+
+
+procedure RemoveFixups(Instance: TPersistent);
+
+begin
+end;
+
+
+
+procedure BeginGlobalLoading;
+
+begin
+end;
+
+
+procedure NotifyGlobalLoading;
+
+begin
+end;
+
+
+procedure EndGlobalLoading;
+
+begin
+end;
+
+
+
+function CollectionsEqual(C1, C2: TCollection): Boolean;
+
+begin
+  CollectionsEqual:=false;
+end;
+
+
+
+{ Object conversion routines }
+
+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 + #10);
+  end;
+
+  procedure OutString(s: String);
+  var
+    res, NewStr: String;
+    i: Integer;
+    InString, NewInString: Boolean;
+  begin
+    res := '';
+    InString := False;
+    for i := 1 to Length(s) do begin
+      NewInString := InString;
+      case s[i] of
+        #0..#31: begin
+	    if InString then
+	      NewInString := False;
+	    NewStr := '#' + IntToStr(Ord(s[i]));
+	  end;
+        '''':
+	    if InString then NewStr := ''''''
+	    else NewStr := '''''''';
+	else begin
+	  if not InString then
+	    NewInString := True;
+	  NewStr := s[i];
+	end;
+      end;
+      if NewInString <> InString then begin
+        NewStr := '''' + NewStr;
+        InString := NewInString;
+      end;
+      res := res + NewStr;
+    end;
+    if InString then res := res + '''';
+    OutStr(res);
+  end;
+
+  function ReadInt(ValueType: TValueType): LongInt;
+  begin
+    case ValueType of
+      vaInt8: Result := ShortInt(Input.ReadByte);
+      vaInt16: Result := SmallInt(Input.ReadWord);
+      vaInt32: Result := LongInt(Input.ReadDWord);
+    end;
+  end;
+
+  function ReadInt: LongInt;
+  begin
+    Result := ReadInt(TValueType(Input.ReadByte));
+  end;
+
+  function ReadSStr: String;
+  var
+    len: Byte;
+  begin
+    len := Input.ReadByte;
+    SetLength(Result, len);
+    Input.Read(Result[1], len);
+  end;
+
+  procedure ReadPropList(indent: String);
+
+    procedure ProcessValue(ValueType: TValueType; Indent: String);
+
+      procedure Stop(s: String);
+      begin
+        WriteLn(s);
+        Halt;
+      end;
+
+      procedure ProcessBinary;
+      var
+        ToDo, DoNow, i: LongInt;
+        lbuf: array[0..31] of Byte;
+        s: String;
+      begin
+        ToDo := Input.ReadDWord;
+        OutLn('{');
+        while ToDo > 0 do begin
+          DoNow := ToDo;
+          if DoNow > 32 then DoNow := 32;
+  	  Dec(ToDo, DoNow);
+ 	  s := Indent + '  ';
+	  Input.Read(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;
+      ext: Extended;
+
+    begin
+      OutStr('(' + IntToStr(Ord(Valuetype)) + ') ');
+      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(Input.ReadWord)));
+        vaInt32: OutLn(IntToStr(LongInt(Input.ReadDWord)));
+        vaExtended: begin
+            Input.Read(ext, SizeOf(ext));
+            OutLn(FloatToStr(ext));
+          end;
+        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: Stop('!!LString!!');
+        vaNil: Stop('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;
+        vaWString: begin OutLn('!!WString!!'); exit end;}
+        else
+          Stop(IntToStr(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 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 WriteString(s: String);
+  begin
+    Output.WriteByte(Length(s));
+    Output.Write(s[1], Length(s));
+  end;
+
+  procedure WriteInteger(value: LongInt);
+  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));
+      Output.WriteWord(Word(value));
+    end else begin
+      Output.WriteByte(ord(vaInt32));
+      Output.WriteDWord(LongWord(value));
+    end;
+  end;
+
+  procedure ProcessProperty; forward;
+
+  procedure ProcessValue;
+  var
+    flt: Extended;
+    s: String;
+    stream: TMemoryStream;
+  begin
+    case parser.Token of
+      toInteger: WriteInteger(parser.TokenInt);
+      toFloat: begin
+          Output.WriteByte(Ord(vaExtended));
+	  flt := Parser.TokenFloat;
+          Output.Write(flt, SizeOf(flt));
+        end;
+      toString: begin
+          s := parser.TokenString;
+	  while parser.NextToken = '+' do begin
+	    parser.NextToken;	// Get next string fragment
+	    parser.CheckToken(toString);
+	    s := s + parser.TokenString;
+	  end;
+          Output.WriteByte(Ord(vaString));
+          WriteString(s);
+        end;
+      toSymbol:
+          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.TokenString);
+          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);
+        end;
+      // List
+      '(': begin
+          parser.NextToken;
+	  Output.WriteByte(Ord(vaList));
+	  while parser.Token <> ')' do ProcessValue;
+	  Output.WriteByte(0);
+        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);
+        end;
+      // Binary data
+      '{': begin
+          Output.WriteByte(Ord(vaBinary));
+	  stream := TMemoryStream.Create;
+	  try
+	    parser.HexToBinary(stream);
+	    Output.WriteDWord(stream.Size);
+	    Output.Write(Stream.Memory^, stream.Size);
+	  finally
+	    stream.Free;
+	  end;
+        end;
+    else WriteLn('Token: "', parser.Token, '" ', Ord(parser.Token));
+    end;
+    parser.NextToken;
+  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;
+    // WriteLn(name);
+    WriteString(name);
+    parser.CheckToken('=');
+    parser.NextToken;
+    ProcessValue;
+  end;
+
+  procedure ProcessObject;
+  var
+    IsInherited: Boolean;
+    ObjectName, ObjectType: String;
+  begin
+    if parser.TokenSymbolIs('OBJECT') then
+      IsInherited := False
+    else begin
+      parser.CheckTokenSymbol('INHERITED');
+      IsInherited := True;
+    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;
+    end;
+    WriteString(ObjectType);
+    WriteString(ObjectName);
+
+    // Convert property list
+    while not (parser.TokenSymbolIs('END') or
+      parser.TokenSymbolIs('OBJECT') or
+      parser.TokenSymbolIs('INHERITED')) 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.Write(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, SizeStartPos, BinSize: 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;
+
+  // Write resource header
+  name := UpperCase(name);
+  Output.WriteByte($ff);
+  Output.WriteByte(10);
+  Output.WriteByte(0);
+  Output.Write(name[1], Length(name) + 1);	// Write null-terminated form type name
+  Output.WriteWord($1030);
+  SizeStartPos := Output.Position;
+  Output.WriteDWord(0);			// Placeholder for data size
+  ObjectTextToBinary(Input, Output);	// Convert the stuff!
+  BinSize := Output.Position - SizeStartPos - 4;
+  Output.Position := SizeStartPos;
+  Output.WriteDWord(BinSize);		// 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;
+
+
+
+
+{
+  $Log$
+  Revision 1.15  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  2000/01/04 18:07:16  michael
+  + Streaming implemented
+
+  Revision 1.1  2000/01/03 19:33:06  peter
+    * moved to packages dir
+
+  Revision 1.13  1999/10/19 11:27:03  sg
+  * Added DFM<->ASCII conversion procedures
+
+  Revision 1.12  1999/09/30 19:31:42  fcl
+  * Implemented LineStart  (sg)
+
+  Revision 1.11  1999/09/11 21:59:31  fcl
+  * Moved class and registration functions to cregist.inc  (sg)
+
+  Revision 1.10  1999/04/13 08:52:29  michael
+  + Moved strings.inc to stringl.inc, to avoid conflict with strings unit
+
+  Revision 1.9  1999/04/08 10:18:50  peter
+    * makefile updates
+
+}

fcl/inc/classesh.inc

@@ -0,0 +1,1406 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+
+{ We NEED ansistrings !!}
+{$H+}
+
+type
+   { extra types to compile with FPC }
+
+   TRTLCriticalSection = class(TObject);
+   HRSRC = longint;
+   THANDLE = longint;
+   TComponentName = string;
+   IUnKnown = class(TObject);
+   TGUID = longint;
+   HMODULE = longint;
+
+   TPoint = record
+      x,y : integer;
+   end;
+
+   TSmallPoint = record
+      x,y : smallint;
+   end;
+
+   TRect = record
+      Left,Right,Top,Bottom : Integer;
+   end;
+
+const
+
+{ Maximum TList size }
+
+  MaxListSize = Maxint div 16;
+
+{ values for TShortCut }
+
+  scShift = $2000;
+  scCtrl = $4000;
+  scAlt = $8000;
+  scNone = 0;
+
+{ TStream seek origins }
+
+  soFromBeginning = 0;
+  soFromCurrent = 1;
+  soFromEnd = 2;
+
+{ TFileStream create mode }
+
+  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);
+
+Const 
+  FilerSignature : Array[1..4] of char = 'TPF0';
+
+type
+
+{ Text alignment types }
+
+  TAlignment = (taLeftJustify, taRightJustify, taCenter);
+
+  { TLeftRight = taLeftJustify..taRightJustify; }
+
+{ Types used by standard events }
+
+  TShiftState = set of (ssShift, ssAlt, ssCtrl,
+    ssLeft, ssRight, ssMiddle, ssDouble,
+    // Extra additions
+    ssMeta, ssSuper, ssHyper, ssAltGr, ssCaps, ssNum, ssScroll);
+
+  { THelpContext = -MaxLongint..MaxLongint; }
+
+{ 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);
+  EListError = class(Exception);
+  EBitsError = class(Exception);
+  EStringListError = class(Exception);
+  EComponentError = class(Exception);
+  EParserError = class(Exception);
+  EOutOfResources = class(EOutOfMemory);
+  EInvalidOperation = class(Exception);
+
+{ Forward class declarations }
+
+  TStream = class;
+  TAbstractFiler = Class;
+  TAbstractWriter = Class;
+  TAbstractReader = Class;
+  
+  TFiler = class;
+  TReader = class;
+  TWriter = class;
+  TComponent = class;
+
+{ TList class }
+
+  PPointerList = ^TPointerList;
+  TPointerList = array[0..MaxListSize - 1] of Pointer;
+  TListSortCompare = function (Item1, Item2: Pointer): Integer;
+
+  TList = class(TObject)
+  private
+    FList: PPointerList;
+    FCount: Integer;
+    FCapacity: Integer;
+  protected
+    function Get(Index: Integer): Pointer;
+    procedure Grow; virtual;
+    procedure Put(Index: Integer; Item: Pointer);
+    procedure SetCapacity(NewCapacity: Integer);
+    procedure SetCount(NewCount: Integer);
+  public
+    destructor Destroy; override;
+    function Add(Item: Pointer): Integer;
+    procedure Clear;
+    procedure Delete(Index: Integer);
+    class procedure Error(const Msg: string; Data: Integer); virtual;
+    procedure Exchange(Index1, Index2: Integer);
+    function Expand: TList;
+    function First: Pointer;
+    function IndexOf(Item: Pointer): Integer;
+    procedure Insert(Index: Integer; Item: Pointer);
+    function Last: Pointer;
+    procedure Move(CurIndex, NewIndex: Integer);
+    function Remove(Item: Pointer): Integer;
+    procedure Pack;
+    procedure Sort(Compare: TListSortCompare);
+    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;
+
+{ TThreadList class }
+
+  TThreadList = class
+  private
+    FList: TList;
+    FLock: TRTLCriticalSection;
+  public
+    constructor Create;
+    destructor Destroy; { override; }
+    procedure Add(Item: Pointer);
+    procedure Clear;
+    function  LockList: TList;
+    procedure Remove(Item: Pointer);
+    procedure UnlockList;
+  end;
+
+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 longint;
+
+   TBits = class(TObject)
+   private
+      { Private declarations }
+      FBits : ^TBitArray;
+      FSize : longint;  { total longints 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);
+   public
+      { Public declarations }
+      constructor Create(theSize : longint); 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;
+
+{ TCollection class }
+
+  TCollection = class;
+
+  TCollectionItem = class(TPersistent)
+  private
+    FCollection: TCollection;
+    FID: Integer;
+    function GetIndex: Integer;
+    procedure SetCollection(Value: TCollection);
+  protected
+    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;
+  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;
+
+  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;
+    property PropName: string read GetPropName write FPropName;
+  public
+    constructor Create(AItemClass: TCollectionItemClass);
+    destructor Destroy; override;
+    function Add: TCollectionItem;
+    procedure Assign(Source: TPersistent); override;
+    procedure BeginUpdate;
+    procedure Clear;
+    procedure EndUpdate;
+    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;
+
+  TStrings = class;
+
+{ IStringsAdapter interface }
+{ Maintains link between TStrings and IStrings implementations }
+
+  { !!!! Interfaces aren't supported by FPC
+  IStringsAdapter = interface
+    procedure ReferenceStrings(S: TStrings);
+    procedure ReleaseStrings;
+  end;
+  }
+  IStringsAdapter = class(TObject);
+
+{ TStrings class }
+
+  TStrings = class(TPersistent)
+  private
+    FUpdateCount: Integer;
+    FAdapter: IStringsAdapter;
+    function GetCommaText: string;
+    function GetName(Index: Integer): string;
+    function GetValue(const Name: string): string;
+    procedure ReadData(Reader: TReader);
+    procedure SetCommaText(const Value: string);
+    procedure SetStringsAdapter(const Value: IStringsAdapter);
+    procedure SetValue(const Name, Value: string);
+    procedure WriteData(Writer: TWriter);
+  protected
+    procedure DefineProperties(Filer: TFiler); override;
+    procedure Error(const Msg: string; 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;
+  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;
+    function IndexOfObject(AObject: TObject): Integer;
+    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;
+    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 }
+
+  TDuplicates = (dupIgnore, dupAccept, dupError);
+
+  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;
+    FSorted: Boolean;
+    FDuplicates: TDuplicates;
+    FOnChange: TNotifyEvent;
+    FOnChanging: TNotifyEvent;
+    procedure ExchangeItems(Index1, Index2: Integer);
+    procedure Grow;
+    procedure QuickSort(L, R: Integer);
+    procedure InsertItem(Index: Integer; const S: string);
+    procedure SetSorted(Value: 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;
+  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;
+    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
+    property Sorted: Boolean read FSorted write SetSorted;
+    property OnChange: TNotifyEvent read FOnChange write FOnChange;
+    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
+  end;
+
+{ TStream abstract class }
+
+  TStream = class(TObject)
+  private
+    function GetPosition: Longint;
+    procedure SetPosition(Pos: Longint);
+    function GetSize: Longint;
+  protected
+    procedure SetSize(NewSize: Longint); virtual;
+  public
+    function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
+    function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
+    function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
+    procedure ReadBuffer(var Buffer; Count: Longint);
+    procedure WriteBuffer(const Buffer; Count: Longint);
+    function CopyFrom(Source: TStream; Count: Longint): Longint;
+    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 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 (S : String);
+    property Position: Longint read GetPosition write SetPosition;
+    property Size: Longint read GetSize write SetSize;
+  end;
+
+{ THandleStream class }
+
+  THandleStream = class(TStream)
+  private
+    FHandle: Integer;
+  public
+    constructor Create(AHandle: Integer);
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+    property Handle: Integer read FHandle;
+  end;
+
+{ TFileStream class }
+
+  TFileStream = class(THandleStream)
+  Private
+    FFileName : String;
+  protected
+    procedure SetSize(NewSize: Longint); override;
+  public
+    constructor Create(const AFileName: string; Mode: Word);
+    destructor Destroy; override;
+    function Seek(Offset: Longint; Origin: Word): Longint; 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 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 }
+
+  TResourceStream = class(TCustomMemoryStream)
+  private
+    HResInfo: HRSRC;
+    HGlobal: 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;
+    function Write(const Buffer; Count: Longint): Longint; override;
+  end;
+
+{ TStreamAdapter }
+{ Implements OLE IStream on VCL TStream }
+{ we don't need that yet
+  TStreamAdapter = class(TInterfacedObject, IStream)
+  private
+    FStream: TStream;
+  public
+    constructor Create(Stream: TStream);
+    function Read(pv: Pointer; cb: Longint;
+      pcbRead: PLongint): HResult; stdcall;
+    function Write(pv: Pointer; cb: Longint;
+      pcbWritten: PLongint): HResult; stdcall;
+    function Seek(dlibMove: Largeint; dwOrigin: Longint;
+      out libNewPosition: Largeint): HResult; stdcall;
+    function SetSize(libNewSize: Largeint): HResult; stdcall;
+    function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
+      out cbWritten: Largeint): HResult; stdcall;
+    function Commit(grfCommitFlags: Longint): HResult; stdcall;
+    function Revert: HResult; stdcall;
+    function LockRegion(libOffset: Largeint; cb: Largeint;
+      dwLockType: Longint): HResult; stdcall;
+    function UnlockRegion(libOffset: Largeint; cb: Largeint;
+      dwLockType: Longint): HResult; stdcall;
+    function Stat(out statstg: TStatStg;
+      grfStatFlag: Longint): HResult; stdcall;
+    function Clone(out stm: IStream): HResult; stdcall;
+  end;
+}
+{ TFiler }
+
+  TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
+    vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
+    vaNil, vaCollection);
+
+  TFilerFlag = (ffInherited, ffChildPos);
+  TFilerFlags = set of TFilerFlag;
+
+(*
+  TReaderProc = procedure(Reader: TReader) of object;
+  TWriterProc = procedure(Writer: TWriter) of object;
+  TStreamProc = procedure(Stream: TStream) of object;
+*)
+
+  TReaderProc = procedure(Reader: TAbstractReader) of object;
+  TWriterProc = procedure(Writer: TAbstractWriter) of object;
+  TStreamProc = procedure(Stream: TStream) of object;
+
+  TAbstractFiler = class(TObject)
+  private
+    FRoot: TComponent;
+    FAncestor: TPersistent;
+     FIgnoreChildren: Boolean;
+     FPrefix : String;
+   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 FRoot;
+    property Ancestor: TPersistent read FAncestor write FAncestor;
+    property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren;
+  end;
+
+{ TReader }
+
+  TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
+    var Address: Pointer; var Error: 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;
+
+
+  TAbstractReader = class(TAbstractFiler);
+(*  private
+  protected
+    function Error(const Message: string): Boolean; virtual;
+    function FindMethod(ARoot: TComponent; const AMethodName: string): Pointer; virtual;
+    procedure SetName(Component: TComponent; var Name: string); virtual;
+    procedure ReferenceName(var Name: string); virtual;
+    function FindAncestorComponent(const Name: string;
+                                   ComponentClass: TPersistentClass): TComponent; virtual;
+  public
+    destructor Destroy; override;
+    procedure BeginReferences;
+    procedure DefineProperty(const Name: string;
+      rd : TReaderProc; wd : TWriterProc;
+      HasData: Boolean); override;
+    procedure DefineBinaryProperty(const Name: string;
+      rd, wd: TStreamProc;
+      HasData: Boolean); override;
+    function EndOfList: Boolean;
+    procedure EndReferences;
+    procedure FixupReferences;
+    procedure FlushBuffer; override;
+    function NextValue: TValueType;
+    procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
+    procedure ReadCollection(Collection: TCollection);
+    function ReadComponent(Component: TComponent): TComponent;
+    procedure ReadComponents(AOwner, AParent: TComponent;
+      Proc: TReadComponentsProc);
+    function ReadRootComponent(ARoot: TComponent): TComponent;
+    { Abstract methods }
+    procedure ReadSignature;
+    function ReadBoolean: Boolean; abstract;
+    function ReadChar: Char; abstract;
+    function ReadFloat: Extended;
+    function ReadIdent: string;
+    function ReadInteger: Longint;
+    procedure ReadListBegin;
+    procedure ReadListEnd;
+    function ReadStr: string;
+    function ReadString: string;
+    function ReadValue: TValueType;
+    procedure CopyValue(Writer: TWriter); 
+    {!!!}
+    property Owner: TComponent read FOwner write FOwner;
+    property Parent: TComponent read FParent write FParent;
+    property Position: Longint read GetPosition write SetPosition;
+    property OnError: TReaderError read FOnError write FOnError;
+    property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod;
+    property OnSetName: TSetNameEvent read FOnSetName write FOnSetName;
+    property OnReferenceName: TReferenceNameEvent read FOnReferenceName write FOnReferenceName;
+    property OnAncestorNotFound: TAncestorNotFoundEvent read FOnAncestorNotFound write FOnAncestorNotFound;
+  end;
+*)
+
+{ TAbstractWriter }
+
+  TAbstractWriter = class(TAbstractFiler)
+  private
+    FRootAncestor: TComponent;
+    FPropPath: string;
+    FAncestorList: TList;
+    FAncestorPos: Integer;
+    FChildPos: Integer;
+    procedure AddAncestor(Component: TComponent);
+    procedure WriteData(Instance: TComponent); // linker optimization
+    procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
+    procedure WriteProperties(Instance: TPersistent);
+    Procedure DoOrdinalProp(Instance : TPersistent;Propinfo :PPropInfo);
+    Procedure DoStringProp(Instance : TPersistent;Propinfo :PPropInfo);
+    Procedure DoFloatProp(Instance : TPersistent;Propinfo :PPropInfo);
+    Procedure DoCollectionProp(Name: ShortString; Value : TCollection);
+    Procedure DoClassProp(Instance : TPersistent;Propinfo :PPropInfo);
+    Procedure DoMethodProp(Instance : TPersistent;Propinfo :PPropInfo);
+  protected
+    procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer);Virtual;Abstract;
+    Procedure StartObject(Const AClassName,AName : String);Virtual;abstract;
+    Procedure EndObject;Virtual;Abstract;
+    Procedure StartCollection(Const Name : String);Virtual;abstract;
+    Procedure EndCollection;Virtual;Abstract;
+    Procedure StartCollectionItem;Virtual;abstract;
+    Procedure EndCollectionItem;Virtual;Abstract;
+  public
+    destructor Destroy; override;
+    procedure DefineProperty(const Name: string;
+      rd : TReaderProc; wd : TWriterProc;
+      HasData: Boolean); override;
+    procedure DefineBinaryProperty(const Name: string;
+      rd, wd: TStreamProc;
+      HasData: Boolean); override;
+    procedure WriteDescendent(ARoot: TComponent; AAncestor: TComponent);
+    procedure WriteRootComponent(ARoot: TComponent);
+    procedure WriteComponent(Component: TComponent);virtual;
+    { Abstract }
+    Procedure WriteIntegerProperty(Const Name : Shortstring;Value : Longint);virtual;abstract;
+    Procedure WriteSetProperty (Const Name : ShortString;Value : longint; BaseType : TTypeInfo);virtual;abstract;
+    Procedure WriteEnumerationProperty (Const Name : ShortString;Value : Longint; Const EnumName : ShortSTring);virtual;abstract;
+    Procedure WriteStringProperty(Const Name : ShortString; Const Value : String);virtual;abstract;
+    Procedure WriteFloatProperty(Const Name : ShortString; Value : Extended);virtual;abstract;
+    Procedure WriteCollectionProperty(Const Name : ShortString;Value : TCollection);virtual;abstract;
+    Procedure WriteClassProperty(Instance : TPersistent;Propinfo :PPropInfo);virtual;abstract;
+    Procedure WriteComponentProperty(Const Name : ShortString;Value : TComponent);virtual;abstract;
+    Procedure WriteNilProperty(Const Name : Shortstring);virtual; abstract;
+    Procedure WriteMethodProperty(Const Name,AMethodName : ShortString);virtual;abstract;
+    Procedure WriteBinaryProperty(Const Name; Value : TStream);Virtual;Abstract;
+(*
+    { Abstract compatibility methods}
+    Procedure WriteValue(Value : TValueType);virtual;abstract;
+    procedure Write(const Buf; Count: Longint);virtual;abstract;
+    procedure WriteBoolean(Value: Boolean);virtual;abstract;
+    procedure WriteCollection(Value: TCollection);virtual;abstract;
+    procedure WriteComponent(Component: TComponent);virtual;abstract;
+    procedure WriteChar(Value: Char);virtual;abstract;
+    procedure WriteFloat(Value: Extended);virtual;abstract;
+    procedure WriteIdent(const Ident: string);virtual;abstract;
+    procedure WriteInteger(Value: Longint);virtual;abstract;
+    procedure WriteListBegin;virtual;abstract;
+    procedure WriteListEnd;virtual;abstract;
+    procedure WriteSignature;virtual;abstract;
+    procedure WriteStr(const Value: string);virtual;abstract;
+    procedure WriteString(const Value: string);virtual;abstract;
+*)
+    property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
+  end;
+
+  TWriter = class(TAbstractWriter)
+  Private 
+    FStream : TStream;
+    function GetPosition: Longint;
+    procedure SetPosition(Value: Longint);
+    procedure WritePropName(const PropName: string);
+  protected
+    procedure WriteBinary(wd : TStreamProc);
+  public
+    Constructor Create(S : TStream);
+    destructor Destroy; override;
+    { Compatibility }
+    procedure WriteBuffer;
+    Procedure FlushBuffer;
+    { Abstract }
+    Procedure WriteIntegerProperty(Const Name : Shortstring;Value : Longint);override;
+    Procedure WriteSetProperty (Const Name : ShortString;Value : longint; BaseType : TTypeInfo);override;
+    Procedure WriteEnumerationProperty (Const Name : ShortString;Value : Longint; Const EnumName : ShortSTring);override;
+    Procedure WriteStringProperty(Const Name : ShortString; Const Value : String);override;
+    Procedure WriteFloatProperty(Const Name : ShortString; Value : Extended);override;
+    Procedure WriteCollectionProperty(Const Name : ShortString;Value : TCollection);override;
+    Procedure WriteClassProperty(Instance : TPersistent;Propinfo :PPropInfo);override;
+    Procedure WriteComponentProperty(Const Name : ShortSTring; Value : TComponent);override;
+    Procedure WriteNilProperty(Const Name : Shortstring);override;
+    Procedure WriteMethodProperty(Const Name,AMethodName : ShortString);override;
+    { Abstract compatibility methods}
+    procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer); virtual;
+    Procedure WriteValue(Value : TValueType);virtual;
+    procedure Write(const Buf; Count: Longint);virtual;
+    procedure WriteBoolean(Value: Boolean);virtual;
+    procedure WriteCollection(Value: TCollection);virtual;
+    procedure WriteChar(Value: Char);virtual;
+    procedure WriteFloat(Value: Extended);virtual;
+    procedure WriteIdent(const Ident: string);virtual;
+    procedure WriteInteger(Value: Longint);virtual;
+    procedure WriteListBegin;virtual;
+    procedure WriteListEnd;virtual;
+    procedure WriteSignature;virtual;
+    procedure WriteStr(const Value: string);virtual;
+    procedure WriteString(const Value: string);virtual;
+    procedure DefineProperty(const Name: string;
+      rd : TReaderProc; wd : TWriterProc;
+      HasData: Boolean); override;
+    procedure DefineBinaryProperty(const Name: string;
+      rd, wd: TStreamProc;
+      HasData: Boolean); override;
+    property Position: Longint read GetPosition write SetPosition;
+  end;
+
+  TTextWriter = class(TAbstractWriter)
+  Private 
+    FStream : TStream;
+    Procedure Write(Const Msg : String);
+    Procedure WriteLn(Const Msg : String);
+    Procedure WriteFmt(Fmt : String; Args :  Array of const);
+    procedure WritePropName(const PropName: string);
+  protected
+   Procedure StartCollection(Const AName : String);
+   Procedure StartCollectionItem;
+   Procedure EndCollectionItem;  
+   Procedure EndCollection;
+  public
+    Constructor Create(S : TStream);
+    destructor Destroy; override;
+    { Abstract }
+    Procedure StartObject(Const AClassName,AName : String);override;
+    Procedure EndObject;Virtual;override;
+    Procedure WriteIntegerProperty(Const Name : Shortstring;Value : Longint);override;
+    Procedure WriteSetProperty (Const Name : ShortString;Value : longint; BaseType : TTypeInfo);override;
+    Procedure WriteEnumerationProperty (Const Name : ShortString;Value : Longint; Const EnumName : ShortSTring);override;
+    Procedure WriteStringProperty(Const Name : ShortString; Const Value : String);override;
+    Procedure WriteFloatProperty(Const Name : ShortString; Value : Extended);override;
+    Procedure WriteCollectionProperty(Const Name : ShortString;Value : TCollection);override;
+    Procedure WriteClassProperty(Instance : TPersistent;Propinfo :PPropInfo);override;
+    Procedure WriteComponentProperty(Const Name : ShortSTring; Value : TComponent);override;
+    Procedure WriteNilProperty(Const Name : Shortstring);override;
+    Procedure WriteMethodProperty(Const Name,AMethodName : ShortString);override;
+  end;
+
+  TFiler = Class(TAbstractFiler);
+  TReader = Class(TWriter);
+
+(*
+  TFiler = class(TObject)
+  private
+    FStream: TStream;
+    FBuffer: Pointer;
+    FBufSize: Integer;
+    FBufPos: Integer;
+    FBufEnd: Integer;
+    FRoot: TComponent;
+    FAncestor: TPersistent;
+    FIgnoreChildren: Boolean;
+  public
+    constructor Create(Stream: TStream; BufSize: Integer);
+    destructor Destroy; override;
+    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;
+    procedure FlushBuffer; virtual; abstract;
+    property Root: TComponent read FRoot write FRoot;
+    property Ancestor: TPersistent read FAncestor write FAncestor;
+    property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren;
+  end;
+
+{ TReader }
+
+  TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
+    var Address: Pointer; var Error: 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;
+
+  TReader = class(TFiler)
+  private
+    FOwner: TComponent;
+    FParent: TComponent;
+    FFixups: TList;
+    FLoaded: TList;
+    FOnFindMethod: TFindMethodEvent;
+    FOnSetName: TSetNameEvent;
+    FOnReferenceName: TReferenceNameEvent;
+    FOnAncestorNotFound: TAncestorNotFoundEvent;
+    FOnError: TReaderError;
+    FCanHandleExcepts: Boolean;
+    FPropName: string;
+    procedure CheckValue(Value: TValueType);
+    procedure DoFixupReferences;
+    procedure FreeFixups;
+    function GetPosition: Longint;
+    procedure PropertyError;
+    procedure ReadBuffer;
+    procedure ReadData(Instance: TComponent);
+    procedure ReadDataInner(Instance: TComponent);
+    procedure ReadProperty(AInstance: TPersistent);
+    procedure ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
+    function ReadSet(SetType: Pointer): Integer;
+    procedure SetPosition(Value: Longint);
+    procedure SkipSetBody;
+    procedure SkipValue;
+    procedure SkipProperty;
+    procedure SkipComponent(SkipHeader: Boolean);
+  protected
+    function Error(const Message: string): Boolean; virtual;
+    function FindMethod(ARoot: TComponent; const AMethodName: string): Pointer; virtual;
+    procedure SetName(Component: TComponent; var Name: string); virtual;
+    procedure ReferenceName(var Name: string); virtual;
+    function FindAncestorComponent(const Name: string;
+      ComponentClass: TPersistentClass): TComponent; virtual;
+  public
+    destructor Destroy; override;
+    procedure BeginReferences;
+    procedure DefineProperty(const Name: string;
+      rd : TReaderProc; wd : TWriterProc;
+      HasData: Boolean); override;
+    procedure DefineBinaryProperty(const Name: string;
+      rd, wd: TStreamProc;
+      HasData: Boolean); override;
+    function EndOfList: Boolean;
+    procedure EndReferences;
+    procedure FixupReferences;
+    procedure FlushBuffer; override;
+    function NextValue: TValueType;
+    procedure Read(var Buf; Count: Longint);
+    function ReadBoolean: Boolean;
+    function ReadChar: Char;
+    procedure ReadCollection(Collection: TCollection);
+    function ReadComponent(Component: TComponent): TComponent;
+    procedure ReadComponents(AOwner, AParent: TComponent;
+      Proc: TReadComponentsProc);
+    function ReadFloat: Extended;
+    function ReadIdent: string;
+    function ReadInteger: Longint;
+    procedure ReadListBegin;
+    procedure ReadListEnd;
+    procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
+    function ReadRootComponent(ARoot: TComponent): TComponent;
+    procedure ReadSignature;
+    function ReadStr: string;
+    function ReadString: string;
+    function ReadValue: TValueType;
+    procedure CopyValue(Writer: TWriter); {!!!}
+    property Owner: TComponent read FOwner write FOwner;
+    property Parent: TComponent read FParent write FParent;
+    property Position: Longint read GetPosition write SetPosition;
+    property OnError: TReaderError read FOnError write FOnError;
+    property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod;
+    property OnSetName: TSetNameEvent read FOnSetName write FOnSetName;
+    property OnReferenceName: TReferenceNameEvent read FOnReferenceName write FOnReferenceName;
+    property OnAncestorNotFound: TAncestorNotFoundEvent read FOnAncestorNotFound write FOnAncestorNotFound;
+  end;
+
+{ TWriter }
+
+  TWriter = class(TFiler)
+  private
+    FRootAncestor: TComponent;
+    FPropPath: string;
+    FAncestorList: TList;
+    FAncestorPos: Integer;
+    FChildPos: Integer;
+    procedure AddAncestor(Component: TComponent);
+    function GetPosition: Longint;
+    procedure SetPosition(Value: Longint);
+    procedure WriteBuffer;
+    procedure WriteData(Instance: TComponent); 
+    procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
+    procedure WriteProperties(Instance: TPersistent);
+    procedure WritePropName(const PropName: string);
+  protected
+    procedure WriteBinary(wd : TStreamProc);
+    procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
+    procedure WriteValue(Value: TValueType);
+  public
+    destructor Destroy; override;
+    procedure DefineProperty(const Name: string;
+      rd : TReaderProc; wd : TWriterProc;
+      HasData: Boolean); override;
+    procedure DefineBinaryProperty(const Name: string;
+      rd, wd: TStreamProc;
+      HasData: Boolean); override;
+    procedure FlushBuffer; override;
+    procedure Write(const Buf; Count: Longint);
+    procedure WriteBoolean(Value: Boolean);
+    procedure WriteCollection(Value: TCollection);
+    procedure WriteComponent(Component: TComponent);
+    procedure WriteChar(Value: Char);
+    procedure WriteDescendent(ARoot: TComponent; AAncestor: TComponent);
+    procedure WriteFloat(Value: Extended);
+    procedure WriteIdent(const Ident: string);
+    procedure WriteInteger(Value: Longint);
+    procedure WriteListBegin;
+    procedure WriteListEnd;
+    procedure WriteRootComponent(ARoot: TComponent);
+    procedure WriteSignature;
+    procedure WriteStr(const Value: string);
+    procedure WriteString(const Value: string);
+    property Position: Longint read GetPosition write SetPosition;
+    property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
+  end;
+*)
+
+{ TParser }
+
+  TParser = class(TObject)
+  private
+    FStream: TStream;
+    FOrigin: Longint;
+    FBuffer: PChar;
+    FBufPtr: PChar;
+    FBufEnd: PChar;
+    FSourcePtr: PChar;
+    FSourceEnd: PChar;
+    FTokenPtr: PChar;
+    FStringPtr: PChar;
+    FSourceLine: Integer;
+    FSaveChar: Char;
+    FToken: Char;
+    procedure ReadBuffer;
+    procedure SkipBlanks;
+  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;
+    function TokenFloat: Extended;
+    function TokenInt: Longint;
+    function TokenString: string;
+    function TokenSymbolIs(const S: string): Boolean;
+    property SourceLine: Integer read FSourceLine;
+    property Token: Char read FToken;
+  end;
+
+{ TThread }
+
+  EThread = class(Exception);
+
+  TThreadMethod = procedure of object;
+  TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
+    tpTimeCritical);
+
+  TThread = class
+  private
+    FHandle: THandle;
+    FThreadID: THandle;
+    FTerminated: Boolean;
+    FSuspended: Boolean;
+    FFreeOnTerminate: Boolean;
+    FFinished: Boolean;
+    FReturnValue: Integer;
+    FOnTerminate: TNotifyEvent;
+    FMethod: TThreadMethod;
+    FSynchronizeException: TObject;
+    procedure CallOnTerminate;
+    function GetPriority: TThreadPriority;
+    procedure SetPriority(Value: TThreadPriority);
+    procedure SetSuspended(Value: Boolean);
+  protected
+    procedure DoTerminate; virtual;
+    procedure Execute; virtual; abstract;
+    procedure Synchronize(Method: TThreadMethod);
+    property ReturnValue: Integer read FReturnValue write FReturnValue;
+    property Terminated: Boolean read FTerminated;
+  public
+{$ifdef linux}
+    { Needed for linux }
+    FStackPointer : integer;
+    FStackSize    : integer;
+    FCallExitProcess : boolean;
+{$endif}
+    constructor Create(CreateSuspended: Boolean);
+    destructor Destroy; { override; }
+    procedure Resume;
+    procedure Suspend;
+    procedure Terminate;
+    function WaitFor: Integer;
+    property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
+    property Handle: THandle read FHandle;
+    property Priority: TThreadPriority read GetPriority write SetPriority;
+    property Suspended: Boolean read FSuspended write SetSuspended;
+    property ThreadID: THandle read FThreadID;
+    property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
+  end;
+
+{ TComponent class }
+
+  TOperation = (opInsert, opRemove);
+  TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
+    csDesigning, csAncestor, csUpdating, csFixups);
+  TComponentStyle = set of (csInheritable, csCheckPropAvail);
+  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;
+  }
+
+  TComponent = class(TPersistent)
+  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 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 Notification(AComponent: TComponent;
+      Operation: TOperation); virtual;
+    procedure ReadState(Reader: TAbstractReader); 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): Integer; stdcall;
+    //!!!! function _AddRef: Integer; stdcall;
+    //!!!! function _Release: Integer; stdcall;
+    { 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
+    procedure WriteState(Writer: TAbstractWriter); virtual;
+    constructor Create(AOwner: TComponent); virtual;
+    destructor Destroy; override;
+    procedure DestroyComponents;
+    procedure Destroying;
+    function FindComponent(const AName: string): TComponent;
+    procedure FreeNotification(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;
+    // property ComObject: IUnknown read GetComObject;
+    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;
+
+{ TComponent class reference type }
+
+  TComponentClass = class of TComponent;
+
+{ Component registration handlers }
+
+  TActiveXRegType = (axrComponentOnly, axrIncludeDescendants);
+
+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;
+
+{ 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 ClassName: string): TPersistentClass;
+function GetClass(const ClassName: string): 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);
+
+
+{ 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;
+
+var
+  MainThreadID: THandle;
+  FindGlobalComponent: TFindGlobalComponent;
+
+procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
+  IntToIdent: 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 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 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);
+
+procedure BeginGlobalLoading;
+procedure NotifyGlobalLoading;
+procedure EndGlobalLoading;
+
+function CollectionsEqual(C1, C2: TCollection): 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;
+
+{
+  $Log$
+  Revision 1.20  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.3  2000/01/05 11:05:29  michael
+  + Better collection support
+
+  Revision 1.2  2000/01/04 18:07:16  michael
+  + Streaming implemented
+
+  Revision 1.1  2000/01/03 19:33:07  peter
+    * moved to packages dir
+
+  Revision 1.18  1999/11/30 15:28:38  michael
+  + Added FileNAme property for filestreams
+
+  Revision 1.17  1999/10/20 20:24:21  florian
+    + sc* constants added as suggested by Shane Miller
+
+  Revision 1.16  1999/09/13 08:35:16  fcl
+  * Changed some argument names (Root->ARoot etc.) because the new compiler
+    now performs more ambiguity checks  (sg)
+
+  Revision 1.15  1999/09/11 22:01:03  fcl
+  * Activated component registration callbacks  (sg)
+
+  Revision 1.14  1999/08/26 21:11:25  peter
+    * ShiftState extended
+
+  Revision 1.13  1999/05/31 12:43:10  peter
+    * fixed tthread for linux additions
+
+  Revision 1.12  1999/05/14 17:52:53  peter
+    * removed wrong destroy overrides (gave errors with the new compiler)
+
+  Revision 1.11  1999/04/09 12:13:30  michael
+  + Changed TBits to TbitsPlus from Michael A. Hess (renamed to Tbits)
+
+  Revision 1.10  1998/10/30 14:52:49  michael
+  + Added format in interface
+  + Some errors in parser fixed, it uses exceptions now
+  + Strings now has no more syntax errors.
+
+  Revision 1.9  1998/10/24 13:45:35  michael
+  + Implemented stringlist. Untested, since classes broken.
+
+  Revision 1.8  1998/09/23 07:47:41  michael
+  + Some changes by TSE
+
+  Revision 1.7  1998/08/22 10:41:00  michael
+  + Some adaptations for changed comment and published handling
+
+  Revision 1.6  1998/06/11 13:46:32  michael
+  + Fixed some functions. TFileStream OK.
+
+  Revision 1.5  1998/06/10 21:53:06  michael
+  + Implemented Handle/FileStreams
+
+  Revision 1.4  1998/05/27 11:41:43  michael
+  Implemented TCollection and TCollectionItem
+
+  Revision 1.3  1998/05/06 12:58:35  michael
+  + Added WriteAnsiString method to TStream
+
+  Revision 1.2  1998/05/04 14:30:11  michael
+  * Split file according to Class; implemented dummys for all methods, so unit compiles.
+
+  Revision 1.1  1998/05/04 12:16:01  florian
+    + Initial revisions after making a new directory structure
+
+}

fcl/inc/collect.inc

@@ -0,0 +1,368 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.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);
+  Changed;
+end;
+
+
+
+procedure TCollection.RemoveItem(Item: TCollectionItem);
+
+begin
+  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 OwnerName,ThePropName : String;
+
+begin
+  Result:=ClassName;
+  If GetOwner=Nil then Exit;
+  OwnerName:=GetOwner.GetNamePath;
+  If OwnerName='' then Exit;
+  ThePropName:=PropName;
+  if ThePropName='' then exit;
+  Result:=OwnerName+'.'+PropName;
+end;
+
+
+
+procedure TCollection.Changed;
+
+begin
+  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
+end;
+
+
+
+procedure TCollection.Clear;
+
+begin
+  If Assigned(FItems) then
+    While FItems.Count>0 do TCollectionItem(FItems.Last).Free;
+end;
+
+
+
+procedure TCollection.EndUpdate;
+
+begin
+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;
+
+{
+  $Log$
+  Revision 1.8  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:07  peter
+    * moved to packages dir
+
+  Revision 1.6  1999/04/17 08:04:55  michael
+  + RemoveItem now sets FCollection, to avoid a loop.
+
+  Revision 1.5  1999/04/13 12:46:15  michael
+  + Some bug fixes by Romio
+
+  Revision 1.4  1999/04/05 09:56:04  michael
+  + Fixed bugs reported by Romio in TCollection
+
+  Revision 1.3  1998/10/02 22:41:23  michael
+  + Added exceptions for error handling
+
+  Revision 1.2  1998/05/27 11:41:41  michael
+  Implemented TCollection and TCollectionItem
+
+  Revision 1.1  1998/05/04 14:30:11  michael
+  * Split file according to Class; implemented dummys for all methods, so unit compiles.
+
+}

fcl/inc/compon.inc

@@ -0,0 +1,499 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+
+{****************************************************************************}
+{*                             TComponent                                   *}
+{****************************************************************************}
+
+Type
+  Longrec = Record
+    Hi,lo : word;
+    end;
+
+Function  TComponent.GetComponent(AIndex: Integer): TComponent;
+
+begin
+  If not assigned(FComponents) then
+    Result:=Nil
+  else
+    Result:=TComponent(FComponents.Items[Aindex]);
+end;
+
+
+Function  TComponent.GetComponentCount: Integer;
+
+begin
+  If not assigned(FComponents) then
+    result:=0
+  else
+    Result:=FComponents.Count;
+end;
+
+
+Function  TComponent.GetComponentIndex: Integer;
+
+begin
+  If Assigned(FOwner) and Assigned(FOwner.FComponents) then
+    Result:=FOWner.FComponents.IndexOf(Self)
+  else
+    Result:=-1;
+end;
+
+
+Procedure TComponent.Insert(AComponent: TComponent);
+
+begin
+  If not assigned(FComponents) then
+    FComponents:=TList.Create;
+  FComponents.Add(AComponent);
+  AComponent.FOwner:=Self;
+end;
+
+
+Procedure TComponent.ReadLeft(Reader: TReader);
+
+begin
+//  LongRec(FDesignInfo).Lo:=Reader.ReadInteger;
+end;
+
+
+Procedure TComponent.ReadTop(Reader: TReader);
+
+begin
+//  LongRec(FDesignInfo).Hi:=Reader.ReadInteger;
+end;
+
+
+Procedure TComponent.Remove(AComponent: TComponent);
+
+begin
+  AComponent.FOwner:=Nil;
+  If assigned(FCOmponents) then
+    begin
+    FComponents.Remove(AComponent);
+    IF FComponents.Count=0 then
+      begin
+      FComponents.Free;
+      FComponents:=Nil;
+      end;
+    end;
+end;
+
+
+Procedure TComponent.SetComponentIndex(Value: Integer);
+
+Var Temp,Count : longint;
+
+begin
+  If Not assigned(Fowner) then exit;
+  Temp:=getcomponentindex;
+  If temp<0 then exit;
+  If value<0 then value:=0;
+  Count:=Fowner.FComponents.Count;
+  If Value>=Count then value:=count-1;
+  If Value<>Temp then
+    begin
+    FOWner.FComponents.Delete(Temp);
+    FOwner.FComponents.Insert(Value,Self);
+    end;
+end;
+
+
+Procedure TComponent.SetReference(Enable: Boolean);
+
+begin
+  // For delphi compatibility only.
+end;
+
+
+Procedure TComponent.WriteLeft(Writer: TWriter);
+
+begin
+  Writer.WriteInteger(LongRec(FDesignInfo).Lo);
+end;
+
+
+Procedure TComponent.WriteTop(Writer: TWriter);
+
+begin
+  Writer.WriteInteger(LongRec(FDesignInfo).Hi);
+end;
+
+
+Procedure TComponent.ChangeName(const NewName: TComponentName);
+
+begin
+  FName:=NewName;
+end;
+
+
+Procedure TComponent.DefineProperties(Filer: TFiler);
+
+Var Ancestor : TComponent;
+    Temp : longint;
+
+begin
+  Temp:=0;
+  Ancestor:=TComponent(Filer.Ancestor);
+  If Assigned(Ancestor) then Temp:=Ancestor.FDesignInfo;
+{
+  Filer.Defineproperty('left',readleft,writeleft,
+                       (longrec(FDesignInfo).Lo<>Longrec(temp).Lo));
+  Filer.Defineproperty('top',readtop,writetop,
+                       (longrec(FDesignInfo).Hi<>Longrec(temp).Hi));
+}
+end;
+
+
+Procedure TComponent.GetChildren(Proc: TGetChildProc; Root: TComponent);
+
+begin
+  // Does nothing.
+end;
+
+
+Function  TComponent.GetChildOwner: TComponent;
+
+begin
+ Result:=Nil;
+end;
+
+
+Function  TComponent.GetChildParent: TComponent;
+
+begin
+  Result:=Self;
+end;
+
+
+Function  TComponent.GetNamePath: string;
+
+begin
+  Result:=FName;
+end;
+
+
+Function  TComponent.GetOwner: TPersistent;
+
+begin
+  Result:=FOwner;
+end;
+
+
+Procedure TComponent.Loaded;
+
+begin
+  Exclude(FComponentState,csLoading);
+end;
+
+
+Procedure TComponent.Notification(AComponent: TComponent;
+  Operation: TOperation);
+
+Var Runner : Longint;
+
+begin
+  If (Operation=opRemove) and Assigned(FFreeNotifies) then
+    begin
+    FFreeNotifies.Remove(AComponent);
+    If FFreeNotifies.Count=0 then
+      begin
+      FFreeNotifies.Free;
+      FFreenotifies:=Nil;
+      end;
+    end;
+  If assigned(FComponents) then
+    For Runner:=0 To FComponents.Count-1 do
+      TComponent(FComponents.Items[Runner]).Notification(AComponent,Operation);
+end;
+
+
+Procedure TComponent.ReadState(Reader: TAbstractReader);
+
+begin
+//!!  Reader.ReadData(Self);
+end;
+
+
+Procedure TComponent.SetAncestor(Value: Boolean);
+
+Var Runner : Longint;
+
+begin
+  If Value then
+    Include(FComponentState,csAncestor)
+  else
+    Include(FCOmponentState,csAncestor);
+  if Assigned(FComponents) then
+    For Runner:=0 To FComponents.Count do
+      TComponent(FComponents.Items[Runner]).SetAncestor(Value);
+end;
+
+
+Procedure TComponent.SetDesigning(Value: Boolean);
+
+Var Runner : Longint;
+
+begin
+  If Value then
+    Include(FComponentSTate,csDesigning)
+  else
+    Exclude(FComponentSTate,csDesigning);
+  if Assigned(FComponents) then
+    For Runner:=0 To FComponents.Count do
+      TComponent(FComponents.items[Runner]).SetDesigning(Value);
+end;
+
+
+Procedure TComponent.SetName(const NewName: TComponentName);
+
+begin
+  If FName=NewName then exit;
+  If not IsValidIdent(NewName) then
+    Raise EComponentError.CreateFmt(SInvalidName,[NewName]);
+  If Assigned(FOwner) Then
+    FOwner.ValidateRename(Self,FName,NewName)
+  else
+    ValidateRename(Nil,FName,NewName);
+  SetReference(False);
+  ChangeName(NewName);
+  Setreference(True);
+end;
+
+
+Procedure TComponent.SetChildOrder(Child: TComponent; Order: Integer);
+
+begin
+  // does nothing
+end;
+
+
+Procedure TComponent.SetParentComponent(Value: TComponent);
+
+begin
+  // Does nothing
+end;
+
+
+Procedure TComponent.Updating;
+
+begin
+  Include (FComponentState,csUpdating);
+end;
+
+
+Procedure TComponent.Updated;
+
+begin
+  Exclude(FComponentState,csUpdating);
+end;
+
+
+class Procedure TComponent.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
+
+begin
+  // For compatibility only.
+end;
+
+
+Procedure TComponent.ValidateRename(AComponent: TComponent;
+  const CurName, NewName: string);
+
+begin
+//!! This contradicts the Delphi manual.
+  If (AComponent<>Nil) and (CurName<>NewName) and
+     (FindComponent(NewName)<>Nil) then
+      raise EComponentError.Createfmt(SDuplicateName,[newname]);
+  If (csDesigning in FComponentState) and (FOwner<>Nil) then
+    FOwner.ValidateRename(AComponent,Curname,Newname);
+end;
+
+
+Procedure TComponent.ValidateContainer(AComponent: TComponent);
+
+begin
+end;
+
+
+Procedure TComponent.ValidateInsert(AComponent: TComponent);
+
+begin
+  // Does nothing.
+end;
+
+
+Procedure TComponent.WriteState(Writer: TAbstractWriter);
+
+begin
+  Writer.WriteData(self);
+end;
+
+
+Constructor TComponent.Create(AOwner: TComponent);
+
+begin
+  FComponentStyle:=[csInheritable];
+  If Assigned(AOwner) then AOwner.InsertComponent(Self);
+end;
+
+
+Destructor TComponent.Destroy;
+
+Var Runner : Longint;
+
+begin
+  If Assigned(FFreeNotifies) then
+    begin
+    For Runner:=0 To FFreeNotifies.Count-1 do
+      TComponent(FFreeNotifies.Items[Runner]).Notification (self,opRemove);
+    FFreeNotifies.Free;
+    FFreeNotifies:=Nil;
+    end;
+  Destroying;
+  DestroyComponents;
+  If FOwner<>Nil Then FOwner.RemoveComponent(Self);
+  inherited destroy;
+end;
+
+
+Procedure TComponent.DestroyComponents;
+
+Var acomponent: TComponent;
+
+begin
+  While assigned(FComponents) do
+    begin
+    aComponent:=TComponent(FComponents.Last);
+    Remove(aComponent);
+    Acomponent.Destroy;
+    end;
+end;
+
+
+Procedure TComponent.Destroying;
+
+Var Runner : longint;
+
+begin
+  If csDestroying in FComponentstate Then Exit;
+  include (FComponentState,csDestroying);
+  If Assigned(FComponents) then
+    for Runner:=0 to FComponents.Count-1 do
+      TComponent(FComponents.Items[Runner]).Destroying;
+end;
+
+
+Function  TComponent.FindComponent(const AName: string): TComponent;
+
+Var I : longint;
+
+begin
+  Result:=Nil;
+  If (AName='') or Not assigned(FComponents) then exit;
+  For i:=0 to FComponents.Count-1 do
+    if TComponent(FComponents[I]).Name=AName then
+      begin
+      Result:=TComponent(FComponents.Items[I]);
+      exit;
+      end;
+end;
+
+
+Procedure TComponent.FreeNotification(AComponent: TComponent);
+
+begin
+  If (Owner<>Nil) and (AComponent=Owner) then exit;
+  If not (Assigned(FFreeNotifies)) then
+    FFreeNotifies:=TList.Create;
+  If FFreeNotifies.IndexOf(AComponent)=-1 then
+    begin
+    FFreeNotifies.Add(AComponent);
+    AComponent.FreeNotification (self);
+    end;
+end;
+
+
+Procedure TComponent.FreeOnRelease;
+
+begin
+  // Delphi compatibility only at the moment.
+end;
+
+
+Function  TComponent.GetParentComponent: TComponent;
+
+begin
+  Result:=Nil;
+end;
+
+
+Function  TComponent.HasParent: Boolean;
+
+begin
+  Result:=False;
+end;
+
+
+Procedure TComponent.InsertComponent(AComponent: TComponent);
+
+begin
+  AComponent.ValidateContainer(Self);
+  ValidateRename(AComponent,'',AComponent.FName);
+  Insert(AComponent);
+  AComponent.SetReference(True);
+  If csDesigning in FComponentState then
+    AComponent.SetDesigning(true);
+  Notification(AComponent,opInsert);
+end;
+
+
+Procedure TComponent.RemoveComponent(AComponent: TComponent);
+
+begin
+  Notification(AComponent,opRemove);
+  AComponent.SetReference(False);
+  Remove(AComponent);
+  Acomponent.Setdesigning(False);
+  ValidateRename(AComponent,AComponent.FName,'');
+end;
+
+
+Function  TComponent.SafeCallException(ExceptObject: TObject;
+  ExceptAddr: Pointer): Integer;
+
+begin
+  SafeCallException:=0;
+end;
+
+{
+  $Log$
+  Revision 1.10  2000-01-06 01:20:32  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  2000/01/04 18:07:16  michael
+  + Streaming implemented
+
+  Revision 1.1  2000/01/03 19:33:07  peter
+    * moved to packages dir
+
+  Revision 1.8  1999/04/12 14:41:00  michael
+  + Fixed TComponent methods where defaults are used
+
+  Revision 1.7  1999/04/12 08:02:48  michael
+  + Fixed bug in ValidateRename
+
+  Revision 1.6  1999/04/08 10:18:51  peter
+    * makefile updates
+
+}

fcl/inc/constse.inc

@@ -0,0 +1,271 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+
+const
+  SAssignError = '%s can not be assigned to %s';
+  SFCreateError = 'File %s can not be created';
+  SFOpenError = 'File %s can not be opened';
+  SReadError = 'Stream-Read-Error';
+  SWriteError = 'Stream-Write-Error';
+  SMemoryStreamError = 'Can not expand Memory Stream';
+  SCantWriteResourceStreamError = 'Can not write to read-only ResourceStream';
+  SDuplicateReference = 'WriteObject was called twice for one instance';
+  SClassNotFound = 'Class %s not found';
+  SInvalidImage = 'Illegal stream image';
+  SResNotFound = 'Resource %s not found';
+  SClassMismatch = 'Resource %s has wrong class';
+  SListIndexError = 'List index exceeds bounds (%d)';
+  SListCapacityError = 'The maximum list capacity is reached (%d)';
+  SListCountError = 'List count too large (%d)';
+  SSortedListError = 'Operation not allowed on sorted StringLists';
+  SDuplicateString = 'Duplicate entries not allowed in StringList';
+  SInvalidTabIndex = 'Registerindex out of bounds';
+  SDuplicateName = 'A Component with name %s exists already';
+  SInvalidName = '"%s" is not a valid identifier name';
+  SDuplicateClass = 'A Class with name %s exists already';
+  SNoComSupport = '%s is not registered as COM-Class';
+  SLineTooLong = 'Line too long';
+
+  SInvalidPropertyValue = 'Invalid property value';
+  SInvalidPropertyPath = 'Invalid property path';
+  SUnknownProperty = 'Unknown property';
+  SReadOnlyProperty = 'Read-only property';
+  SPropertyException = 'Error when reading %s.%s: %s';
+  SAncestorNotFound = 'Ancestor of ''%s'' not found.';
+  SInvalidBitmap = 'Invalid Bitmap';
+  SInvalidIcon = 'Invalid Icon';
+  SInvalidMetafile = 'Invalid MetaFile';
+  SInvalidPixelFormat = 'Invalid PixelFormat';
+  SBitmapEmpty = 'Bitmap is empty';
+  SScanLine = 'Line index out of bounds';
+  SChangeIconSize = 'Can not change Icon size';
+  SOleGraphic = 'Invalid operation for TOleGraphic';
+  SUnknownExtension = 'Unknown extension (.%s)';
+  SUnknownClipboardFormat = 'Unknown Clipboard format';
+  SOutOfResources = 'Out of system resources';
+  SNoCanvasHandle = 'Canvas handle does not allow drawing';
+  SInvalidImageSize = 'Invalid image size';
+  STooManyImages = 'Too many images';
+  SDimsDoNotMatch = 'Image size mismatch';
+  SInvalidImageList = 'Invalid ImageList';
+  SReplaceImage = 'Image can not be replaced';
+  SImageIndexError = 'Invalid ImageList-Index';
+  SImageReadFail = 'The ImageList data could not be read from Stream';
+  SImageWriteFail = 'The ImageList data could not be written to Stream';
+  SWindowDCError = 'Error when??';
+  SClientNotSet = 'Client of TDrag was not initialized';
+  SWindowClass = 'Error when initializing Window Class';
+  SWindowCreate = 'Error when creating Window';
+  SCannotFocus = 'A disbled or invisible Window cannot get focus';
+  SParentRequired = 'Element ''%s'' has no parent Window';
+  SMDIChildNotVisible = 'A MDI-Child Windows can not be hidden.';
+  SVisibleChanged = 'Visible property cannot be changed in OnShow or OnHide handlers';
+  SCannotShowModal = 'A visible Window can not be made modal';
+  SScrollBarRange = 'Scrollbar property out of range';
+  SPropertyOutOfRange = 'Property %s out of range';
+  SMenuIndexError = 'Menu Index out of range';
+  SMenuReinserted = 'Menu reinserted';
+  SMenuNotFound = 'Menu entry not found in menu';
+  SNoTimers = 'No timers available';
+  SNotPrinting = 'Printer is not printing';
+  SPrinting = 'Printer is busy';
+  SPrinterIndexError = 'PrinterIndex out of range';
+  SInvalidPrinter = 'Selected printer is invalid';
+  SDeviceOnPort = '%s on %s';
+  SGroupIndexTooLow = 'GroupIndex must be greater than preceding menu groupindex';
+  STwoMDIForms = 'There is only one MDI window available';
+  SNoMDIForm = 'No MDI form is available, none is active';
+  SRegisterError = 'Invalid registry';
+  SImageCanvasNeedsBitmap = 'A Canvas can only be changedif it contains a bitmap';
+  SControlParentSetToSelf = 'A component can not have itself as parent';
+  SOKButton = 'OK';
+  SCancelButton = 'Cancel';
+  SYesButton = '&Yes';
+  SNoButton = '&No';
+  SHelpButton = '&Help';
+  SCloseButton = '&Close';
+  SIgnoreButton = '&Ignore';
+  SRetryButton = '&Retry';
+  SAbortButton = 'Abort';
+  SAllButton = '&All';
+
+  SFB = 'VH';
+  SFG = 'VG';
+  SBG = 'HG';
+  SOldTShape = 'Can not load older version of TShape';
+  SVMetafiles = 'MetaFiles';
+  SVEnhMetafiles = 'Enhanced MetaFiles';
+  SVIcons = 'Icons';
+  SVBitmaps = 'Bitmaps';
+  SGridTooLarge = 'Grid to large for this operation';
+  STooManyDeleted = 'Zu viele Zeilen oder Spalten gelöscht';
+  SIndexOutOfRange = 'Grid index out of range';
+  SFixedColTooBig = 'The number of fixed Columns must be less than the Column count';
+  SFixedRowTooBig = 'The number of fixed Rows must be less that the Row count';
+  SInvalidStringGridOp = 'Es können keine Zeilen des ''Grids'' gelöscht oder eingefügt werden';
+  SParseError = '%s in Line %d';
+
+  SIdentifierExpected = 'Identifier expected';
+  SStringExpected = 'String expected';
+  SNumberExpected = 'Number expected';
+
+  SCharExpected = '%s expected';
+
+  SSymbolExpected = '%s expected';
+
+  SInvalidNumber = 'Invalid numerical value';
+  SInvalidString = 'Invalid string constant';
+  SInvalidProperty = 'Invalid property value';
+  SInvalidBinary = 'Invalid binary';
+  SOutlineIndexError = 'Node index not found';
+  SOutlineExpandError = 'Parent node must be expanded';
+  SInvalidCurrentItem = 'Invalid item';
+  SMaskErr = 'Invalid mask';
+  SMaskEditErr = 'Invalid mask. Use the ESC-key to undo changes.';
+  SOutlineError = 'Invalid Node index';
+  SOutlineBadLevel = '???';
+  SOutlineSelection = 'Ungültige Auswahl';
+  SOutlineFileLoad = 'Fehler beim Dateiladen';
+  SOutlineLongLine = 'Zeile zu lang';
+  SOutlineMaxLevels = 'Maximale Gliederungstiefe überschritten';
+
+  SMsgDlgWarning = 'Warning';
+  SMsgDlgError = 'Error';
+  SMsgDlgInformation = 'Information';
+  SMsgDlgConfirm = 'Confirm';
+  SMsgDlgYes = '&Yes';
+  SMsgDlgNo = '&No';
+  SMsgDlgOK = 'OK';
+  SMsgDlgCancel = 'Cancel';
+  SMsgDlgHelp = '&Help';
+  SMsgDlgHelpNone = 'No help available';
+  SMsgDlgHelpHelp = 'Help';
+  SMsgDlgAbort = '&Abort';
+  SMsgDlgRetry = '&Retry';
+  SMsgDlgIgnore = '&Ignore';
+  SMsgDlgAll = '&All';
+  SMsgDlgNoToAll = 'N&o to all';
+  SMsgDlgYesToAll = 'Yes to A&lle';
+
+  SmkcBkSp = 'Backspace';
+  SmkcTab = 'Tab';
+  SmkcEsc = 'Esc';
+  SmkcEnter = 'Enter';
+  SmkcSpace = 'Space';
+  SmkcPgUp = 'Page up';
+  SmkcPgDn = 'Page down';
+  SmkcEnd = 'End';
+  SmkcHome = 'Home';
+  SmkcLeft = 'Left';
+  SmkcUp = 'Up';
+  SmkcRight = 'Right';
+  SmkcDown = 'Down';
+  SmkcIns = 'Insert';
+  SmkcDel = 'Delete';
+  SmkcShift = 'Shift+';
+  SmkcCtrl = 'Ctrl+';
+  SmkcAlt = 'Alt+';
+
+  srUnknown = '(Ukknown)';
+  srNone = '(Empty)';
+  SOutOfRange = 'Value must be between %d and %d';
+  SCannotCreateName = 'Cannot use standard name for and unknown component';
+
+  SDateEncodeError = 'Ungültiges Argument für Datumskodierung';
+  STimeEncodeError = 'Ungültiges Argument für Zeitkodierung';
+  SInvalidDate = '''''%s'''' ist kein gültiges Datum';
+  SInvalidTime = '''''%s'''' ist keine gültige Zeit';
+  SInvalidDateTime = '''''%s'''' ist kein gültiges Datum und Zeit';
+  SInsertLineError = 'Zeile kann nicht eingefügt werden';
+
+  SCannotDragForm = 'Formulare können nicht gezogen werden';
+  SPutObjectError = 'PutObject auf undefiniertes Element';
+  SCardDLLNotLoaded = 'CARDS.DLL kann nicht geladen werden';
+  SDuplicateCardId = 'Doppelte CardId gefunden';
+
+  SDdeErr = 'Ein Fehler wurde von der DDE zurückgeliefert  ($0%x)';
+  SDdeConvErr = 'DDE Fehler - Konversation wurde nicht hergestellt ($0%x)';
+  SDdeMemErr = 'Fehler trat auf, da unzureichender Speicher für DDE ($0%x)';
+  SDdeNoConnect = 'DDE-Konversation kann nicht eingerichtet werden';
+
+
+  SDefaultFilter = 'Alle Dateien (*.*)|*.*';
+  sAllFilter = 'Alle Dateien';
+  SNoVolumeLabel = ': [ - Ohne Namen - ]';
+
+  SConfirmCreateDir = 'Das angegebene Verzeichnis existiert nicht. Soll es angelegt werden?';
+  SSelectDirCap = 'Verzeichnis auswählen';
+  SCannotCreateDir = 'Das Verzeichnis kann nicht erstellt werden';
+  SDirNameCap = 'Verzeichnis&name:';
+  SDrivesCap = '&Laufwerke:';
+  SDirsCap = '&Verzeichnisse:';
+  SFilesCap = '&Dateien: (*.*)';
+  SNetworkCap = 'Ne&tzwerk...';
+
+  SColorPrefix = 'Farbe';
+  SColorTags = 'ABCDEFGHIJKLMNOP';
+
+  SInvalidClipFmt = 'Ungültiges Format der Zwischenablage';
+  SIconToClipboard = 'Zwischenablage unterstützt keine Symbole';
+
+  SDefault = 'Vorgabe';
+
+  SInvalidMemoSize = 'Text überschreitet Memo-Kapazität';
+  SCustomColors = 'Selbstdefinierte Farben';
+  SInvalidPrinterOp = 'Operation auf ausgewähltem Drucker nicht verfügbar';
+  SNoDefaultPrinter = 'Zur Zeit ist kein Standard-Drucker gewählt';
+
+  SIniFileWriteError = 'nach %s kann nicht geschrieben werden';
+
+  SBitsIndexError = 'Bits-Index außerhalb des zulässigen Bereichs';
+
+  SUntitled = '(Unbenannt)';
+
+  SInvalidRegType = 'Ungültiger Datentyp für ''%s''';
+  SRegCreateFailed = 'Erzeugung von Schlüssel %s misslungen';
+  SRegSetDataFailed = 'Konnte Daten für ''%s'' nicht setzen';
+  SRegGetDataFailed = 'Konnte Daten für ''%s'' nicht holen';
+
+  SUnknownConversion = 'Unbekannte Dateierweiterung für RichEdit-Konvertierung (.%s)';
+  SDuplicateMenus = 'Menü ''%s'' wird bereits von einem anderen Formular benutzt';
+
+  SPictureLabel = 'Bild:';
+  SPictureDesc = ' (%dx%d)';
+  SPreviewLabel = 'Vorschau';
+
+  SCannotOpenAVI = 'AVI kann nicht geöffnet werden';
+
+  SNotOpenErr = 'Kein MCI-Gerät geöffnet';
+  SMPOpenFilter = 'Alle Dateien (*.*)|*.*|Wave-Dateien (*.WAV)|*.WAV|Midi-Dateien (*.MID)|*.MID|Video für Windows (*.avi)|*.avi';
+  SMCINil = '';
+  SMCIAVIVideo = 'AVIVideo';
+  SMCICDAudio = 'CDAudio';
+  SMCIDAT = 'DAT';
+  SMCIDigitalVideo = 'DigitalVideo';
+  SMCIMMMovie = 'MMMovie';
+  SMCIOther = 'Andere';
+  SMCIOverlay = 'Overlay';
+  SMCIScanner = 'Scanner';
+  SMCISequencer = 'Sequencer';
+  SMCIVCR = 'VCR';
+  SMCIVideodisc = 'Videodisc';
+  SMCIWaveAudio = 'WaveAudio';
+  SMCIUnknownError = 'Unbekannter Fehlercode';
+
+  SBoldItalicFont = 'Fett kursiv';
+  SBoldFont = 'Fett';
+  SItalicFont = 'Kursiv';
+  SRegularFont = 'Normal';
+
+  SPropertiesVerb = 'Eigenschaften';

fcl/inc/constsg.inc

@@ -0,0 +1,272 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+
+const
+  SAssignError = '%s kann nicht zu  %s zugewiesen werden';
+  SFCreateError = 'Datei %s kann nicht erstellt werden';
+  SFOpenError = 'Datei %s kann nicht geöffnet werden';
+  SReadError = 'Stream-Read-Fehler';
+  SWriteError = 'Stream-Write-Fehler';
+  SMemoryStreamError = 'Expandieren des Speicher-Stream wegen Speichermangel nicht möglich';
+  SCantWriteResourceStreamError = 'In einen zum Lesen geöffneten Ressourcen-Stream kann nicht geschrieben werden';
+  SDuplicateReference = 'Zweimaliger Aufruf von WriteObject für die gleiche Instanz';
+  SClassNotFound = 'Klasse %s nicht gefunden';
+  SInvalidImage = 'Ungültiges Stream-Format';
+  SResNotFound = 'Ressource %s nicht gefunden';
+  SClassMismatch = 'Ressource %s hat die falsche Klasse';
+  SListIndexError = 'Der Index der Liste überschreitet das Maximum (%d)';
+  SListCapacityError = 'Die Kapazität der Liste ist erschöpft (%d)';
+  SListCountError = 'Zu viele Einträge in der Liste (%d)';
+  SSortedListError = 'Operation bei sortierten Stringlisten nicht erlaubt';
+  SDuplicateString = 'In der Stringliste sind Duplikate nicht erlaubt';
+  SInvalidTabIndex = 'Registerindex außerhalb des zulässigen Bereichs';
+  SDuplicateName = 'Eine Komponente mit der Bezeichnung %s existiert bereits';
+  SInvalidName = '''''%s'''' ist kein gültiger Komponentenname';
+  SDuplicateClass = 'Eine Klasse mit der Bezeichnung %s existiert bereits';
+  SNoComSupport = '%s wurde nicht als COM-Klasse registriert';
+  SInvalidInteger = '''''%s'''' ist kein gültiger Integerwert';
+  SLineTooLong = 'Zeile zu lang';
+
+  SInvalidPropertyValue = 'Ungültiger Wert der Eigenschaft';
+  SInvalidPropertyPath = 'Ungültiger Pfad für Eigenschaft';
+  SUnknownProperty = 'Eigenschaft existiert nicht';
+  SReadOnlyProperty = 'Eigenschaft kann nur gelesen werden';
+  SPropertyException = 'Fehler beim Lesen von %s.%s: %s';
+  SAncestorNotFound = 'Vorfahr für ''%s'' nicht gefunden';
+  SInvalidBitmap = 'Bitmap ist ungültig';
+  SInvalidIcon = 'Ungültiges Symbol';
+  SInvalidMetafile = 'Metadatei ist ungültig';
+  SInvalidPixelFormat = 'Ungültiges Pixelformat';
+  SBitmapEmpty = 'Bitmap ist leer';
+  SScanLine = 'Bereichsüberschreitung bei Zeilenindex';
+  SChangeIconSize = 'Die Größe eines Symbols kann nicht geändert werden';
+  SOleGraphic = 'Ungültige Operation für TOleGraphic';
+  SUnknownExtension = 'Unbekannte Bilddateierweiterung (.%s)';
+  SUnknownClipboardFormat = 'Format der Zwischenablage wird nicht unterstützt';
+  SOutOfResources = 'Systemressourcen erschöpft.';
+  SNoCanvasHandle = 'Leinwand/Bild erlaubt kein Zeichnen';
+  SInvalidImageSize = 'Ungültige Bildgröße';
+  STooManyImages = 'Zu viele Bilder';
+  SDimsDoNotMatch = 'Bildgröße und Bildlistengröße stimmen nicht überein';
+  SInvalidImageList = 'Ungültige ImageList';
+  SReplaceImage = 'Bild kann nicht ersetzt werden';
+  SImageIndexError = 'Ungültiger ImageList-Index';
+  SImageReadFail = 'Die ImageList-Daten konnten nicht aus dem Stream gelesen werden';
+  SImageWriteFail = 'Die ImageList-Daten konnten nicht in den Stream geschrieben werden';
+  SWindowDCError = 'Fehler beim Erstellen des Fenster-Gerätekontexts';
+  SClientNotSet = 'Client von TDrag wurde nicht initialisiert';
+  SWindowClass = 'Fehler beim Erzeugen einer Fensterklasse';
+  SWindowCreate = 'Fehler beim Erzeugen eines Fensters';
+  SCannotFocus = 'Ein deaktiviertes oder unsichtbares Fenster kann nicht den Fokus erhalten';
+  SParentRequired = 'Element ''%s'' hat kein übergeordnetes Fenster';
+  SMDIChildNotVisible = 'Ein MDI-Kindformular kann nicht verborgen werden';
+  SVisibleChanged = 'Eigenschaft Visible kann in OnShow oder OnHide nicht verändert werden';
+  SCannotShowModal = 'Aus einem sichtbaren Fenster kann kein modales gemacht werden';
+  SScrollBarRange = 'Eigenschaft Scrollbar außerhalb des zulässigen Bereichs';
+  SPropertyOutOfRange = 'Eigenschaft %s außerhalb des gültigen Bereichs';
+  SMenuIndexError = 'Menüindex außerhalb des zulässigen Bereichs';
+  SMenuReinserted = 'Menü zweimal eingefügt';
+  SMenuNotFound = 'Untermenü ist nicht im Menü';
+  SNoTimers = 'Nicht genügend Timer verfügbar';
+  SNotPrinting = 'Der Drucker ist nicht am Drucken';
+  SPrinting = 'Das Drucken ist im Gang';
+  SPrinterIndexError = 'Druckerindex außerhalb des zulässigen Bereichs';
+  SInvalidPrinter = 'Ausgewählter Drucker ist ungültig';
+  SDeviceOnPort = '%s an %s';
+  SGroupIndexTooLow = 'GroupIndex kann nicht kleiner sein als der GroupIndex eines vorhergehenden Menüelementes';
+  STwoMDIForms = 'Es ist nur ein MDI-Formular pro Anwendung möglich';
+  SNoMDIForm = 'Formular kann nicht erstellt werden. Zur Zeit sind keine MDI-Formulare aktiv';
+  SRegisterError = 'Ungültige Komponentenregistrierung';
+  SImageCanvasNeedsBitmap = 'Ein Bild kann nur geändert werden, wenn es ein Bitmap enthält';
+  SControlParentSetToSelf = 'Ein Steuerelement kann nicht sich selbst als Vorfahr haben';
+  SOKButton = 'OK';
+  SCancelButton = 'Abbrechen';
+  SYesButton = '&Ja';
+  SNoButton = '&Nein';
+  SHelpButton = '&Hilfe';
+  SCloseButton = '&Schließen';
+  SIgnoreButton = '&Ignorieren';
+  SRetryButton = '&Wiederholen';
+  SAbortButton = 'Abbruch';
+  SAllButton = '&Alles';
+
+  SFB = 'VH';
+  SFG = 'VG';
+  SBG = 'HG';
+  SOldTShape = 'Kann ältere Version von TShape nicht laden';
+  SVMetafiles = 'Metadateien';
+  SVEnhMetafiles = 'Erweiterte Metadateien';
+  SVIcons = 'Symbole';
+  SVBitmaps = 'Bitmaps';
+  SGridTooLarge = 'Gitter zu groß für Operation';
+  STooManyDeleted = 'Zu viele Zeilen oder Spalten gelöscht';
+  SIndexOutOfRange = 'Gitterindex außerhalb des zulässigen Bereichs';
+  SFixedColTooBig = 'Die Anzahl fester Spalten muß kleiner sein als die Spaltenanzahl';
+  SFixedRowTooBig = 'Die Anzahl fester Zeilen muß kleiner sein als die Zeilenanzahl';
+  SInvalidStringGridOp = 'Es können keine Zeilen des ''Grids'' gelöscht oder eingefügt werden';
+  SParseError = '%s in Zeile %d';
+
+  SIdentifierExpected = 'Bezeichner erwartet';
+  SStringExpected = 'String erwartet';
+  SNumberExpected = 'Zahl erwartet';
+
+  SCharExpected = '%s erwartet';
+
+  SSymbolExpected = '%s erwartet';
+
+  SInvalidNumber = 'Ungültiger numerischer Wert';
+  SInvalidString = 'Ungültige Stringkonstante';
+  SInvalidProperty = 'Ungültiger Wert der Eigenschaft';
+  SInvalidBinary = 'Ungültiger Binärwert';
+  SOutlineIndexError = 'Gliederungsindex nicht gefunden';
+  SOutlineExpandError = 'Elternknoten muß expandiert sein';
+  SInvalidCurrentItem = 'Ungültiger Wert';
+  SMaskErr = 'Ungültiger Eingabewert';
+  SMaskEditErr = 'Ungültiger Eingabewert. Benutzen Sie die ESC-Taste, um die Änderungen rückgängig zu machen.';
+  SOutlineError = 'Ungültiger Gliederungsindex';
+  SOutlineBadLevel = 'Ungültige Zuweisung von Ebenen';
+  SOutlineSelection = 'Ungültige Auswahl';
+  SOutlineFileLoad = 'Fehler beim Dateiladen';
+  SOutlineLongLine = 'Zeile zu lang';
+  SOutlineMaxLevels = 'Maximale Gliederungstiefe überschritten';
+
+  SMsgDlgWarning = 'Warnung';
+  SMsgDlgError = 'Fehler';
+  SMsgDlgInformation = 'Information';
+  SMsgDlgConfirm = 'Bestätigen';
+  SMsgDlgYes = '&Ja';
+  SMsgDlgNo = '&Nein';
+  SMsgDlgOK = 'OK';
+  SMsgDlgCancel = 'Abbrechen';
+  SMsgDlgHelp = '&Hilfe';
+  SMsgDlgHelpNone = 'Keine Hilfe verfügbar';
+  SMsgDlgHelpHelp = 'Hilfe';
+  SMsgDlgAbort = '&Abbrechen';
+  SMsgDlgRetry = '&Wiederholen';
+  SMsgDlgIgnore = '&Ignorieren';
+  SMsgDlgAll = '&Alles';
+  SMsgDlgNoToAll = '&Alle Nein';
+  SMsgDlgYesToAll = 'A&lle Ja';
+
+  SmkcBkSp = 'Rück';
+  SmkcTab = 'Tab';
+  SmkcEsc = 'Esc';
+  SmkcEnter = 'Enter';
+  SmkcSpace = 'Leertaste';
+  SmkcPgUp = 'BildAuf';
+  SmkcPgDn = 'BildAb';
+  SmkcEnd = 'Ende';
+  SmkcHome = 'Pos1';
+  SmkcLeft = 'Linksbündig';
+  SmkcUp = 'Nach oben';
+  SmkcRight = 'Rechts';
+  SmkcDown = 'Nach unten';
+  SmkcIns = 'Einfg';
+  SmkcDel = 'Entf';
+  SmkcShift = 'Umsch+';
+  SmkcCtrl = 'Strg+';
+  SmkcAlt = 'Alt+';
+
+  srUnknown = '(Unbekannt)';
+  srNone = '(Leer)';
+  SOutOfRange = 'Wert muß zwischen %d und %d liegen';
+  SCannotCreateName = 'Für eine unbenannte Komponente kann kein Standard-Methodennamen erstellt werden';
+
+  SDateEncodeError = 'Ungültiges Argument für Datumskodierung';
+  STimeEncodeError = 'Ungültiges Argument für Zeitkodierung';
+  SInvalidDate = '''''%s'''' ist kein gültiges Datum';
+  SInvalidTime = '''''%s'''' ist keine gültige Zeit';
+  SInvalidDateTime = '''''%s'''' ist kein gültiges Datum und Zeit';
+  SInsertLineError = 'Zeile kann nicht eingefügt werden';
+
+  SCannotDragForm = 'Formulare können nicht gezogen werden';
+  SPutObjectError = 'PutObject auf undefiniertes Element';
+  SCardDLLNotLoaded = 'CARDS.DLL kann nicht geladen werden';
+  SDuplicateCardId = 'Doppelte CardId gefunden';
+
+  SDdeErr = 'Ein Fehler wurde von der DDE zurückgeliefert  ($0%x)';
+  SDdeConvErr = 'DDE Fehler - Konversation wurde nicht hergestellt ($0%x)';
+  SDdeMemErr = 'Fehler trat auf, da unzureichender Speicher für DDE ($0%x)';
+  SDdeNoConnect = 'DDE-Konversation kann nicht eingerichtet werden';
+
+
+  SDefaultFilter = 'Alle Dateien (*.*)|*.*';
+  sAllFilter = 'Alle Dateien';
+  SNoVolumeLabel = ': [ - Ohne Namen - ]';
+
+  SConfirmCreateDir = 'Das angegebene Verzeichnis existiert nicht. Soll es angelegt werden?';
+  SSelectDirCap = 'Verzeichnis auswählen';
+  SCannotCreateDir = 'Das Verzeichnis kann nicht erstellt werden';
+  SDirNameCap = 'Verzeichnis&name:';
+  SDrivesCap = '&Laufwerke:';
+  SDirsCap = '&Verzeichnisse:';
+  SFilesCap = '&Dateien: (*.*)';
+  SNetworkCap = 'Ne&tzwerk...';
+
+  SColorPrefix = 'Farbe';
+  SColorTags = 'ABCDEFGHIJKLMNOP';
+
+  SInvalidClipFmt = 'Ungültiges Format der Zwischenablage';
+  SIconToClipboard = 'Zwischenablage unterstützt keine Symbole';
+
+  SDefault = 'Vorgabe';
+
+  SInvalidMemoSize = 'Text überschreitet Memo-Kapazität';
+  SCustomColors = 'Selbstdefinierte Farben';
+  SInvalidPrinterOp = 'Operation auf ausgewähltem Drucker nicht verfügbar';
+  SNoDefaultPrinter = 'Zur Zeit ist kein Standard-Drucker gewählt';
+
+  SIniFileWriteError = 'nach %s kann nicht geschrieben werden';
+
+  SBitsIndexError = 'Bits-Index außerhalb des zulässigen Bereichs';
+
+  SUntitled = '(Unbenannt)';
+
+  SInvalidRegType = 'Ungültiger Datentyp für ''%s''';
+  SRegCreateFailed = 'Erzeugung von Schlüssel %s misslungen';
+  SRegSetDataFailed = 'Konnte Daten für ''%s'' nicht setzen';
+  SRegGetDataFailed = 'Konnte Daten für ''%s'' nicht holen';
+
+  SUnknownConversion = 'Unbekannte Dateierweiterung für RichEdit-Konvertierung (.%s)';
+  SDuplicateMenus = 'Menü ''%s'' wird bereits von einem anderen Formular benutzt';
+
+  SPictureLabel = 'Bild:';
+  SPictureDesc = ' (%dx%d)';
+  SPreviewLabel = 'Vorschau';
+
+  SCannotOpenAVI = 'AVI kann nicht geöffnet werden';
+
+  SNotOpenErr = 'Kein MCI-Gerät geöffnet';
+  SMPOpenFilter = 'Alle Dateien (*.*)|*.*|Wave-Dateien (*.WAV)|*.WAV|Midi-Dateien (*.MID)|*.MID|Video für Windows (*.avi)|*.avi';
+  SMCINil = '';
+  SMCIAVIVideo = 'AVIVideo';
+  SMCICDAudio = 'CDAudio';
+  SMCIDAT = 'DAT';
+  SMCIDigitalVideo = 'DigitalVideo';
+  SMCIMMMovie = 'MMMovie';
+  SMCIOther = 'Andere';
+  SMCIOverlay = 'Overlay';
+  SMCIScanner = 'Scanner';
+  SMCISequencer = 'Sequencer';
+  SMCIVCR = 'VCR';
+  SMCIVideodisc = 'Videodisc';
+  SMCIWaveAudio = 'WaveAudio';
+  SMCIUnknownError = 'Unbekannter Fehlercode';
+
+  SBoldItalicFont = 'Fett kursiv';
+  SBoldFont = 'Fett';
+  SItalicFont = 'Kursiv';
+  SRegularFont = 'Normal';
+
+  SPropertiesVerb = 'Eigenschaften';

fcl/inc/constss.inc

@@ -0,0 +1,271 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+
+const
+  SAssignError = '%s no puede ser assignado a  %s';
+  SFCreateError = 'Fichero %s no puede ser creado';
+  SFOpenError = 'Fichero %s no puede ser abierto';
+  SReadError = 'Error-Lectura-Stream';
+  SWriteError = 'Error-Escritura-Stream';
+  SMemoryStreamError = 'No es posible expandir Memoria Stream';
+  SCantWriteResourceStreamError = 'No se puede escribir en un ResourceStream de solo lectura';
+  SDuplicateReference = 'WriteObject fue llamado dos veces por una sola instancia';
+  SClassNotFound = 'Clase %s no encontrada';
+  SInvalidImage = 'Imagen stream ilegal';
+  SResNotFound = 'No se encontro el resource %s';
+  SClassMismatch = 'El resource %s tiene una clase erronea';
+  SListIndexError = 'El indice de lista excede los limites (%d)';
+  SListCapacityError = 'La maxima capacidad de lista a sido alcanzada (%d)';
+  SListCountError = 'Contador de lista demasiado grande (%d)';
+  SSortedListError = 'Operacion no permitida en StringLists ordenado';
+  SDuplicateString = 'Entradas duplicadas no permitidas en StringList';
+  SInvalidTabIndex = 'Registerindex fuera de limites';
+  SDuplicateName = 'Un componente con el nombre %s existe actualmente';
+  SInvalidName = '"%s" no es un nombre identificador valido';
+  SDuplicateClass = 'Una Clase con el nombre %s existe actualmente';
+  SNoComSupport = '%s no esta registrado como COM-Class';
+  SLineTooLong = 'Linea demasiado larga';
+
+  SInvalidPropertyValue = 'Valor de propiedad no valido';
+  SInvalidPropertyPath = 'Path de propiedad no valido';
+  SUnknownProperty = 'Propiedad desconocidad';
+  SReadOnlyProperty = 'Propiedad de solo lectura';
+  SPropertyException = 'Error leyendo %s.%s: %s';
+{N}  SAncestorNotFound = 'Ancestor of ''%s'' not found.';
+  SInvalidBitmap = 'Bitmap no valido';
+  SInvalidIcon = 'Icono no valido';
+  SInvalidMetafile = 'MetaFile no valido';
+  SInvalidPixelFormat = 'PixelFormat no valido';
+  SBitmapEmpty = 'El bitmap esta vacio';
+  SScanLine = 'Indice de linea fuera de limites';
+  SChangeIconSize = 'No se puede cambiar el tama¤o del icono';
+  SOleGraphic = 'Operacion no valida para TOleGraphic';
+  SUnknownExtension = 'Extension desconocida (.%s)';
+  SUnknownClipboardFormat = 'Formato de Portapapeles desconocido';
+  SOutOfResources = 'Recursos de sistema agotados';
+  SNoCanvasHandle = 'El manejador Canvas no permite dibujar';
+  SInvalidImageSize = 'Tama¤o de imagen no valido';
+  STooManyImages = 'Demasiadas imagenes';
+  SDimsDoNotMatch = 'El tama¤o de la imagen no coincide';
+  SInvalidImageList = 'ImageList no valido';
+  SReplaceImage = 'La imagen no puede ser reemplazada';
+  SImageIndexError = 'ImageList-Index no valido';
+  SImageReadFail = 'Los datos de ImageList no pueden ser leido desde Stream';
+  SImageWriteFail = 'Los datos de ImageList no pueden ser escritos en Stream';
+  SWindowDCError = 'Error cuando??';
+  SClientNotSet = 'El cliente de TDrag no fue iniciado';
+  SWindowClass = 'Error inicializando Window Class';
+  SWindowCreate = 'Error creando una Ventana';
+{?}  SCannotFocus = 'Una Ventana invisible or desactivada no puede obtener el foco';
+  SParentRequired = 'El elemento ''%s'' no tiene una ventana padre';
+  SMDIChildNotVisible = 'Una ventana MDI-Child no puede ser ocultada.';
+  SVisibleChanged = 'Una propiedad visual no puede ser cambiada en el manejador OnShow o OnHide';
+{?}  SCannotShowModal = 'Una Ventana visible no puede ser hecha modal';
+  SScrollBarRange = 'Propiedad de Scrollbar fuera de limites';
+  SPropertyOutOfRange = 'Propiedad %s fuera de limites';
+  SMenuIndexError = 'Indice de menu fuera de rango';
+  SMenuReinserted = 'Menu reinsertado';
+  SMenuNotFound = 'Entrada de menu no encontra en menu';
+  SNoTimers = 'No hay timers disponibles';
+  SNotPrinting = 'La impresora no esta imprimiendo';
+  SPrinting = 'La impresora esta ocupada';
+  SPrinterIndexError = 'PrinterIndex fuera de rango';
+  SInvalidPrinter = 'La impresora seleccionada no es valida';
+  SDeviceOnPort = '%s en %s';
+  SGroupIndexTooLow = 'GroupIndex tiene que ser mayor que el goupindex del menu predecesor';
+  STwoMDIForms = 'Solo hay una ventana MDI disponible';
+  SNoMDIForm = 'No hay ningun MDI form disponible, none esta activado';
+  SRegisterError = 'Registro invalido';
+  SImageCanvasNeedsBitmap = 'Un Canvas solo puede ser cambiado si contiene un bitmap';
+  SControlParentSetToSelf = 'Un componente no puede tenerse a si mismo como padre';
+  SOKButton = 'Aceptar';
+  SCancelButton = 'Cancelar';
+  SYesButton = '&Si';
+  SNoButton = '&No';
+  SHelpButton = '&Ayuda';
+  SCloseButton = '&Cerrar';
+  SIgnoreButton = '&Ignorar';
+  SRetryButton = '&Reintentar';
+  SAbortButton = 'Abortar';
+  SAllButton = '&Todo';
+
+{?}  SFB = 'VH';
+{?}  SFG = 'VG';
+{?}  SBG = 'HG';
+  SOldTShape = 'No es posible cargar versiones antiguas de TShape';
+  SVMetafiles = 'MetaFiles';
+  SVEnhMetafiles = 'MetaFiles ampliados';
+  SVIcons = 'Iconos';
+  SVBitmaps = 'Bitmaps';
+  SGridTooLarge = 'Malla demasiado grande para esta operacion';
+{?}  STooManyDeleted = 'Zu viele Zeilen oder Spalten gelöscht';
+  SIndexOutOfRange = 'Indice de malla fuera de rango';
+  SFixedColTooBig = 'El numero de columnas fijas tiene que ser menor que el contador Column';
+  SFixedRowTooBig = 'El numero de filas fijas tiene que ser menor que el contador Row';
+{?}  SInvalidStringGridOp = 'Es können keine Zeilen des ''Grids'' gelöscht oder eingefügt werden';
+  SParseError = '%s en Linia %d';
+
+  SIdentifierExpected = 'Falta identificador';
+  SStringExpected = 'Falta string';
+  SNumberExpected = 'Falta numero';
+
+  SCharExpected = 'Falta %s';
+
+  SSymbolExpected = 'Falta %s';
+
+  SInvalidNumber = 'Valor numerico no valido';
+  SInvalidString = 'Constante string no valida';
+  SInvalidProperty = 'Valor de propiedad no valido';
+  SInvalidBinary = 'Binario no valido';
+  SOutlineIndexError = 'Indice de nodo no encontrado';
+  SOutlineExpandError = 'El nodo padre tiene que ser expandido';
+  SInvalidCurrentItem = 'Item no valido';
+  SMaskErr = 'Mascara no valida';
+  SMaskEditErr = 'Mascara no valida. Usa la tecla ESC para deshacer los cambios.';
+  SOutlineError = 'Indice de nodo no valido';
+  SOutlineBadLevel = '???';
+{?}  SOutlineSelection = 'Ungültige Auswahl';
+{?}  SOutlineFileLoad = 'Fehler beim Dateiladen';
+{?}  SOutlineLongLine = 'Zeile zu lang';
+{?}  SOutlineMaxLevels = 'Maximale Gliederungstiefe überschritten';
+
+  SMsgDlgWarning = 'Atencion';
+  SMsgDlgError = 'Error';
+  SMsgDlgInformation = 'Informacion';
+  SMsgDlgConfirm = 'Confirmar';
+  SMsgDlgYes = '&Si';
+  SMsgDlgNo = '&No';
+  SMsgDlgOK = 'Aceptar';
+  SMsgDlgCancel = 'Cancelar';
+  SMsgDlgHelp = '&Ayuda';
+  SMsgDlgHelpNone = 'No hay ayuda disponible';
+  SMsgDlgHelpHelp = 'Ayuda';
+  SMsgDlgAbort = 'A&bortar';
+  SMsgDlgRetry = '&Reintentar';
+  SMsgDlgIgnore = '&Ignorar';
+  SMsgDlgAll = '&Todo';
+  SMsgDlgNoToAll = 'N&o a todo';
+  SMsgDlgYesToAll = 'Si a To&do';
+
+  SmkcBkSp = 'Backspace';
+  SmkcTab = 'Tabulador';
+  SmkcEsc = 'Esc';
+  SmkcEnter = 'Intro';
+  SmkcSpace = 'Espacio';
+  SmkcPgUp = 'Pagina arriva';
+  SmkcPgDn = 'Pagina abajo';
+  SmkcEnd = 'Fin';
+  SmkcHome = 'Inicio';
+  SmkcLeft = 'Izquierda';
+  SmkcUp = 'Arriba';
+  SmkcRight = 'Derecha';
+  SmkcDown = 'Abajo';
+  SmkcIns = 'Insertar';
+  SmkcDel = 'Suprimir';
+  SmkcShift = 'Shift+';
+  SmkcCtrl = 'Ctrl+';
+  SmkcAlt = 'Alt+';
+
+  srUnknown = '(Desconocido)';
+  srNone = '(Vacio)';
+  SOutOfRange = 'El valor tiene que estar entre %d y %d';
+  SCannotCreateName = 'No es posible use el nombre estandard para un componente desconocido';
+
+{?}  SDateEncodeError = 'Ungültiges Argument für Datumskodierung';
+{?}  STimeEncodeError = 'Ungültiges Argument für Zeitkodierung';
+{?}  SInvalidDate = '''''%s'''' ist kein gültiges Datum';
+{?}  SInvalidTime = '''''%s'''' ist keine gültige Zeit';
+{?}  SInvalidDateTime = '''''%s'''' ist kein gültiges Datum und Zeit';
+{?}  SInsertLineError = 'Zeile kann nicht eingefügt werden';
+
+{?}  SCannotDragForm = 'Formulare können nicht gezogen werden';
+{?}  SPutObjectError = 'PutObject auf undefiniertes Element';
+{?}  SCardDLLNotLoaded = 'CARDS.DLL kann nicht geladen werden';
+{?}  SDuplicateCardId = 'Doppelte CardId gefunden';
+
+{?}  SDdeErr = 'Ein Fehler wurde von der DDE zurückgeliefert  ($0%x)';
+{?}  SDdeConvErr = 'DDE Fehler - Konversation wurde nicht hergestellt ($0%x)';
+{?}  SDdeMemErr = 'Fehler trat auf, da unzureichender Speicher für DDE ($0%x)';
+{?}  SDdeNoConnect = 'DDE-Konversation kann nicht eingerichtet werden';
+
+
+{?}  SDefaultFilter = 'Alle Dateien (*.*)|*.*';
+{?}  sAllFilter = 'Alle Dateien';
+{?}  SNoVolumeLabel = ': [ - Ohne Namen - ]';
+
+{?}  SConfirmCreateDir = 'Das angegebene Verzeichnis existiert nicht. Soll es angelegt werden?';
+{?}  SSelectDirCap = 'Verzeichnis auswählen';
+{?}  SCannotCreateDir = 'Das Verzeichnis kann nicht erstellt werden';
+{?}  SDirNameCap = 'Verzeichnis&name:';
+{?}  SDrivesCap = '&Laufwerke:';
+{?}  SDirsCap = '&Verzeichnisse:';
+{?}  SFilesCap = '&Dateien: (*.*)';
+{?}  SNetworkCap = 'Ne&tzwerk...';
+
+{?}  SColorPrefix = 'Farbe';
+  SColorTags = 'ABCDEFGHIJKLMNOP';
+
+{?}  SInvalidClipFmt = 'Ungültiges Format der Zwischenablage';
+{?}  SIconToClipboard = 'Zwischenablage unterstützt keine Symbole';
+
+{?}  SDefault = 'Vorgabe';
+
+{?}  SInvalidMemoSize = 'Text überschreitet Memo-Kapazität';
+{?}  SCustomColors = 'Selbstdefinierte Farben';
+{?}  SInvalidPrinterOp = 'Operation auf ausgewähltem Drucker nicht verfügbar';
+{?}  SNoDefaultPrinter = 'Zur Zeit ist kein Standard-Drucker gewählt';
+
+{?}  SIniFileWriteError = 'nach %s kann nicht geschrieben werden';
+
+{?}  SBitsIndexError = 'Bits-Index außerhalb des zulässigen Bereichs';
+
+{?}  SUntitled = '(Unbenannt)';
+
+{?}  SInvalidRegType = 'Ungültiger Datentyp für ''%s''';
+{?}  SRegCreateFailed = 'Erzeugung von Schlüssel %s misslungen';
+{?}  SRegSetDataFailed = 'Konnte Daten für ''%s'' nicht setzen';
+{?}  SRegGetDataFailed = 'Konnte Daten für ''%s'' nicht holen';
+
+{?}  SUnknownConversion = 'Unbekannte Dateierweiterung für RichEdit-Konvertierung (.%s)';
+{?}  SDuplicateMenus = 'Menü ''%s'' wird bereits von einem anderen Formular benutzt';
+
+{?}  SPictureLabel = 'Bild:';
+  SPictureDesc = ' (%dx%d)';
+{?}  SPreviewLabel = 'Vorschau';
+
+{?}  SCannotOpenAVI = 'AVI kann nicht geöffnet werden';
+
+{?}  SNotOpenErr = 'Kein MCI-Gerät geöffnet';
+{?}  SMPOpenFilter = 'Alle Dateien (*.*)|*.*|Wave-Dateien (*.WAV)|*.WAV|Midi-Dateien (*.MID)|*.MID|Video für Windows (*.avi)|*.avi';
+  SMCINil = '';
+  SMCIAVIVideo = 'AVIVideo';
+  SMCICDAudio = 'CDAudio';
+  SMCIDAT = 'DAT';
+  SMCIDigitalVideo = 'DigitalVideo';
+  SMCIMMMovie = 'MMMovie';
+  SMCIOther = 'Andere';
+  SMCIOverlay = 'Overlay';
+  SMCIScanner = 'Scanner';
+  SMCISequencer = 'Sequencer';
+  SMCIVCR = 'VCR';
+  SMCIVideodisc = 'Videodisc';
+  SMCIWaveAudio = 'WaveAudio';
+  SMCIUnknownError = 'Unbekannter Fehlercode';
+
+  SBoldItalicFont = 'Negrita cursiva';
+  SBoldFont = 'Negrita';
+  SItalicFont = 'Cursiva';
+  SRegularFont = 'Normal';
+
+{?}  SPropertiesVerb = 'Eigenschaften';

fcl/inc/cregist.inc

@@ -0,0 +1,161 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999 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.
+
+ **********************************************************************}
+
+
+
+{ Class registration routines }
+
+procedure RegisterClass(AClass: TPersistentClass);
+
+begin
+end;
+
+
+procedure RegisterClasses(AClasses: array of TPersistentClass);
+
+begin
+end;
+
+
+procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
+
+begin
+end;
+
+
+procedure UnRegisterClass(AClass: TPersistentClass);
+
+begin
+end;
+
+
+procedure UnRegisterClasses(AClasses: array of TPersistentClass);
+
+begin
+end;
+
+
+procedure UnRegisterModuleClasses(Module: HMODULE);
+
+begin
+end;
+
+
+function FindClass(const ClassName: string): TPersistentClass;
+
+begin
+  FindClass:=nil;
+end;
+
+
+function GetClass(const ClassName: string): TPersistentClass;
+
+begin
+  GetClass:=nil;
+end;
+
+
+
+{ Component registration routines }
+
+type
+  TComponentPage = class(TCollectionItem)
+  public
+    Name: String;
+    Classes: TList;
+  end;
+var
+  ComponentPages: TCollection;
+
+procedure InitComponentPages;
+begin
+  ComponentPages := TCollection.Create(TComponentPage);
+  { Add a empty page which will be used for storing the NoIcon components }
+  ComponentPages.Add;
+end;
+
+procedure RegisterComponents(const Page: string;
+  ComponentClasses: array of TComponentClass);
+var
+  i: Integer;
+  pg: TComponentPage;
+begin
+  if Page = '' then exit;  { prevent caller from doing nonsense }
+
+  pg := nil;
+  if not Assigned(ComponentPages) then
+    InitComponentPages
+  else
+    for i := 0 to ComponentPages.Count - 1 do
+      if TComponentPage(ComponentPages.Items[i]).Name = Page then begin
+        pg := TComponentPage(ComponentPages.Items[i]);
+	break;
+      end;
+
+  if pg = nil then begin
+    pg := TComponentPage(ComponentPages.Add);
+    pg.Name := Page;
+  end;
+
+  if pg.Classes = nil then
+    pg.Classes := TList.Create;
+
+  for i := Low(ComponentClasses) to High(ComponentClasses) do
+    pg.Classes.Add(ComponentClasses[i]);
+
+  if Assigned(RegisterComponentsProc) then
+    RegisterComponentsProc(Page, ComponentClasses);
+end;
+
+
+procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
+var
+  pg: TComponentPage;
+  i: Integer;
+begin
+  if not Assigned(ComponentPages) then
+    InitComponentPages;
+
+  pg := TComponentPage(ComponentPages.Items[0]);
+  if pg.Classes = nil then
+    pg.Classes := TList.Create;
+
+  for i := Low(ComponentClasses) to High(ComponentClasses) do
+    pg.Classes.Add(ComponentClasses[i]);
+
+  if Assigned(RegisterNoIconProc) then
+    RegisterNoIconProc(ComponentClasses);
+end;
+
+
+procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass;
+  AxRegType: TActiveXRegType);
+
+begin
+end;
+
+
+{
+  $Log$
+  Revision 1.3  2000-01-06 01:20:33  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:07  peter
+    * moved to packages dir
+
+  Revision 1.1  1999/09/11 22:02:35  fcl
+  * Imported function skeletons from old classes.inc
+  * Implementation of RegisterComponents and RegisterNoIcon  (sg)
+
+}

fcl/inc/ezcgi.pp

@@ -0,0 +1,392 @@
+unit ezcgi;
+
+{$mode delphi}
+{$H+ }
+
+interface
+
+uses classes, strings, sysutils;
+
+const
+   hexTable = '0123456789ABCDEF';
+
+type
+   ECGIException = class(Exception);
+
+   TEZcgi = class(TObject)
+   private
+      { Private declarations }
+      FVariables : TStringList;
+      FName : String;
+      FEmail : String;
+      FQueryString : String;
+
+      { Token variables }
+      aString : String;
+      aSepStr : String;
+      aPos    : Byte;
+      aLenStr : Byte;
+      aLenSep : Byte;
+
+      procedure InitToken(aStr, aSep : String);
+      function NextToken(var aToken : String; var aSepChar : Char) : Boolean;
+
+      procedure GetQueryItems;
+      procedure ProcessRequest;
+      procedure LoadEnvVariables;
+      function GetVal(Index : String) : String;      
+      function GetName(Index : Integer) : String;      
+      function GetVariable(Index : Integer) : String;      
+      function GetVarCount : Integer;
+      procedure ReadPostQuery;
+      procedure ReadGetQuery;
+   protected
+      { Protected declarations }
+
+      procedure OutputError(errorMessage : String);
+   public
+      { Public declarations }
+      constructor Create;
+      destructor Destroy; override;
+      procedure Run;
+      procedure WriteContent(ctype : String);
+      procedure PutLine(sOut : String);
+      function GetValue(Index : String; defaultValue : String) : String;
+      
+      procedure DoPost; virtual;
+      procedure DoGet; virtual;
+
+      property Values[Index : String] : String read GetVal;
+      property Names[Index : Integer] : String read GetName;
+      property Variables[Index : Integer] : String read GetVariable;
+      property VariableCount : Integer read GetVarCount;
+      
+      property Name : String read FName write FName;
+      property Email : String read FEmail write FEmail;
+   end;
+
+implementation
+
+{ *********** Include OS-dependent Getenv Call ************ }
+
+{$I ezcgi.inc}
+
+{ *********** Public Methods *************** }
+
+constructor TEZcgi.Create;
+begin
+   FName := 'No name available';
+   FEmail := 'Email address unavailable';
+
+   FVariables := TStringList.Create;
+
+   LoadEnvVariables;
+   
+end;
+
+destructor TEZcgi.Destroy;
+begin
+   FVariables.Free;
+end;
+
+procedure TEZcgi.Run;
+begin
+   ProcessRequest;
+end;
+
+procedure TEZcgi.DoPost;
+begin
+  // Must be overriden by child class
+end;
+
+procedure TEZcgi.DoGet;
+begin
+  // Must be overriden by child class
+end;
+
+procedure TEZcgi.WriteContent(ctype : String);
+begin
+   writeln('Content-Type: ',ctype);
+   writeln;
+end;
+
+procedure TEZcgi.PutLine(sOut : String);
+begin
+   writeln(sOut);
+end;
+
+function TEZcgi.GetValue(Index, defaultValue : String) : String;
+begin
+   result := GetVal(Index);
+   if result = '' then
+      result := defaultValue;
+end;
+
+
+{ *********** Private Methods *************** }
+
+procedure TEZcgi.LoadEnvVariables;
+
+   procedure GetEData(variable : String);
+   var
+      tempStr : String;
+   begin
+      // This is a system dependent call !!
+      tempStr := GetEnv(variable);
+      if tempStr <> '' then
+         FVariables.Add(variable + '=' + tempStr);
+   end;
+
+begin
+
+   { Standard CGI Environment Variables }
+   GetEData('AUTH_TYPE');
+   GetEData('CONTENT_LENGTH');
+   GetEData('CONTENT_TYPE');
+   GetEData('GATEWAY_INTERFACE');
+   GetEData('PATH_INFO');
+   GetEData('PATH_TRANSLATED');
+   GetEData('QUERY_STRING');
+   GetEData('REMOTE_ADDR');
+   GetEData('REMOTE_HOST');
+   GetEData('REMOTE_IDENT');
+   GetEData('REMOTE_USER');
+   GetEData('REQUEST_METHOD');
+   GetEData('SCRIPT_NAME');
+   GetEData('SERVER_NAME');
+   GetEData('SERVER_PORT');
+   GetEData('SERVER_PROTOCOL');
+   GetEData('SERVER_SOFTWARE');
+
+
+   { Standard HTTP Environment Variables }
+   GetEData('HTTP_ACCEPT');
+   GetEData('HTTP_ACCEPT_CHARSET');
+   GetEData('HTTP_ACCEPT_ENCODING');
+   GetEData('HTTP_IF_MODIFIED_SINCE');
+   GetEData('HTTP_REFERER');
+   GetEData('HTTP_USER_AGENT');
+end;
+
+procedure TEZcgi.ProcessRequest;
+var
+   request : String;
+begin
+
+   request := GetVal('REQUEST_METHOD');
+   
+   if request = '' then
+      OutputError('No REQUEST_METHOD passed from server!')
+   else if request = 'POST' then
+   begin
+      ReadPostQuery;
+      DoPost;
+   end
+   else if request = 'GET' then
+      begin
+         ReadGetQuery;
+	 DoGet;
+      end
+   else
+      OutputError('Invalid REQUEST_METHOD passed from server!');
+end;
+
+function TEZcgi.GetVal(Index : String) : String;
+begin
+   result := FVariables.Values[Index];
+end;
+
+function TEZcgi.GetName(Index : Integer) : String;
+begin
+   result := FVariables.Names[Index];
+end;
+
+function TEZcgi.GetVariable(Index : Integer) : String;
+begin
+   result := FVariables[Index];
+end;
+
+function TEZcgi.GetVarCount : Integer;
+begin
+   result := FVariables.Count;
+end;
+
+procedure TEZcgi.ReadPostQuery;
+var
+   index : Integer;
+   ch : Char;
+   temp : String;
+   code : Word;
+   contentLength : Integer;
+   theType : String;
+      
+begin
+
+   temp := GetVal('CONTENT_LENGTH');
+   if Length(temp) > 0 then
+   begin
+      Val(temp, contentLength, code);
+      if code <> 0 then
+         contentLength := 0;
+   end;
+
+   if contentLength = 0 then
+      OutputError('No content length passed from server!');
+
+   theType := UpperCase(GetVal('CONTENT_TYPE'));
+
+   if theType <> 'APPLICATION/X-WWW-FORM-URLENCODED' then
+      OutputError('No content type passed from server!');
+
+   FQueryString := '';
+
+   for index := 0 to contentLength do
+   begin
+      Read(ch);
+      FQueryString := FQueryString + ch;
+   end;
+
+   GetQueryItems;
+end;
+
+procedure TEZcgi.ReadGetQuery;
+begin
+   FQueryString := GetVal('QUERY_STRING');
+
+   if FQueryString = '' then
+      OutputError('No QUERY_STRING passed from server!');
+
+   GetQueryItems;
+end;
+
+procedure TEZcgi.GetQueryItems;
+var
+   queryItem : String;
+   delimiter : Char;
+
+   function hexConverter(h1, h2 : Char) : Char;
+   var
+      thex : byte;
+   begin
+      tHex := (Pos(upcase(h1), hexTable) - 1) * 16;
+      tHex := tHex + Pos(upcase(h2), hexTable) - 1;
+
+      result := chr(thex);
+   end;
+
+   procedure Convert_ESC_Chars;
+   var
+      index : Integer;
+   begin
+      repeat
+         index := Pos('+', queryItem);
+	 if index > 0 then
+	    queryItem[index] := Chr(32);
+      until index = 0;
+      repeat
+         index := Pos('%', queryItem);
+	 if index > 0 then
+	 begin
+	    queryItem[index] := hexConverter(queryItem[index + 1], queryItem[index + 2]);
+	    system.Delete(queryItem, index + 1, 2);
+	 end;
+      until index = 0;
+   end;
+
+begin
+   InitToken(FQueryString, '&');
+   
+   while NextToken(queryItem, delimiter) do
+   begin
+      if queryItem <> '' then
+      begin
+         Convert_ESC_Chars;
+         FVariables.Add(queryItem);
+      end;
+   end;
+end;
+
+procedure TEZcgi.OutputError(errorMessage : String);
+begin
+   WriteContent('text/html');
+   writeln('<html><head><title>CGI ERROR</title></head>');
+   writeln('<body>');
+   writeln('<center><hr><h1>CGI ERROR</h1><hr></center><br><br>');
+   writeln('This CGI application encountered the following error: <br>');
+   writeln('<ul><br>');
+   writeln('<li> error: ',errorMessage,'<br><hr>'); 
+   writeln('<h5><p><i>Notify ',FName,' <a href="mailto:',FEmail,'">',FEmail,'</a></i></p></h5>');
+   writeln('</body></html>');
+
+   Raise ECGIException.Create(errorMessage);
+end;
+
+procedure TEZcgi.InitToken(aStr, aSep : String);
+begin
+     aString := aStr;
+     aSepStr := aSep;
+     aPos    := 1;
+     aLenStr := Length(aString);
+     aLenSep := Length(aSepStr);
+end;
+
+function TEZcgi.NextToken(var aToken : String; var aSepChar : Char) : Boolean;
+var
+   i : Byte;
+   j : Byte;
+   BoT : Byte;
+   EoT : Byte;
+   isSep : Boolean;
+
+begin
+   BoT := aPos;
+   EoT := aPos;
+   for i := aPos to aLenStr do
+   begin
+      IsSep := false;
+      for j := 1 to aLenSep do
+      begin
+         if aString[i] = aSepStr[j] then
+         begin
+            IsSep := true;
+            Break;
+         end;
+      end;
+      if IsSep then
+      begin
+         EoT  := i;
+         aPos := i + 1;
+         aSepChar := aString[i];
+         Break;
+      end
+      else
+      begin
+         if i = aLenStr then
+         begin
+            EoT  := i;
+            aPos := i;
+            Break;
+         end;
+      end;
+   end;
+   if aPos < aLenStr then
+   begin
+      aToken := Copy(aString, BoT, EoT - BoT);
+      Result := true;
+   end
+   else
+   begin
+      if aPos = aLenStr then
+      begin
+         aToken := Copy(aString, BoT, EoT - BoT + 1);
+         Result := true;
+         aPos   := aPos + 1;
+      end
+      else
+      begin
+         Result := false;
+      end;
+   end;
+end;
+
+end.

fcl/inc/filer.inc

@@ -0,0 +1,32 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+{ *********************************************************************
+  *                         TFiler                                    *
+  *********************************************************************}
+
+{
+  $Log$
+  Revision 1.4  2000-01-06 01:20:33  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  2000/01/04 18:07:16  michael
+  + Streaming implemented
+
+  Revision 1.2  1998/08/24 12:38:23  michael
+  small fixes
+
+  Revision 1.1  1998/05/04 14:30:11  michael
+  * Split file according to Class; implemented dummys for all methods, so unit compiles.
+
+}

fcl/inc/filerec.inc

@@ -0,0 +1,56 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by the Free Pascal development team
+
+    FileRec record definition
+
+
+    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.
+
+ **********************************************************************}
+
+{
+  This file contains the definition of the filerec record.
+  It is put separately, so it is available outside the system
+  unit without sacrificing TP compatibility.
+}
+
+const
+  filerecnamelength = 255;
+type
+  FileRec = Packed Record
+    Handle,
+    Mode,
+    RecSize   : longint;
+    _private  : array[1..32] of byte;
+    UserData  : array[1..16] of byte;
+    name      : array[0..filerecnamelength] of char;
+  End;
+
+{
+  $Log$
+  Revision 1.3  2000-01-06 01:20:33  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:07  peter
+    * moved to packages dir
+
+  Revision 1.1  1999/08/09 16:18:00  michael
+  + Added filerec.inc for xmlread changes by Sebastian guenther
+
+  Revision 1.5  1998/09/14 10:48:15  peter
+    * FPC_ names
+    * Heap manager is now system independent
+
+  Revision 1.4  1998/09/04 18:16:13  peter
+    * uniform filerec/textrec (with recsize:longint and name:0..255)
+
+  Revision 1.3  1998/05/21 11:55:59  carl
+   * works with all OS
+}

fcl/inc/gettext.pp

@@ -0,0 +1,278 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1998 by the Free Pascal development team
+
+    Gettext interface to resourcestrings.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$MODE objfpc}
+{$H+}
+
+unit gettext;
+
+interface
+
+uses sysutils, classes;
+
+const
+  MOFileHeaderMagic = $950412de;
+
+type
+
+  TMOFileHeader = packed record
+    magic: LongWord;             // MOFileHeaderMagic
+    revision: LongWord;          // 0
+    nstrings: LongWord;          // Number of string pairs
+    OrigTabOffset: LongWord;     // Offset of original string offset table
+    TransTabOffset: LongWord;    // Offset of translated string offset table
+    HashTabSize: LongWord;       // Size of hashing table
+    HashTabOffset: LongWord;     // Offset of first hashing table entry
+  end;
+
+  TMOStringInfo = packed record
+    length: LongWord;
+    offset: LongWord;
+  end;
+
+  TMOStringTable = array[LongWord] of TMOStringInfo;
+  PMOStringTable = ^TMOStringTable;
+
+
+  TLongWordArray = array[LongWord] of LongWord;
+  PLongWordArray = ^TLongWordArray;
+
+  TPCharArray = array[LongWord] of PChar;
+  PPCharArray = ^TPCharArray;
+
+  TMOFile = class
+  protected
+    HashTableSize: LongWord;
+    HashTable: PLongWordArray;
+    OrigTable, TranslTable: PMOStringTable;
+    OrigStrings, TranslStrings: PPCharArray;
+  public
+    constructor Create(AFilename: String);
+    constructor Create(AStream: TStream);
+    function Translate(AOrig: PChar; ALen: Integer; AHash: LongWord): String;
+    function Translate(AOrig: String; AHash: LongWord): String;
+    function Translate(AOrig: String): String;
+  end;
+
+  EMOFileError = class(Exception)
+  end;
+
+
+  procedure TranslateResourceStrings(AFile: TMOFile);
+  procedure TranslateResourceStrings(AFilename: String);
+
+implementation
+
+uses dos;
+
+constructor TMOFile.Create(AStream: TStream);
+var
+  header: TMOFileHeader;
+  i: Integer;
+  s: String;
+begin
+  inherited Create;
+
+  AStream.Read(header, Sizeof(header));
+
+  if header.magic <> MOFileHeaderMagic then
+    raise EMOFileError.Create('Invalid magic - not a MO file?');
+
+{  WriteLn('Revision: ', header.revision);
+  WriteLn('# of strings: ', header.nstrings);
+  WriteLn('OrigTabOffset: ', header.OrigTabOffset);
+  WriteLn('TransTabOffset: ', header.TransTabOffset);
+  WriteLn('# of hashcodes: ', header.HashTabSize);
+  WriteLn('HashTabOffset: ', header.HashTabOffset);
+}
+  GetMem(OrigTable, header.nstrings * SizeOf(TMOStringInfo));
+  GetMem(TranslTable, header.nstrings * SizeOf(TMOStringInfo));
+  GetMem(OrigStrings, header.nstrings * SizeOf(PChar));
+  GetMem(TranslStrings, header.nstrings * SizeOf(PChar));
+
+
+  AStream.Position := header.OrigTabOffset;
+  AStream.Read(OrigTable^, header.nstrings * SizeOf(TMOStringInfo));
+
+  AStream.Position := header.TransTabOffset;
+  AStream.Read(TranslTable^, header.nstrings * SizeOf(TMOStringInfo));
+
+
+  // Read strings
+  for i := 0 to header.nstrings - 1 do begin
+    AStream.Position := OrigTable^[i].offset;
+    SetLength(s, OrigTable^[i].length);
+    AStream.Read(s[1], OrigTable^[i].length);
+    OrigStrings^[i] := StrNew(PChar(s));
+  end;
+
+  for i := 0 to header.nstrings - 1 do begin
+    AStream.Position := TranslTable^[i].offset;
+    SetLength(s, TranslTable^[i].length);
+    AStream.Read(s[1], TranslTable^[i].length);
+    TranslStrings^[i] := StrNew(PChar(s));
+  end;
+
+  // Read hashing table
+  HashTableSize := header.HashTabSize;
+  GetMem(HashTable, 4 * HashTableSize);
+  AStream.Position := header.HashTabOffset;
+  AStream.Read(HashTable^, 4 * HashTableSize);
+end;
+
+constructor TMOFile.Create(AFilename: String);
+var
+  f: TStream;
+begin
+  f := TFileStream.Create(AFilename, fmOpenRead);
+  try
+    Self.Create(f);
+  finally
+    f.Free;
+  end;
+end;
+
+
+function TMOFile.Translate(AOrig: PChar; ALen: Integer; AHash: LongWord): String;
+var
+  idx, incr, nstr: LongWord;
+begin
+  idx := AHash mod HashTableSize;
+  incr := 1 + (AHash mod (HashTableSize - 2));
+  while True do begin
+    nstr := HashTable^[idx];
+    if nstr = 0 then begin
+      Result := '';
+      exit;
+    end;
+    if (OrigTable^[nstr - 1].length = ALen) and
+       (StrComp(OrigStrings^[nstr - 1], AOrig) = 0) then begin
+      Result := TranslStrings^[nstr - 1];
+      exit;
+    end;
+    if idx >= HashTableSize - incr then
+      Dec(idx, HashTableSize - incr)
+    else
+      Inc(idx, incr);
+  end;
+end;
+
+function TMOFile.Translate(AOrig: String; AHash: LongWord): String;
+begin
+  Result := Translate(PChar(AOrig), Length(AOrig), AHash);
+end;
+
+function TMOFile.Translate(AOrig: String): String;
+begin
+  Result := Translate(AOrig, Hash(AOrig));
+end;
+
+
+// -------------------------------------------------------
+//   Resourcestring translation procedures
+// -------------------------------------------------------
+
+{
+  Define USEITERATOR if you want to translate the strings using
+  the SetResourceStrings call. This is not recommended for this
+  particular iplementation, since we must pass through a global 
+  variable TheFile : TMOFile. However that works too.
+}
+
+{$ifdef USEITERATOR}
+Var 
+  Thefile : TMOFile;
+
+Function Translate (Name,Value : AnsiString; Hash : Longint) : AnsiString;
+
+begin
+  Result:=TheFile.Translate(Value,Hash);
+end;
+
+procedure TranslateResourceStrings(AFile: TMOFile);
+var
+  i,j : Integer;
+  s : String;
+begin
+  TheFile:=AFile;
+  SetResourceStrings(@Translate);
+end;
+{$else}
+
+procedure TranslateResourceStrings(AFile: TMOFile);
+var
+  i,j,count : Integer;
+  s : String;
+begin
+  For I:=0 to ResourceStringTableCount-1 do
+    begin
+    Count:=ResourceStringCount(I);
+    For J:=0 to Count-1 do
+      begin
+      S:=AFile.Translate(GetResourceStringDefaultValue(I,J),
+                         GetResourceStringHash(I,J));
+      if S <> '' then
+        SetResourceStringValue(I,J,S);
+      end;
+    end;
+end;
+{$endif}
+
+procedure TranslateResourceStrings(AFilename: String);
+var
+  mo: TMOFile;
+  lang: String;
+begin
+  lang := Copy(GetEnv('LANG'), 1, 2);
+  try
+    mo := TMOFile.Create(Format(AFilename, [lang]));
+    TranslateResourceStrings(mo);
+    mo.Free;
+  except
+    on e: Exception do;
+  end;
+end;
+
+end.
+
+
+{
+  $Log$
+  Revision 1.7  2000-01-06 01:20:33  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:07  peter
+    * moved to packages dir
+
+  Revision 1.5  1999/10/15 19:42:18  michael
+  hash is available in tables
+
+  Revision 1.4  1999/08/28 13:35:16  michael
+  * Uses now hash function of objpas
+
+  Revision 1.3  1999/08/27 15:53:36  michael
+  + Adapted to new resourcestring mechanism. Uses objpas interface only
+
+  Revision 1.2  1999/08/26 11:05:15  peter
+    * updated for new resourcestrings
+
+  Revision 1.1  1999/08/04 11:31:09  michael
+  * Added gettext
+
+  Revision 1.1  1999/07/25 16:23:31  michael
+  + Initial implementation from Sebastian Guenther
+
+}

fcl/inc/idea.pp

@@ -0,0 +1,410 @@
+UNIT IDEA;
+
+{
+ IDEA encryption routines for pascal
+ ported from PGP 2.3
+
+ IDEA encryption routines for pascal, ported from PGP 2.3
+ Copyright (C) for this port 1998 Ingo Korb
+ Copyright (C) for the stream support 1999 Michael Van Canneyt
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Library General Public
+ License as published by the Free Software Foundation; either
+ version 2 of the License, or (at your option) any later version.
+
+ This library 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.  See the GNU
+ Library General Public License for more details.
+
+ You should have received a copy of the GNU Library General Public
+ License along with this library; if not, write to the Free
+ Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+}
+
+
+{$R-,Q-}
+{ Not nice but fast... }
+
+INTERFACE
+
+Uses Sysutils,Classes;
+
+CONST IDEAKEYSIZE = 16;
+      IDEABLOCKSIZE = 8;
+      ROUNDS = 8;
+      KEYLEN = (6*ROUNDS+4);
+
+TYPE IDEAkey = ARRAY[0..keylen-1] OF Word;
+     ideacryptkey = ARRAY[0..7] OF Word;
+     ideacryptdata = ARRAY[0..3] OF Word;
+
+PROCEDURE EnKeyIdea(userkey: ideacryptkey; VAR z: ideakey);
+PROCEDURE DeKeyIdea(z: IDEAKey; VAR dk: ideakey);
+PROCEDURE CipherIdea(input: ideacryptdata; VAR out: ideacryptdata; z: IDEAkey);
+
+Type  
+
+EIDEAError = Class(EStreamError);
+
+TIDEAEncryptStream = Class(TStream)
+  private
+    FDest : TStream;
+    FKey : IDEAKey;
+    FData : IDEACryptData;
+    FBufpos : Byte;
+    FPos : Longint;
+  public
+    constructor Create(AKey : ideakey; Dest: TStream);
+    destructor Destroy; override;
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+    procedure Flush;
+    Property Key : IDEAKey Read FKey;
+  end;
+
+TIDEADeCryptStream = Class(TStream)
+  private
+    FSRC : TStream;
+    FKey : IDEAKey;
+    FData : IDEACryptData;
+    FBufpos : Byte;
+    FPos : Longint;
+  public
+    constructor Create(AKey : ideakey; Src: TStream);
+    destructor Destroy; override;
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+    Property Key : IDEAKey Read FKey;
+  end;
+
+IMPLEMENTATION
+
+Const 
+  SNoSeekAllowed = 'Seek not allowed on encryption streams';
+  SNoReadAllowed = 'Reading from encryption stream not allowed';
+  SNoWriteAllowed = 'Writing to decryption stream not allowed';
+
+Type 
+  PByte = ^Byte;
+
+PROCEDURE mul(VAR a:Word; b: Word);
+VAR p: LongInt;
+BEGIN
+  IF (a <> 0) THEN BEGIN
+    IF (b <> 0) THEN BEGIN
+      p := LongInt(a)*b;
+      b := p;
+      a := p SHR 16;
+      IF (b < a) THEN a := b - a + 1
+                 ELSE a := b - a;
+    END ELSE a := 1 - a;
+  END ELSE a := 1-b;
+END;
+
+FUNCTION inv(x: word): Word;
+VAR t0,t1,q,y: Word;
+BEGIN
+  IF x <= 1 THEN BEGIN
+    inv := x;
+    exit;
+  END;
+  t1 := 65537 DIV x;
+  y := 65537 MOD x;
+  IF y = 1 THEN BEGIN
+    inv := Word(1-t1);
+    exit;
+  END;
+  t0 := 1;
+  REPEAT
+    q := x DIV y;
+    x := x MOD y;
+    t0 := t0 + q * t1;
+    IF x = 1 THEN BEGIN
+      inv := t0;
+      exit;
+    END;
+    q := y DIV x;
+    y := y MOD x;
+    t1 := t1 + q*t0;
+  UNTIL y = 1;
+  inv := word(1-t1);
+END;
+
+PROCEDURE EnKeyIdea(userkey: ideacryptkey; VAR z: ideakey);
+VAR zi,i,j: integer;
+BEGIN
+  FOR j := 0 TO 7 DO z[j] := userkey[j];
+  i := 0;
+  zi := 0;
+  i := 0;
+  FOR j := 8 TO keylen-1 DO BEGIN
+    Inc(i);
+    z[zi+i+7] := (z[zi+(i AND 7)] SHL 9) OR (z[zi+((i+1) AND 7)] SHR 7);
+    zi := zi + (i AND 8);
+    i := i AND 7;
+  END;
+  FOR i := 0 TO 7 DO userkey[i] := 0;
+  zi := 0;
+END;
+
+PROCEDURE DeKeyIdea(z: IDEAKey; VAR dk: ideakey);
+VAR j: Integer;
+    t1,t2,t3: Word;
+    p: IDEAKey;
+    ip,it,idk: Integer;
+    iz: Integer;
+BEGIN
+  iz := 0;
+  ip := keylen;
+  FOR j := 0 TO keylen - 1 DO p[j] := 0;
+  idk := 0;
+  t1 := inv(z[iz]);   Inc(iz);
+  t2 := not(z[iz])+1; Inc(iz);
+  t3 := not(z[iz])+1; Inc(iz);
+  Dec(ip); p[ip] := inv(z[iz]); Inc(iz);
+  Dec(ip); p[ip] := t3;
+  Dec(ip); p[ip] := t2;
+  Dec(ip); p[ip] := t1;
+  FOR j := 1 TO rounds-1 DO BEGIN
+    t1 := z[iz]; Inc(iz);
+    Dec(ip); p[ip] := z[iz]; Inc(iz);
+    Dec(ip); p[ip] := t1;
+    t1 := inv(z[iz]);   Inc(iz);
+    t2 := Not(z[iz])+1; Inc(iz);
+    t3 := Not(z[iz])+1; Inc(iz);
+    Dec(ip); p[ip] := inv(z[iz]); Inc(iz);
+    Dec(ip); p[ip] := t2;
+    Dec(ip); p[ip] := t3;
+    Dec(ip); p[ip] := t1;
+  END;
+  t1 := z[iz]; Inc(iz);
+  Dec(ip); p[ip] := z[iz]; Inc(iz);
+  Dec(ip); p[ip] := t1;
+  t1 := inv(z[iz]);   Inc(iz);
+  t2 := Not(z[iz])+1; Inc(iz);
+  t3 := Not(z[iz])+1; Inc(iz);
+  Dec(ip); p[ip] := inv(z[iz]); Inc(iz);
+  Dec(ip); p[ip] := t3;
+  Dec(ip); p[ip] := t2;
+  Dec(ip); p[ip] := t1;
+  FOR j := 0 TO KeyLen-1 DO BEGIN
+    dk[j] := p[j];
+    p[j] := 0;
+  END;
+  FOR j := 0 TO 51 DO z[j] := 0;
+  t1 := 0;
+  t2 := 0;
+  t3 := 0;
+  ip := 0;
+  it := 0;
+  idk := 0;
+  iz := 0;
+END;
+
+PROCEDURE CipherIdea(input: ideacryptdata; VAR out: ideacryptdata; z:
+IDEAkey);
+VAR x1, x2, x3, x4, t1, t2: Word;
+    r: Integer;
+    zi: Integer;
+BEGIN
+  zi := 0;
+  x1 := input[0];
+  x2 := input[1];
+  x3 := input[2];
+  x4 := input[3];
+  FOR r := 1 TO ROUNDS DO BEGIN
+    mul(x1,z[zi]);    Inc(zi);
+    x2 := x2 + z[zi]; Inc(zi);
+    x3 := x3 + z[zi]; Inc(zi);
+    mul(x4, z[zi]);   Inc(zi);
+    t2 := x1 XOR x3;
+    mul(t2, z[zi]);   Inc(zi);
+    t1 := t2 + (x2 XOR x4);
+    mul(t1, z[zi]);   Inc(zi);
+    t2 := t1+t2;
+    x1 := x1 XOR t1;
+    x4 := x4 XOR t2;
+    t2 := t2 XOR x2;
+    x2 := x3 XOR t1;
+    x3 := t2;
+  END;
+  mul(x1, z[zi]);       Inc(zi);
+  out[0] := x1;
+  out[1] := x3 + z[zi]; Inc(zi);
+  out[2] := x2 + z[zi]; Inc(zi);
+  Mul(x4,z[zi]);
+  out[3] := x4;
+  FOR r := 0 TO 3 DO input[r] := 0;
+  FOR r := 0 TO 51 DO z[r] := 0;
+  x1 := 0;
+  x2 := 0;
+  x3 := 0;
+  x4 := 0;
+  t1 := 0;
+  t2 := 0;
+  zi := 0;
+END;
+
+constructor TIDEAEncryptStream.Create(AKey : ideakey; Dest: TStream);
+
+begin
+  FKey:=Key;
+  FDest:=Dest;
+  FBufPos:=0;
+  Fpos:=0;
+end;
+
+Destructor TIDEAEncryptStream.Destroy; 
+
+
+begin
+  Flush;
+  Inherited Destroy;
+end;
+
+Procedure TIDEAEncryptStream.Flush;
+
+Var
+  OutData : IdeaCryptData;
+  
+begin
+  If FBufPos>0 then
+    begin 
+    // Fill with spaces.
+    FillChar(PByte(@FData)[FBufPos],SizeOf(FData)-FBufPos,' ');
+    CipherIdea(Fdata,OutData,FKey);
+    FDest.Write(OutData,SizeOf(OutData));
+    end;
+end;
+
+function TIDEAEncryptStream.Read(var Buffer; Count: Longint): Longint; 
+
+begin
+  Raise EIDEAError.Create(SNoReadAllowed);
+end;
+
+function TIDEAEncryptStream.Write(const Buffer; Count: Longint): Longint; 
+
+Var 
+  mvsize : Longint;
+  OutData : IDEAcryptdata;
+
+begin
+  Result:=0;
+  While Count>0 do
+    begin
+    MVsize:=Count;
+    If Mvsize>SizeOf(Fdata)-FBufPos then
+      mvsize:=SizeOf(FData)-FBufPos;
+    Move(Pbyte(@Buffer)[Result],PByte(@FData)[FBufPos],MVSize);
+    If FBufPos+mvSize=Sizeof(FData) then
+      begin
+      // Empty buffer.
+      CipherIdea(Fdata,OutData,FKey);
+      // this will raise an exception if needed.
+      FDest.Writebuffer(OutData,SizeOf(OutData));
+      FBufPos:=0;
+      end
+    else
+      inc(FBufPos,mvsize);
+    Dec(Count,MvSize);
+    Inc(Result,mvSize);
+    end;
+  Inc(FPos,Result);
+end;
+
+
+function TIDEAEncryptStream.Seek(Offset: Longint; Origin: Word): Longint; 
+
+begin
+  if (Offset = 0) and (Origin = soFromCurrent) then
+    Result := FPos
+  else
+    Raise EIDEAError.Create(SNoSeekAllowed);
+end;
+
+constructor TIDEADeCryptStream.Create(AKey : ideakey; Src: TStream);
+
+begin
+  inherited Create;
+  FKey:=Key;
+  FPos:=0;
+  FBufPos:=SizeOf(Fdata);
+  FSrc:=Src;
+end;
+
+destructor TIDEADeCryptStream.Destroy; 
+begin
+  Inherited destroy;
+end;
+
+function TIDEADeCryptStream.Read(var Buffer; Count: Longint): Longint; 
+  
+Var 
+  mvsize : Longint;
+  InData : IDEAcryptdata;
+
+begin
+  Result:=0;
+  While Count>0 do
+    begin
+    // Empty existing buffer.
+    If FBufPos<SizeOf(FData) then
+      begin
+      mvSize:=Sizeof(FData)-FBufPos;
+      If MvSize>count then 
+        mvsize:=Count;
+      Move(PByte(@FData)[FBufPos],Pbyte(@Buffer)[Result],MVSize);
+      Dec(Count,mvsize);
+      Inc(Result,mvsize);
+      inc(fBufPos,mvsize);
+      end;
+    // Fill buffer again if needed.  
+    If (FBufPos=SizeOf(FData)) and (Count>0) then
+      begin
+      mvsize:=FSrc.Read(InData,SizeOf(InData));
+      If mvsize>0 then
+        begin
+        If MvSize<SizeOf(InData) Then
+          // Fill with spaces
+          FillChar(PByte(@InData)[mvsize],SizeOf(InData)-mvsize,' ');
+        CipherIdea(InData,FData,FKey);
+        FBufPos:=0;
+        end
+      else
+        Count:=0; // No more data available from stream; st
+      end;
+    end;
+  Inc(FPos,Result);
+end;
+
+function TIDEADeCryptStream.Write(const Buffer; Count: Longint): Longint; 
+begin
+  Raise EIDEAError.Create(SNoReadAllowed);
+end;
+
+function TIDEADeCryptStream.Seek(Offset: Longint; Origin: Word): Longint; 
+
+Var Buffer : Array[0..1023] of byte;
+    i : longint;
+    
+begin
+  // Fake seek if possible by reading and discarding bytes.
+  If ((Offset>=0) and (Origin = soFromCurrent)) or
+    ((Offset>FPos) and (Origin = soFromBeginning)) then
+      begin
+      For I:=1 to (Offset div SizeOf(Buffer)) do
+        ReadBuffer(Buffer,SizeOf(Buffer));
+      ReadBuffer(Buffer,Offset mod SizeOf(Buffer));
+      Result:=FPos;
+      end
+  else             
+    Raise EIDEAError.Create(SNoSeekAllowed);
+end;
+
+END.
+

fcl/inc/inifiles.pp

@@ -0,0 +1,508 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 by Michael A. Hess
+
+    adapted from code by Stephan Schneider
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit IniFiles;
+
+{$mode objfpc}
+{$H+}
+
+interface
+
+uses Classes;
+
+type
+
+{ TIniFile class }
+
+   TIniFile = class(TObject)
+   private
+     FFileName   : string;
+     FStream     : TStream;
+     FFileBuffer : TStringList;
+     function GetName(const line : string) : string;
+     function GetValue(const line, name : string) : string;
+     function IsComment(const line : string) : boolean;
+     function IsSection(const line : string) : boolean;
+     function GetSectionIndex(const section : string) : integer;
+   protected
+     procedure SetFileName(const fn:string);
+     procedure SetStream(s:TStream);
+     procedure LoadFromFile;
+     procedure SaveToFile;
+     procedure LoadFromStream;
+     procedure SaveToStream;
+   public
+     constructor Create(const theFileName : string);
+     constructor Create(s:TStream);
+     destructor Destroy; override;
+     procedure DeleteKey(const section, ident : string);
+     procedure EraseSection(const section : string);
+     function ReadBool(const section, ident : string; defaultValue : boolean) : boolean;
+     function ReadInteger(const section, ident : string; defaultValue : longint) : longint;
+     procedure ReadSection(const section : string; strings : TStrings);
+     procedure ReadSections(strings : TStrings);
+     procedure ReadSectionValues(const section : string; strings : TStrings);
+     procedure ReadSectionRaw(const section : string; strings : TStrings);
+     function ReadString(const section, ident, defaultValue : string) : string;
+     procedure WriteBool(const section, ident : string; value : boolean);
+     procedure WriteInteger(const section, ident : string; value : longint);
+     procedure WriteString(const section, ident, value : string);
+     property FileName : String read FFileName;
+   end;
+
+implementation
+
+uses SysUtils;
+
+const
+   brackets  : array[0..1] of Char = ('[', ']');
+   separator : Char = '=';
+   comment   : Char = ';';
+
+
+{ TIniFile }
+
+constructor TIniFile.Create(const theFileName : string);
+begin
+   FFileName := theFileName;
+   FStream:=nil;
+   FFileBuffer := TStringList.Create;
+
+   if FileExists(fileName) then
+      LoadFromFile;
+end;
+
+constructor TIniFile.Create(s:TStream);
+begin
+   FFileName := '';
+   FStream:=s;
+   FFileBuffer := TStringList.Create;
+
+   LoadFromStream;
+end;
+
+destructor TIniFile.Destroy;
+begin
+   FFileBuffer.Free;
+end;
+
+function TIniFile.GetName(const line : string) : string;
+var
+   index,index2 : integer;
+begin
+   Result := '';
+   index := Pos(separator, line);
+   if index <> 0 then
+    begin
+      index2:=Pos(comment, line);
+      if (index2=0) or (index2>index) then
+       result := Trim(Copy(line, 1, index - 1));
+    end;
+end;
+
+function TIniFile.GetValue(const line, name : string) : string;
+var
+   index1,index2,index3 : integer;
+begin
+   result := '';
+   if (line <> '') and (name <> '') then
+   begin
+      index1 := Pos(name, line);
+      index2 := Pos(separator, line);
+      index3 := Pos(comment, line);
+      if index3=0 then
+       index3:=MaxInt;
+      if (index1 <> 0) and (index2 <> 0) and (index2 > index1) then
+         result := Trim(Copy(line, index2 + 1, index3));
+   end;
+end;
+
+function TIniFile.IsSection(const line : string) : boolean;
+var
+   str : string;
+begin
+   result := False;
+   if line <> '' then
+   begin
+      str := Trim(line);
+      if (str[1] = brackets[0]) and (str[Length(str)] = brackets[1]) then
+         result := True;
+   end;
+end;
+
+function TIniFile.IsComment(const line : string) : boolean;
+var
+   str : string;
+begin
+   result := False;
+   if line <> '' then
+   begin
+      str := Trim(line);
+      result := (str[1]=comment);
+   end;
+end;
+
+function TIniFile.GetSectionIndex(const section : string) : integer;
+begin
+   result := FFileBuffer.IndexOf(brackets[0] + section + brackets[1]);
+end;
+
+{ Load/Save }
+
+procedure TIniFile.SetFileName(const fn:string);
+begin
+  FFileName:=fn;
+end;
+
+procedure TIniFile.SetStream(s:TStream);
+begin
+  FStream:=s;
+end;
+
+procedure TIniFile.LoadFromFile;
+begin
+  if FFileName<>'' then
+   FFileBuffer.LoadFromFile(FFileName);
+end;
+
+procedure TIniFile.SaveToFile;
+begin
+  if FFileName<>'' then
+   FFileBuffer.SaveToFile(FFileName);
+end;
+
+procedure TIniFile.LoadFromStream;
+begin
+  if assigned(FStream) then
+   FFileBuffer.LoadFromStream(FStream);
+end;
+
+procedure TIniFile.SaveToStream;
+begin
+  if assigned(FStream) then
+   FFileBuffer.SaveToStream(FStream);
+end;
+
+{ Read all Names of one Section }
+
+procedure TIniFile.ReadSection(const section : string; strings : TStrings);
+var
+   index : integer;
+   name : string;
+begin
+   strings.BeginUpdate;
+   try
+      strings.Clear;
+      if FFileBuffer.Count > 0 then
+      begin
+         index := GetSectionIndex(section);
+         if index <> -1 then
+         begin
+            Inc(index);
+            while (index < FFileBuffer.Count) and not IsSection(FFileBuffer[index]) do
+            begin
+               name := GetName(FFileBuffer[index]);
+               if name <> '' then
+                  strings.Add(name);
+               Inc(index);
+            end;
+         end;
+      end;
+   finally
+      strings.EndUpdate;
+   end;
+end;
+
+{ Read all Sections of the Ini-File }
+
+procedure TIniFile.ReadSections(strings : TStrings);
+var
+   index : integer;
+   section : string;
+begin
+   strings.BeginUpdate;
+   try
+      strings.Clear;
+      if FFileBuffer.Count > 0 then
+      begin
+         index := 0;
+         while (index < FFileBuffer.Count) do
+         begin
+            if IsSection(FFileBuffer[index]) then
+            begin
+               section := Trim(FFileBuffer[index]);
+               Delete(section, 1, 1);
+               Delete(section, Length(section), 1);
+               strings.Add(Trim(section));
+            end;
+            Inc(index);
+         end;
+      end;
+   finally
+      strings.EndUpdate;
+   end;
+end;
+
+{ Reads a String-Value of "ident" in one "section".
+  The result is "defaultValue" if
+  o section doesn't exists
+  o ident doesn't exists
+  o ident doesn't have any assigned value }
+
+function TIniFile.ReadString(const section, ident, defaultValue : string) : string;
+var
+   index : integer;
+   value : string;
+begin
+   result := defaultValue;
+   if FFileBuffer.Count > 0 then
+   begin
+      index := GetSectionIndex(section);
+      if index <> -1 then
+      begin
+         Inc(index);
+         while (index < FFileBuffer.Count) and not IsSection(FFileBuffer[index]) do
+         begin
+            if GetName(FFileBuffer[index]) = ident then
+            begin
+              value := GetValue(FFileBuffer[index], ident);
+              if value <> '' then
+               begin
+                 result := value;
+                 if (result[length(result)]='\') then
+                  begin
+                    inc(index);
+                    while (index < FFileBuffer.Count) and (result[length(result)]='\') do
+                     begin
+                       result:=Copy(result,1,length(result)-1)+Trim(FFileBuffer[index]);
+                       inc(index);
+                     end;
+                  end;
+               end;
+              break;
+            end;
+            Inc(index);
+         end;
+      end;
+   end;
+end;
+
+{ Reads an Integer-Value of Ident in one Section }
+
+function TIniFile.ReadInteger(const section, ident : string; defaultValue : longint) : longint;
+var
+   intStr : string;
+begin
+   intStr := ReadString(section, ident, '');
+   { convert a Hex-Value }
+   if (Length(intStr) > 2) and (intStr[1] = '0') and ((intStr[2] = 'X') or (intStr[2] = 'x')) then
+      intStr := '$' + Copy(intStr, 3, Maxint);
+   result := StrToIntDef(intStr, defaultValue);
+end;
+
+{ Reads a Bool-Value of Ident in one Section }
+
+function TIniFile.ReadBool(const section, ident : string; defaultValue : boolean) : boolean;
+begin
+   result := ReadInteger(section, ident, Ord(defaultValue)) <> 0;
+end;
+
+{ Reads all Names + Values of one Section }
+
+procedure TIniFile.ReadSectionValues(const section : string; strings : TStrings);
+var
+   name : string;
+   value : string;
+   index : integer;
+begin
+   strings.BeginUpdate;
+   try
+      strings.Clear;
+      if FFileBuffer.Count > 0 then
+      begin
+         index := GetSectionIndex(section);
+         if index <> -1 then
+         begin
+            Inc(index);
+            while (index < FFileBuffer.Count) and not IsSection(FFileBuffer[index]) do
+            begin
+               name := GetName(FFileBuffer[index]);
+               if name <> '' then
+               begin
+                  value := GetValue(FFileBuffer[index], name);
+                  strings.Add(name + separator + value);
+               end;
+               Inc(index);
+            end;
+         end;
+      end;
+   finally
+      strings.EndUpdate;
+   end;
+end;
+
+procedure TIniFile.ReadSectionRaw(const section : string; strings : TStrings);
+var
+   eols,index : integer;
+begin
+   strings.BeginUpdate;
+   try
+      eols:=0;
+      strings.Clear;
+      if FFileBuffer.Count > 0 then
+      begin
+         index := GetSectionIndex(section);
+         if index <> -1 then
+         begin
+            Inc(index);
+            while (index < FFileBuffer.Count) and not IsSection(FFileBuffer[index]) do
+             begin
+               { Skip empty lines at the end of the section }
+               if FFileBuffer[index]='' then
+                inc(eols)
+               else
+                begin
+                  while eols>0 do
+                   begin
+                     Strings.Add('');
+                     dec(eols);
+                   end;
+                  if not IsComment(FFileBuffer[index]) then
+                   strings.Add(FFileBuffer[index]);
+                end;
+               Inc(index);
+             end;
+         end;
+      end;
+   finally
+      strings.EndUpdate;
+   end;
+end;
+
+{ Writes a String-Value for Ident in one Section.
+  Note: If Section and/or Ident don't exist, they will be placed in the Ini-File }
+
+procedure TIniFile.WriteString(const section, ident, value : string);
+var
+   index : integer;
+begin
+   index := GetSectionIndex(section);
+   { Section exists }
+   if index <> -1 then
+   begin
+      Inc(index);
+      while (index < FFileBuffer.Count) and not IsSection(FFileBuffer[index]) and
+            (GetName(FFileBuffer[index]) <> ident) do
+         Inc(index);
+      if (index >= FFileBuffer.Count) or IsSection(FFileBuffer[index]) then
+      begin         { End of File or ident doesn't exists in the section }
+         if ident <> '' then
+            FFileBuffer.Insert(index, ident + separator + value);
+      end
+      else if ident <> '' then   { Ident does exists in the section }
+         FFileBuffer[index] := ident + separator + value;
+   end
+   else   { section doesn't exists, so add new [section] with ident=value }
+   begin
+      FFileBuffer.Add('');
+      FFileBuffer.Add(brackets[0] + section + brackets[1]);
+      if ident <> '' then
+         FFileBuffer.Add(ident + separator + value);
+   end;
+   SaveToFile;
+end;
+
+{ Writes an Integer-Value for Ident in one Section }
+
+procedure TIniFile.WriteInteger(const section, ident : string; value : longint);
+begin
+   WriteString(section, ident, IntToStr(value));
+end;
+
+{ Writes a Bool-Value for Ident in one Section }
+
+procedure TIniFile.WriteBool(const section, ident : string; value : boolean);
+const
+   values: array[boolean] of string = ('0', '1');
+begin
+   WriteString(section, ident, values[Value]);
+end;
+
+{ Deletes the value of ident in one section.
+  Note: Only if section and ident exist, the value of ident will be set to NULL }
+
+procedure TIniFile.DeleteKey(const section, ident : string);
+var
+   index : integer;
+begin
+   index := GetSectionIndex(section);
+   if index <> -1 then
+   begin
+      Inc(index);
+      while (index < FFileBuffer.Count) and not IsSection(FFileBuffer[index]) and
+            (GetName(FFileBuffer[index]) <> ident) do
+         Inc(index);
+      if not (index >= FFileBuffer.Count) and not IsSection(FFileBuffer[index]) then
+      begin         { Ident does exists }
+         FFileBuffer.Delete(index);
+         SaveToFile;
+      end;
+   end;
+end;
+
+{ Erases the whole Section from an Ini-File }
+
+procedure TIniFile.EraseSection(const section : string);
+var
+   index : integer;
+begin
+   index := GetSectionIndex(section);
+   if index <> -1 then
+   begin
+      FFileBuffer.Delete(index);           { Delete Section-Header }
+      while (index < FFileBuffer.Count) and not IsSection(FFileBuffer[index]) do
+         FFileBuffer.Delete(index);        { Delete Section-Items }
+      if index > 0 then FFileBuffer.Insert(index, '');
+    SaveToFile;
+  end;
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.7  2000-01-06 01:20:33  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:07  peter
+    * moved to packages dir
+
+  Revision 1.5  1999/11/23 09:50:51  peter
+    * load/save stream support
+
+  Revision 1.4  1999/11/08 15:01:38  peter
+    * fpcmake support
+
+  Revision 1.3  1999/11/02 23:58:37  peter
+    * comment support
+    * readsectionraw method
+
+  Revision 1.2  1999/04/29 16:21:54  michael
+  + Default mode Hugestrings
+
+  Revision 1.1  1999/04/08 15:44:10  michael
+  + Donated by Michael A. Hess
+
+  Initial Release 1999/04/07 MAH
+
+}

fcl/inc/iostream.pp

@@ -0,0 +1,96 @@
+unit iostream;
+
+Interface
+
+Uses Classes;
+
+Type
+
+  TiosType = (iosInput,iosOutPut,iosError); 
+  EIOStreamError = Class(EStreamError);
+  
+  TIOStream = Class(THandleStream)
+    Private
+      FType,
+      FPos : Longint;
+    Public
+      Constructor Create(IOSType : TiosType);
+      Function Read(var Buffer; Count: Longint): Longint;override;
+      Function Write(const Buffer; Count: Longint): Longint;override;
+      Procedure SetSize(NewSize: Longint); override;
+      Function Seek(Offset: Longint; Origin: Word): Longint; override;
+   end;
+
+Implementation
+
+Const
+  SReadOnlyStream = 'Cannot write to an input stream.';
+  SWriteOnlyStream = 'Cannot read from an output stream.';
+  SInvalidOperation = 'Cannot perform this operation on a IOStream.';
+  
+Constructor TIOStream.Create(IOSType : TiosType);
+
+begin
+  FType:=Ord(IOSType);
+  Inherited Create(Ftype);
+end;
+
+
+Function TIOStream.Read(var Buffer; Count: Longint): Longint;
+
+begin
+  If Ftype>0 then
+    Raise EIOStreamError.Create(SWriteOnlyStream)
+  else
+    begin
+    Result:=Inherited Read(Buffer,Count);
+    Inc(FPos,Result);
+    end;
+end;
+
+
+Function TIOStream.Write(const Buffer; Count: Longint): Longint;
+
+begin
+  If Ftype=0 then
+    Raise EIOStreamError.Create(SReadOnlyStream)
+  else
+    begin
+    Result:=Inherited Write(Buffer,Count);
+    Inc(FPos,Result);
+    end;
+end;
+
+
+Procedure TIOStream.SetSize(NewSize: Longint); 
+
+begin
+  Raise EIOStreamError.Create(SInvalidOperation);
+end;
+
+
+Function TIOStream.Seek(Offset: Longint; Origin: Word): Longint; 
+
+Const BufSize = 100;
+
+Var Buf : array[1..BufSize] of Byte;
+
+begin
+  If (Origin=soFromCurrent) and (Offset=0) then
+     result:=FPos;
+  { Try to fake seek by reading and discarding }
+  if (Ftype>0) or
+     Not((Origin=soFromCurrent) and (Offset>=0) or  
+         ((Origin=soFrombeginning) and (OffSet>=FPos))) then 
+     Raise EIOStreamError.Create(SInvalidOperation);
+  if Origin=soFromBeginning then
+    Dec(Offset,FPos);
+  While ((Offset Div BufSize)>0) 
+        and (Read(Buf,SizeOf(Buf))=BufSize) do
+     Dec(Offset,BufSize);
+  If (Offset>0) then
+    Read(Buf,BufSize);
+  Result:=FPos;   
+end;
+
+end.

fcl/inc/lists.inc

@@ -0,0 +1,410 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+
+{****************************************************************************}
+{*                             TList                                        *}
+{****************************************************************************}
+
+{  TList = class(TObject)
+  private
+    FList: PPointerList;
+    FCount: Integer;
+    FCapacity: Integer;
+}
+Const
+  // Ratio of Pointer and Word Size.
+  WordRatio = SizeOf(Pointer) Div SizeOf(Word);
+
+function TList.Get(Index: Integer): Pointer;
+
+begin
+  If (Index<0) or (Index>FCount) then
+    Error(SListIndexError,Index);
+  Result:=FList^[Index];
+end;
+
+
+
+procedure TList.Grow;
+
+begin
+  // Only for compatibility with Delphi. Not needed.
+end;
+
+
+
+procedure TList.Put(Index: Integer; Item: Pointer);
+
+begin
+  if (Index<0) or (Index>=FCount) then
+    Error(SListIndexError,Index);
+  Flist^[Index]:=Item;
+end;
+
+
+
+procedure TList.SetCapacity(NewCapacity: Integer);
+
+Var NewList,ToFree : PPointerList;
+
+begin
+  If (NewCapacity<0) or (NewCapacity>MaxListSize) then
+     Error (SListCapacityError,NewCapacity);
+  If NewCapacity>FCapacity then
+    begin
+    GetMem (NewList,NewCapacity*SizeOf(Pointer));
+    If NewList=Nil then
+      //!! Find another one here !!
+      Error (SListCapacityError,NewCapacity);
+    If Assigned(FList) then
+      begin
+      System.Move (FList^,NewList^,FCapacity*Sizeof(Pointer));
+      FillWord (NewList^[FCapacity],(NewCapacity-FCapacity)*WordRatio, 0);
+      FreeMem (Flist,FCapacity*SizeOf(Pointer));
+      end;
+    Flist:=NewList;
+    FCapacity:=NewCapacity;
+    end
+  else if NewCapacity<FCapacity then
+    begin
+    If NewCapacity<0 then
+      Error (SListCapacityError,NEwCapacity);
+    ToFree:=Flist+NewCapacity*SizeOf(Pointer);
+    FreeMem (ToFree, (FCapacity-NewCapacity)*SizeOf(Pointer));
+    FCapacity:=NewCapacity;
+    end;
+end;
+
+
+
+procedure TList.SetCount(NewCount: Integer);
+
+begin
+  If (NewCount<0) or (NewCount>MaxListSize)then
+    Error(SListCountError,NewCount);
+  If NewCount<FCount then
+    FCount:=NewCount
+  else If NewCount>FCount then
+    begin
+    If NewCount>FCapacity then
+      SetCapacity (NewCount);
+    If FCount<NewCount then
+      FillWord (Flist^[FCount],(NewCount-FCount)* WordRatio ,0);
+    FCount:=Newcount;
+    end;
+end;
+
+
+
+destructor TList.Destroy;
+
+begin
+  Self.Clear;
+  inherited Destroy;
+end;
+
+
+Function TList.Add(Item: Pointer): Integer;
+
+begin
+  Self.Insert (Count,Item);
+  Result:=Count-1;
+end;
+
+
+
+Procedure TList.Clear;
+
+begin
+  If Assigned(FList) then
+    begin
+    FreeMem (Flist,FCapacity*SizeOf(Pointer));
+    FList:=Nil;
+    FCapacity:=0;
+    FCount:=0;
+    end;
+end;
+
+
+
+Procedure TList.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));
+end;
+
+
+class procedure TList.Error(const Msg: string; Data: Integer);
+
+begin
+  //!! Find a way to get call  address
+  Raise EListError.CreateFmt(Msg,[Data]);
+end;
+
+procedure TList.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 TList.Expand: TList;
+
+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;
+  SetCapacity(FCapacity+IncSize);
+  Result:=Self;
+end;
+
+
+function TList.First: Pointer;
+
+begin
+  If FCount=0 then 
+    Result:=Nil
+  else
+    Result:=Items[0];
+end;
+
+
+
+function TList.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 TList.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 TList.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 TList.Move(CurIndex, NewIndex: Integer);
+
+Var Temp : Pointer;
+
+begin
+  If ((CurIndex<0) or (CurIndex>Count-1)) then
+    Error(SListIndexError,CurIndex);
+  If (NewINdex<0) then
+    Error(SlistIndexError,NewIndex);
+  Temp:=FList^[CurIndex];
+  Self.Delete(CurIndex);
+  // ?? If NewIndex>CurIndex then NewIndex:=NewIndex-1;
+  // Newindex changes when deleting ??
+  Self.Insert (NewIndex,Temp);
+end;
+
+
+function TList.Remove(Item: Pointer): Integer;
+
+begin
+  Result:=IndexOf(Item);
+  If Result<>-1 then
+    Self.Delete (Result);
+end;
+
+
+
+Procedure TList.Pack;
+
+Var  {Last,I,J,}Runner : Longint;
+
+begin
+  // Not the fastest; but surely correct
+  For Runner:=Fcount-1 downto 0 do
+    if Items[Runner]=Nil then Self.Delete(Runner);
+{ The following may be faster in case of large and defragmented lists
+  If count=0 then exit;
+  Runner:=0;I:=0;
+  TheLast:=Count;
+  while runner<count do
+    begin
+    // Find first Nil
+    While (FList^[Runner]<>Nil) and (Runner<Count) do Runner:=Runner+1;
+    if Runner<Count do
+      begin
+      // Start searching for non-nil from last known nil+1
+      if i<Runner then I:=Runner+1;
+      While (Flist[I]^=Nil) and (I<Count) do I:=I+1;
+      // Start looking for last non-nil of block.
+      J:=I+1;
+      While (Flist^[J]<>Nil) and (J<Count) do J:=J+1;
+      // Move block and zero out
+      Move (Flist^[I],Flist^[Runner],J*SizeOf(Pointer));
+      FillWord (Flist^[I],(J-I)*WordRatio,0);
+      // Update Runner and Last to point behind last block
+      TheLast:=Runner+(J-I);
+      If J=Count then
+         begin
+         // Shortcut, when J=Count we checked all pointers
+         Runner:=Count
+      else
+         begin
+         Runner:=TheLast;
+         I:=j;
+      end;
+    end;
+  Count:=TheLast;
+}
+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 TList.Sort(Compare: TListSortCompare);
+
+begin
+  If Not Assigned(FList) or (FCount<2) then exit;
+  QuickSort (Flist, 0, FCount-1,Compare);
+end;
+
+{****************************************************************************}
+{*                             TThreadList                                  *}
+{****************************************************************************}
+
+
+constructor TThreadList.Create;
+
+begin
+end;
+
+
+
+destructor TThreadList.Destroy;
+
+begin
+end;
+
+
+
+procedure TThreadList.Add(Item: Pointer);
+
+begin
+end;
+
+
+procedure TThreadList.Clear;
+
+begin
+end;
+
+
+
+function TThreadList.LockList: TList;
+
+
+begin
+  LockList:=nil;
+end;
+
+
+
+procedure TThreadList.Remove(Item: Pointer);
+
+
+begin
+end;
+
+
+
+procedure TThreadList.UnlockList;
+
+begin
+end;
+
+
+{
+  $Log$
+  Revision 1.9  2000-01-06 01:20:33  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:07  peter
+    * moved to packages dir
+
+  Revision 1.7  1999/04/13 12:46:16  michael
+  + Some bug fixes by Romio
+
+  Revision 1.6  1999/04/08 10:18:52  peter
+    * makefile updates
+
+}

fcl/inc/parser.inc

@@ -0,0 +1,325 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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;
+
+procedure TParser.ReadBuffer;
+var
+  Count            : Integer;
+begin
+  Inc(FOrigin, FSourcePtr - FBuffer);
+
+  FSourceEnd[0] := FSaveChar;
+  Count         := FBufPtr - FSourcePtr;
+  if Count <> 0 then
+  begin
+    Move(FSourcePtr[0], FBuffer[0], Count);
+  end;
+
+  FBufPtr := FBuffer + Count;
+  Inc(FBufPtr, FStream.Read(FBufPtr[0], FBufEnd - FBufPtr));
+
+  FSourcePtr := FBuffer;
+  FSourceEnd := FBufPtr;
+  if (FSourceEnd = FBufEnd) then
+  begin
+    FSourceEnd := LineStart(FBuffer, FSourceEnd - 1);
+    if FSourceEnd = FBuffer then
+    begin
+      Error(SLineTooLong);
+    end;
+  end;
+  FSaveChar := FSourceEnd[0];
+  FSourceEnd[0] := #0;
+end;
+
+procedure TParser.SkipBlanks;
+begin
+  while FSourcePtr^ < #33 do begin
+    if FSourcePtr^ = #0 then begin
+      ReadBuffer;
+      if FSourcePtr^ = #0 then exit;
+      continue;
+    end else if FSourcePtr^ = #10 then Inc(FSourceLine);
+    Inc(FSourcePtr);
+  end;
+end;
+
+constructor TParser.Create(Stream: TStream);
+begin
+  inherited Create;
+
+  FStream := Stream;
+  GetMem(FBuffer, ParseBufSize);
+
+  FBuffer[0]  := #0;
+  FBufPtr     := FBuffer;
+  FBufEnd     := FBuffer + ParseBufSize;
+  FSourcePtr  := FBuffer;
+  FSourceEnd  := FBuffer;
+  FTokenPtr   := FBuffer;
+  FSourceLine := 1;
+
+  NextToken;
+end;
+
+
+destructor TParser.Destroy;
+begin
+  if Assigned(FBuffer) then
+  begin
+    FStream.Seek(Longint(FTokenPtr) - Longint(FBufPtr), 1);
+    FreeMem(FBuffer, ParseBufSize);
+  end;
+
+  inherited Destroy;
+end;
+
+procedure TParser.CheckToken(T : Char);
+begin
+  if Token <> T then
+  begin
+    case T of
+      toSymbol:
+        Error(SIdentifierExpected);
+      toString:
+        Error(SStringExpected);
+      toInteger, toFloat:
+        Error(SNumberExpected);
+    else
+      ErrorFmt(SCharExpected, [T]);
+    end;
+  end;
+end;
+
+procedure TParser.CheckTokenSymbol(const S: string);
+begin
+  if not TokenSymbolIs(S) then
+    ErrorFmt(SSymbolExpected, [S]);
+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(SParseError, [Message, FSourceLine]);
+end;
+
+
+procedure TParser.HexToBinary(Stream: TStream);
+
+  function HexDigitToInt(c: Char): Integer;
+  begin
+    if (c >= '0') and (c <= '9') then Result := Ord(c) - Ord('0')
+    else if (c >= 'A') and (c <= 'F') then Result := Ord(c) - Ord('A') + 10
+    else if (c >= 'a') and (c <= 'f') then Result := Ord(c) - Ord('a') + 10
+    else Result := -1;
+  end;
+
+var
+  buf: array[0..255] of Byte;
+  digit1: Integer;
+  bytes: Integer;
+begin
+  SkipBlanks;
+  while FSourcePtr^ <> '}' do begin
+    bytes := 0;
+    while True do begin
+      digit1 := HexDigitToInt(FSourcePtr[0]);
+      if digit1 < 0 then break;
+      buf[bytes] := digit1 shl 4 or HexDigitToInt(FSourcePtr[1]);
+      Inc(FSourcePtr, 2);
+      Inc(bytes);
+    end;
+    if bytes = 0 then Error(SInvalidBinary);
+    Stream.Write(buf, bytes);
+    SkipBlanks;
+  end;
+  NextToken;
+end;
+
+
+Function TParser.NextToken: Char;
+var
+  I                : Integer;
+  P, S             : PChar;
+begin
+  SkipBlanks;
+  P := FSourcePtr;
+  FTokenPtr := P;
+  case P^ of
+    'A'..'Z', 'a'..'z', '_':
+      begin
+        Inc(P);
+        while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P);
+        Result := toSymbol;
+      end;
+    '#', '''':
+      begin
+        S := P;
+        while True do
+          case P^ of
+            '#':
+              begin
+                Inc(P);
+                I := 0;
+                while P^ in ['0'..'9'] do
+                begin
+                  I := I * 10 + (Ord(P^) - Ord('0'));
+                  Inc(P);
+                end;
+                S^ := Chr(I);
+                Inc(S);
+              end;
+            '''':
+              begin
+                Inc(P);
+                while True do
+                begin
+                  case P^ of
+                    #0, #10, #13:
+                      Error(SInvalidString);
+                    '''':
+                      begin
+                        Inc(P);
+                        if P^ <> '''' then Break;
+                      end;
+                  end;
+                  S^ := P^;
+                  Inc(S);
+                  Inc(P);
+                end;
+              end;
+          else
+            Break;
+          end;
+        FStringPtr := S;
+        Result := toString;
+      end;
+    '$':
+      begin
+        Inc(P);
+        while P^ in ['0'..'9', 'A'..'F', 'a'..'f'] do Inc(P);
+        Result := toInteger;
+      end;
+    '-', '0'..'9':
+      begin
+        Inc(P);
+        while P^ in ['0'..'9'] do Inc(P);
+        Result := toInteger;
+        while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do
+        begin
+          Inc(P);
+          Result := toFloat;
+        end;
+      end;
+  else
+    Result := P^;
+    if Result <> toEOF then Inc(P);
+  end;
+  FSourcePtr := P;
+  FToken := Result;
+end;
+
+Function TParser.SourcePos: Longint;
+begin
+  Result := FOrigin + (FTokenPtr - FBuffer);
+end;
+
+
+Function TParser.TokenComponentIdent: String;
+var
+  P                : PChar;
+begin
+  CheckToken(toSymbol);
+
+  P := FSourcePtr;
+  while P^ = '.' do
+  begin
+    Inc(P);
+    if not (P^ in ['A'..'Z', 'a'..'z', '_']) then
+      Error(SIdentifierExpected);
+    repeat
+      Inc(P)
+    until not (P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
+  end;
+  FSourcePtr := P;
+  Result := TokenString;
+end;
+
+Function TParser.TokenFloat: Extended;
+var
+  FloatError       : Integer;
+  Back             : Real;
+begin
+  Result   := 0;
+  Val(TokenString, Back, FloatError);
+  Result := Back;
+end;
+
+Function TParser.TokenInt: Longint;
+begin
+  Result := StrToInt(TokenString);
+end;
+
+Function TParser.TokenString: string;
+var
+  L                : Integer;
+  StrBuf           : array[0..1023] of Char;
+begin
+  if FToken = toString then begin
+    L := FStringPtr - FTokenPtr
+  end else begin
+    L := FSourcePtr - FTokenPtr;
+  end;
+
+  StrLCopy(StrBuf, FTokenPtr, L);
+  Result := StrPas(StrBuf);
+end;
+
+Function TParser.TokenSymbolIs(const S: string): Boolean;
+begin
+  Result := (Token = toSymbol) and (CompareText(S, TokenString) = 0);
+end;
+{
+  $Log$
+  Revision 1.10  2000-01-06 01:20:33  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:08  peter
+    * moved to packages dir
+
+  Revision 1.8  1999/09/30 19:32:08  fcl
+  * Implemented TParser.HexToBinary  (sg)
+
+  Revision 1.7  1999/09/28 10:28:21  fcl
+  * Fixed some severe bugs  (sg)
+
+  Revision 1.6  1999/04/08 10:18:53  peter
+    * makefile updates
+
+}

fcl/inc/persist.inc

@@ -0,0 +1,99 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+{****************************************************************************}
+{*                             TPersistent                                  *}
+{****************************************************************************}
+
+
+procedure TPersistent.AssignError(Source: TPersistent);
+
+Var SourceName : String;
+
+begin
+  If Source<>Nil then 
+    SourceName:=Source.ClassName
+  else
+    SourceName:='Nil';
+  Writeln ('Error assigning to ',ClassName,' from : ',SourceName);
+  raise EConvertError.CreateFmt (SAssignError,[SourceName,ClassName]);
+end;
+
+
+
+procedure TPersistent.AssignTo(Dest: TPersistent);
+
+
+begin
+  Dest.AssignError(Self);
+end;
+
+
+procedure TPersistent.DefineProperties(Filer: TFiler);
+
+begin
+end;
+
+
+function  TPersistent.GetOwner: TPersistent;
+
+begin
+  Result:=Nil;
+end;
+
+destructor TPersistent.Destroy; 
+
+begin
+  Inherited Destroy;
+end;
+
+
+procedure TPersistent.Assign(Source: TPersistent);
+
+begin
+  If Source<>Nil then 
+    Source.AssignTo(Self)
+  else
+    AssignError(Nil);
+end;
+
+function  TPersistent.GetNamePath: string;
+
+Var OwnerName :String;
+
+begin
+ Result:=ClassNAme;
+ If GetOwner<>Nil then 
+   begin
+   OwnerName:=GetOwner.GetNamePath;
+   If OwnerName<>'' then Result:=OwnerName+'.'+Result;
+   end;
+end;
+{
+  $Log$
+  Revision 1.5  2000-01-06 01:20:33  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.1  2000/01/03 19:33:08  peter
+    * moved to packages dir
+
+  Revision 1.3  1998/10/02 22:41:29  michael
+  + Added exceptions for error handling
+
+  Revision 1.2  1998/05/27 12:22:14  michael
+  + Implemented TPersistent
+
+  Revision 1.1  1998/05/04 14:30:12  michael
+  * Split file according to Class; implemented dummys for all methods, so unit compiles.
+
+}

fcl/inc/pipes.pp

@@ -0,0 +1,121 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1998 by Michael Van Canneyt
+
+    Implementation of pipe stream.
+    
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+Unit Pipes;
+
+Interface
+
+Uses sysutils,Classes;
+
+Type
+  EPipeError = Class(EStreamError);
+  ENoReadPipe = Class(EPipeError);
+  ENoWritePipe = Class (EPipeError);
+  EPipeSeek = Class (EPipeError);
+  EPipeCreation = Class (EPipeError);
+
+  TInputPipeStream = Class(THandleStream)
+    Private 
+      FPos : longint;
+    public
+      Function Write (Const Buffer; Count : Longint) :Longint; Override;
+      Function Seek (Offset : Longint;Origin : Word) : longint;override;
+      Function Read (Var Buffer; Count : Longint) : longint; Override;
+    end;
+
+  TOutputPipeStream = Class(THandleStream)
+    Public
+      Function Seek (Offset : Longint;Origin : Word) : longint;override;
+      Function Read (Var Buffer; Count : Longint) : longint; Override;
+    end;
+
+Procedure CreatePipeStreams (Var InPipe : TInputPipeStream;
+                             Var OutPipe : TOutputPipeStream);
+
+Const EPipeMsg = 'Failed to create pipe.';
+      ENoReadMSg = 'Cannot read from OuputPipeStream.';
+      ENoWriteMsg = 'Cannot write to InputPipeStream.';
+      ENoSeekMsg = 'Cannot seek on pipes';
+
+
+Implementation
+
+{$i pipes.inc}
+
+Procedure CreatePipeStreams (Var InPipe : TInputPipeStream;
+                             Var OutPipe : TOutputPipeStream);
+
+Var InHandle,OutHandle : Longint;
+
+begin
+  if CreatePipeHandles (InHandle, OutHandle) then
+    begin
+    Inpipe:=TinputPipeStream.Create (InHandle);
+    OutPipe:=ToutputPipeStream.Create (OutHandle);
+    end
+  Else
+    Raise EPipeCreation.Create (EPipeMsg)
+end;
+
+Function TInputPipeStream.Write (Const Buffer; Count : Longint) : longint;
+
+begin
+  Raise ENoWritePipe.Create (ENoWriteMsg);
+end;
+
+Function TInputPipeStream.Read (Var Buffer; Count : Longint) : longint;
+
+begin
+  Result:=Inherited Read(Buffer,Count);
+  Inc(FPos,Result);
+end;
+
+Function TInputPipeStream.Seek (Offset : Longint;Origin : Word) : longint;
+
+Const BufSize = 100;
+
+Var Buf : array[1..BufSize] of Byte;
+
+begin
+  If (Origin=soFromCurrent) and (Offset=0) then
+     result:=FPos;
+  { Try to fake seek by reading and discarding }
+  if Not((Origin=soFromCurrent) and (Offset>=0) or  
+         ((Origin=soFrombeginning) and (OffSet>=FPos))) then 
+     Raise EPipeSeek.Create(ENoSeekMSg);
+  if Origin=soFromBeginning then
+    Dec(Offset,FPos);
+  While ((Offset Div BufSize)>0) 
+        and (Read(Buf,SizeOf(Buf))=BufSize) do
+     Dec(Offset,BufSize);
+  If (Offset>0) then
+    Read(Buf,BufSize);
+  Result:=FPos;   
+end;
+
+Function TOutputPipeStream.Read(Var Buffer; Count : Longint) : longint;
+
+begin
+  Raise ENoReadPipe.Create (ENoReadMsg);
+end;
+
+Function TOutputPipeStream.Seek (Offset : Longint;Origin : Word) : longint;
+
+begin
+  Raise EPipeSeek.Create (ENoSeekMsg);
+end;
+
+end.

fcl/inc/reader.inc

@@ -0,0 +1,389 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 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.
+
+ **********************************************************************}
+{****************************************************************************}
+{*                             TREADER                                      *}
+{****************************************************************************}
+
+Procedure TReader.CheckValue(Value: TValueType);
+
+begin
+end;
+
+
+
+Procedure TReader.DoFixupReferences;
+
+begin
+end;
+
+
+
+Procedure TReader.FreeFixups;
+
+begin
+end;
+
+
+
+Function TReader.GetPosition: Longint;
+
+begin
+  GetPosition:=0;
+end;
+
+
+
+Procedure TReader.PropertyError;
+
+begin
+end;
+
+
+
+Procedure TReader.ReadBuffer;
+
+begin
+end;
+
+
+
+Procedure TReader.ReadData(Instance: TComponent);
+
+begin
+end;
+
+
+
+Procedure TReader.ReadDataInner(Instance: TComponent);
+
+begin
+end;
+
+
+
+Procedure TReader.ReadProperty(AInstance: TPersistent);
+
+begin
+end;
+
+
+
+Procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
+
+begin
+end;
+
+
+
+Function TReader.ReadSet(SetType: Pointer): Integer;
+
+begin
+  ReadSet:=0;
+end;
+
+
+
+Procedure TReader.SetPosition(Value: Longint);
+
+begin
+end;
+
+
+
+Procedure TReader.SkipSetBody;
+
+begin
+end;
+
+
+
+Procedure TReader.SkipValue;
+
+begin
+end;
+
+
+
+Procedure TReader.SkipProperty;
+
+begin
+end;
+
+
+
+Procedure TReader.SkipComponent(SkipHeader: Boolean);
+
+begin
+end;
+
+
+
+Function TReader.Error(const Message: string): Boolean;
+
+begin
+  Error:=false;
+end;
+
+
+
+Function TReader.FindMethod(ARoot: TComponent; const AMethodName: string): Pointer;
+
+begin
+  FindMethod:=nil;
+end;
+
+
+
+Procedure TReader.SetName(Component: TComponent; var Name: string);
+
+begin
+end;
+
+
+
+Procedure TReader.ReferenceName(var Name: string);
+
+begin
+end;
+
+
+
+Function TReader.FindAncestorComponent(const Name: string;
+  ComponentClass: TPersistentClass): TComponent;
+
+begin
+  FindAncestorComponent:=nil;
+end;
+
+
+
+destructor TReader.Destroy;
+
+begin
+end;
+
+
+
+Procedure TReader.BeginReferences;
+
+begin
+end;
+
+
+
+Procedure TReader.DefineProperty(const Name: string;
+  rd : TReaderProc; wd : TWriterProc;
+  HasData: Boolean);
+
+begin
+end;
+
+
+
+Procedure TReader.DefineBinaryProperty(const Name: string;
+  rd, wd: TStreamProc;
+  HasData: Boolean);
+
+begin
+end;
+
+
+
+Function TReader.EndOfList: Boolean;
+
+begin
+  EndOfList:=false;
+end;
+
+
+
+Procedure TReader.EndReferences;
+
+begin
+end;
+
+
+
+Procedure TReader.FixupReferences;
+
+begin
+end;
+
+
+
+Procedure TReader.FlushBuffer;
+
+begin
+end;
+
+
+
+Function TReader.NextValue: TValueType;
+
+begin
+  NextValue:=vaNull;
+end;
+
+
+
+Procedure TReader.Read(var Buf; Count: Longint);
+
+begin
+end;
+
+
+
+Function TReader.ReadBoolean: Boolean;
+
+begin
+  ReadBoolean:=false;
+end;
+
+
+
+Function TReader.ReadChar: Char;
+
+begin
+  ReadChar:=#0;
+end;
+
+
+
+Procedure TReader.ReadCollection(Collection: TCollection);
+
+begin
+end;
+
+
+
+Function TReader.ReadComponent(Component: TComponent): TComponent;
+
+begin
+  ReadComponent:=nil;
+end;
+
+
+
+Procedure TReader.ReadComponents(AOwner, AParent: TComponent;
+  Proc: TReadComponentsProc);
+
+begin
+end;
+
+
+
+Function TReader.ReadFloat: Extended;
+
+begin
+  ReadFloat:=0.0;
+end;
+
+
+
+Function TReader.ReadIdent: string;
+
+begin
+  ReadIdent:='';
+end;
+
+
+
+Function TReader.ReadInteger: Longint;
+
+begin
+  ReadInteger:=0;
+end;
+
+
+
+Procedure TReader.ReadListBegin;
+
+begin
+end;
+
+
+
+Procedure TReader.ReadListEnd;
+
+begin
+end;
+
+
+
+Procedure TReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
+
+begin
+end;
+
+
+
+Function TReader.ReadRootComponent(ARoot: TComponent): TComponent;
+
+begin
+  ReadRootComponent:=nil;
+end;
+
+
+
+Procedure TReader.ReadSignature;
+
+begin
+end;
+
+
+
+Function TReader.ReadStr: string;
+
+begin
+  ReadStr:='';
+end;
+
+
+
+Function TReader.ReadString: string;
+
+begin
+  ReadString:='';
+end;
+
+
+
+Function TReader.ReadValue: TValueType;
+
+begin
+  ReadValue:=vaNull;
+end;
+
+
+
+Procedure TReader.CopyValue(Writer: TWriter); {!!!}
+
+begin
+end;
+{
+  $Log$
+  Revision 1.5  2000-01-06 01:20:33  peter
+    * moved out of packages/ back to topdir
+
+  Revision 1.2  2000/01/04 18:07:16  michael
+  + Streaming implemented
+
+  Revision 1.3  1999/09/13 08:35:16  fcl
+  * Changed some argument names (Root->ARoot etc.) because the new compiler
+    now performs more ambiguity checks  (sg)
+
+  Revision 1.2  1999/04/08 10:18:54  peter
+    * makefile updates
+
+}