diff options
| author | peter <peter@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2008-01-14 16:54:03 +0000 |
|---|---|---|
| committer | peter <peter@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2008-01-14 16:54:03 +0000 |
| commit | e5247b2cfbbc77f34dcf5a46d5f0066ea887e7b2 (patch) | |
| tree | 035171903206a511a36bb5fe6bb79a231f95ce88 /packages/fv | |
| parent | 1e8bbc586f27f8cff8d18e4dd94d18ddc8989b09 (diff) | |
| download | fpc-e5247b2cfbbc77f34dcf5a46d5f0066ea887e7b2.tar.gz | |
* moved freevision package
git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@9752 3ad0048d-3df7-0310-abae-a5850022a9f2
Diffstat (limited to 'packages/fv')
38 files changed, 35951 insertions, 0 deletions
diff --git a/packages/fv/Makefile b/packages/fv/Makefile new file mode 100644 index 0000000000..61820c22fa --- /dev/null +++ b/packages/fv/Makefile @@ -0,0 +1,2790 @@ +# +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2007/12/01] +# +default: all +MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded +BSDs = freebsd netbsd openbsd darwin +UNIXs = linux $(BSDs) solaris qnx +LIMIT83fs = go32v2 os2 emx watcom +OSNeedsComspecToRunBatch = go32v2 watcom +FORCE: +.PHONY: FORCE +override PATH:=$(patsubst %/,%,$(subst \,/,$(PATH))) +ifneq ($(findstring darwin,$(OSTYPE)),) +inUnix=1 #darwin +SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH))) +else +ifeq ($(findstring ;,$(PATH)),) +inUnix=1 +SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH))) +else +SEARCHPATH:=$(subst ;, ,$(PATH)) +endif +endif +SEARCHPATH+=$(patsubst %/,%,$(subst \,/,$(dir $(MAKE)))) +PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(SEARCHPATH)))) +ifeq ($(PWD),) +PWD:=$(strip $(wildcard $(addsuffix /pwd,$(SEARCHPATH)))) +ifeq ($(PWD),) +$(error You need the GNU utils package to use this Makefile) +else +PWD:=$(firstword $(PWD)) +SRCEXEEXT= +endif +else +PWD:=$(firstword $(PWD)) +SRCEXEEXT=.exe +endif +ifndef inUnix +ifeq ($(OS),Windows_NT) +inWinNT=1 +else +ifdef OS2_SHELL +inOS2=1 +endif +endif +else +ifneq ($(findstring cygdrive,$(PATH)),) +inCygWin=1 +endif +endif +ifdef inUnix +SRCBATCHEXT=.sh +else +ifdef inOS2 +SRCBATCHEXT=.cmd +else +SRCBATCHEXT=.bat +endif +endif +ifdef COMSPEC +ifneq ($(findstring $(OS_SOURCE),$(OSNeedsComspecToRunBatch)),) +RUNBATCH=$(COMSPEC) /C +endif +endif +ifdef inUnix +PATHSEP=/ +else +PATHSEP:=$(subst /,\,/) +ifdef inCygWin +PATHSEP=/ +endif +endif +ifdef PWD +BASEDIR:=$(subst \,/,$(shell $(PWD))) +ifdef inCygWin +ifneq ($(findstring /cygdrive/,$(BASEDIR)),) +BASENODIR:=$(patsubst /cygdrive%,%,$(BASEDIR)) +BASEDRIVE:=$(firstword $(subst /, ,$(BASENODIR))) +BASEDIR:=$(subst /cygdrive/$(BASEDRIVE)/,$(BASEDRIVE):/,$(BASEDIR)) +endif +endif +else +BASEDIR=. +endif +ifdef inOS2 +ifndef ECHO +ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO=echo +else +ECHO:=$(firstword $(ECHO)) +endif +else +ECHO:=$(firstword $(ECHO)) +endif +endif +export ECHO +endif +override DEFAULT_FPCDIR=../.. +ifndef FPC +ifdef PP +FPC=$(PP) +endif +endif +ifndef FPC +FPCPROG:=$(strip $(wildcard $(addsuffix /fpc$(SRCEXEEXT),$(SEARCHPATH)))) +ifneq ($(FPCPROG),) +FPCPROG:=$(firstword $(FPCPROG)) +ifneq ($(CPU_TARGET),) +FPC:=$(shell $(FPCPROG) -P$(CPU_TARGET) -PB) +else +FPC:=$(shell $(FPCPROG) -PB) +endif +ifneq ($(findstring Error,$(FPC)),) +override FPC=$(firstword $(strip $(wildcard $(addsuffix /ppc386$(SRCEXEEXT),$(SEARCHPATH))))) +endif +else +override FPC=$(firstword $(strip $(wildcard $(addsuffix /ppc386$(SRCEXEEXT),$(SEARCHPATH))))) +endif +endif +override FPC:=$(subst $(SRCEXEEXT),,$(FPC)) +override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT) +FOUNDFPC:=$(strip $(wildcard $(FPC))) +ifeq ($(FOUNDFPC),) +FOUNDFPC=$(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH)))) +ifeq ($(FOUNDFPC),) +$(error Compiler $(FPC) not found) +endif +endif +ifndef FPC_COMPILERINFO +FPC_COMPILERINFO:=$(shell $(FPC) -iVSPTPSOTO) +endif +ifndef FPC_VERSION +FPC_VERSION:=$(word 1,$(FPC_COMPILERINFO)) +endif +export FPC FPC_VERSION FPC_COMPILERINFO +unexport CHECKDEPEND ALLDEPENDENCIES +ifndef CPU_TARGET +ifdef CPU_TARGET_DEFAULT +CPU_TARGET=$(CPU_TARGET_DEFAULT) +endif +endif +ifndef OS_TARGET +ifdef OS_TARGET_DEFAULT +OS_TARGET=$(OS_TARGET_DEFAULT) +endif +endif +ifneq ($(words $(FPC_COMPILERINFO)),5) +FPC_COMPILERINFO+=$(shell $(FPC) -iSP) +FPC_COMPILERINFO+=$(shell $(FPC) -iTP) +FPC_COMPILERINFO+=$(shell $(FPC) -iSO) +FPC_COMPILERINFO+=$(shell $(FPC) -iTO) +endif +ifndef CPU_SOURCE +CPU_SOURCE:=$(word 2,$(FPC_COMPILERINFO)) +endif +ifndef CPU_TARGET +CPU_TARGET:=$(word 3,$(FPC_COMPILERINFO)) +endif +ifndef OS_SOURCE +OS_SOURCE:=$(word 4,$(FPC_COMPILERINFO)) +endif +ifndef OS_TARGET +OS_TARGET:=$(word 5,$(FPC_COMPILERINFO)) +endif +FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET) +FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE) +ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),) +TARGETSUFFIX=$(OS_TARGET) +SOURCESUFFIX=$(OS_SOURCE) +else +TARGETSUFFIX=$(FULL_TARGET) +SOURCESUFFIX=$(FULL_SOURCE) +endif +ifneq ($(FULL_TARGET),$(FULL_SOURCE)) +CROSSCOMPILE=1 +endif +ifeq ($(findstring makefile,$(MAKECMDGOALS)),) +ifeq ($(findstring $(FULL_TARGET),$(MAKEFILETARGETS)),) +$(error The Makefile doesn't support target $(FULL_TARGET), please run fpcmake first) +endif +endif +ifneq ($(findstring $(OS_TARGET),$(BSDs)),) +BSDhier=1 +endif +ifeq ($(OS_TARGET),linux) +linuxHier=1 +endif +export OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE TARGETSUFFIX SOURCESUFFIX CROSSCOMPILE +ifdef FPCDIR +override FPCDIR:=$(subst \,/,$(FPCDIR)) +ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) +override FPCDIR=wrong +endif +else +override FPCDIR=wrong +endif +ifdef DEFAULT_FPCDIR +ifeq ($(FPCDIR),wrong) +override FPCDIR:=$(subst \,/,$(DEFAULT_FPCDIR)) +ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) +override FPCDIR=wrong +endif +endif +endif +ifeq ($(FPCDIR),wrong) +ifdef inUnix +override FPCDIR=/usr/local/lib/fpc/$(FPC_VERSION) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR=/usr/lib/fpc/$(FPC_VERSION) +endif +else +override FPCDIR:=$(subst /$(FPC),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH)))))) +override FPCDIR:=$(FPCDIR)/.. +ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) +override FPCDIR:=$(FPCDIR)/.. +ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) +override FPCDIR:=$(BASEDIR) +ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) +override FPCDIR=c:/pp +endif +endif +endif +endif +endif +ifndef CROSSBINDIR +CROSSBINDIR:=$(wildcard $(FPCDIR)/bin/$(TARGETSUFFIX)) +endif +ifndef BINUTILSPREFIX +ifndef CROSSBINDIR +ifdef CROSSCOMPILE +BINUTILSPREFIX=$(CPU_TARGET)-$(OS_TARGET)- +endif +endif +endif +UNITSDIR:=$(wildcard $(FPCDIR)/units/$(TARGETSUFFIX)) +ifeq ($(UNITSDIR),) +UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET)) +endif +PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages $(FPCDIR)/packages/base $(FPCDIR)/packages/extra) +override PACKAGE_NAME=fv +override PACKAGE_VERSION=2.0.0 +ifeq ($(FULL_TARGET),i386-linux) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-go32v2) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-win32) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-os2) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-freebsd) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-beos) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-netbsd) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-solaris) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-qnx) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-netware) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-openbsd) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-wdosx) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-darwin) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-emx) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-watcom) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-netwlibc) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-wince) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-embedded) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-symbian) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),m68k-linux) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),m68k-freebsd) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),m68k-netbsd) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),m68k-amiga) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),m68k-atari) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),m68k-openbsd) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),m68k-palmos) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),m68k-embedded) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),powerpc-linux) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),powerpc-netbsd) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),powerpc-amiga) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),powerpc-macos) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),powerpc-darwin) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),powerpc-morphos) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),powerpc-embedded) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),sparc-linux) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),sparc-netbsd) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),sparc-solaris) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),sparc-embedded) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),x86_64-linux) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),x86_64-freebsd) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),x86_64-darwin) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),x86_64-win64) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),x86_64-embedded) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),arm-linux) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),arm-palmos) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),arm-wince) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),arm-gba) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),arm-nds) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),arm-embedded) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),arm-symbian) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),powerpc64-linux) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),powerpc64-darwin) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),powerpc64-embedded) +override TARGET_UNITS+=buildfv +endif +ifeq ($(FULL_TARGET),i386-linux) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-go32v2) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-win32) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-os2) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-freebsd) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-beos) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-netbsd) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-solaris) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-qnx) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-netware) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-openbsd) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-wdosx) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-darwin) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-emx) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-watcom) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-netwlibc) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-wince) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-embedded) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-symbian) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),m68k-linux) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),m68k-freebsd) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),m68k-netbsd) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),m68k-amiga) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),m68k-atari) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),m68k-openbsd) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),m68k-palmos) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),m68k-embedded) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),powerpc-linux) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),powerpc-netbsd) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),powerpc-amiga) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),powerpc-macos) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),powerpc-darwin) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),powerpc-morphos) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),powerpc-embedded) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),sparc-linux) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),sparc-netbsd) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),sparc-solaris) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),sparc-embedded) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),x86_64-linux) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),x86_64-freebsd) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),x86_64-darwin) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),x86_64-win64) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),x86_64-embedded) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),arm-linux) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),arm-palmos) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),arm-wince) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),arm-gba) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),arm-nds) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),arm-embedded) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),arm-symbian) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),powerpc64-linux) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),powerpc64-darwin) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),powerpc64-embedded) +override TARGET_IMPLICITUNITS+=app colortxt dialogs drivers editors fvcommon fvconsts gadgets histlist inplong memory menus msgbox statuses stddlg tabs time validate views sysmsg asciitab timeddlg outline +endif +ifeq ($(FULL_TARGET),i386-linux) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-go32v2) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-win32) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-os2) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-freebsd) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-beos) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-netbsd) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-solaris) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-qnx) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-netware) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-openbsd) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-wdosx) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-darwin) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-emx) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-watcom) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-netwlibc) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-wince) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-embedded) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-symbian) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),m68k-linux) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),m68k-freebsd) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),m68k-netbsd) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),m68k-amiga) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),m68k-atari) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),m68k-openbsd) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),m68k-palmos) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),m68k-embedded) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),powerpc-linux) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),powerpc-netbsd) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),powerpc-amiga) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),powerpc-macos) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),powerpc-darwin) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),powerpc-morphos) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),powerpc-embedded) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),sparc-linux) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),sparc-netbsd) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),sparc-solaris) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),sparc-embedded) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),x86_64-linux) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),x86_64-freebsd) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),x86_64-darwin) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),x86_64-win64) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),x86_64-embedded) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),arm-linux) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),arm-palmos) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),arm-wince) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),arm-gba) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),arm-nds) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),arm-embedded) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),arm-symbian) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),powerpc64-linux) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),powerpc64-darwin) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),powerpc64-embedded) +override TARGET_RSTS+=app dialogs editors msgbox stddlg +endif +ifeq ($(FULL_TARGET),i386-linux) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-go32v2) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-win32) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-os2) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-freebsd) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-beos) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-netbsd) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-solaris) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-qnx) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-netware) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-openbsd) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-wdosx) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-darwin) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-emx) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-watcom) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-netwlibc) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-wince) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-embedded) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),i386-symbian) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),m68k-linux) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),m68k-freebsd) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),m68k-netbsd) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),m68k-amiga) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),m68k-atari) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),m68k-openbsd) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),m68k-palmos) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),m68k-embedded) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),powerpc-linux) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),powerpc-netbsd) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),powerpc-amiga) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),powerpc-macos) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),powerpc-darwin) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),powerpc-morphos) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),powerpc-embedded) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),sparc-linux) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),sparc-netbsd) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),sparc-solaris) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),sparc-embedded) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),x86_64-linux) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),x86_64-freebsd) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),x86_64-darwin) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),x86_64-win64) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),x86_64-embedded) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),arm-linux) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),arm-palmos) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),arm-wince) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),arm-gba) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),arm-nds) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),arm-embedded) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),arm-symbian) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),powerpc64-linux) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),powerpc64-darwin) +override TARGET_EXAMPLEDIRS+=examples +endif +ifeq ($(FULL_TARGET),powerpc64-embedded) +override TARGET_EXAMPLEDIRS+=examples +endif +override INSTALL_BUILDUNIT=buildfv +override INSTALL_FPCPACKAGE=y +ifeq ($(FULL_TARGET),i386-linux) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-go32v2) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-win32) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-os2) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-freebsd) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-beos) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-netbsd) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-solaris) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-qnx) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-netware) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-openbsd) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-wdosx) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-darwin) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-emx) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-watcom) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-netwlibc) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-wince) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-embedded) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),i386-symbian) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),m68k-linux) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),m68k-freebsd) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),m68k-netbsd) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),m68k-amiga) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),m68k-atari) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),m68k-openbsd) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),m68k-palmos) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),m68k-embedded) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),powerpc-linux) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),powerpc-netbsd) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),powerpc-amiga) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),powerpc-macos) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),powerpc-darwin) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),powerpc-morphos) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),powerpc-embedded) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),sparc-linux) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),sparc-netbsd) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),sparc-solaris) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),sparc-embedded) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),x86_64-linux) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),x86_64-freebsd) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),x86_64-darwin) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),x86_64-win64) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),x86_64-embedded) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),arm-linux) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),arm-palmos) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),arm-wince) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),arm-gba) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),arm-nds) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),arm-embedded) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),arm-symbian) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),powerpc64-linux) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),powerpc64-darwin) +override COMPILER_SOURCEDIR+=src +endif +ifeq ($(FULL_TARGET),powerpc64-embedded) +override COMPILER_SOURCEDIR+=src +endif +ifdef REQUIRE_UNITSDIR +override UNITSDIR+=$(REQUIRE_UNITSDIR) +endif +ifdef REQUIRE_PACKAGESDIR +override PACKAGESDIR+=$(REQUIRE_PACKAGESDIR) +endif +ifdef ZIPINSTALL +ifneq ($(findstring $(OS_TARGET),$(UNIXs)),) +UNIXHier=1 +endif +else +ifneq ($(findstring $(OS_SOURCE),$(UNIXs)),) +UNIXHier=1 +endif +endif +ifndef INSTALL_PREFIX +ifdef PREFIX +INSTALL_PREFIX=$(PREFIX) +endif +endif +ifndef INSTALL_PREFIX +ifdef UNIXHier +INSTALL_PREFIX=/usr/local +else +ifdef INSTALL_FPCPACKAGE +INSTALL_BASEDIR:=/pp +else +INSTALL_BASEDIR:=/$(PACKAGE_NAME) +endif +endif +endif +export INSTALL_PREFIX +ifdef INSTALL_FPCSUBDIR +export INSTALL_FPCSUBDIR +endif +ifndef DIST_DESTDIR +DIST_DESTDIR:=$(BASEDIR) +endif +export DIST_DESTDIR +ifndef COMPILER_UNITTARGETDIR +ifdef PACKAGEDIR_MAIN +COMPILER_UNITTARGETDIR=$(PACKAGEDIR_MAIN)/units/$(TARGETSUFFIX) +else +COMPILER_UNITTARGETDIR=units/$(TARGETSUFFIX) +endif +endif +ifndef COMPILER_TARGETDIR +COMPILER_TARGETDIR=. +endif +ifndef INSTALL_BASEDIR +ifdef UNIXHier +ifdef INSTALL_FPCPACKAGE +INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/fpc/$(FPC_VERSION) +else +INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/$(PACKAGE_NAME) +endif +else +INSTALL_BASEDIR:=$(INSTALL_PREFIX) +endif +endif +ifndef INSTALL_BINDIR +ifdef UNIXHier +INSTALL_BINDIR:=$(INSTALL_PREFIX)/bin +else +INSTALL_BINDIR:=$(INSTALL_BASEDIR)/bin +ifdef INSTALL_FPCPACKAGE +ifdef CROSSCOMPILE +ifdef CROSSINSTALL +INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(SOURCESUFFIX) +else +INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(TARGETSUFFIX) +endif +else +INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(TARGETSUFFIX) +endif +endif +endif +endif +ifndef INSTALL_UNITDIR +INSTALL_UNITDIR:=$(INSTALL_BASEDIR)/units/$(TARGETSUFFIX) +ifdef INSTALL_FPCPACKAGE +ifdef PACKAGE_NAME +INSTALL_UNITDIR:=$(INSTALL_UNITDIR)/$(PACKAGE_NAME) +endif +endif +endif +ifndef INSTALL_LIBDIR +ifdef UNIXHier +INSTALL_LIBDIR:=$(INSTALL_PREFIX)/lib +else +INSTALL_LIBDIR:=$(INSTALL_UNITDIR) +endif +endif +ifndef INSTALL_SOURCEDIR +ifdef UNIXHier +ifdef BSDhier +SRCPREFIXDIR=share/src +else +ifdef linuxHier +SRCPREFIXDIR=share/src +else +SRCPREFIXDIR=src +endif +endif +ifdef INSTALL_FPCPACKAGE +ifdef INSTALL_FPCSUBDIR +INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/fpc-$(FPC_VERSION)/$(INSTALL_FPCSUBDIR)/$(PACKAGE_NAME) +else +INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/fpc-$(FPC_VERSION)/$(PACKAGE_NAME) +endif +else +INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/$(PACKAGE_NAME)-$(PACKAGE_VERSION) +endif +else +ifdef INSTALL_FPCPACKAGE +ifdef INSTALL_FPCSUBDIR +INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source/$(INSTALL_FPCSUBDIR)/$(PACKAGE_NAME) +else +INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source/$(PACKAGE_NAME) +endif +else +INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source +endif +endif +endif +ifndef INSTALL_DOCDIR +ifdef UNIXHier +ifdef BSDhier +DOCPREFIXDIR=share/doc +else +ifdef linuxHier +DOCPREFIXDIR=share/doc +else +DOCPREFIXDIR=doc +endif +endif +ifdef INSTALL_FPCPACKAGE +INSTALL_DOCDIR:=$(INSTALL_PREFIX)/$(DOCPREFIXDIR)/fpc-$(FPC_VERSION)/$(PACKAGE_NAME) +else +INSTALL_DOCDIR:=$(INSTALL_PREFIX)/$(DOCPREFIXDIR)/$(PACKAGE_NAME)-$(PACKAGE_VERSION) +endif +else +ifdef INSTALL_FPCPACKAGE +INSTALL_DOCDIR:=$(INSTALL_BASEDIR)/doc/$(PACKAGE_NAME) +else +INSTALL_DOCDIR:=$(INSTALL_BASEDIR)/doc +endif +endif +endif +ifndef INSTALL_EXAMPLEDIR +ifdef UNIXHier +ifdef INSTALL_FPCPACKAGE +ifdef BSDhier +INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/fpc-$(FPC_VERSION)/$(PACKAGE_NAME) +else +ifdef linuxHier +INSTALL_EXAMPLEDIR:=$(INSTALL_DOCDIR)/examples +else +INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/fpc-$(FPC_VERSION)/examples/$(PACKAGE_NAME) +endif +endif +else +ifdef BSDhier +INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/$(PACKAGE_NAME)-$(PACKAGE_VERSION) +else +ifdef linuxHier +INSTALL_EXAMPLEDIR:=$(INSTALL_DOCDIR)/examples/$(PACKAGE_NAME)-$(PACKAGE_VERSION) +else +INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/$(PACKAGE_NAME)-$(PACKAGE_VERSION) +endif +endif +endif +else +ifdef INSTALL_FPCPACKAGE +INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples/$(PACKAGE_NAME) +else +INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples +endif +endif +endif +ifndef INSTALL_DATADIR +INSTALL_DATADIR=$(INSTALL_BASEDIR) +endif +ifndef INSTALL_SHAREDDIR +INSTALL_SHAREDDIR=$(INSTALL_PREFIX)/lib +endif +ifdef CROSSCOMPILE +ifndef CROSSBINDIR +CROSSBINDIR:=$(wildcard $(CROSSTARGETDIR)/bin/$(SOURCESUFFIX)) +ifeq ($(CROSSBINDIR),) +CROSSBINDIR:=$(wildcard $(INSTALL_BASEDIR)/cross/$(TARGETSUFFIX)/bin/$(FULL_SOURCE)) +endif +endif +else +CROSSBINDIR= +endif +BATCHEXT=.bat +LOADEREXT=.as +EXEEXT=.exe +PPLEXT=.ppl +PPUEXT=.ppu +OEXT=.o +ASMEXT=.s +SMARTEXT=.sl +STATICLIBEXT=.a +SHAREDLIBEXT=.so +SHAREDLIBPREFIX=libfp +STATICLIBPREFIX=libp +IMPORTLIBPREFIX=libimp +RSTEXT=.rst +ifeq ($(findstring 1.0.,$(FPC_VERSION)),) +ifeq ($(OS_TARGET),go32v1) +STATICLIBPREFIX= +SHORTSUFFIX=v1 +endif +ifeq ($(OS_TARGET),go32v2) +STATICLIBPREFIX= +SHORTSUFFIX=dos +endif +ifeq ($(OS_TARGET),watcom) +STATICLIBPREFIX= +OEXT=.obj +ASMEXT=.asm +SHAREDLIBEXT=.dll +SHORTSUFFIX=wat +endif +ifeq ($(OS_TARGET),linux) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=lnx +endif +ifeq ($(OS_TARGET),freebsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=fbs +endif +ifeq ($(OS_TARGET),netbsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=nbs +endif +ifeq ($(OS_TARGET),openbsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=obs +endif +ifeq ($(OS_TARGET),win32) +SHAREDLIBEXT=.dll +SHORTSUFFIX=w32 +endif +ifeq ($(OS_TARGET),os2) +BATCHEXT=.cmd +AOUTEXT=.out +STATICLIBPREFIX= +SHAREDLIBEXT=.dll +SHORTSUFFIX=os2 +ECHO=echo +endif +ifeq ($(OS_TARGET),emx) +BATCHEXT=.cmd +AOUTEXT=.out +STATICLIBPREFIX= +SHAREDLIBEXT=.dll +SHORTSUFFIX=emx +ECHO=echo +endif +ifeq ($(OS_TARGET),amiga) +EXEEXT= +SHAREDLIBEXT=.library +SHORTSUFFIX=amg +endif +ifeq ($(OS_TARGET),morphos) +EXEEXT= +SHAREDLIBEXT=.library +SHORTSUFFIX=mos +endif +ifeq ($(OS_TARGET),atari) +EXEEXT=.ttp +SHORTSUFFIX=ata +endif +ifeq ($(OS_TARGET),beos) +BATCHEXT=.sh +EXEEXT= +SHORTSUFFIX=be +endif +ifeq ($(OS_TARGET),solaris) +BATCHEXT=.sh +EXEEXT= +SHORTSUFFIX=sun +endif +ifeq ($(OS_TARGET),qnx) +BATCHEXT=.sh +EXEEXT= +SHORTSUFFIX=qnx +endif +ifeq ($(OS_TARGET),netware) +EXEEXT=.nlm +STATICLIBPREFIX= +SHORTSUFFIX=nw +endif +ifeq ($(OS_TARGET),netwlibc) +EXEEXT=.nlm +STATICLIBPREFIX= +SHORTSUFFIX=nwl +endif +ifeq ($(OS_TARGET),macos) +BATCHEXT= +EXEEXT= +DEBUGSYMEXT=.xcoff +SHORTSUFFIX=mac +endif +ifeq ($(OS_TARGET),darwin) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=dwn +endif +ifeq ($(OS_TARGET),gba) +EXEEXT=.gba +SHAREDLIBEXT=.so +SHORTSUFFIX=gba +endif +ifeq ($(OS_TARGET),symbian) +SHAREDLIBEXT=.dll +SHORTSUFFIX=symbian +endif +else +ifeq ($(OS_TARGET),go32v1) +PPUEXT=.pp1 +OEXT=.o1 +ASMEXT=.s1 +SMARTEXT=.sl1 +STATICLIBEXT=.a1 +SHAREDLIBEXT=.so1 +STATICLIBPREFIX= +SHORTSUFFIX=v1 +endif +ifeq ($(OS_TARGET),go32v2) +STATICLIBPREFIX= +SHORTSUFFIX=dos +endif +ifeq ($(OS_TARGET),watcom) +STATICLIBPREFIX= +SHORTSUFFIX=wat +endif +ifeq ($(OS_TARGET),linux) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=lnx +endif +ifeq ($(OS_TARGET),freebsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=fbs +endif +ifeq ($(OS_TARGET),netbsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=nbs +endif +ifeq ($(OS_TARGET),openbsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=obs +endif +ifeq ($(OS_TARGET),win32) +PPUEXT=.ppw +OEXT=.ow +ASMEXT=.sw +SMARTEXT=.slw +STATICLIBEXT=.aw +SHAREDLIBEXT=.dll +SHORTSUFFIX=w32 +endif +ifeq ($(OS_TARGET),os2) +BATCHEXT=.cmd +PPUEXT=.ppo +ASMEXT=.so2 +OEXT=.oo2 +AOUTEXT=.out +SMARTEXT=.sl2 +STATICLIBPREFIX= +STATICLIBEXT=.ao2 +SHAREDLIBEXT=.dll +SHORTSUFFIX=os2 +ECHO=echo +endif +ifeq ($(OS_TARGET),amiga) +EXEEXT= +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +SHAREDLIBEXT=.library +SHORTSUFFIX=amg +endif +ifeq ($(OS_TARGET),atari) +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +EXEEXT=.ttp +SHORTSUFFIX=ata +endif +ifeq ($(OS_TARGET),beos) +BATCHEXT=.sh +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +EXEEXT= +SHORTSUFFIX=be +endif +ifeq ($(OS_TARGET),solaris) +BATCHEXT=.sh +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +EXEEXT= +SHORTSUFFIX=sun +endif +ifeq ($(OS_TARGET),qnx) +BATCHEXT=.sh +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +EXEEXT= +SHORTSUFFIX=qnx +endif +ifeq ($(OS_TARGET),netware) +STATICLIBPREFIX= +PPUEXT=.ppu +OEXT=.o +ASMEXT=.s +SMARTEXT=.sl +STATICLIBEXT=.a +SHAREDLIBEXT=.nlm +EXEEXT=.nlm +SHORTSUFFIX=nw +endif +ifeq ($(OS_TARGET),netwlibc) +STATICLIBPREFIX= +PPUEXT=.ppu +OEXT=.o +ASMEXT=.s +SMARTEXT=.sl +STATICLIBEXT=.a +SHAREDLIBEXT=.nlm +EXEEXT=.nlm +SHORTSUFFIX=nwl +endif +ifeq ($(OS_TARGET),macos) +BATCHEXT= +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +EXEEXT= +DEBUGSYMEXT=.xcoff +SHORTSUFFIX=mac +endif +endif +ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),) +FPCMADE=fpcmade.$(SHORTSUFFIX) +ZIPSUFFIX=$(SHORTSUFFIX) +ZIPCROSSPREFIX= +ZIPSOURCESUFFIX=src +ZIPEXAMPLESUFFIX=exm +else +FPCMADE=fpcmade.$(TARGETSUFFIX) +ZIPSOURCESUFFIX=.source +ZIPEXAMPLESUFFIX=.examples +ifdef CROSSCOMPILE +ZIPSUFFIX=.$(SOURCESUFFIX) +ZIPCROSSPREFIX=$(TARGETSUFFIX)- +else +ZIPSUFFIX=.$(TARGETSUFFIX) +ZIPCROSSPREFIX= +endif +endif +ifndef ECHO +ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO= __missing_command_ECHO +else +ECHO:=$(firstword $(ECHO)) +endif +else +ECHO:=$(firstword $(ECHO)) +endif +endif +export ECHO +ifndef DATE +DATE:=$(strip $(wildcard $(addsuffix /gdate$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(DATE),) +DATE:=$(strip $(wildcard $(addsuffix /date$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(DATE),) +DATE= __missing_command_DATE +else +DATE:=$(firstword $(DATE)) +endif +else +DATE:=$(firstword $(DATE)) +endif +endif +export DATE +ifndef GINSTALL +GINSTALL:=$(strip $(wildcard $(addsuffix /ginstall$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(GINSTALL),) +GINSTALL:=$(strip $(wildcard $(addsuffix /install$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(GINSTALL),) +GINSTALL= __missing_command_GINSTALL +else +GINSTALL:=$(firstword $(GINSTALL)) +endif +else +GINSTALL:=$(firstword $(GINSTALL)) +endif +endif +export GINSTALL +ifndef CPPROG +CPPROG:=$(strip $(wildcard $(addsuffix /cp$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(CPPROG),) +CPPROG= __missing_command_CPPROG +else +CPPROG:=$(firstword $(CPPROG)) +endif +endif +export CPPROG +ifndef RMPROG +RMPROG:=$(strip $(wildcard $(addsuffix /rm$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(RMPROG),) +RMPROG= __missing_command_RMPROG +else +RMPROG:=$(firstword $(RMPROG)) +endif +endif +export RMPROG +ifndef MVPROG +MVPROG:=$(strip $(wildcard $(addsuffix /mv$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(MVPROG),) +MVPROG= __missing_command_MVPROG +else +MVPROG:=$(firstword $(MVPROG)) +endif +endif +export MVPROG +ifndef MKDIRPROG +MKDIRPROG:=$(strip $(wildcard $(addsuffix /gmkdir$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(MKDIRPROG),) +MKDIRPROG:=$(strip $(wildcard $(addsuffix /mkdir$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(MKDIRPROG),) +MKDIRPROG= __missing_command_MKDIRPROG +else +MKDIRPROG:=$(firstword $(MKDIRPROG)) +endif +else +MKDIRPROG:=$(firstword $(MKDIRPROG)) +endif +endif +export MKDIRPROG +ifndef ECHOREDIR +ifndef inUnix +ECHOREDIR=echo +else +ECHOREDIR=$(ECHO) +endif +endif +ifndef COPY +COPY:=$(CPPROG) -fp +endif +ifndef COPYTREE +COPYTREE:=$(CPPROG) -Rfp +endif +ifndef MKDIRTREE +MKDIRTREE:=$(MKDIRPROG) -p +endif +ifndef MOVE +MOVE:=$(MVPROG) -f +endif +ifndef DEL +DEL:=$(RMPROG) -f +endif +ifndef DELTREE +DELTREE:=$(RMPROG) -rf +endif +ifndef INSTALL +ifdef inUnix +INSTALL:=$(GINSTALL) -c -m 644 +else +INSTALL:=$(COPY) +endif +endif +ifndef INSTALLEXE +ifdef inUnix +INSTALLEXE:=$(GINSTALL) -c -m 755 +else +INSTALLEXE:=$(COPY) +endif +endif +ifndef MKDIR +MKDIR:=$(GINSTALL) -m 755 -d +endif +export ECHOREDIR COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR +ifndef PPUMOVE +PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(PPUMOVE),) +PPUMOVE= __missing_command_PPUMOVE +else +PPUMOVE:=$(firstword $(PPUMOVE)) +endif +endif +export PPUMOVE +ifndef FPCMAKE +FPCMAKE:=$(strip $(wildcard $(addsuffix /fpcmake$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(FPCMAKE),) +FPCMAKE= __missing_command_FPCMAKE +else +FPCMAKE:=$(firstword $(FPCMAKE)) +endif +endif +export FPCMAKE +ifndef ZIPPROG +ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ZIPPROG),) +ZIPPROG= __missing_command_ZIPPROG +else +ZIPPROG:=$(firstword $(ZIPPROG)) +endif +endif +export ZIPPROG +ifndef TARPROG +TARPROG:=$(strip $(wildcard $(addsuffix /gtar$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(TARPROG),) +TARPROG:=$(strip $(wildcard $(addsuffix /tar$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(TARPROG),) +TARPROG= __missing_command_TARPROG +else +TARPROG:=$(firstword $(TARPROG)) +endif +else +TARPROG:=$(firstword $(TARPROG)) +endif +endif +export TARPROG +ASNAME=$(BINUTILSPREFIX)as +LDNAME=$(BINUTILSPREFIX)ld +ARNAME=$(BINUTILSPREFIX)ar +RCNAME=$(BINUTILSPREFIX)rc +ifneq ($(findstring 1.0.,$(FPC_VERSION)),) +ifeq ($(OS_TARGET),win32) +ifeq ($(CROSSBINDIR),) +ASNAME=asw +LDNAME=ldw +ARNAME=arw +endif +endif +endif +ifndef ASPROG +ifdef CROSSBINDIR +ASPROG=$(CROSSBINDIR)/$(ASNAME)$(SRCEXEEXT) +else +ASPROG=$(ASNAME) +endif +endif +ifndef LDPROG +ifdef CROSSBINDIR +LDPROG=$(CROSSBINDIR)/$(LDNAME)$(SRCEXEEXT) +else +LDPROG=$(LDNAME) +endif +endif +ifndef RCPROG +ifdef CROSSBINDIR +RCPROG=$(CROSSBINDIR)/$(RCNAME)$(SRCEXEEXT) +else +RCPROG=$(RCNAME) +endif +endif +ifndef ARPROG +ifdef CROSSBINDIR +ARPROG=$(CROSSBINDIR)/$(ARNAME)$(SRCEXEEXT) +else +ARPROG=$(ARNAME) +endif +endif +AS=$(ASPROG) +LD=$(LDPROG) +RC=$(RCPROG) +AR=$(ARPROG) +PPAS=ppas$(SRCBATCHEXT) +ifdef inUnix +LDCONFIG=ldconfig +else +LDCONFIG= +endif +ifdef DATE +DATESTR:=$(shell $(DATE) +%Y%m%d) +else +DATESTR= +endif +ifndef UPXPROG +ifeq ($(OS_TARGET),go32v2) +UPXPROG:=1 +endif +ifeq ($(OS_TARGET),win32) +UPXPROG:=1 +endif +ifdef UPXPROG +UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(UPXPROG),) +UPXPROG= +else +UPXPROG:=$(firstword $(UPXPROG)) +endif +else +UPXPROG= +endif +endif +export UPXPROG +ZIPOPT=-9 +ZIPEXT=.zip +ifeq ($(USETAR),bz2) +TAROPT=vj +TAREXT=.tar.bz2 +else +TAROPT=vz +TAREXT=.tar.gz +endif +override REQUIRE_PACKAGES=rtl +ifeq ($(FULL_TARGET),i386-linux) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-go32v2) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-win32) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-os2) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-freebsd) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-beos) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-netbsd) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-solaris) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-qnx) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-netware) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-openbsd) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-wdosx) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-darwin) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-emx) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-watcom) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-netwlibc) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-wince) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-embedded) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),i386-symbian) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),m68k-linux) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),m68k-freebsd) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),m68k-netbsd) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),m68k-amiga) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),m68k-atari) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),m68k-openbsd) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),m68k-palmos) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),m68k-embedded) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),powerpc-linux) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),powerpc-netbsd) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),powerpc-amiga) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),powerpc-macos) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),powerpc-darwin) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),powerpc-morphos) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),powerpc-embedded) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),sparc-linux) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),sparc-netbsd) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),sparc-solaris) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),sparc-embedded) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),x86_64-linux) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),x86_64-freebsd) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),x86_64-darwin) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),x86_64-win64) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),x86_64-embedded) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),arm-linux) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),arm-palmos) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),arm-wince) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),arm-gba) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),arm-nds) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),arm-embedded) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),arm-symbian) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),powerpc64-linux) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),powerpc64-darwin) +REQUIRE_PACKAGES_RTL=1 +endif +ifeq ($(FULL_TARGET),powerpc64-embedded) +REQUIRE_PACKAGES_RTL=1 +endif +ifdef REQUIRE_PACKAGES_RTL +PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/Makefile.fpc,$(PACKAGESDIR)))))) +ifneq ($(PACKAGEDIR_RTL),) +ifneq ($(wildcard $(PACKAGEDIR_RTL)/units/$(TARGETSUFFIX)),) +UNITDIR_RTL=$(PACKAGEDIR_RTL)/units/$(TARGETSUFFIX) +else +UNITDIR_RTL=$(PACKAGEDIR_RTL) +endif +ifdef CHECKDEPEND +$(PACKAGEDIR_RTL)/$(FPCMADE): + $(MAKE) -C $(PACKAGEDIR_RTL) $(FPCMADE) +override ALLDEPENDENCIES+=$(PACKAGEDIR_RTL)/$(FPCMADE) +endif +else +PACKAGEDIR_RTL= +UNITDIR_RTL:=$(subst /Package.fpc,,$(strip $(wildcard $(addsuffix /rtl/Package.fpc,$(UNITSDIR))))) +ifneq ($(UNITDIR_RTL),) +UNITDIR_RTL:=$(firstword $(UNITDIR_RTL)) +else +UNITDIR_RTL= +endif +endif +ifdef UNITDIR_RTL +override COMPILER_UNITDIR+=$(UNITDIR_RTL) +endif +endif +ifndef NOCPUDEF +override FPCOPTDEF=$(CPU_TARGET) +endif +ifneq ($(OS_TARGET),$(OS_SOURCE)) +override FPCOPT+=-T$(OS_TARGET) +endif +ifneq ($(CPU_TARGET),$(CPU_SOURCE)) +override FPCOPT+=-P$(CPU_TARGET) +endif +ifeq ($(OS_SOURCE),openbsd) +override FPCOPT+=-FD$(NEW_BINUTILS_PATH) +endif +ifndef CROSSBOOTSTRAP +ifneq ($(BINUTILSPREFIX),) +override FPCOPT+=-XP$(BINUTILSPREFIX) +endif +ifneq ($(BINUTILSPREFIX),) +override FPCOPT+=-Xr$(RLINKPATH) +endif +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 +ifdef LINKSMART +override FPCOPT+=-XX +endif +ifdef CREATESMART +override FPCOPT+=-CX +endif +ifdef DEBUG +override FPCOPT+=-gl +override FPCOPTDEF+=DEBUG +endif +ifdef RELEASE +ifneq ($(findstring 2.0.,$(FPC_VERSION)),) +ifeq ($(CPU_TARGET),i386) +FPCCPUOPT:=-OG2p3 +endif +ifeq ($(CPU_TARGET),powerpc) +FPCCPUOPT:=-O1r +endif +else +FPCCPUOPT:=-O2 +endif +override FPCOPT+=-Ur -Xs $(FPCCPUOPT) -n +override FPCOPTDEF+=RELEASE +endif +ifdef STRIP +override FPCOPT+=-Xs +endif +ifdef OPTIMIZE +override FPCOPT+=-O2 +endif +ifdef VERBOSE +override FPCOPT+=-vwni +endif +ifdef COMPILER_OPTIONS +override FPCOPT+=$(COMPILER_OPTIONS) +endif +ifdef COMPILER_UNITDIR +override FPCOPT+=$(addprefix -Fu,$(COMPILER_UNITDIR)) +endif +ifdef COMPILER_LIBRARYDIR +override FPCOPT+=$(addprefix -Fl,$(COMPILER_LIBRARYDIR)) +endif +ifdef COMPILER_OBJECTDIR +override FPCOPT+=$(addprefix -Fo,$(COMPILER_OBJECTDIR)) +endif +ifdef COMPILER_INCLUDEDIR +override FPCOPT+=$(addprefix -Fi,$(COMPILER_INCLUDEDIR)) +endif +ifdef CROSSBINDIR +override FPCOPT+=-FD$(CROSSBINDIR) +endif +ifdef COMPILER_TARGETDIR +override FPCOPT+=-FE$(COMPILER_TARGETDIR) +ifeq ($(COMPILER_TARGETDIR),.) +override TARGETDIRPREFIX= +else +override TARGETDIRPREFIX=$(COMPILER_TARGETDIR)/ +endif +endif +ifdef COMPILER_UNITTARGETDIR +override FPCOPT+=-FU$(COMPILER_UNITTARGETDIR) +ifeq ($(COMPILER_UNITTARGETDIR),.) +override UNITTARGETDIRPREFIX= +else +override UNITTARGETDIRPREFIX=$(COMPILER_UNITTARGETDIR)/ +endif +else +ifdef COMPILER_TARGETDIR +override COMPILER_UNITTARGETDIR=$(COMPILER_TARGETDIR) +override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX) +endif +endif +ifdef CREATESHARED +override FPCOPT+=-Cg +ifeq ($(CPU_TARGET),i386) +override FPCOPT+=-Aas +endif +endif +ifeq ($(findstring 2.0.,$(FPC_VERSION)),) +ifeq ($(OS_TARGET),linux) +ifeq ($(CPU_TARGET),x86_64) +override FPCOPT+=-Cg +endif +endif +endif +ifdef LINKSHARED +endif +ifdef OPT +override FPCOPT+=$(OPT) +endif +ifdef FPCOPTDEF +override FPCOPT+=$(addprefix -d,$(FPCOPTDEF)) +endif +ifdef CFGFILE +override FPCOPT+=@$(CFGFILE) +endif +ifdef USEENV +override FPCEXTCMD:=$(FPCOPT) +override FPCOPT:=!FPCEXTCMD +export FPCEXTCMD +endif +override AFULL_TARGET=$(CPU_TARGET)-$(OS_TARGET) +override AFULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE) +ifneq ($(AFULL_TARGET),$(AFULL_SOURCE)) +override ACROSSCOMPILE=1 +endif +ifdef ACROSSCOMPILE +override FPCOPT+=$(CROSSOPT) +endif +override COMPILER:=$(FPC) $(FPCOPT) +ifeq (,$(findstring -s ,$(COMPILER))) +EXECPPAS= +else +ifeq ($(FULL_SOURCE),$(FULL_TARGET)) +ifdef RUNBATCH +EXECPPAS:=@$(RUNBATCH) $(PPAS) +else +EXECPPAS:=@$(PPAS) +endif +endif +endif +.PHONY: fpc_units +ifneq ($(TARGET_UNITS),) +override ALLTARGET+=fpc_units +override UNITPPUFILES=$(addsuffix $(PPUEXT),$(TARGET_UNITS)) +override IMPLICITUNITPPUFILES=$(addsuffix $(PPUEXT),$(TARGET_IMPLICITUNITS)) +override INSTALLPPUFILES+=$(UNITPPUFILES) $(IMPLICITUNITPPUFILES) +override CLEANPPUFILES+=$(UNITPPUFILES) $(IMPLICITUNITPPUFILES) +endif +fpc_units: $(COMPILER_UNITTARGETDIR) $(UNITPPUFILES) +ifdef TARGET_RSTS +override RSTFILES=$(addsuffix $(RSTEXT),$(TARGET_RSTS)) +override CLEANRSTFILES+=$(RSTFILES) +endif +.PHONY: fpc_examples +ifneq ($(TARGET_EXAMPLES),) +HASEXAMPLES=1 +override EXAMPLESOURCEFILES:=$(wildcard $(addsuffix .pp,$(TARGET_EXAMPLES)) $(addsuffix .pas,$(TARGET_EXAMPLES)) $(addsuffix .lpr,$(TARGET_EXAMPLES)) $(addsuffix .dpr,$(TARGET_EXAMPLES))) +override EXAMPLEFILES:=$(addsuffix $(EXEEXT),$(TARGET_EXAMPLES)) +override EXAMPLEOFILES:=$(addsuffix $(OEXT),$(TARGET_EXAMPLES)) $(addprefix $(STATICLIBPREFIX),$(addsuffix $(STATICLIBEXT),$(TARGET_EXAMPLES))) $(addprefix $(IMPORTLIBPREFIX),$(addsuffix $(STATICLIBEXT),$(TARGET_EXAMPLES))) +override CLEANEXEFILES+=$(EXAMPLEFILES) $(EXAMPLEOFILES) +ifeq ($(OS_TARGET),os2) +override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_EXAMPLES)) +endif +ifeq ($(OS_TARGET),emx) +override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_EXAMPLES)) +endif +endif +ifneq ($(TARGET_EXAMPLEDIRS),) +HASEXAMPLES=1 +endif +fpc_examples: all $(EXAMPLEFILES) $(addsuffix _all,$(TARGET_EXAMPLEDIRS)) +.PHONY: fpc_all fpc_smart fpc_debug fpc_release fpc_shared +$(FPCMADE): $(ALLDEPENDENCIES) $(ALLTARGET) + @$(ECHOREDIR) Compiled > $(FPCMADE) +fpc_all: $(FPCMADE) +fpc_smart: + $(MAKE) all LINKSMART=1 CREATESMART=1 +fpc_debug: + $(MAKE) all DEBUG=1 +fpc_release: + $(MAKE) all RELEASE=1 +.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .lpr .dpr .pp .rc .res +$(COMPILER_UNITTARGETDIR): + $(MKDIRTREE) $(COMPILER_UNITTARGETDIR) +$(COMPILER_TARGETDIR): + $(MKDIRTREE) $(COMPILER_TARGETDIR) +%$(PPUEXT): %.pp + $(COMPILER) $< + $(EXECPPAS) +%$(PPUEXT): %.pas + $(COMPILER) $< + $(EXECPPAS) +%$(EXEEXT): %.pp + $(COMPILER) $< + $(EXECPPAS) +%$(EXEEXT): %.pas + $(COMPILER) $< + $(EXECPPAS) +%$(EXEEXT): %.lpr + $(COMPILER) $< + $(EXECPPAS) +%$(EXEEXT): %.dpr + $(COMPILER) $< + $(EXECPPAS) +%.res: %.rc + windres -i $< -o $@ +vpath %.pp $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR) +vpath %.pas $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR) +vpath %.lpr $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR) +vpath %.dpr $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR) +vpath %.inc $(COMPILER_INCLUDEDIR) +vpath %$(OEXT) $(COMPILER_UNITTARGETDIR) +vpath %$(PPUEXT) $(COMPILER_UNITTARGETDIR) +.PHONY: fpc_shared +override INSTALLTARGET+=fpc_shared_install +ifndef SHARED_LIBVERSION +SHARED_LIBVERSION=$(FPC_VERSION) +endif +ifndef SHARED_LIBNAME +SHARED_LIBNAME=$(PACKAGE_NAME) +endif +ifndef SHARED_FULLNAME +SHARED_FULLNAME=$(SHAREDLIBPREFIX)$(SHARED_LIBNAME)-$(SHARED_LIBVERSION)$(SHAREDLIBEXT) +endif +ifndef SHARED_LIBUNITS +SHARED_LIBUNITS:=$(TARGET_UNITS) $(TARGET_IMPLICITUNITS) +override SHARED_LIBUNITS:=$(filter-out $(INSTALL_BUILDUNIT),$(SHARED_LIBUNITS)) +endif +fpc_shared: +ifdef HASSHAREDLIB + $(MAKE) all CREATESHARED=1 LINKSHARED=1 CREATESMART=1 +ifneq ($(SHARED_BUILD),n) + $(PPUMOVE) -q $(SHARED_LIBUNITS) -i$(COMPILER_UNITTARGETDIR) -o$(SHARED_FULLNAME) -d$(COMPILER_UNITTARGETDIR) +endif +else + @$(ECHO) Shared Libraries not supported +endif +fpc_shared_install: +ifneq ($(SHARED_BUILD),n) +ifneq ($(SHARED_LIBUNITS),) +ifneq ($(wildcard $(COMPILER_UNITTARGETDIR)/$(SHARED_FULLNAME)),) + $(INSTALL) $(COMPILER_UNITTARGETDIR)/$(SHARED_FULLNAME) $(INSTALL_SHAREDDIR) +endif +endif +endif +.PHONY: fpc_install fpc_sourceinstall fpc_exampleinstall +ifdef INSTALL_UNITS +override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(INSTALL_UNITS)) +endif +ifdef INSTALL_BUILDUNIT +override INSTALLPPUFILES:=$(filter-out $(INSTALL_BUILDUNIT)$(PPUEXT),$(INSTALLPPUFILES)) +endif +ifdef INSTALLPPUFILES +override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))) $(addprefix $(IMPORTLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))) +ifneq ($(UNITTARGETDIRPREFIX),) +override INSTALLPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(notdir $(INSTALLPPUFILES))) +override INSTALLPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(notdir $(INSTALLPPULINKFILES)))) +endif +override INSTALL_CREATEPACKAGEFPC=1 +endif +ifdef INSTALLEXEFILES +ifneq ($(TARGETDIRPREFIX),) +override INSTALLEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(notdir $(INSTALLEXEFILES))) +endif +endif +fpc_install: all $(INSTALLTARGET) +ifdef INSTALLEXEFILES + $(MKDIR) $(INSTALL_BINDIR) +ifdef UPXPROG + -$(UPXPROG) $(INSTALLEXEFILES) +endif + $(INSTALLEXE) $(INSTALLEXEFILES) $(INSTALL_BINDIR) +endif +ifdef INSTALL_CREATEPACKAGEFPC +ifdef FPCMAKE +ifdef PACKAGE_VERSION +ifneq ($(wildcard Makefile.fpc),) + $(FPCMAKE) -p -T$(CPU_TARGET)-$(OS_TARGET) Makefile.fpc + $(MKDIR) $(INSTALL_UNITDIR) + $(INSTALL) Package.fpc $(INSTALL_UNITDIR) +endif +endif +endif +endif +ifdef INSTALLPPUFILES + $(MKDIR) $(INSTALL_UNITDIR) + $(INSTALL) $(INSTALLPPUFILES) $(INSTALL_UNITDIR) +ifneq ($(INSTALLPPULINKFILES),) + $(INSTALL) $(INSTALLPPULINKFILES) $(INSTALL_UNITDIR) +endif +ifneq ($(wildcard $(LIB_FULLNAME)),) + $(MKDIR) $(INSTALL_LIBDIR) + $(INSTALL) $(LIB_FULLNAME) $(INSTALL_LIBDIR) +ifdef inUnix + ln -sf $(LIB_FULLNAME) $(INSTALL_LIBDIR)/$(LIB_NAME) +endif +endif +endif +ifdef INSTALL_FILES + $(MKDIR) $(INSTALL_DATADIR) + $(INSTALL) $(INSTALL_FILES) $(INSTALL_DATADIR) +endif +fpc_sourceinstall: distclean + $(MKDIR) $(INSTALL_SOURCEDIR) + $(COPYTREE) $(BASEDIR)/* $(INSTALL_SOURCEDIR) +fpc_exampleinstall: $(addsuffix _distclean,$(TARGET_EXAMPLEDIRS)) +ifdef HASEXAMPLES + $(MKDIR) $(INSTALL_EXAMPLEDIR) +endif +ifdef EXAMPLESOURCEFILES + $(COPY) $(EXAMPLESOURCEFILES) $(INSTALL_EXAMPLEDIR) +endif +ifdef TARGET_EXAMPLEDIRS + $(COPYTREE) $(addsuffix /*,$(TARGET_EXAMPLEDIRS)) $(INSTALL_EXAMPLEDIR) +endif +.PHONY: fpc_distinstall +fpc_distinstall: install exampleinstall +.PHONY: fpc_zipinstall fpc_zipsourceinstall fpc_zipexampleinstall +ifndef PACKDIR +ifndef inUnix +PACKDIR=$(BASEDIR)/../fpc-pack +else +PACKDIR=/tmp/fpc-pack +endif +endif +ifndef ZIPNAME +ifdef DIST_ZIPNAME +ZIPNAME=$(DIST_ZIPNAME) +else +ZIPNAME=$(PACKAGE_NAME) +endif +endif +ifndef FULLZIPNAME +FULLZIPNAME=$(ZIPCROSSPREFIX)$(ZIPPREFIX)$(ZIPNAME)$(ZIPSUFFIX) +endif +ifndef ZIPTARGET +ifdef DIST_ZIPTARGET +ZIPTARGET=DIST_ZIPTARGET +else +ZIPTARGET=install +endif +endif +ifndef USEZIP +ifdef inUnix +USETAR=1 +endif +endif +ifndef inUnix +USEZIPWRAPPER=1 +endif +ifdef USEZIPWRAPPER +ZIPPATHSEP=$(PATHSEP) +ZIPWRAPPER=$(subst /,$(PATHSEP),$(DIST_DESTDIR)/fpczip$(SRCBATCHEXT)) +else +ZIPPATHSEP=/ +endif +ZIPCMD_CDPACK:=cd $(subst /,$(ZIPPATHSEP),$(PACKDIR)) +ZIPCMD_CDBASE:=cd $(subst /,$(ZIPPATHSEP),$(BASEDIR)) +ifdef USETAR +ZIPDESTFILE:=$(DIST_DESTDIR)/$(FULLZIPNAME)$(TAREXT) +ZIPCMD_ZIP:=$(TARPROG) cf$(TAROPT) $(ZIPDESTFILE) * +else +ZIPDESTFILE:=$(DIST_DESTDIR)/$(FULLZIPNAME)$(ZIPEXT) +ZIPCMD_ZIP:=$(subst /,$(ZIPPATHSEP),$(ZIPPROG)) -Dr $(ZIPOPT) $(ZIPDESTFILE) * +endif +fpc_zipinstall: + $(MAKE) $(ZIPTARGET) INSTALL_PREFIX=$(PACKDIR) ZIPINSTALL=1 + $(MKDIR) $(DIST_DESTDIR) + $(DEL) $(ZIPDESTFILE) +ifdef USEZIPWRAPPER +ifneq ($(ECHOREDIR),echo) + $(ECHOREDIR) -e "$(subst \,\\,$(ZIPCMD_CDPACK))" > $(ZIPWRAPPER) + $(ECHOREDIR) -e "$(subst \,\\,$(ZIPCMD_ZIP))" >> $(ZIPWRAPPER) + $(ECHOREDIR) -e "$(subst \,\\,$(ZIPCMD_CDBASE))" >> $(ZIPWRAPPER) +else + echo $(ZIPCMD_CDPACK) > $(ZIPWRAPPER) + echo $(ZIPCMD_ZIP) >> $(ZIPWRAPPER) + echo $(ZIPCMD_CDBASE) >> $(ZIPWRAPPER) +endif +ifdef inUnix + /bin/sh $(ZIPWRAPPER) +else +ifdef RUNBATCH + $(RUNBATCH) (ZIPWRAPPER) +else + $(ZIPWRAPPER) +endif +endif + $(DEL) $(ZIPWRAPPER) +else + $(ZIPCMD_CDPACK) ; $(ZIPCMD_ZIP) ; $(ZIPCMD_CDBASE) +endif + $(DELTREE) $(PACKDIR) +fpc_zipsourceinstall: + $(MAKE) fpc_zipinstall ZIPTARGET=sourceinstall ZIPSUFFIX=$(ZIPSOURCESUFFIX) +fpc_zipexampleinstall: +ifdef HASEXAMPLES + $(MAKE) fpc_zipinstall ZIPTARGET=exampleinstall ZIPSUFFIX=$(ZIPEXAMPLESUFFIX) +endif +fpc_zipdistinstall: + $(MAKE) fpc_zipinstall ZIPTARGET=distinstall +.PHONY: fpc_clean fpc_cleanall fpc_distclean +ifdef EXEFILES +override CLEANEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(CLEANEXEFILES)) +endif +ifdef CLEAN_UNITS +override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(CLEAN_UNITS)) +endif +ifdef CLEANPPUFILES +override CLEANPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))) $(addprefix $(IMPORTLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))) +ifdef DEBUGSYMEXT +override CLEANPPULINKFILES+=$(subst $(PPUEXT),$(DEBUGSYMEXT),$(CLEANPPUFILES)) +endif +override CLEANPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILES)) +override CLEANPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILES))) +endif +fpc_clean: $(CLEANTARGET) +ifdef CLEANEXEFILES + -$(DEL) $(CLEANEXEFILES) +endif +ifdef CLEANPPUFILES + -$(DEL) $(CLEANPPUFILES) +endif +ifneq ($(CLEANPPULINKFILES),) + -$(DEL) $(CLEANPPULINKFILES) +endif +ifdef CLEANRSTFILES + -$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES)) +endif +ifdef CLEAN_FILES + -$(DEL) $(CLEAN_FILES) +endif +ifdef LIB_NAME + -$(DEL) $(LIB_NAME) $(LIB_FULLNAME) +endif + -$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE) + -$(DEL) *$(ASMEXT) *_ppas$(BATCHEXT) +fpc_cleanall: $(CLEANTARGET) +ifdef CLEANEXEFILES + -$(DEL) $(CLEANEXEFILES) +endif +ifdef COMPILER_UNITTARGETDIR +ifdef CLEANPPUFILES + -$(DEL) $(CLEANPPUFILES) +endif +ifneq ($(CLEANPPULINKFILES),) + -$(DEL) $(CLEANPPULINKFILES) +endif +ifdef CLEANRSTFILES + -$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES)) +endif +endif + -$(DELTREE) units + -$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT) +ifneq ($(PPUEXT),.ppu) + -$(DEL) *.o *.ppu *.a +endif + -$(DELTREE) *$(SMARTEXT) + -$(DEL) fpcmade.* Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE) + -$(DEL) *_ppas$(BATCHEXT) +ifdef AOUTEXT + -$(DEL) *$(AOUTEXT) +endif +ifdef DEBUGSYMEXT + -$(DEL) *$(DEBUGSYMEXT) +endif +fpc_distclean: cleanall +.PHONY: fpc_baseinfo +override INFORULES+=fpc_baseinfo +fpc_baseinfo: + @$(ECHO) + @$(ECHO) == Package info == + @$(ECHO) Package Name..... $(PACKAGE_NAME) + @$(ECHO) Package Version.. $(PACKAGE_VERSION) + @$(ECHO) + @$(ECHO) == Configuration info == + @$(ECHO) + @$(ECHO) FPC.......... $(FPC) + @$(ECHO) FPC Version.. $(FPC_VERSION) + @$(ECHO) Source CPU... $(CPU_SOURCE) + @$(ECHO) Target CPU... $(CPU_TARGET) + @$(ECHO) Source OS.... $(OS_SOURCE) + @$(ECHO) Target OS.... $(OS_TARGET) + @$(ECHO) Full Source.. $(FULL_SOURCE) + @$(ECHO) Full Target.. $(FULL_TARGET) + @$(ECHO) SourceSuffix. $(SOURCESUFFIX) + @$(ECHO) TargetSuffix. $(TARGETSUFFIX) + @$(ECHO) + @$(ECHO) == Directory info == + @$(ECHO) + @$(ECHO) Required pkgs... $(REQUIRE_PACKAGES) + @$(ECHO) + @$(ECHO) Basedir......... $(BASEDIR) + @$(ECHO) FPCDir.......... $(FPCDIR) + @$(ECHO) CrossBinDir..... $(CROSSBINDIR) + @$(ECHO) UnitsDir........ $(UNITSDIR) + @$(ECHO) PackagesDir..... $(PACKAGESDIR) + @$(ECHO) + @$(ECHO) GCC library..... $(GCCLIBDIR) + @$(ECHO) Other library... $(OTHERLIBDIR) + @$(ECHO) + @$(ECHO) == Tools info == + @$(ECHO) + @$(ECHO) As........ $(AS) + @$(ECHO) Ld........ $(LD) + @$(ECHO) Ar........ $(AR) + @$(ECHO) Rc........ $(RC) + @$(ECHO) + @$(ECHO) Mv........ $(MVPROG) + @$(ECHO) Cp........ $(CPPROG) + @$(ECHO) Rm........ $(RMPROG) + @$(ECHO) GInstall.. $(GINSTALL) + @$(ECHO) Echo...... $(ECHO) + @$(ECHO) Shell..... $(SHELL) + @$(ECHO) Date...... $(DATE) + @$(ECHO) FPCMake... $(FPCMAKE) + @$(ECHO) PPUMove... $(PPUMOVE) + @$(ECHO) Upx....... $(UPXPROG) + @$(ECHO) Zip....... $(ZIPPROG) + @$(ECHO) + @$(ECHO) == Object info == + @$(ECHO) + @$(ECHO) Target Loaders........ $(TARGET_LOADERS) + @$(ECHO) Target Units.......... $(TARGET_UNITS) + @$(ECHO) Target Implicit Units. $(TARGET_IMPLICITUNITS) + @$(ECHO) Target Programs....... $(TARGET_PROGRAMS) + @$(ECHO) Target Dirs........... $(TARGET_DIRS) + @$(ECHO) Target Examples....... $(TARGET_EXAMPLES) + @$(ECHO) Target ExampleDirs.... $(TARGET_EXAMPLEDIRS) + @$(ECHO) + @$(ECHO) Clean Units......... $(CLEAN_UNITS) + @$(ECHO) Clean Files......... $(CLEAN_FILES) + @$(ECHO) + @$(ECHO) Install Units....... $(INSTALL_UNITS) + @$(ECHO) Install Files....... $(INSTALL_FILES) + @$(ECHO) + @$(ECHO) == Install info == + @$(ECHO) + @$(ECHO) DateStr.............. $(DATESTR) + @$(ECHO) ZipName.............. $(ZIPNAME) + @$(ECHO) ZipPrefix............ $(ZIPPREFIX) + @$(ECHO) ZipCrossPrefix....... $(ZIPCROSSPREFIX) + @$(ECHO) ZipSuffix............ $(ZIPSUFFIX) + @$(ECHO) FullZipName.......... $(FULLZIPNAME) + @$(ECHO) Install FPC Package.. $(INSTALL_FPCPACKAGE) + @$(ECHO) + @$(ECHO) Install base dir..... $(INSTALL_BASEDIR) + @$(ECHO) Install binary dir... $(INSTALL_BINDIR) + @$(ECHO) Install library dir.. $(INSTALL_LIBDIR) + @$(ECHO) Install units dir.... $(INSTALL_UNITDIR) + @$(ECHO) Install source dir... $(INSTALL_SOURCEDIR) + @$(ECHO) Install doc dir...... $(INSTALL_DOCDIR) + @$(ECHO) Install example dir.. $(INSTALL_EXAMPLEDIR) + @$(ECHO) Install data dir..... $(INSTALL_DATADIR) + @$(ECHO) + @$(ECHO) Dist destination dir. $(DIST_DESTDIR) + @$(ECHO) Dist zip name........ $(DIST_ZIPNAME) + @$(ECHO) +.PHONY: fpc_info +fpc_info: $(INFORULES) +.PHONY: fpc_makefile fpc_makefiles fpc_makefile_sub1 fpc_makefile_sub2 \ + fpc_makefile_dirs +fpc_makefile: + $(FPCMAKE) -w -T$(OS_TARGET) Makefile.fpc +fpc_makefile_sub1: +ifdef TARGET_DIRS + $(FPCMAKE) -w -T$(OS_TARGET) $(addsuffix /Makefile.fpc,$(TARGET_DIRS)) +endif +ifdef TARGET_EXAMPLEDIRS + $(FPCMAKE) -w -T$(OS_TARGET) $(addsuffix /Makefile.fpc,$(TARGET_EXAMPLEDIRS)) +endif +fpc_makefile_sub2: $(addsuffix _makefile_dirs,$(TARGET_DIRS) $(TARGET_EXAMPLEDIRS)) +fpc_makefile_dirs: fpc_makefile_sub1 fpc_makefile_sub2 +fpc_makefiles: fpc_makefile fpc_makefile_dirs +ifeq ($(FULL_TARGET),i386-linux) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-go32v2) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-win32) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-os2) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-freebsd) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-beos) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-netbsd) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-solaris) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-qnx) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-netware) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-openbsd) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-wdosx) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-darwin) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-emx) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-watcom) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-netwlibc) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-wince) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-embedded) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),i386-symbian) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),m68k-linux) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),m68k-freebsd) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),m68k-netbsd) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),m68k-amiga) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),m68k-atari) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),m68k-openbsd) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),m68k-palmos) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),m68k-embedded) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),powerpc-linux) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),powerpc-netbsd) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),powerpc-amiga) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),powerpc-macos) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),powerpc-darwin) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),powerpc-morphos) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),powerpc-embedded) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),sparc-linux) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),sparc-netbsd) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),sparc-solaris) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),sparc-embedded) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),x86_64-linux) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),x86_64-freebsd) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),x86_64-darwin) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),x86_64-win64) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),x86_64-embedded) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),arm-linux) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),arm-palmos) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),arm-wince) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),arm-gba) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),arm-nds) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),arm-embedded) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),arm-symbian) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),powerpc64-linux) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),powerpc64-darwin) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifeq ($(FULL_TARGET),powerpc64-embedded) +TARGET_EXAMPLEDIRS_EXAMPLES=1 +endif +ifdef TARGET_EXAMPLEDIRS_EXAMPLES +examples_all: + $(MAKE) -C examples all +examples_debug: + $(MAKE) -C examples debug +examples_smart: + $(MAKE) -C examples smart +examples_release: + $(MAKE) -C examples release +examples_units: + $(MAKE) -C examples units +examples_examples: + $(MAKE) -C examples examples +examples_shared: + $(MAKE) -C examples shared +examples_install: + $(MAKE) -C examples install +examples_sourceinstall: + $(MAKE) -C examples sourceinstall +examples_exampleinstall: + $(MAKE) -C examples exampleinstall +examples_distinstall: + $(MAKE) -C examples distinstall +examples_zipinstall: + $(MAKE) -C examples zipinstall +examples_zipsourceinstall: + $(MAKE) -C examples zipsourceinstall +examples_zipexampleinstall: + $(MAKE) -C examples zipexampleinstall +examples_zipdistinstall: + $(MAKE) -C examples zipdistinstall +examples_clean: + $(MAKE) -C examples clean +examples_distclean: + $(MAKE) -C examples distclean +examples_cleanall: + $(MAKE) -C examples cleanall +examples_info: + $(MAKE) -C examples info +examples_makefiles: + $(MAKE) -C examples makefiles +examples: + $(MAKE) -C examples all +.PHONY: examples_all examples_debug examples_smart examples_release examples_units examples_examples examples_shared examples_install examples_sourceinstall examples_exampleinstall examples_distinstall examples_zipinstall examples_zipsourceinstall examples_zipexampleinstall examples_zipdistinstall examples_clean examples_distclean examples_cleanall examples_info examples_makefiles examples +endif +all: fpc_all +debug: fpc_debug +smart: fpc_smart +release: fpc_release +units: fpc_units +examples: fpc_examples +shared: fpc_shared +install: fpc_install +sourceinstall: fpc_sourceinstall +exampleinstall: fpc_exampleinstall +distinstall: fpc_distinstall +zipinstall: fpc_zipinstall +zipsourceinstall: fpc_zipsourceinstall +zipexampleinstall: fpc_zipexampleinstall +zipdistinstall: fpc_zipdistinstall +clean: fpc_clean $(addsuffix _clean,$(TARGET_EXAMPLEDIRS)) +distclean: fpc_distclean +cleanall: fpc_cleanall +info: fpc_info +makefiles: fpc_makefiles +.PHONY: all debug smart release units examples shared install sourceinstall exampleinstall distinstall zipinstall zipsourceinstall zipexampleinstall zipdistinstall clean distclean cleanall info makefiles +ifneq ($(wildcard fpcmake.loc),) +include fpcmake.loc +endif +.NOTPARALLEL: diff --git a/packages/fv/Makefile.fpc b/packages/fv/Makefile.fpc new file mode 100644 index 0000000000..a71340c514 --- /dev/null +++ b/packages/fv/Makefile.fpc @@ -0,0 +1,33 @@ +# +# Makefile.fpc for Free Vision for Free Pascal +# + +[package] +name=fv +version=2.0.0 + +[target] +units=buildfv +implicitunits=app colortxt dialogs drivers editors \ + fvcommon fvconsts gadgets histlist inplong memory \ + menus msgbox statuses stddlg tabs time validate \ + views sysmsg asciitab timeddlg outline +exampledirs=examples +rsts=app dialogs editors msgbox stddlg + +[libs] +libname=libfpfv.so +libversion=2.0.0 + +[compiler] +sourcedir=src + +[install] +buildunit=buildfv +fpcpackage=y + +[default] +fpcdir=../.. + +[rules] +.NOTPARALLEL: diff --git a/packages/fv/examples/Makefile b/packages/fv/examples/Makefile new file mode 100644 index 0000000000..c1b5642a6b --- /dev/null +++ b/packages/fv/examples/Makefile @@ -0,0 +1,1928 @@ +# +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2007/12/01] +# +default: all +MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded +BSDs = freebsd netbsd openbsd darwin +UNIXs = linux $(BSDs) solaris qnx +LIMIT83fs = go32v2 os2 emx watcom +OSNeedsComspecToRunBatch = go32v2 watcom +FORCE: +.PHONY: FORCE +override PATH:=$(patsubst %/,%,$(subst \,/,$(PATH))) +ifneq ($(findstring darwin,$(OSTYPE)),) +inUnix=1 #darwin +SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH))) +else +ifeq ($(findstring ;,$(PATH)),) +inUnix=1 +SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH))) +else +SEARCHPATH:=$(subst ;, ,$(PATH)) +endif +endif +SEARCHPATH+=$(patsubst %/,%,$(subst \,/,$(dir $(MAKE)))) +PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(SEARCHPATH)))) +ifeq ($(PWD),) +PWD:=$(strip $(wildcard $(addsuffix /pwd,$(SEARCHPATH)))) +ifeq ($(PWD),) +$(error You need the GNU utils package to use this Makefile) +else +PWD:=$(firstword $(PWD)) +SRCEXEEXT= +endif +else +PWD:=$(firstword $(PWD)) +SRCEXEEXT=.exe +endif +ifndef inUnix +ifeq ($(OS),Windows_NT) +inWinNT=1 +else +ifdef OS2_SHELL +inOS2=1 +endif +endif +else +ifneq ($(findstring cygdrive,$(PATH)),) +inCygWin=1 +endif +endif +ifdef inUnix +SRCBATCHEXT=.sh +else +ifdef inOS2 +SRCBATCHEXT=.cmd +else +SRCBATCHEXT=.bat +endif +endif +ifdef COMSPEC +ifneq ($(findstring $(OS_SOURCE),$(OSNeedsComspecToRunBatch)),) +RUNBATCH=$(COMSPEC) /C +endif +endif +ifdef inUnix +PATHSEP=/ +else +PATHSEP:=$(subst /,\,/) +ifdef inCygWin +PATHSEP=/ +endif +endif +ifdef PWD +BASEDIR:=$(subst \,/,$(shell $(PWD))) +ifdef inCygWin +ifneq ($(findstring /cygdrive/,$(BASEDIR)),) +BASENODIR:=$(patsubst /cygdrive%,%,$(BASEDIR)) +BASEDRIVE:=$(firstword $(subst /, ,$(BASENODIR))) +BASEDIR:=$(subst /cygdrive/$(BASEDRIVE)/,$(BASEDRIVE):/,$(BASEDIR)) +endif +endif +else +BASEDIR=. +endif +ifdef inOS2 +ifndef ECHO +ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO=echo +else +ECHO:=$(firstword $(ECHO)) +endif +else +ECHO:=$(firstword $(ECHO)) +endif +endif +export ECHO +endif +override DEFAULT_FPCDIR=../../.. +ifndef FPC +ifdef PP +FPC=$(PP) +endif +endif +ifndef FPC +FPCPROG:=$(strip $(wildcard $(addsuffix /fpc$(SRCEXEEXT),$(SEARCHPATH)))) +ifneq ($(FPCPROG),) +FPCPROG:=$(firstword $(FPCPROG)) +ifneq ($(CPU_TARGET),) +FPC:=$(shell $(FPCPROG) -P$(CPU_TARGET) -PB) +else +FPC:=$(shell $(FPCPROG) -PB) +endif +ifneq ($(findstring Error,$(FPC)),) +override FPC=$(firstword $(strip $(wildcard $(addsuffix /ppc386$(SRCEXEEXT),$(SEARCHPATH))))) +endif +else +override FPC=$(firstword $(strip $(wildcard $(addsuffix /ppc386$(SRCEXEEXT),$(SEARCHPATH))))) +endif +endif +override FPC:=$(subst $(SRCEXEEXT),,$(FPC)) +override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT) +FOUNDFPC:=$(strip $(wildcard $(FPC))) +ifeq ($(FOUNDFPC),) +FOUNDFPC=$(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH)))) +ifeq ($(FOUNDFPC),) +$(error Compiler $(FPC) not found) +endif +endif +ifndef FPC_COMPILERINFO +FPC_COMPILERINFO:=$(shell $(FPC) -iVSPTPSOTO) +endif +ifndef FPC_VERSION +FPC_VERSION:=$(word 1,$(FPC_COMPILERINFO)) +endif +export FPC FPC_VERSION FPC_COMPILERINFO +unexport CHECKDEPEND ALLDEPENDENCIES +ifndef CPU_TARGET +ifdef CPU_TARGET_DEFAULT +CPU_TARGET=$(CPU_TARGET_DEFAULT) +endif +endif +ifndef OS_TARGET +ifdef OS_TARGET_DEFAULT +OS_TARGET=$(OS_TARGET_DEFAULT) +endif +endif +ifneq ($(words $(FPC_COMPILERINFO)),5) +FPC_COMPILERINFO+=$(shell $(FPC) -iSP) +FPC_COMPILERINFO+=$(shell $(FPC) -iTP) +FPC_COMPILERINFO+=$(shell $(FPC) -iSO) +FPC_COMPILERINFO+=$(shell $(FPC) -iTO) +endif +ifndef CPU_SOURCE +CPU_SOURCE:=$(word 2,$(FPC_COMPILERINFO)) +endif +ifndef CPU_TARGET +CPU_TARGET:=$(word 3,$(FPC_COMPILERINFO)) +endif +ifndef OS_SOURCE +OS_SOURCE:=$(word 4,$(FPC_COMPILERINFO)) +endif +ifndef OS_TARGET +OS_TARGET:=$(word 5,$(FPC_COMPILERINFO)) +endif +FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET) +FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE) +ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),) +TARGETSUFFIX=$(OS_TARGET) +SOURCESUFFIX=$(OS_SOURCE) +else +TARGETSUFFIX=$(FULL_TARGET) +SOURCESUFFIX=$(FULL_SOURCE) +endif +ifneq ($(FULL_TARGET),$(FULL_SOURCE)) +CROSSCOMPILE=1 +endif +ifeq ($(findstring makefile,$(MAKECMDGOALS)),) +ifeq ($(findstring $(FULL_TARGET),$(MAKEFILETARGETS)),) +$(error The Makefile doesn't support target $(FULL_TARGET), please run fpcmake first) +endif +endif +ifneq ($(findstring $(OS_TARGET),$(BSDs)),) +BSDhier=1 +endif +ifeq ($(OS_TARGET),linux) +linuxHier=1 +endif +export OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE TARGETSUFFIX SOURCESUFFIX CROSSCOMPILE +ifdef FPCDIR +override FPCDIR:=$(subst \,/,$(FPCDIR)) +ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) +override FPCDIR=wrong +endif +else +override FPCDIR=wrong +endif +ifdef DEFAULT_FPCDIR +ifeq ($(FPCDIR),wrong) +override FPCDIR:=$(subst \,/,$(DEFAULT_FPCDIR)) +ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) +override FPCDIR=wrong +endif +endif +endif +ifeq ($(FPCDIR),wrong) +ifdef inUnix +override FPCDIR=/usr/local/lib/fpc/$(FPC_VERSION) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR=/usr/lib/fpc/$(FPC_VERSION) +endif +else +override FPCDIR:=$(subst /$(FPC),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH)))))) +override FPCDIR:=$(FPCDIR)/.. +ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) +override FPCDIR:=$(FPCDIR)/.. +ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) +override FPCDIR:=$(BASEDIR) +ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),) +override FPCDIR=c:/pp +endif +endif +endif +endif +endif +ifndef CROSSBINDIR +CROSSBINDIR:=$(wildcard $(FPCDIR)/bin/$(TARGETSUFFIX)) +endif +ifndef BINUTILSPREFIX +ifndef CROSSBINDIR +ifdef CROSSCOMPILE +BINUTILSPREFIX=$(CPU_TARGET)-$(OS_TARGET)- +endif +endif +endif +UNITSDIR:=$(wildcard $(FPCDIR)/units/$(TARGETSUFFIX)) +ifeq ($(UNITSDIR),) +UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET)) +endif +PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages $(FPCDIR)/packages/base $(FPCDIR)/packages/extra) +ifeq ($(FULL_TARGET),i386-linux) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-go32v2) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-win32) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-os2) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-freebsd) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-beos) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-netbsd) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-solaris) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-qnx) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-netware) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-openbsd) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-wdosx) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-darwin) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-emx) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-watcom) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-netwlibc) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-wince) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-embedded) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),i386-symbian) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),m68k-linux) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),m68k-freebsd) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),m68k-netbsd) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),m68k-amiga) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),m68k-atari) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),m68k-openbsd) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),m68k-palmos) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),m68k-embedded) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),powerpc-linux) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),powerpc-netbsd) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),powerpc-amiga) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),powerpc-macos) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),powerpc-darwin) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),powerpc-morphos) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),powerpc-embedded) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),sparc-linux) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),sparc-netbsd) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),sparc-solaris) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),sparc-embedded) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),x86_64-linux) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),x86_64-freebsd) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),x86_64-darwin) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),x86_64-win64) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),x86_64-embedded) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),arm-linux) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),arm-palmos) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),arm-wince) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),arm-gba) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),arm-nds) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),arm-embedded) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),arm-symbian) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),powerpc64-linux) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),powerpc64-darwin) +override TARGET_PROGRAMS+=testapp +endif +ifeq ($(FULL_TARGET),powerpc64-embedded) +override TARGET_PROGRAMS+=testapp +endif +ifdef REQUIRE_UNITSDIR +override UNITSDIR+=$(REQUIRE_UNITSDIR) +endif +ifdef REQUIRE_PACKAGESDIR +override PACKAGESDIR+=$(REQUIRE_PACKAGESDIR) +endif +ifdef ZIPINSTALL +ifneq ($(findstring $(OS_TARGET),$(UNIXs)),) +UNIXHier=1 +endif +else +ifneq ($(findstring $(OS_SOURCE),$(UNIXs)),) +UNIXHier=1 +endif +endif +ifndef INSTALL_PREFIX +ifdef PREFIX +INSTALL_PREFIX=$(PREFIX) +endif +endif +ifndef INSTALL_PREFIX +ifdef UNIXHier +INSTALL_PREFIX=/usr/local +else +ifdef INSTALL_FPCPACKAGE +INSTALL_BASEDIR:=/pp +else +INSTALL_BASEDIR:=/$(PACKAGE_NAME) +endif +endif +endif +export INSTALL_PREFIX +ifdef INSTALL_FPCSUBDIR +export INSTALL_FPCSUBDIR +endif +ifndef DIST_DESTDIR +DIST_DESTDIR:=$(BASEDIR) +endif +export DIST_DESTDIR +ifndef COMPILER_UNITTARGETDIR +ifdef PACKAGEDIR_MAIN +COMPILER_UNITTARGETDIR=$(PACKAGEDIR_MAIN)/units/$(TARGETSUFFIX) +else +COMPILER_UNITTARGETDIR=units/$(TARGETSUFFIX) +endif +endif +ifndef COMPILER_TARGETDIR +COMPILER_TARGETDIR=. +endif +ifndef INSTALL_BASEDIR +ifdef UNIXHier +ifdef INSTALL_FPCPACKAGE +INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/fpc/$(FPC_VERSION) +else +INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/$(PACKAGE_NAME) +endif +else +INSTALL_BASEDIR:=$(INSTALL_PREFIX) +endif +endif +ifndef INSTALL_BINDIR +ifdef UNIXHier +INSTALL_BINDIR:=$(INSTALL_PREFIX)/bin +else +INSTALL_BINDIR:=$(INSTALL_BASEDIR)/bin +ifdef INSTALL_FPCPACKAGE +ifdef CROSSCOMPILE +ifdef CROSSINSTALL +INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(SOURCESUFFIX) +else +INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(TARGETSUFFIX) +endif +else +INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(TARGETSUFFIX) +endif +endif +endif +endif +ifndef INSTALL_UNITDIR +INSTALL_UNITDIR:=$(INSTALL_BASEDIR)/units/$(TARGETSUFFIX) +ifdef INSTALL_FPCPACKAGE +ifdef PACKAGE_NAME +INSTALL_UNITDIR:=$(INSTALL_UNITDIR)/$(PACKAGE_NAME) +endif +endif +endif +ifndef INSTALL_LIBDIR +ifdef UNIXHier +INSTALL_LIBDIR:=$(INSTALL_PREFIX)/lib +else +INSTALL_LIBDIR:=$(INSTALL_UNITDIR) +endif +endif +ifndef INSTALL_SOURCEDIR +ifdef UNIXHier +ifdef BSDhier +SRCPREFIXDIR=share/src +else +ifdef linuxHier +SRCPREFIXDIR=share/src +else +SRCPREFIXDIR=src +endif +endif +ifdef INSTALL_FPCPACKAGE +ifdef INSTALL_FPCSUBDIR +INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/fpc-$(FPC_VERSION)/$(INSTALL_FPCSUBDIR)/$(PACKAGE_NAME) +else +INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/fpc-$(FPC_VERSION)/$(PACKAGE_NAME) +endif +else +INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/$(PACKAGE_NAME)-$(PACKAGE_VERSION) +endif +else +ifdef INSTALL_FPCPACKAGE +ifdef INSTALL_FPCSUBDIR +INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source/$(INSTALL_FPCSUBDIR)/$(PACKAGE_NAME) +else +INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source/$(PACKAGE_NAME) +endif +else +INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source +endif +endif +endif +ifndef INSTALL_DOCDIR +ifdef UNIXHier +ifdef BSDhier +DOCPREFIXDIR=share/doc +else +ifdef linuxHier +DOCPREFIXDIR=share/doc +else +DOCPREFIXDIR=doc +endif +endif +ifdef INSTALL_FPCPACKAGE +INSTALL_DOCDIR:=$(INSTALL_PREFIX)/$(DOCPREFIXDIR)/fpc-$(FPC_VERSION)/$(PACKAGE_NAME) +else +INSTALL_DOCDIR:=$(INSTALL_PREFIX)/$(DOCPREFIXDIR)/$(PACKAGE_NAME)-$(PACKAGE_VERSION) +endif +else +ifdef INSTALL_FPCPACKAGE +INSTALL_DOCDIR:=$(INSTALL_BASEDIR)/doc/$(PACKAGE_NAME) +else +INSTALL_DOCDIR:=$(INSTALL_BASEDIR)/doc +endif +endif +endif +ifndef INSTALL_EXAMPLEDIR +ifdef UNIXHier +ifdef INSTALL_FPCPACKAGE +ifdef BSDhier +INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/fpc-$(FPC_VERSION)/$(PACKAGE_NAME) +else +ifdef linuxHier +INSTALL_EXAMPLEDIR:=$(INSTALL_DOCDIR)/examples +else +INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/fpc-$(FPC_VERSION)/examples/$(PACKAGE_NAME) +endif +endif +else +ifdef BSDhier +INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/$(PACKAGE_NAME)-$(PACKAGE_VERSION) +else +ifdef linuxHier +INSTALL_EXAMPLEDIR:=$(INSTALL_DOCDIR)/examples/$(PACKAGE_NAME)-$(PACKAGE_VERSION) +else +INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/$(PACKAGE_NAME)-$(PACKAGE_VERSION) +endif +endif +endif +else +ifdef INSTALL_FPCPACKAGE +INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples/$(PACKAGE_NAME) +else +INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples +endif +endif +endif +ifndef INSTALL_DATADIR +INSTALL_DATADIR=$(INSTALL_BASEDIR) +endif +ifndef INSTALL_SHAREDDIR +INSTALL_SHAREDDIR=$(INSTALL_PREFIX)/lib +endif +ifdef CROSSCOMPILE +ifndef CROSSBINDIR +CROSSBINDIR:=$(wildcard $(CROSSTARGETDIR)/bin/$(SOURCESUFFIX)) +ifeq ($(CROSSBINDIR),) +CROSSBINDIR:=$(wildcard $(INSTALL_BASEDIR)/cross/$(TARGETSUFFIX)/bin/$(FULL_SOURCE)) +endif +endif +else +CROSSBINDIR= +endif +BATCHEXT=.bat +LOADEREXT=.as +EXEEXT=.exe +PPLEXT=.ppl +PPUEXT=.ppu +OEXT=.o +ASMEXT=.s +SMARTEXT=.sl +STATICLIBEXT=.a +SHAREDLIBEXT=.so +SHAREDLIBPREFIX=libfp +STATICLIBPREFIX=libp +IMPORTLIBPREFIX=libimp +RSTEXT=.rst +ifeq ($(findstring 1.0.,$(FPC_VERSION)),) +ifeq ($(OS_TARGET),go32v1) +STATICLIBPREFIX= +SHORTSUFFIX=v1 +endif +ifeq ($(OS_TARGET),go32v2) +STATICLIBPREFIX= +SHORTSUFFIX=dos +endif +ifeq ($(OS_TARGET),watcom) +STATICLIBPREFIX= +OEXT=.obj +ASMEXT=.asm +SHAREDLIBEXT=.dll +SHORTSUFFIX=wat +endif +ifeq ($(OS_TARGET),linux) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=lnx +endif +ifeq ($(OS_TARGET),freebsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=fbs +endif +ifeq ($(OS_TARGET),netbsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=nbs +endif +ifeq ($(OS_TARGET),openbsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=obs +endif +ifeq ($(OS_TARGET),win32) +SHAREDLIBEXT=.dll +SHORTSUFFIX=w32 +endif +ifeq ($(OS_TARGET),os2) +BATCHEXT=.cmd +AOUTEXT=.out +STATICLIBPREFIX= +SHAREDLIBEXT=.dll +SHORTSUFFIX=os2 +ECHO=echo +endif +ifeq ($(OS_TARGET),emx) +BATCHEXT=.cmd +AOUTEXT=.out +STATICLIBPREFIX= +SHAREDLIBEXT=.dll +SHORTSUFFIX=emx +ECHO=echo +endif +ifeq ($(OS_TARGET),amiga) +EXEEXT= +SHAREDLIBEXT=.library +SHORTSUFFIX=amg +endif +ifeq ($(OS_TARGET),morphos) +EXEEXT= +SHAREDLIBEXT=.library +SHORTSUFFIX=mos +endif +ifeq ($(OS_TARGET),atari) +EXEEXT=.ttp +SHORTSUFFIX=ata +endif +ifeq ($(OS_TARGET),beos) +BATCHEXT=.sh +EXEEXT= +SHORTSUFFIX=be +endif +ifeq ($(OS_TARGET),solaris) +BATCHEXT=.sh +EXEEXT= +SHORTSUFFIX=sun +endif +ifeq ($(OS_TARGET),qnx) +BATCHEXT=.sh +EXEEXT= +SHORTSUFFIX=qnx +endif +ifeq ($(OS_TARGET),netware) +EXEEXT=.nlm +STATICLIBPREFIX= +SHORTSUFFIX=nw +endif +ifeq ($(OS_TARGET),netwlibc) +EXEEXT=.nlm +STATICLIBPREFIX= +SHORTSUFFIX=nwl +endif +ifeq ($(OS_TARGET),macos) +BATCHEXT= +EXEEXT= +DEBUGSYMEXT=.xcoff +SHORTSUFFIX=mac +endif +ifeq ($(OS_TARGET),darwin) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=dwn +endif +ifeq ($(OS_TARGET),gba) +EXEEXT=.gba +SHAREDLIBEXT=.so +SHORTSUFFIX=gba +endif +ifeq ($(OS_TARGET),symbian) +SHAREDLIBEXT=.dll +SHORTSUFFIX=symbian +endif +else +ifeq ($(OS_TARGET),go32v1) +PPUEXT=.pp1 +OEXT=.o1 +ASMEXT=.s1 +SMARTEXT=.sl1 +STATICLIBEXT=.a1 +SHAREDLIBEXT=.so1 +STATICLIBPREFIX= +SHORTSUFFIX=v1 +endif +ifeq ($(OS_TARGET),go32v2) +STATICLIBPREFIX= +SHORTSUFFIX=dos +endif +ifeq ($(OS_TARGET),watcom) +STATICLIBPREFIX= +SHORTSUFFIX=wat +endif +ifeq ($(OS_TARGET),linux) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=lnx +endif +ifeq ($(OS_TARGET),freebsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=fbs +endif +ifeq ($(OS_TARGET),netbsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=nbs +endif +ifeq ($(OS_TARGET),openbsd) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=obs +endif +ifeq ($(OS_TARGET),win32) +PPUEXT=.ppw +OEXT=.ow +ASMEXT=.sw +SMARTEXT=.slw +STATICLIBEXT=.aw +SHAREDLIBEXT=.dll +SHORTSUFFIX=w32 +endif +ifeq ($(OS_TARGET),os2) +BATCHEXT=.cmd +PPUEXT=.ppo +ASMEXT=.so2 +OEXT=.oo2 +AOUTEXT=.out +SMARTEXT=.sl2 +STATICLIBPREFIX= +STATICLIBEXT=.ao2 +SHAREDLIBEXT=.dll +SHORTSUFFIX=os2 +ECHO=echo +endif +ifeq ($(OS_TARGET),amiga) +EXEEXT= +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +SHAREDLIBEXT=.library +SHORTSUFFIX=amg +endif +ifeq ($(OS_TARGET),atari) +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +EXEEXT=.ttp +SHORTSUFFIX=ata +endif +ifeq ($(OS_TARGET),beos) +BATCHEXT=.sh +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +EXEEXT= +SHORTSUFFIX=be +endif +ifeq ($(OS_TARGET),solaris) +BATCHEXT=.sh +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +EXEEXT= +SHORTSUFFIX=sun +endif +ifeq ($(OS_TARGET),qnx) +BATCHEXT=.sh +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +EXEEXT= +SHORTSUFFIX=qnx +endif +ifeq ($(OS_TARGET),netware) +STATICLIBPREFIX= +PPUEXT=.ppu +OEXT=.o +ASMEXT=.s +SMARTEXT=.sl +STATICLIBEXT=.a +SHAREDLIBEXT=.nlm +EXEEXT=.nlm +SHORTSUFFIX=nw +endif +ifeq ($(OS_TARGET),netwlibc) +STATICLIBPREFIX= +PPUEXT=.ppu +OEXT=.o +ASMEXT=.s +SMARTEXT=.sl +STATICLIBEXT=.a +SHAREDLIBEXT=.nlm +EXEEXT=.nlm +SHORTSUFFIX=nwl +endif +ifeq ($(OS_TARGET),macos) +BATCHEXT= +PPUEXT=.ppu +ASMEXT=.s +OEXT=.o +SMARTEXT=.sl +STATICLIBEXT=.a +EXEEXT= +DEBUGSYMEXT=.xcoff +SHORTSUFFIX=mac +endif +endif +ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),) +FPCMADE=fpcmade.$(SHORTSUFFIX) +ZIPSUFFIX=$(SHORTSUFFIX) +ZIPCROSSPREFIX= +ZIPSOURCESUFFIX=src +ZIPEXAMPLESUFFIX=exm +else +FPCMADE=fpcmade.$(TARGETSUFFIX) +ZIPSOURCESUFFIX=.source +ZIPEXAMPLESUFFIX=.examples +ifdef CROSSCOMPILE +ZIPSUFFIX=.$(SOURCESUFFIX) +ZIPCROSSPREFIX=$(TARGETSUFFIX)- +else +ZIPSUFFIX=.$(TARGETSUFFIX) +ZIPCROSSPREFIX= +endif +endif +ifndef ECHO +ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO= __missing_command_ECHO +else +ECHO:=$(firstword $(ECHO)) +endif +else +ECHO:=$(firstword $(ECHO)) +endif +endif +export ECHO +ifndef DATE +DATE:=$(strip $(wildcard $(addsuffix /gdate$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(DATE),) +DATE:=$(strip $(wildcard $(addsuffix /date$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(DATE),) +DATE= __missing_command_DATE +else +DATE:=$(firstword $(DATE)) +endif +else +DATE:=$(firstword $(DATE)) +endif +endif +export DATE +ifndef GINSTALL +GINSTALL:=$(strip $(wildcard $(addsuffix /ginstall$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(GINSTALL),) +GINSTALL:=$(strip $(wildcard $(addsuffix /install$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(GINSTALL),) +GINSTALL= __missing_command_GINSTALL +else +GINSTALL:=$(firstword $(GINSTALL)) +endif +else +GINSTALL:=$(firstword $(GINSTALL)) +endif +endif +export GINSTALL +ifndef CPPROG +CPPROG:=$(strip $(wildcard $(addsuffix /cp$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(CPPROG),) +CPPROG= __missing_command_CPPROG +else +CPPROG:=$(firstword $(CPPROG)) +endif +endif +export CPPROG +ifndef RMPROG +RMPROG:=$(strip $(wildcard $(addsuffix /rm$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(RMPROG),) +RMPROG= __missing_command_RMPROG +else +RMPROG:=$(firstword $(RMPROG)) +endif +endif +export RMPROG +ifndef MVPROG +MVPROG:=$(strip $(wildcard $(addsuffix /mv$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(MVPROG),) +MVPROG= __missing_command_MVPROG +else +MVPROG:=$(firstword $(MVPROG)) +endif +endif +export MVPROG +ifndef MKDIRPROG +MKDIRPROG:=$(strip $(wildcard $(addsuffix /gmkdir$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(MKDIRPROG),) +MKDIRPROG:=$(strip $(wildcard $(addsuffix /mkdir$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(MKDIRPROG),) +MKDIRPROG= __missing_command_MKDIRPROG +else +MKDIRPROG:=$(firstword $(MKDIRPROG)) +endif +else +MKDIRPROG:=$(firstword $(MKDIRPROG)) +endif +endif +export MKDIRPROG +ifndef ECHOREDIR +ifndef inUnix +ECHOREDIR=echo +else +ECHOREDIR=$(ECHO) +endif +endif +ifndef COPY +COPY:=$(CPPROG) -fp +endif +ifndef COPYTREE +COPYTREE:=$(CPPROG) -Rfp +endif +ifndef MKDIRTREE +MKDIRTREE:=$(MKDIRPROG) -p +endif +ifndef MOVE +MOVE:=$(MVPROG) -f +endif +ifndef DEL +DEL:=$(RMPROG) -f +endif +ifndef DELTREE +DELTREE:=$(RMPROG) -rf +endif +ifndef INSTALL +ifdef inUnix +INSTALL:=$(GINSTALL) -c -m 644 +else +INSTALL:=$(COPY) +endif +endif +ifndef INSTALLEXE +ifdef inUnix +INSTALLEXE:=$(GINSTALL) -c -m 755 +else +INSTALLEXE:=$(COPY) +endif +endif +ifndef MKDIR +MKDIR:=$(GINSTALL) -m 755 -d +endif +export ECHOREDIR COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR +ifndef PPUMOVE +PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(PPUMOVE),) +PPUMOVE= __missing_command_PPUMOVE +else +PPUMOVE:=$(firstword $(PPUMOVE)) +endif +endif +export PPUMOVE +ifndef FPCMAKE +FPCMAKE:=$(strip $(wildcard $(addsuffix /fpcmake$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(FPCMAKE),) +FPCMAKE= __missing_command_FPCMAKE +else +FPCMAKE:=$(firstword $(FPCMAKE)) +endif +endif +export FPCMAKE +ifndef ZIPPROG +ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ZIPPROG),) +ZIPPROG= __missing_command_ZIPPROG +else +ZIPPROG:=$(firstword $(ZIPPROG)) +endif +endif +export ZIPPROG +ifndef TARPROG +TARPROG:=$(strip $(wildcard $(addsuffix /gtar$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(TARPROG),) +TARPROG:=$(strip $(wildcard $(addsuffix /tar$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(TARPROG),) +TARPROG= __missing_command_TARPROG +else +TARPROG:=$(firstword $(TARPROG)) +endif +else +TARPROG:=$(firstword $(TARPROG)) +endif +endif +export TARPROG +ASNAME=$(BINUTILSPREFIX)as +LDNAME=$(BINUTILSPREFIX)ld +ARNAME=$(BINUTILSPREFIX)ar +RCNAME=$(BINUTILSPREFIX)rc +ifneq ($(findstring 1.0.,$(FPC_VERSION)),) +ifeq ($(OS_TARGET),win32) +ifeq ($(CROSSBINDIR),) +ASNAME=asw +LDNAME=ldw +ARNAME=arw +endif +endif +endif +ifndef ASPROG +ifdef CROSSBINDIR +ASPROG=$(CROSSBINDIR)/$(ASNAME)$(SRCEXEEXT) +else +ASPROG=$(ASNAME) +endif +endif +ifndef LDPROG +ifdef CROSSBINDIR +LDPROG=$(CROSSBINDIR)/$(LDNAME)$(SRCEXEEXT) +else +LDPROG=$(LDNAME) +endif +endif +ifndef RCPROG +ifdef CROSSBINDIR +RCPROG=$(CROSSBINDIR)/$(RCNAME)$(SRCEXEEXT) +else +RCPROG=$(RCNAME) +endif +endif +ifndef ARPROG +ifdef CROSSBINDIR +ARPROG=$(CROSSBINDIR)/$(ARNAME)$(SRCEXEEXT) +else +ARPROG=$(ARNAME) +endif +endif +AS=$(ASPROG) +LD=$(LDPROG) +RC=$(RCPROG) +AR=$(ARPROG) +PPAS=ppas$(SRCBATCHEXT) +ifdef inUnix +LDCONFIG=ldconfig +else +LDCONFIG= +endif +ifdef DATE +DATESTR:=$(shell $(DATE) +%Y%m%d) +else +DATESTR= +endif +ifndef UPXPROG +ifeq ($(OS_TARGET),go32v2) +UPXPROG:=1 +endif +ifeq ($(OS_TARGET),win32) +UPXPROG:=1 +endif +ifdef UPXPROG +UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(UPXPROG),) +UPXPROG= +else +UPXPROG:=$(firstword $(UPXPROG)) +endif +else +UPXPROG= +endif +endif +export UPXPROG +ZIPOPT=-9 +ZIPEXT=.zip +ifeq ($(USETAR),bz2) +TAROPT=vj +TAREXT=.tar.bz2 +else +TAROPT=vz +TAREXT=.tar.gz +endif +override REQUIRE_PACKAGES=rtl fv +ifeq ($(FULL_TARGET),i386-linux) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-go32v2) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-win32) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-os2) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-freebsd) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-beos) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-netbsd) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-solaris) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-qnx) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-netware) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-openbsd) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-wdosx) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-darwin) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-emx) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-watcom) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-netwlibc) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-wince) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-embedded) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),i386-symbian) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),m68k-linux) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),m68k-freebsd) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),m68k-netbsd) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),m68k-amiga) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),m68k-atari) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),m68k-openbsd) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),m68k-palmos) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),m68k-embedded) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),powerpc-linux) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),powerpc-netbsd) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),powerpc-amiga) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),powerpc-macos) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),powerpc-darwin) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),powerpc-morphos) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),powerpc-embedded) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),sparc-linux) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),sparc-netbsd) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),sparc-solaris) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),sparc-embedded) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),x86_64-linux) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),x86_64-freebsd) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),x86_64-darwin) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),x86_64-win64) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),x86_64-embedded) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),arm-linux) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),arm-palmos) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),arm-wince) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),arm-gba) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),arm-nds) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),arm-embedded) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),arm-symbian) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),powerpc64-linux) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),powerpc64-darwin) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifeq ($(FULL_TARGET),powerpc64-embedded) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_FV=1 +endif +ifdef REQUIRE_PACKAGES_RTL +PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/Makefile.fpc,$(PACKAGESDIR)))))) +ifneq ($(PACKAGEDIR_RTL),) +ifneq ($(wildcard $(PACKAGEDIR_RTL)/units/$(TARGETSUFFIX)),) +UNITDIR_RTL=$(PACKAGEDIR_RTL)/units/$(TARGETSUFFIX) +else +UNITDIR_RTL=$(PACKAGEDIR_RTL) +endif +ifdef CHECKDEPEND +$(PACKAGEDIR_RTL)/$(FPCMADE): + $(MAKE) -C $(PACKAGEDIR_RTL) $(FPCMADE) +override ALLDEPENDENCIES+=$(PACKAGEDIR_RTL)/$(FPCMADE) +endif +else +PACKAGEDIR_RTL= +UNITDIR_RTL:=$(subst /Package.fpc,,$(strip $(wildcard $(addsuffix /rtl/Package.fpc,$(UNITSDIR))))) +ifneq ($(UNITDIR_RTL),) +UNITDIR_RTL:=$(firstword $(UNITDIR_RTL)) +else +UNITDIR_RTL= +endif +endif +ifdef UNITDIR_RTL +override COMPILER_UNITDIR+=$(UNITDIR_RTL) +endif +endif +ifdef REQUIRE_PACKAGES_FV +PACKAGEDIR_FV:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /fv/Makefile.fpc,$(PACKAGESDIR)))))) +ifneq ($(PACKAGEDIR_FV),) +ifneq ($(wildcard $(PACKAGEDIR_FV)/units/$(TARGETSUFFIX)),) +UNITDIR_FV=$(PACKAGEDIR_FV)/units/$(TARGETSUFFIX) +else +UNITDIR_FV=$(PACKAGEDIR_FV) +endif +ifdef CHECKDEPEND +$(PACKAGEDIR_FV)/$(FPCMADE): + $(MAKE) -C $(PACKAGEDIR_FV) $(FPCMADE) +override ALLDEPENDENCIES+=$(PACKAGEDIR_FV)/$(FPCMADE) +endif +else +PACKAGEDIR_FV= +UNITDIR_FV:=$(subst /Package.fpc,,$(strip $(wildcard $(addsuffix /fv/Package.fpc,$(UNITSDIR))))) +ifneq ($(UNITDIR_FV),) +UNITDIR_FV:=$(firstword $(UNITDIR_FV)) +else +UNITDIR_FV= +endif +endif +ifdef UNITDIR_FV +override COMPILER_UNITDIR+=$(UNITDIR_FV) +endif +endif +ifndef NOCPUDEF +override FPCOPTDEF=$(CPU_TARGET) +endif +ifneq ($(OS_TARGET),$(OS_SOURCE)) +override FPCOPT+=-T$(OS_TARGET) +endif +ifneq ($(CPU_TARGET),$(CPU_SOURCE)) +override FPCOPT+=-P$(CPU_TARGET) +endif +ifeq ($(OS_SOURCE),openbsd) +override FPCOPT+=-FD$(NEW_BINUTILS_PATH) +endif +ifndef CROSSBOOTSTRAP +ifneq ($(BINUTILSPREFIX),) +override FPCOPT+=-XP$(BINUTILSPREFIX) +endif +ifneq ($(BINUTILSPREFIX),) +override FPCOPT+=-Xr$(RLINKPATH) +endif +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 +ifdef LINKSMART +override FPCOPT+=-XX +endif +ifdef CREATESMART +override FPCOPT+=-CX +endif +ifdef DEBUG +override FPCOPT+=-gl +override FPCOPTDEF+=DEBUG +endif +ifdef RELEASE +ifneq ($(findstring 2.0.,$(FPC_VERSION)),) +ifeq ($(CPU_TARGET),i386) +FPCCPUOPT:=-OG2p3 +endif +ifeq ($(CPU_TARGET),powerpc) +FPCCPUOPT:=-O1r +endif +else +FPCCPUOPT:=-O2 +endif +override FPCOPT+=-Ur -Xs $(FPCCPUOPT) -n +override FPCOPTDEF+=RELEASE +endif +ifdef STRIP +override FPCOPT+=-Xs +endif +ifdef OPTIMIZE +override FPCOPT+=-O2 +endif +ifdef VERBOSE +override FPCOPT+=-vwni +endif +ifdef COMPILER_OPTIONS +override FPCOPT+=$(COMPILER_OPTIONS) +endif +ifdef COMPILER_UNITDIR +override FPCOPT+=$(addprefix -Fu,$(COMPILER_UNITDIR)) +endif +ifdef COMPILER_LIBRARYDIR +override FPCOPT+=$(addprefix -Fl,$(COMPILER_LIBRARYDIR)) +endif +ifdef COMPILER_OBJECTDIR +override FPCOPT+=$(addprefix -Fo,$(COMPILER_OBJECTDIR)) +endif +ifdef COMPILER_INCLUDEDIR +override FPCOPT+=$(addprefix -Fi,$(COMPILER_INCLUDEDIR)) +endif +ifdef CROSSBINDIR +override FPCOPT+=-FD$(CROSSBINDIR) +endif +ifdef COMPILER_TARGETDIR +override FPCOPT+=-FE$(COMPILER_TARGETDIR) +ifeq ($(COMPILER_TARGETDIR),.) +override TARGETDIRPREFIX= +else +override TARGETDIRPREFIX=$(COMPILER_TARGETDIR)/ +endif +endif +ifdef COMPILER_UNITTARGETDIR +override FPCOPT+=-FU$(COMPILER_UNITTARGETDIR) +ifeq ($(COMPILER_UNITTARGETDIR),.) +override UNITTARGETDIRPREFIX= +else +override UNITTARGETDIRPREFIX=$(COMPILER_UNITTARGETDIR)/ +endif +else +ifdef COMPILER_TARGETDIR +override COMPILER_UNITTARGETDIR=$(COMPILER_TARGETDIR) +override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX) +endif +endif +ifdef CREATESHARED +override FPCOPT+=-Cg +ifeq ($(CPU_TARGET),i386) +override FPCOPT+=-Aas +endif +endif +ifeq ($(findstring 2.0.,$(FPC_VERSION)),) +ifeq ($(OS_TARGET),linux) +ifeq ($(CPU_TARGET),x86_64) +override FPCOPT+=-Cg +endif +endif +endif +ifdef LINKSHARED +endif +ifdef OPT +override FPCOPT+=$(OPT) +endif +ifdef FPCOPTDEF +override FPCOPT+=$(addprefix -d,$(FPCOPTDEF)) +endif +ifdef CFGFILE +override FPCOPT+=@$(CFGFILE) +endif +ifdef USEENV +override FPCEXTCMD:=$(FPCOPT) +override FPCOPT:=!FPCEXTCMD +export FPCEXTCMD +endif +override AFULL_TARGET=$(CPU_TARGET)-$(OS_TARGET) +override AFULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE) +ifneq ($(AFULL_TARGET),$(AFULL_SOURCE)) +override ACROSSCOMPILE=1 +endif +ifdef ACROSSCOMPILE +override FPCOPT+=$(CROSSOPT) +endif +override COMPILER:=$(FPC) $(FPCOPT) +ifeq (,$(findstring -s ,$(COMPILER))) +EXECPPAS= +else +ifeq ($(FULL_SOURCE),$(FULL_TARGET)) +ifdef RUNBATCH +EXECPPAS:=@$(RUNBATCH) $(PPAS) +else +EXECPPAS:=@$(PPAS) +endif +endif +endif +.PHONY: fpc_exes +ifndef CROSSINSTALL +ifneq ($(TARGET_PROGRAMS),) +override EXEFILES=$(addsuffix $(EXEEXT),$(TARGET_PROGRAMS)) +override EXEOFILES:=$(addsuffix $(OEXT),$(TARGET_PROGRAMS)) $(addprefix $(STATICLIBPREFIX),$(addsuffix $(STATICLIBEXT),$(TARGET_PROGRAMS))) $(addprefix $(IMPORTLIBPREFIX),$(addsuffix $(STATICLIBEXT),$(TARGET_PROGRAMS))) +override ALLTARGET+=fpc_exes +override INSTALLEXEFILES+=$(EXEFILES) +override CLEANEXEFILES+=$(EXEFILES) $(EXEOFILES) +ifeq ($(OS_TARGET),os2) +override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_PROGRAMS)) +endif +ifeq ($(OS_TARGET),emx) +override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_PROGRAMS)) +endif +endif +endif +fpc_exes: $(COMPILER_TARGETDIR) $(COMPILER_UNITTARGETDIR) $(EXEFILES) +ifdef TARGET_RSTS +override RSTFILES=$(addsuffix $(RSTEXT),$(TARGET_RSTS)) +override CLEANRSTFILES+=$(RSTFILES) +endif +.PHONY: fpc_all fpc_smart fpc_debug fpc_release fpc_shared +$(FPCMADE): $(ALLDEPENDENCIES) $(ALLTARGET) + @$(ECHOREDIR) Compiled > $(FPCMADE) +fpc_all: $(FPCMADE) +fpc_smart: + $(MAKE) all LINKSMART=1 CREATESMART=1 +fpc_debug: + $(MAKE) all DEBUG=1 +fpc_release: + $(MAKE) all RELEASE=1 +.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .lpr .dpr .pp .rc .res +$(COMPILER_UNITTARGETDIR): + $(MKDIRTREE) $(COMPILER_UNITTARGETDIR) +$(COMPILER_TARGETDIR): + $(MKDIRTREE) $(COMPILER_TARGETDIR) +%$(PPUEXT): %.pp + $(COMPILER) $< + $(EXECPPAS) +%$(PPUEXT): %.pas + $(COMPILER) $< + $(EXECPPAS) +%$(EXEEXT): %.pp + $(COMPILER) $< + $(EXECPPAS) +%$(EXEEXT): %.pas + $(COMPILER) $< + $(EXECPPAS) +%$(EXEEXT): %.lpr + $(COMPILER) $< + $(EXECPPAS) +%$(EXEEXT): %.dpr + $(COMPILER) $< + $(EXECPPAS) +%.res: %.rc + windres -i $< -o $@ +vpath %.pp $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR) +vpath %.pas $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR) +vpath %.lpr $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR) +vpath %.dpr $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR) +vpath %.inc $(COMPILER_INCLUDEDIR) +vpath %$(OEXT) $(COMPILER_UNITTARGETDIR) +vpath %$(PPUEXT) $(COMPILER_UNITTARGETDIR) +.PHONY: fpc_shared +override INSTALLTARGET+=fpc_shared_install +ifndef SHARED_LIBVERSION +SHARED_LIBVERSION=$(FPC_VERSION) +endif +ifndef SHARED_LIBNAME +SHARED_LIBNAME=$(PACKAGE_NAME) +endif +ifndef SHARED_FULLNAME +SHARED_FULLNAME=$(SHAREDLIBPREFIX)$(SHARED_LIBNAME)-$(SHARED_LIBVERSION)$(SHAREDLIBEXT) +endif +ifndef SHARED_LIBUNITS +SHARED_LIBUNITS:=$(TARGET_UNITS) $(TARGET_IMPLICITUNITS) +override SHARED_LIBUNITS:=$(filter-out $(INSTALL_BUILDUNIT),$(SHARED_LIBUNITS)) +endif +fpc_shared: +ifdef HASSHAREDLIB + $(MAKE) all CREATESHARED=1 LINKSHARED=1 CREATESMART=1 +ifneq ($(SHARED_BUILD),n) + $(PPUMOVE) -q $(SHARED_LIBUNITS) -i$(COMPILER_UNITTARGETDIR) -o$(SHARED_FULLNAME) -d$(COMPILER_UNITTARGETDIR) +endif +else + @$(ECHO) Shared Libraries not supported +endif +fpc_shared_install: +ifneq ($(SHARED_BUILD),n) +ifneq ($(SHARED_LIBUNITS),) +ifneq ($(wildcard $(COMPILER_UNITTARGETDIR)/$(SHARED_FULLNAME)),) + $(INSTALL) $(COMPILER_UNITTARGETDIR)/$(SHARED_FULLNAME) $(INSTALL_SHAREDDIR) +endif +endif +endif +.PHONY: fpc_install fpc_sourceinstall fpc_exampleinstall +ifdef INSTALL_UNITS +override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(INSTALL_UNITS)) +endif +ifdef INSTALL_BUILDUNIT +override INSTALLPPUFILES:=$(filter-out $(INSTALL_BUILDUNIT)$(PPUEXT),$(INSTALLPPUFILES)) +endif +ifdef INSTALLPPUFILES +override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))) $(addprefix $(IMPORTLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))) +ifneq ($(UNITTARGETDIRPREFIX),) +override INSTALLPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(notdir $(INSTALLPPUFILES))) +override INSTALLPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(notdir $(INSTALLPPULINKFILES)))) +endif +override INSTALL_CREATEPACKAGEFPC=1 +endif +ifdef INSTALLEXEFILES +ifneq ($(TARGETDIRPREFIX),) +override INSTALLEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(notdir $(INSTALLEXEFILES))) +endif +endif +fpc_install: all $(INSTALLTARGET) +ifdef INSTALLEXEFILES + $(MKDIR) $(INSTALL_BINDIR) +ifdef UPXPROG + -$(UPXPROG) $(INSTALLEXEFILES) +endif + $(INSTALLEXE) $(INSTALLEXEFILES) $(INSTALL_BINDIR) +endif +ifdef INSTALL_CREATEPACKAGEFPC +ifdef FPCMAKE +ifdef PACKAGE_VERSION +ifneq ($(wildcard Makefile.fpc),) + $(FPCMAKE) -p -T$(CPU_TARGET)-$(OS_TARGET) Makefile.fpc + $(MKDIR) $(INSTALL_UNITDIR) + $(INSTALL) Package.fpc $(INSTALL_UNITDIR) +endif +endif +endif +endif +ifdef INSTALLPPUFILES + $(MKDIR) $(INSTALL_UNITDIR) + $(INSTALL) $(INSTALLPPUFILES) $(INSTALL_UNITDIR) +ifneq ($(INSTALLPPULINKFILES),) + $(INSTALL) $(INSTALLPPULINKFILES) $(INSTALL_UNITDIR) +endif +ifneq ($(wildcard $(LIB_FULLNAME)),) + $(MKDIR) $(INSTALL_LIBDIR) + $(INSTALL) $(LIB_FULLNAME) $(INSTALL_LIBDIR) +ifdef inUnix + ln -sf $(LIB_FULLNAME) $(INSTALL_LIBDIR)/$(LIB_NAME) +endif +endif +endif +ifdef INSTALL_FILES + $(MKDIR) $(INSTALL_DATADIR) + $(INSTALL) $(INSTALL_FILES) $(INSTALL_DATADIR) +endif +fpc_sourceinstall: distclean + $(MKDIR) $(INSTALL_SOURCEDIR) + $(COPYTREE) $(BASEDIR)/* $(INSTALL_SOURCEDIR) +fpc_exampleinstall: $(addsuffix _distclean,$(TARGET_EXAMPLEDIRS)) +ifdef HASEXAMPLES + $(MKDIR) $(INSTALL_EXAMPLEDIR) +endif +ifdef EXAMPLESOURCEFILES + $(COPY) $(EXAMPLESOURCEFILES) $(INSTALL_EXAMPLEDIR) +endif +ifdef TARGET_EXAMPLEDIRS + $(COPYTREE) $(addsuffix /*,$(TARGET_EXAMPLEDIRS)) $(INSTALL_EXAMPLEDIR) +endif +.PHONY: fpc_clean fpc_cleanall fpc_distclean +ifdef EXEFILES +override CLEANEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(CLEANEXEFILES)) +endif +ifdef CLEAN_UNITS +override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(CLEAN_UNITS)) +endif +ifdef CLEANPPUFILES +override CLEANPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))) $(addprefix $(IMPORTLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))) +ifdef DEBUGSYMEXT +override CLEANPPULINKFILES+=$(subst $(PPUEXT),$(DEBUGSYMEXT),$(CLEANPPUFILES)) +endif +override CLEANPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILES)) +override CLEANPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILES))) +endif +fpc_clean: $(CLEANTARGET) +ifdef CLEANEXEFILES + -$(DEL) $(CLEANEXEFILES) +endif +ifdef CLEANPPUFILES + -$(DEL) $(CLEANPPUFILES) +endif +ifneq ($(CLEANPPULINKFILES),) + -$(DEL) $(CLEANPPULINKFILES) +endif +ifdef CLEANRSTFILES + -$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES)) +endif +ifdef CLEAN_FILES + -$(DEL) $(CLEAN_FILES) +endif +ifdef LIB_NAME + -$(DEL) $(LIB_NAME) $(LIB_FULLNAME) +endif + -$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE) + -$(DEL) *$(ASMEXT) *_ppas$(BATCHEXT) +fpc_cleanall: $(CLEANTARGET) +ifdef CLEANEXEFILES + -$(DEL) $(CLEANEXEFILES) +endif +ifdef COMPILER_UNITTARGETDIR +ifdef CLEANPPUFILES + -$(DEL) $(CLEANPPUFILES) +endif +ifneq ($(CLEANPPULINKFILES),) + -$(DEL) $(CLEANPPULINKFILES) +endif +ifdef CLEANRSTFILES + -$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES)) +endif +endif + -$(DELTREE) units + -$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT) +ifneq ($(PPUEXT),.ppu) + -$(DEL) *.o *.ppu *.a +endif + -$(DELTREE) *$(SMARTEXT) + -$(DEL) fpcmade.* Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE) + -$(DEL) *_ppas$(BATCHEXT) +ifdef AOUTEXT + -$(DEL) *$(AOUTEXT) +endif +ifdef DEBUGSYMEXT + -$(DEL) *$(DEBUGSYMEXT) +endif +fpc_distclean: cleanall +.PHONY: fpc_baseinfo +override INFORULES+=fpc_baseinfo +fpc_baseinfo: + @$(ECHO) + @$(ECHO) == Package info == + @$(ECHO) Package Name..... $(PACKAGE_NAME) + @$(ECHO) Package Version.. $(PACKAGE_VERSION) + @$(ECHO) + @$(ECHO) == Configuration info == + @$(ECHO) + @$(ECHO) FPC.......... $(FPC) + @$(ECHO) FPC Version.. $(FPC_VERSION) + @$(ECHO) Source CPU... $(CPU_SOURCE) + @$(ECHO) Target CPU... $(CPU_TARGET) + @$(ECHO) Source OS.... $(OS_SOURCE) + @$(ECHO) Target OS.... $(OS_TARGET) + @$(ECHO) Full Source.. $(FULL_SOURCE) + @$(ECHO) Full Target.. $(FULL_TARGET) + @$(ECHO) SourceSuffix. $(SOURCESUFFIX) + @$(ECHO) TargetSuffix. $(TARGETSUFFIX) + @$(ECHO) + @$(ECHO) == Directory info == + @$(ECHO) + @$(ECHO) Required pkgs... $(REQUIRE_PACKAGES) + @$(ECHO) + @$(ECHO) Basedir......... $(BASEDIR) + @$(ECHO) FPCDir.......... $(FPCDIR) + @$(ECHO) CrossBinDir..... $(CROSSBINDIR) + @$(ECHO) UnitsDir........ $(UNITSDIR) + @$(ECHO) PackagesDir..... $(PACKAGESDIR) + @$(ECHO) + @$(ECHO) GCC library..... $(GCCLIBDIR) + @$(ECHO) Other library... $(OTHERLIBDIR) + @$(ECHO) + @$(ECHO) == Tools info == + @$(ECHO) + @$(ECHO) As........ $(AS) + @$(ECHO) Ld........ $(LD) + @$(ECHO) Ar........ $(AR) + @$(ECHO) Rc........ $(RC) + @$(ECHO) + @$(ECHO) Mv........ $(MVPROG) + @$(ECHO) Cp........ $(CPPROG) + @$(ECHO) Rm........ $(RMPROG) + @$(ECHO) GInstall.. $(GINSTALL) + @$(ECHO) Echo...... $(ECHO) + @$(ECHO) Shell..... $(SHELL) + @$(ECHO) Date...... $(DATE) + @$(ECHO) FPCMake... $(FPCMAKE) + @$(ECHO) PPUMove... $(PPUMOVE) + @$(ECHO) Upx....... $(UPXPROG) + @$(ECHO) Zip....... $(ZIPPROG) + @$(ECHO) + @$(ECHO) == Object info == + @$(ECHO) + @$(ECHO) Target Loaders........ $(TARGET_LOADERS) + @$(ECHO) Target Units.......... $(TARGET_UNITS) + @$(ECHO) Target Implicit Units. $(TARGET_IMPLICITUNITS) + @$(ECHO) Target Programs....... $(TARGET_PROGRAMS) + @$(ECHO) Target Dirs........... $(TARGET_DIRS) + @$(ECHO) Target Examples....... $(TARGET_EXAMPLES) + @$(ECHO) Target ExampleDirs.... $(TARGET_EXAMPLEDIRS) + @$(ECHO) + @$(ECHO) Clean Units......... $(CLEAN_UNITS) + @$(ECHO) Clean Files......... $(CLEAN_FILES) + @$(ECHO) + @$(ECHO) Install Units....... $(INSTALL_UNITS) + @$(ECHO) Install Files....... $(INSTALL_FILES) + @$(ECHO) + @$(ECHO) == Install info == + @$(ECHO) + @$(ECHO) DateStr.............. $(DATESTR) + @$(ECHO) ZipName.............. $(ZIPNAME) + @$(ECHO) ZipPrefix............ $(ZIPPREFIX) + @$(ECHO) ZipCrossPrefix....... $(ZIPCROSSPREFIX) + @$(ECHO) ZipSuffix............ $(ZIPSUFFIX) + @$(ECHO) FullZipName.......... $(FULLZIPNAME) + @$(ECHO) Install FPC Package.. $(INSTALL_FPCPACKAGE) + @$(ECHO) + @$(ECHO) Install base dir..... $(INSTALL_BASEDIR) + @$(ECHO) Install binary dir... $(INSTALL_BINDIR) + @$(ECHO) Install library dir.. $(INSTALL_LIBDIR) + @$(ECHO) Install units dir.... $(INSTALL_UNITDIR) + @$(ECHO) Install source dir... $(INSTALL_SOURCEDIR) + @$(ECHO) Install doc dir...... $(INSTALL_DOCDIR) + @$(ECHO) Install example dir.. $(INSTALL_EXAMPLEDIR) + @$(ECHO) Install data dir..... $(INSTALL_DATADIR) + @$(ECHO) + @$(ECHO) Dist destination dir. $(DIST_DESTDIR) + @$(ECHO) Dist zip name........ $(DIST_ZIPNAME) + @$(ECHO) +.PHONY: fpc_info +fpc_info: $(INFORULES) +.PHONY: fpc_makefile fpc_makefiles fpc_makefile_sub1 fpc_makefile_sub2 \ + fpc_makefile_dirs +fpc_makefile: + $(FPCMAKE) -w -T$(OS_TARGET) Makefile.fpc +fpc_makefile_sub1: +ifdef TARGET_DIRS + $(FPCMAKE) -w -T$(OS_TARGET) $(addsuffix /Makefile.fpc,$(TARGET_DIRS)) +endif +ifdef TARGET_EXAMPLEDIRS + $(FPCMAKE) -w -T$(OS_TARGET) $(addsuffix /Makefile.fpc,$(TARGET_EXAMPLEDIRS)) +endif +fpc_makefile_sub2: $(addsuffix _makefile_dirs,$(TARGET_DIRS) $(TARGET_EXAMPLEDIRS)) +fpc_makefile_dirs: fpc_makefile_sub1 fpc_makefile_sub2 +fpc_makefiles: fpc_makefile fpc_makefile_dirs +all: fpc_all +debug: fpc_debug +smart: fpc_smart +release: fpc_release +units: fpc_units +examples: +shared: fpc_shared +install: fpc_install +sourceinstall: fpc_sourceinstall +exampleinstall: fpc_exampleinstall +distinstall: +zipinstall: +zipsourceinstall: +zipexampleinstall: +zipdistinstall: +clean: fpc_clean +distclean: fpc_distclean +cleanall: fpc_cleanall +info: fpc_info +makefiles: fpc_makefiles +.PHONY: all debug smart release units examples shared install sourceinstall exampleinstall distinstall zipinstall zipsourceinstall zipexampleinstall zipdistinstall clean distclean cleanall info makefiles +ifneq ($(wildcard fpcmake.loc),) +include fpcmake.loc +endif diff --git a/packages/fv/examples/Makefile.fpc b/packages/fv/examples/Makefile.fpc new file mode 100644 index 0000000000..08c7f85529 --- /dev/null +++ b/packages/fv/examples/Makefile.fpc @@ -0,0 +1,12 @@ +# +# Makefile.fpc for Free Vision Test/Examples +# + +[target] +programs=testapp + +[require] +packages=fv + +[default] +fpcdir=../../.. diff --git a/packages/fv/examples/platform.inc b/packages/fv/examples/platform.inc new file mode 100644 index 0000000000..00cc361ec3 --- /dev/null +++ b/packages/fv/examples/platform.inc @@ -0,0 +1,369 @@ +{***************[ PLATFORM INCLUDE UNIT ]******************} +{ } +{ System independent INCLUDE file to sort PLATFORMS } +{ } +{ Parts Copyright (c) 1997 by Balazs Scheidler } +{ bazsi@tas.vein.hu } +{ } +{ Parts Copyright (c) 1999, 2000 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@projectent.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ - C'T patch to BP (16 Bit) } +{ LINUX - FPC 0.9912+ (32 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Who Fix } +{ ------- -------- --- ---------------------------- } +{ 0.1 02 Jul 97 Bazsi Initial implementation } +{ 0.2 28 Aug 97 LdB Fixed OS2 platform sort } +{ 0.3 29 Aug 97 LdB Added assembler type changes } +{ 0.4 29 Aug 97 LdB OS_DOS removed from WINDOWS } +{ 0.5 23 Oct 97 LdB Delphi & speed compilers } +{ 0.6 05 May 98 LdB Virtual Pascal 2.0 added } +{ 0.7 19 May 98 LdB Delphi 2/3 definitions added } +{ 0.8 06 Aug 98 CEC FPC only support fixed WIN32 } +{ 0.9 10 Aug 98 LdB BP_VMTLink def/Undef added } +{ 1.0 27 Aug 98 LdB Atari, Mac etc not undef dos } +{ 1.1 25 Oct 98 PfV Delphi 4 definitions added } +{ 1.2 06 Jun 99 LdB Sybil 2.0 support added } +{ 1.3 13 Jun 99 LdB Sybil 2.0 undef BP_VMT link } +{ 1.31 03 Nov 99 LdB FPC windows defines WIN32 } +{ 1.32 04 Nov 99 LdB Delphi 5 definitions added } +{ 1.33 16 Oct 00 LdB WIN32/WIN16 defines added } +{**********************************************************} + +{ **************************************************************************** + + 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 + + **************************************************************************** + + 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 + + DPMI OS_DOS BP/TP7 PPC_BP PROC_Protected BIT_16 ASM_BP + FPC PPC_FPC PROC_Protected BIT_32 ASM_FPC + + 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_DELPHI2 PROC_Protected BIT_16 ASM_BP + + WIN95/NT OS_WINDOWS DELPHI2 PPC_DELPHI2 PROC_Protected BIT_32 ASM_BP + DELPHI3 PPC_DELPHI3 PROC_Protected BIT_32 ASM_BP + DELPHI4 PPC_DELPHI3 PROC_Protected BIT_32 ASM_BP + DELPHI5 PPC_DELPHI3 PROC_Protected BIT_32 ASM_BP + VIRTUAL PPC_VIRTUAL PROC_Protected BIT 32 ASM_BP + SYBIL2 PPC_SPEED PROC_Protected BIT_32 ASM_BP + FPC PPC_FPC PROC_Protected BIT_32 ASM_FPC + + 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 + SYBIL2 PPC_SPEED PROC_Protected BIT_32 ASM_BP + FPC PPC_FPC PROC_Protected BIT_32 ASM_FPC + ****************************************************************************} +{**************************************************************************** + +FOR ALL COMPILERS BP_VMTLink defined but FPC and Delphi3/Delphi4 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} +{$DEFINE CPU86} + +{---------------------------------------------------------------------------} +{ 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} + {$DEFINE Use_API} + {$DEFINE NO_WINDOW} +{$ENDIF} + +{$IFDEF NoAPI} +{$UNDEF Use_API} +{$UNDEF NO_WINDOW} +{$ENDIF UseAPI} + + +{---------------------------------------------------------------------------} +{ 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 03Nov99 LdB } +{---------------------------------------------------------------------------} +{$IFDEF WINDOWS} + {$UNDEF OS_DOS} + {$DEFINE OS_WINDOWS} + {$UNDEF PROC_Real} + {$DEFINE PROC_Protected} + {$IFDEF FPC} + {$DEFINE WIN32} + {$ENDIF} +{$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} + +{---------------------------------------------------------------------------} +{ DELPHI5 COMPILER changes compiler type - Updated 04Nov99 pfv } +{---------------------------------------------------------------------------} +{$IFDEF VER130} + {$UNDEF PPC_BP} + {$DEFINE PPC_DELPHI} + {$DEFINE PPC_DELPHI3} + {$DEFINE PPC_DELPHI4} + {$DEFINE PPC_DELPHI5} + {$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} + {$UNDEF BP_VMTLink} +{$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} + +{$IFDEF OS_DOS} + {$DEFINE NO_WINDOW} +{$ENDIF} + +{---------------------------------------------------------------------------} +{ WIN16 AND WIN32 set if in windows - Updated 16Oct2000 LdB } +{---------------------------------------------------------------------------} +{$IFDEF OS_WINDOWS} { WINDOWS SYSTEM } + {$IFDEF BIT_16} + {$DEFINE WIN16} { 16 BIT WINDOWS } + {$ENDIF} + {$IFDEF BIT_32} + {$DEFINE WIN32} { 32 BIT WINDOWS } + {$ENDIF} +{$ENDIF} + + + diff --git a/packages/fv/examples/testapp.lpi b/packages/fv/examples/testapp.lpi new file mode 100644 index 0000000000..db391bbc2a --- /dev/null +++ b/packages/fv/examples/testapp.lpi @@ -0,0 +1,67 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <PathDelim Value="\"/> + <Version Value="5"/> + <General> + <Flags> + <MainUnitHasUsesSectionForAllUnits Value="False"/> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <MainUnit Value="0"/> + <IconPath Value="./"/> + <TargetFileExt Value=".exe"/> + <ActiveEditorIndexAtStart Value="0"/> + </General> + <LazDoc Paths=""/> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="testapp.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="testapp"/> + <CursorPos X="1" Y="1"/> + <TopLine Value="1"/> + <EditorIndex Value="0"/> + <UsageCount Value="20"/> + <Loaded Value="True"/> + </Unit0> + </Units> + <JumpHistory Count="0" HistoryIndex="-1"/> + </ProjectOptions> + <CompilerOptions> + <Version Value="5"/> + <PathDelim Value="\"/> + <SearchPaths> + <OtherUnitFiles Value="..\"/> + </SearchPaths> + <CodeGeneration> + <Generate Value="Faster"/> + </CodeGeneration> + <Other> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="2"> + <Item1> + <Name Value="ECodetoolError"/> + </Item1> + <Item2> + <Name Value="EFOpenError"/> + </Item2> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/fv/examples/testapp.pas b/packages/fv/examples/testapp.pas new file mode 100644 index 0000000000..8d4546db38 --- /dev/null +++ b/packages/fv/examples/testapp.pas @@ -0,0 +1,468 @@ +PROGRAM testapp; + +{ $UNDEF OS2PM} + +{$IFDEF OS2PM} + {&PMTYPE PM} { FULL GUI MODE } +{$ENDIF OS2PM} + +{ ******************************* REMARK ****************************** } +{ This is a basic test program to test the app framework. In use will } +{ be menus, statuslines, windows, dialogs, scrollbars, statictext, } +{ radiobuttons, check boxes, list boxes and input lines. } +{ } +{ Working compilers: } +{ WINDOWS BPW, VP2, Delphi1, FPC WIN (0.9912) } +{ DOS has draw bugs but works for BP and FPC DOS (GO32V2) } +{ OS2 dows not work still some PM bits to do } +{ } +{ Not working: } +{ Delphi3, Delphi5 (sus 4) will compile but Tgroup.ForEach etc U/S. } +{ Sybil2 Win32 should work but to big for demo mode so unsure! } +{ } +{ Special things to try out: } +{ Check out the standard windows minimize etc icons. } +{ } +{ } +{ Comments: } +{ There is alot that may seem more complex than it needs to but } +{ I have much more elaborate objects operating such as bitmaps, } +{ bitmap buttons, percentage bars etc and they need these hooks. } +{ Basically the intention is to be able to port existing TV apps } +{ as a start point and then start to optimize and use the new } +{ GUI specific objects. I will try to get some documentation } +{ done on how everything works because some things are hard to } +{ follow in windows. } +{ ****************************** END REMARK *** Leon de Boer, 06Nov99 * } + +{$I Platform.inc} + USES +{$IFDEF OS2PM} + {$IFDEF OS_OS2} Os2Def, os2PmApi, {$ENDIF} +{$ENDIF OS2PM} + Objects, Drivers, Views, Editors, Menus, Dialogs, App, { Standard GFV units } + FVConsts, + {$ifdef TEST} + AsciiTab, + {$endif TEST} + {$ifdef DEBUG} + Gfvgraph, + {$endif DEBUG} + Gadgets, TimedDlg, MsgBox, StdDlg; + + +CONST cmAppToolbar = 1000; + cmWindow1 = 1001; + cmWindow2 = 1002; + cmWindow3 = 1003; + cmTimedBox = 1004; + cmAscii = 1010; + cmCloseWindow1 = 1101; + cmCloseWindow2 = 1102; + cmCloseWindow3 = 1103; + + +{---------------------------------------------------------------------------} +{ TTestAppp OBJECT - STANDARD APPLICATION WITH MENU } +{---------------------------------------------------------------------------} +TYPE + PTVDemo = ^TTVDemo; + + { TTVDemo } + + TTVDemo = OBJECT (TApplication) + ClipboardWindow: PEditWindow; + Clock: PClockView; + Heap: PHeapView; + P1,P2,P3 : PGroup; + {$ifdef TEST} + ASCIIChart : PAsciiChart; + {$endif TEST} + CONSTRUCTOR Init; + PROCEDURE Idle; Virtual; + PROCEDURE HandleEvent(var Event : TEvent);virtual; + PROCEDURE InitMenuBar; Virtual; + PROCEDURE InitDeskTop; Virtual; + PROCEDURE InitStatusLine; Virtual; + PROCEDURE Window1; + PROCEDURE Window2; + PROCEDURE Window3; + PROCEDURE TimedBox; + PROCEDURE AsciiWindow; + PROCEDURE ShowAboutBox; + PROCEDURE NewEditWindow; + PROCEDURE OpenFile; + PROCEDURE CloseWindow(var P : PGroup); + End; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TTvDemo OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +CONSTRUCTOR TTvDemo.Init; +VAR R: TRect; +BEGIN + EditorDialog := @StdEditorDialog; + Inherited Init; + { Initialize demo gadgets } + + GetExtent(R); + R.A.X := R.B.X - 9; R.B.Y := R.A.Y + 1; + Clock := New(PClockView, Init(R)); + Insert(Clock); + + GetExtent(R); + ClipboardWindow := New(PEditWindow, Init(R, '', wnNoNumber)); + if ValidView(ClipboardWindow) <> nil then + begin + ClipboardWindow^.Hide; + ClipboardWindow^.Editor^.CanUndo := False; + InsertWindow(ClipboardWindow); + Clipboard := ClipboardWindow^.Editor; + end; +END; + +procedure TTVDemo.Idle; + +function IsTileable(P: PView): Boolean; far; +begin + IsTileable := (P^.Options and ofTileable <> 0) and + (P^.State and sfVisible <> 0); +end; + +{$ifdef DEBUG} +Var + WasSet : boolean; +{$endif DEBUG} +begin + inherited Idle; +{$ifdef DEBUG} + if WriteDebugInfo then + begin + WasSet:=true; + WriteDebugInfo:=false; + end + else + WasSet:=false; + if WriteDebugInfo then +{$endif DEBUG} + Clock^.Update; + Heap^.Update; +{$ifdef DEBUG} + if WasSet then + WriteDebugInfo:=true; +{$endif DEBUG} + if Desktop^.FirstThat(@IsTileable) <> nil then + EnableCommands([cmTile, cmCascade]) + else + DisableCommands([cmTile, cmCascade]); +end; + +PROCEDURE TTVDemo.HandleEvent(var Event : TEvent); +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evCommand) Then Begin + Case Event.Command Of + cmClipBoard: + begin + ClipboardWindow^.Select; + ClipboardWindow^.Show; + end; + cmNew : NewEditWindow; + cmOpen : OpenFile; + cmWindow1 : Window1; + cmWindow2 : Window2; + cmWindow3 : Window3; + cmTimedBox: TimedBox; + cmAscii : AsciiWindow; + cmCloseWindow1 : CloseWindow(P1); + cmCloseWindow2 : CloseWindow(P2); + cmCloseWindow3 : CloseWindow(P3); + cmAbout: ShowAboutBox; + Else Exit; { Unhandled exit } + End; + End; + ClearEvent(Event); +END; + +{--TTvDemo------------------------------------------------------------------} +{ InitMenuBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Nov99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TTVDemo.InitMenuBar; +VAR R: TRect; +BEGIN + GetExtent(R); { Get view extents } + R.B.Y := R.A.Y + 1; { One line high } + MenuBar := New(PMenuBar, Init(R, NewMenu( + NewSubMenu('~F~ile', 0, NewMenu( + StdFileMenuItems(Nil)), { Standard file menu } + NewSubMenu('~E~dit', 0, NewMenu( + StdEditMenuItems( + NewLine( + NewItem('~V~iew Clipboard', '', kbNoKey, cmClipboard, hcNoContext, + nil)))), { Standard edit menu plus view clipboard} + NewSubMenu('~T~est', 0, NewMenu( + NewItem('~A~scii Chart','',kbNoKey,cmAscii,hcNoContext, + NewItem('Window ~1~','',kbNoKey,cmWindow1,hcNoContext, + NewItem('Window ~2~','',kbNoKey,cmWindow2,hcNoContext, + NewItem('Window ~3~','',kbNoKey,cmWindow3,hcNoContext, + NewItem('~T~imed Box','',kbNoKey,cmTimedBox,hcNoContext, + NewItem('Close Window 1','',kbNoKey,cmCloseWindow1,hcNoContext, + NewItem('Close Window 2','',kbNoKey,cmCloseWindow2,hcNoContext, + NewItem('Close Window 3','',kbNoKey,cmCloseWindow3,hcNoContext, + Nil))))))))), + NewSubMenu('~W~indow', 0, NewMenu( + StdWindowMenuItems(Nil)), { Standard window menu } + NewSubMenu('~H~elp', hcNoContext, NewMenu( + NewItem('~A~bout...','',kbNoKey,cmAbout,hcNoContext, + nil)), + nil))))) //end NewSubMenus + ))); //end MenuBar +END; + +{--TTvDemo------------------------------------------------------------------} +{ InitDesktop -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Nov99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TTvDemo.InitDesktop; +VAR R: TRect; {ToolBar: PToolBar;} +BEGIN + GetExtent(R); { Get app extents } + Inc(R.A.Y); { Adjust top down } + Dec(R.B.Y); { Adjust bottom up } +(* ToolBar := New(PToolBar, Init(R.A.X*FontWidth, + R.A.Y*FontHeight, (R.B.X-R.A.X)*FontWidth, 20, + cmAppToolBar)); + If (ToolBar <> Nil) Then Begin + R.A.X := R.A.X*FontWidth; + R.A.Y := R.A.Y*FontHeight + 25; + R.B.X := -R.B.X*FontWidth; + R.B.Y := -R.B.Y*Fontheight; + ToolBar^.AddTool(NewToolEntry(cmQuit, True, + '20X20EXIT', 'ToolBar.Res')); + ToolBar^.AddTool(NewToolEntry(cmNew, True, + '20X20NEW', 'ToolBar.Res')); + ToolBar^.AddTool(NewToolEntry(cmOpen, True, + '20X20LOAD', 'ToolBar.Res')); + Insert(ToolBar); + End;*) + Desktop := New(PDeskTop, Init(R)); +END; + +procedure TTVDemo.InitStatusLine; +var + R: TRect; +begin + GetExtent(R); + R.A.Y := R.B.Y - 1; + R.B.X := R.B.X - 12; + New(StatusLine, + Init(R, + NewStatusDef(0, $EFFF, + NewStatusKey('~F3~ Open', kbF3, cmOpen, + NewStatusKey('~F4~ New', kbF4, cmNew, + NewStatusKey('~Alt+F3~ Close', kbAltF3, cmClose, + StdStatusKeys(nil + )))),nil + ) + ) + ); + + GetExtent(R); + R.A.X := R.B.X - 12; R.A.Y := R.B.Y - 1; + Heap := New(PHeapView, Init(R)); + Insert(Heap); +end; + +PROCEDURE TTvDemo.Window1; +VAR R: TRect; P: PGroup; +BEGIN + { Create a basic window with static text and radio } + { buttons. The buttons should be orange and white } + R.Assign(5, 1, 35, 16); { Assign area } + P := New(PWindow, Init(R, 'TEST WINDOW 1', 1)); { Create a window } + If (P <> Nil) Then Begin { Window valid } + R.Assign(5, 5, 20, 6); { Assign area } + P^.Insert(New(PInputLine, Init(R, 30))); + R.Assign(5, 8, 20, 9); { Assign area } + P^.Insert(New(PRadioButtons, Init(R, + NewSItem('Test', + NewSITem('Item 2', Nil))))); { Red radio button } + R.Assign(5, 10, 28, 11); { Assign area } + P^.Insert(New(PStaticText, Init(R, + 'SOME STATIC TEXT'))); { Insert static text } + End; + Desktop^.Insert(P); { Insert into desktop } + P1:=P; +END; + +PROCEDURE TTvDemo.AsciiWindow; +begin +{$ifdef TEST} + if ASCIIChart=nil then + begin + New(ASCIIChart, Init); + Desktop^.Insert(ASCIIChart); + end + else + ASCIIChart^.Focus; +{$endif TEST} +end; + +PROCEDURE TTVDemo.ShowAboutBox; +begin + MessageBox(#3'Free Vision TUI Framework'#13 + + #3'Test/Demo Application'#13+ + #3'(www.freepascal.org)', + nil, mfInformation or mfOKButton); +end; + +PROCEDURE TTVDemo.NewEditWindow; +var + R: TRect; +begin + R.Assign(0, 0, 60, 20); + InsertWindow(New(PEditWindow, Init(R, '', wnNoNumber))); +end; + +PROCEDURE TTVDemo.OpenFile; +var + R: TRect; + FileDialog: PFileDialog; + FileName: FNameStr; +const + FDOptions: Word = fdOKButton or fdOpenButton; +begin + FileName := '*.*'; + New(FileDialog, Init(FileName, 'Open file', '~F~ile name', FDOptions, 1)); + if ExecuteDialog(FileDialog, @FileName) <> cmCancel then + begin + R.Assign(0, 0, 75, 20); + InsertWindow(New(PEditWindow, Init(R, FileName, wnNoNumber))); + end; +end; + +PROCEDURE TTvDemo.TimedBox; +var + X: longint; + S: string; +begin + X := TimedMessageBox ('Everything OK?', nil, mfConfirmation or mfOKCancel, 10); + case X of + cmCancel: MessageBox ('cmCancel', nil, mfOKButton); + cmOK: MessageBox ('cmOK', nil, mfOKButton); + else + begin + Str (X, S); + MessageBox (S, nil, mfOKButton); + end; + end; +end; + +PROCEDURE TTvDemo.CloseWindow(var P : PGroup); +BEGIN + If Assigned(P) then + BEGIN + Desktop^.Delete(P); + Dispose(P,Done); + P:=Nil; + END; +END; + +PROCEDURE TTvDemo.Window2; +VAR R: TRect; P: PGroup; +BEGIN + { Create a basic window with check boxes. The } + { check boxes should be orange and white } + R.Assign(15, 3, 45, 18); { Assign area } + P := New(PWindow, Init(R, 'TEST WINDOW 2', 2)); { Create window 2 } + If (P <> Nil) Then Begin { Window valid } + R.Assign(5, 5, 20, 7); { Assign area } + P^.Insert(New(PCheckBoxes, Init(R, + NewSItem('Test check', + NewSITem('Item 2', Nil))))); { Create check box } + End; + Desktop^.Insert(P); { Insert into desktop } + P2:=P; +END; + +PROCEDURE TTvDemo.Window3; +VAR R: TRect; P: PGroup; B: PScrollBar; + List: PStrCollection; Lb: PListBox; +BEGIN + { Create a basic dialog box. In it are buttons, } + { list boxes, scrollbars, inputlines, checkboxes } + R.Assign(32, 2, 77, 18); { Assign screen area } + P := New(PDialog, Init(R, 'TEST DIALOG')); { Create dialog } + If (P <> Nil) Then Begin { Dialog valid } + R.Assign(5, 5, 20, 7); { Allocate area } + P^.Insert(New(PCheckBoxes, Init(R, + NewSItem('Test', + NewSITem('Item 2', Nil))))); { Insert check box } + R.Assign(5, 2, 20, 3); { Assign area } + B := New(PScrollBar, Init(R)); { Insert scroll bar } + If (B <> Nil) Then Begin { Scrollbar valid } + B^.SetRange(0, 100); { Set scrollbar range } + B^.SetValue(50); { Set position } + P^.Insert(B); { Insert scrollbar } + End; + R.Assign(5, 10, 20, 11); { Assign area } + P^.Insert(New(PInputLine, Init(R, 60))); { Create input line } + R.Assign(5, 13, 20, 14); { Assign area } + P^.Insert(New(PInputLine, Init(R, 60))); { Create input line } + R.Assign(40, 8, 41, 14); { Assign area } + B := New(PScrollBar, Init(R)); { Create scrollbar } + P^.Insert(B); { Insert scrollbar } + R.Assign(25, 8, 40, 14); { Assign area } + Lb := New(PListBox, Init(R, 1, B)); { Create listbox } + P^.Insert(Lb); { Insert listbox } + List := New(PStrCollection, Init(10, 5)); { Create string list } + List^.AtInsert(0, NewStr('Zebra')); { Insert text } + List^.AtInsert(1, NewStr('Apple')); { Insert text } + List^.AtInsert(2, NewStr('Third')); { Insert text } + List^.AtInsert(3, NewStr('Peach')); { Insert text } + List^.AtInsert(4, NewStr('Rabbit')); { Insert text } + List^.AtInsert(5, NewStr('Item six')); { Insert text } + List^.AtInsert(6, NewStr('Jaguar')); { Insert text } + List^.AtInsert(7, NewStr('Melon')); { Insert text } + List^.AtInsert(8, NewStr('Ninth')); { Insert text } + List^.AtInsert(9, NewStr('Last item')); { Insert text } + Lb^.Newlist(List); { Give list to listbox } + R.Assign(30, 2, 40, 4); { Assign area } + P^.Insert(New(PButton, Init(R, '~O~k', 100, bfGrabFocus)));{ Create okay button } + R.Assign(30, 15, 40, 17); { Assign area } + Desktop^.Insert(P); { Insert dialog } + P3:=P; + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MAIN PROGRAM START } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +VAR I: Integer; R: TRect; P: PGroup; MyApp: TTvDemo; +{$IFDEF OS2PM} + {$IFDEF OS_OS2} Message: QMSg; Event: TEvent; {$ENDIF} +{$ENDIF OS2PM} +BEGIN + (*SystemPalette := CreateRGBPalette(256); { Create palette } + For I := 0 To 15 Do Begin + GetSystemRGBEntry(I, RGB); { Get palette entry } + AddToRGBPalette(RGB, SystemPalette); { Add entry to palette } + End;*) + + MyApp.Init; { Initialize app } + MyApp.Run; { Run the app } +{$IFDEF OS2PM} + {$IFDEF OS_OS2} + while (MyApp.EndState = 0) + AND WinGetMsg(Anchor, Message, 0, 0, 0) Do Begin + WinDispatchMsg(Anchor, Message); + NextQueuedEvent(Event); + If (event.What <> evNothing) + Then MyApp.handleEvent(Event); + End; + {$ENDIF} +{$ENDIF OS2PM} + MyApp.Done; { Dispose of app } + + {DisposeRGBPalette(SystemPalette);} +END. diff --git a/packages/fv/src/app.pas b/packages/fv/src/app.pas new file mode 100644 index 0000000000..3b245025f5 --- /dev/null +++ b/packages/fv/src/app.pas @@ -0,0 +1,1200 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of APP.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@starwon.com.au - backup e-mail addr } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} + +UNIT App; + +{2.0 compatibility} +{$ifdef VER2_0} + {$macro on} + {$define resourcestring := const} +{$endif} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES + {$IFDEF OS_WINDOWS} { WIN/NT CODE } + Windows, { Standard units } + {$ENDIF} + + {$IFDEF OS_OS2} { OS2 CODE } + {$IFDEF PPC_FPC} + Os2Def, DosCalls, PmWin, { Standard units } + {$ELSE} + Os2Def, Os2Base, OS2PmApi, { Standard units } + {$ENDIF} + {$ENDIF} + Dos, + Video, + FVCommon, {Memory,} { GFV standard units } + Objects, Drivers, Views, Menus, HistList, Dialogs, + msgbox, fvconsts; + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ STANDARD APPLICATION COMMAND CONSTANTS } +{---------------------------------------------------------------------------} +CONST + cmNew = 30; { Open new file } + cmOpen = 31; { Open a file } + cmSave = 32; { Save current } + cmSaveAs = 33; { Save current as } + cmSaveAll = 34; { Save all files } + cmChangeDir = 35; { Change directories } + cmDosShell = 36; { Dos shell } + cmCloseAll = 37; { Close all windows } + +{---------------------------------------------------------------------------} +{ TApplication PALETTE ENTRIES } +{---------------------------------------------------------------------------} +CONST + apColor = 0; { Coloured app } + apBlackWhite = 1; { B&W application } + apMonochrome = 2; { Monochrome app } + +{---------------------------------------------------------------------------} +{ TBackGround PALETTES } +{---------------------------------------------------------------------------} +CONST + CBackground = #1; { Background colour } + +{---------------------------------------------------------------------------} +{ TApplication PALETTES } +{---------------------------------------------------------------------------} +CONST + { Turbo Vision 1.0 Color Palettes } + + CColor = + #$81#$70#$78#$74#$20#$28#$24#$17#$1F#$1A#$31#$31#$1E#$71#$1F + + #$37#$3F#$3A#$13#$13#$3E#$21#$3F#$70#$7F#$7A#$13#$13#$70#$7F#$7E + + #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 + + #$3F#$3E#$1F#$2F#$1A#$20#$72#$31#$31#$30#$2F#$3E#$31#$13#$38#$00; + + CBlackWhite = + #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$0F + + #$07#$0F#$07#$70#$70#$07#$70#$0F#$70#$7F#$7F#$70#$07#$70#$07#$0F + + #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 + + #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00; + + CMonochrome = + #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 + + #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 + + #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + + #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00; + + { Turbo Vision 2.0 Color Palettes } + + CAppColor = + #$71#$70#$78#$74#$20#$28#$24#$17#$1F#$1A#$31#$31#$1E#$71#$1F + + #$37#$3F#$3A#$13#$13#$3E#$21#$3F#$70#$7F#$7A#$13#$13#$70#$7F#$7E + + #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 + + #$3F#$3E#$1F#$2F#$1A#$20#$72#$31#$31#$30#$2F#$3E#$31#$13#$38#$00 + + #$17#$1F#$1A#$71#$71#$1E#$17#$1F#$1E#$20#$2B#$2F#$78#$2E#$10#$30 + + #$3F#$3E#$70#$2F#$7A#$20#$12#$31#$31#$30#$2F#$3E#$31#$13#$38#$00 + + #$37#$3F#$3A#$13#$13#$3E#$30#$3F#$3E#$20#$2B#$2F#$78#$2E#$30#$70 + + #$7F#$7E#$1F#$2F#$1A#$20#$32#$31#$71#$70#$2F#$7E#$71#$13#$38#$00; + + CAppBlackWhite = + #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$0F + + #$07#$0F#$07#$70#$70#$07#$70#$0F#$70#$7F#$7F#$70#$07#$70#$07#$0F + + #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 + + #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00 + + #$07#$0F#$0F#$07#$70#$07#$07#$0F#$0F#$70#$78#$7F#$08#$7F#$08#$70 + + #$7F#$7F#$7F#$0F#$70#$70#$07#$70#$70#$70#$07#$7F#$70#$07#$78#$00 + + #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 + + #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00; + + CAppMonochrome = + #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 + + #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 + + #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + + #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00 + + #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + + #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00 + + #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 + + #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00; + +{---------------------------------------------------------------------------} +{ STANDRARD HELP CONTEXT CONSTANTS } +{---------------------------------------------------------------------------} +CONST +{ Note: range $FF00 - $FFFF of help contexts are reserved by Borland } + hcNew = $FF01; { New file help } + hcOpen = $FF02; { Open file help } + hcSave = $FF03; { Save file help } + hcSaveAs = $FF04; { Save file as help } + hcSaveAll = $FF05; { Save all files help } + hcChangeDir = $FF06; { Change dir help } + hcDosShell = $FF07; { Dos shell help } + hcExit = $FF08; { Exit program help } + + hcUndo = $FF10; { Clipboard undo help } + hcCut = $FF11; { Clipboard cut help } + hcCopy = $FF12; { Clipboard copy help } + hcPaste = $FF13; { Clipboard paste help } + hcClear = $FF14; { Clipboard clear help } + + hcTile = $FF20; { Desktop tile help } + hcCascade = $FF21; { Desktop cascade help } + hcCloseAll = $FF22; { Desktop close all } + hcResize = $FF23; { Window resize help } + hcZoom = $FF24; { Window zoom help } + hcNext = $FF25; { Window next help } + hcPrev = $FF26; { Window previous help } + hcClose = $FF27; { Window close help } + +{***************************************************************************} +{ PUBLIC OBJECT DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TBackGround OBJECT - BACKGROUND OBJECT } +{---------------------------------------------------------------------------} +TYPE + TBackGround = OBJECT (TView) + Pattern: Char; { Background pattern } + CONSTRUCTOR Init (Var Bounds: TRect; APattern: Char); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Store (Var S: TStream); + END; + PBackGround = ^TBackGround; + +{---------------------------------------------------------------------------} +{ TDeskTop OBJECT - DESKTOP OBJECT } +{---------------------------------------------------------------------------} +TYPE + TDeskTop = OBJECT (TGroup) + Background : PBackground; { Background view } + TileColumnsFirst: Boolean; { Tile direction } + CONSTRUCTOR Init (Var Bounds: TRect); + CONSTRUCTOR Load (Var S: TStream); + PROCEDURE TileError; Virtual; + PROCEDURE InitBackGround; Virtual; + PROCEDURE Tile (Var R: TRect); + PROCEDURE Store (Var S: TStream); + PROCEDURE Cascade (Var R: TRect); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PDeskTop = ^TDeskTop; + +{---------------------------------------------------------------------------} +{ TProgram OBJECT - PROGRAM ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TProgram = OBJECT (TGroup) + CONSTRUCTOR Init; + DESTRUCTOR Done; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION CanMoveFocus: Boolean; + FUNCTION ValidView (P: PView): PView; + FUNCTION InsertWindow (P: PWindow): PWindow; + FUNCTION ExecuteDialog (P: PDialog; Data: Pointer): Word; + PROCEDURE Run; Virtual; + PROCEDURE Idle; Virtual; + PROCEDURE InitScreen; Virtual; +{ procedure DoneScreen; virtual;} + PROCEDURE InitDeskTop; Virtual; + PROCEDURE OutOfMemory; Virtual; + PROCEDURE InitMenuBar; Virtual; + PROCEDURE InitStatusLine; Virtual; + PROCEDURE SetScreenMode (Mode: Word); + PROCEDURE SetScreenVideoMode(const Mode: TVideoMode); + PROCEDURE PutEvent (Var Event: TEvent); Virtual; + PROCEDURE GetEvent (Var Event: TEvent); Virtual; + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PProgram = ^TProgram; + +{---------------------------------------------------------------------------} +{ TApplication OBJECT - APPLICATION OBJECT } +{---------------------------------------------------------------------------} +TYPE + TApplication = OBJECT (TProgram) + CONSTRUCTOR Init; + DESTRUCTOR Done; Virtual; + PROCEDURE Tile; + PROCEDURE Cascade; + PROCEDURE DosShell; + PROCEDURE GetTileRect (Var R: TRect); Virtual; + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + procedure WriteShellMsg; virtual; + END; + PApplication = ^TApplication; { Application ptr } + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STANDARD MENU AND STATUS LINES ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-StdStatusKeys------------------------------------------------------ +Returns a pointer to a linked list of commonly used status line keys. +The default status line for TApplication uses StdStatusKeys as its +complete list of status keys. +22Oct99 LdB +---------------------------------------------------------------------} +FUNCTION StdStatusKeys (Next: PStatusItem): PStatusItem; + +{-StdFileMenuItems--------------------------------------------------- +Returns a pointer to a list of menu items for a standard File menu. +The standard File menu items are New, Open, Save, Save As, Save All, +Change Dir, OS Shell, and Exit. +22Oct99 LdB +---------------------------------------------------------------------} +FUNCTION StdFileMenuItems (Next: PMenuItem): PMenuItem; + +{-StdEditMenuItems--------------------------------------------------- +Returns a pointer to a list of menu items for a standard Edit menu. +The standard Edit menu items are Undo, Cut, Copy, Paste, and Clear. +22Oct99 LdB +---------------------------------------------------------------------} +FUNCTION StdEditMenuItems (Next: PMenuItem): PMenuItem; + +{-StdWindowMenuItems------------------------------------------------- +Returns a pointer to a list of menu items for a standard Window menu. +The standard Window menu items are Tile, Cascade, Close All, +Size/Move, Zoom, Next, Previous, and Close. +22Oct99 LdB +---------------------------------------------------------------------} +FUNCTION StdWindowMenuItems (Next: PMenuItem): PMenuItem; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{-RegisterApp-------------------------------------------------------- +Calls RegisterType for each of the object types defined in this unit. +22oct99 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterApp; + +{***************************************************************************} +{ OBJECT REGISTRATION } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TBackGround STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RBackGround: TStreamRec = ( + ObjType: idBackground; { Register id = 30 } + VmtLink: TypeOf(TBackGround); + Load: @TBackGround.Load; { Object load method } + Store: @TBackGround.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TDeskTop STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RDeskTop: TStreamRec = ( + ObjType: idDesktop; { Register id = 31 } + VmtLink: TypeOf(TDeskTop); + Load: @TDeskTop.Load; { Object load method } + Store: @TDeskTop.Store { Object store method } + ); + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED PUBLIC VARIABLES } +{---------------------------------------------------------------------------} +CONST + AppPalette: Integer = apColor; { Application colour } + Desktop: PDeskTop = Nil; { Desktop object } + MenuBar: PMenuView = Nil; { Application menu } + StatusLine: PStatusLine = Nil; { App status line } + Application : PApplication = Nil; { Application object } + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +uses Mouse{,Resource}; + +resourcestring sVideoFailed='Video initialization failed.'; + sTypeExitOnReturn='Type EXIT to return...'; + + +{***************************************************************************} +{ PRIVATE DEFINED CONSTANTS } +{***************************************************************************} + +{***************************************************************************} +{ PRIVATE INITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED PRIVATE VARIABLES } +{---------------------------------------------------------------------------} +CONST Pending: TEvent = (What: evNothing); { Pending event } + +{---------------------------------------------------------------------------} +{ Tileable -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION Tileable (P: PView): Boolean; +BEGIN + Tileable := (P^.Options AND ofTileable <> 0) AND { View is tileable } + (P^.State AND sfVisible <> 0); { View is visible } +END; + +{---------------------------------------------------------------------------} +{ ISqr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION ISqr (X: Sw_Integer): Sw_Integer; +VAR I: Sw_Integer; +BEGIN + I := 0; { Set value to zero } + Repeat + Inc(I); { Inc value } + Until (I * I > X); { Repeat till Sqr > X } + ISqr := I - 1; { Return result } +END; + +{---------------------------------------------------------------------------} +{ MostEqualDivisors -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE MostEqualDivisors (N: Integer; Var X, Y: Integer; FavorY: Boolean); +VAR I: Integer; +BEGIN + I := ISqr(N); { Int square of N } + If ((N MOD I) <> 0) Then { Initial guess } + If ((N MOD (I+1)) = 0) Then Inc(I); { Add one row/column } + If (I < (N DIV I)) Then I := N DIV I; { In first page } + If FavorY Then Begin { Horz preferred } + X := N DIV I; { Calc x position } + Y := I; { Set y position } + End Else Begin { Vert preferred } + Y := N DIV I; { Calc y position } + X := I; { Set x position } + End; +END; + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{--TBackGround--------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TBackGround.Init (Var Bounds: TRect; APattern: Char); +BEGIN + Inherited Init(Bounds); { Call ancestor } + GrowMode := gfGrowHiX + gfGrowHiY; { Set grow modes } + Pattern := APattern; { Hold pattern } +END; + +{--TBackGround--------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TBackGround.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(Pattern, SizeOf(Pattern)); { Read pattern data } +END; + +{--TBackGround--------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TBackGround.GetPalette: PPalette; +CONST P: String[Length(CBackGround)] = CbackGround; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TBackGround--------------------------------------------------------------} +{ DrawBackground -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBackground.Draw; +VAR B: TDrawBuffer; +BEGIN + MoveChar(B, Pattern, GetColor($01), Size.X); { Fill draw buffer } + WriteLine(0, 0, Size.X, Size.Y, B); { Draw to area } +END; + +{--TBackGround--------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TBackGround.Store (Var S: TStream); +BEGIN + TView.Store(S); { TView store called } + S.Write(Pattern, SizeOf(Pattern)); { Write pattern data } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TDesktop OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TDesktop-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TDesktop.Init (Var Bounds: Objects.TRect); +BEGIN + Inherited Init(Bounds); { Call ancestor } + GrowMode := gfGrowHiX + gfGrowHiY; { Set growmode } + InitBackground; { Create background } + If (Background <> Nil) Then Insert(Background); { Insert background } +END; + +{--TDesktop-----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TDesktop.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + GetSubViewPtr(S, Background); { Load background } + S.Read(TileColumnsFirst, SizeOf(TileColumnsFirst));{ Read data } +END; + +{--TDesktop-----------------------------------------------------------------} +{ TileError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDeskTop.TileError; +BEGIN { Abstract method } +END; + +{--TDesktop-----------------------------------------------------------------} +{ InitBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDesktop.InitBackground; +CONST Ch: Char = #176; +VAR R: TRect; +BEGIN + GetExtent(R); { Get desktop extents } + BackGround := New(PBackground, Init(R, Ch)); { Insert a background } +END; + +{--TDesktop-----------------------------------------------------------------} +{ Tile -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDeskTop.Tile (Var R: TRect); +VAR NumCols, NumRows, NumTileable, LeftOver, TileNum: Integer; + + FUNCTION DividerLoc (Lo, Hi, Num, Pos: Integer): Integer; + BEGIN + DividerLoc := LongInt( LongInt(Hi - Lo) * Pos) + DIV Num + Lo; { Calc position } + END; + + PROCEDURE DoCountTileable (P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} + BEGIN + If Tileable(P) Then Inc(NumTileable); { Count tileable views } + END; + + PROCEDURE CalcTileRect (Pos: Integer; Var NR: TRect); + VAR X, Y, D: Integer; + BEGIN + D := (NumCols - LeftOver) * NumRows; { Calc d value } + If (Pos<D) Then Begin + X := Pos DIV NumRows; Y := Pos MOD NumRows; { Calc positions } + End Else Begin + X := (Pos - D) div (NumRows + 1) + + (NumCols - LeftOver); { Calc x position } + Y := (Pos - D) mod (NumRows + 1); { Calc y position } + End; + NR.A.X := DividerLoc(R.A.X, R.B.X, NumCols, X); { Top left x position } + NR.B.X := DividerLoc(R.A.X, R.B.X, NumCols, X+1);{ Right x position } + If (Pos >= D) Then Begin + NR.A.Y := DividerLoc(R.A.Y, R.B.Y,NumRows+1,Y);{ Top y position } + NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows+1, + Y+1); { Bottom y position } + End Else Begin + NR.A.Y := DividerLoc(R.A.Y, R.B.Y,NumRows,Y); { Top y position } + NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows, + Y+1); { Bottom y position } + End; + END; + + PROCEDURE DoTile(P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} + VAR PState: Word; R: TRect; + BEGIN + If Tileable(P) Then Begin + CalcTileRect(TileNum, R); { Calc tileable area } + PState := P^.State; { Hold view state } + P^.State := P^.State AND NOT sfVisible; { Temp not visible } + P^.Locate(R); { Locate view } + P^.State := PState; { Restore view state } + Dec(TileNum); { One less to tile } + End; + END; + +BEGIN + NumTileable := 0; { Zero tileable count } + ForEach(@DoCountTileable); { Count tileable views } + If (NumTileable>0) Then Begin + MostEqualDivisors(NumTileable, NumCols, NumRows, + NOT TileColumnsFirst); { Do pre calcs } + If ((R.B.X - R.A.X) DIV NumCols = 0) OR + ((R.B.Y - R.A.Y) DIV NumRows = 0) Then TileError { Can't tile } + Else Begin + LeftOver := NumTileable MOD NumCols; { Left over count } + TileNum := NumTileable-1; { Tileable views } + ForEach(@DoTile); { Tile each view } + DrawView; { Now redraw } + End; + End; +END; + +{--TDesktop-----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDesktop.Store (Var S: TStream); +BEGIN + TGroup.Store(S); { Call group store } + PutSubViewPtr(S, Background); { Store background } + S.Write(TileColumnsFirst,SizeOf(TileColumnsFirst));{ Write data } +END; + +{--TDesktop-----------------------------------------------------------------} +{ Cascade -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDeskTop.Cascade (Var R: TRect); +VAR CascadeNum: Integer; LastView: PView; Min, Max: TPoint; + + PROCEDURE DoCount (P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} + BEGIN + If Tileable(P) Then Begin + Inc(CascadeNum); LastView := P; { Count cascadable } + End; + END; + + PROCEDURE DoCascade (P: PView); {$IFNDEF PPC_FPC}FAR;{$ENDIF} + VAR PState: Word; NR: TRect; + BEGIN + If Tileable(P) AND (CascadeNum >= 0) Then Begin { View cascadable } + NR.Copy(R); { Copy rect area } + Inc(NR.A.X, CascadeNum); { Inc x position } + Inc(NR.A.Y, CascadeNum); { Inc y position } + PState := P^.State; { Hold view state } + P^.State := P^.State AND NOT sfVisible; { Temp stop draw } + P^.Locate(NR); { Locate the view } + P^.State := PState; { Now allow draws } + Dec(CascadeNum); { Dec count } + End; + END; + +BEGIN + CascadeNum := 0; { Zero cascade count } + ForEach(@DoCount); { Count cascadable } + If (CascadeNum>0) Then Begin + LastView^.SizeLimits(Min, Max); { Check size limits } + If (Min.X > R.B.X - R.A.X - CascadeNum) OR + (Min.Y > R.B.Y - R.A.Y - CascadeNum) Then + TileError Else Begin { Check for error } + Dec(CascadeNum); { One less view } + ForEach(@DoCascade); { Cascade view } + DrawView; { Redraw now } + End; + End; +END; + +{--TDesktop-----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDesktop.HandleEvent (Var Event: TEvent); +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evCommand) Then Begin + Case Event.Command of { Command event } + cmNext: FocusNext(False); { Focus next view } + cmPrev: If (BackGround <> Nil) Then Begin + If Valid(cmReleasedFocus) Then + Current^.PutInFrontOf(Background); { Focus last view } + End Else FocusNext(True); { Focus prior view } + Else Exit; + End; + ClearEvent(Event); { Clear the event } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TProgram OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + + +{--TProgram-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TProgram.Init; +VAR R: TRect; +BEGIN + R.Assign(0, 0, ScreenWidth, ScreenHeight); { Full screen area } + Inherited Init(R); { Call ancestor } + Application := PApplication(@Self); { Set application ptr } + InitScreen; { Initialize screen } + State := sfVisible + sfSelected + sfFocused + + sfModal + sfExposed; { Deafult states } + Options := 0; { No options set } + Size.X := ScreenWidth; { Set x size value } + Size.Y := ScreenHeight; { Set y size value } + InitStatusLine; { Create status line } + InitMenuBar; { Create a bar menu } + InitDesktop; { Create desktop } + If (Desktop <> Nil) Then Insert(Desktop); { Insert desktop } + If (StatusLine <> Nil) Then Insert(StatusLine); { Insert status line } + If (MenuBar <> Nil) Then Insert(MenuBar); { Insert menu bar } +END; + +{--TProgram-----------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TProgram.Done; +BEGIN + { Do not free the Buffer of Video Unit } + If Buffer = Views.PVideoBuf(VideoBuf) then + Buffer:=nil; + If (Desktop <> Nil) Then Dispose(Desktop, Done); { Destroy desktop } + If (MenuBar <> Nil) Then Dispose(MenuBar, Done); { Destroy menu bar } + If (StatusLine <> Nil) Then + Dispose(StatusLine, Done); { Destroy status line } + Application := Nil; { Clear application } + Inherited Done; { Call ancestor } +END; + +{--TProgram-----------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TProgram.GetPalette: PPalette; +CONST P: Array[apColor..apMonochrome] Of String = (CAppColor, CAppBlackWhite, + CAppMonochrome); +BEGIN + GetPalette := @P[AppPalette]; { Return palette } +END; + +{--TProgram-----------------------------------------------------------------} +{ CanMoveFocus -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TProgram.CanMoveFocus: Boolean; +BEGIN + If (Desktop <> Nil) Then { Valid desktop view } + CanMovefocus := DeskTop^.Valid(cmReleasedFocus) { Check focus move } + Else CanMoveFocus := True; { No desktop who cares! } +END; + +{--TProgram-----------------------------------------------------------------} +{ ValidView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TProgram.ValidView (P: PView): PView; +BEGIN + ValidView := Nil; { Preset failure } + If (P <> Nil) Then Begin +(* + If LowMemory Then Begin { Check memroy } + Dispose(P, Done); { Dispose view } + OutOfMemory; { Call out of memory } + Exit; { Now exit } + End; +*) + If NOT P^.Valid(cmValid) Then Begin { Check view valid } + Dispose(P, Done); { Dipose view } + Exit; { Now exit } + End; + ValidView := P; { Return view } + End; +END; + +{--TProgram-----------------------------------------------------------------} +{ InsertWindow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TProgram.InsertWindow (P: PWindow): PWindow; +BEGIN + InsertWindow := Nil; { Preset failure } + If (ValidView(P) <> Nil) Then { Check view valid } + If (CanMoveFocus) AND (Desktop <> Nil) { Can we move focus } + Then Begin + Desktop^.Insert(P); { Insert window } + InsertWindow := P; { Return view ptr } + End Else Dispose(P, Done); { Dispose view } +END; + +{--TProgram-----------------------------------------------------------------} +{ ExecuteDialog -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TProgram.ExecuteDialog (P: PDialog; Data: Pointer): Word; +VAR ExecResult: Word; +BEGIN + ExecuteDialog := cmCancel; { Preset cancel } + If (ValidView(P) <> Nil) Then Begin { Check view valid } + If (Data <> Nil) Then P^.SetData(Data^); { Set data } + If (P <> Nil) Then P^.SelectDefaultView; { Select default } + ExecResult := Desktop^.ExecView(P); { Execute view } + If (ExecResult <> cmCancel) AND (Data <> Nil) + Then P^.GetData(Data^); { Get data back } + Dispose(P, Done); { Dispose of dialog } + ExecuteDialog := ExecResult; { Return result } + End; +END; + +{--TProgram-----------------------------------------------------------------} +{ Run -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.Run; +BEGIN + Execute; { Call execute } +END; + +{--TProgram-----------------------------------------------------------------} +{ Idle -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.Idle; +BEGIN + If (StatusLine <> Nil) Then StatusLine^.Update; { Update statusline } + If CommandSetChanged Then Begin { Check command change } + Message(@Self, evBroadcast, cmCommandSetChanged, + Nil); { Send message } + CommandSetChanged := False; { Clear flag } + End; + GiveUpTimeSlice; +END; + +{--TProgram-----------------------------------------------------------------} +{ InitScreen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.InitScreen; + +{Initscreen is passive only, i.e. it detects the video size and capabilities + after initalization. Active video initalization is the task of Tapplication.} + +BEGIN + { the orginal code can't be used here because of the limited + video unit capabilities, the mono modus can't be handled + } +{ Drivers.InitVideo;} + if (ScreenMode.Col div ScreenMode.Row<2) then + ShadowSize.X := 1 + else + ShadowSize.X := 2; + + ShadowSize.Y := 1; + ShowMarkers := False; + if ScreenMode.color then + AppPalette := apColor + else + AppPalette := apBlackWhite; + Buffer := Views.PVideoBuf(VideoBuf); +END; + + +{procedure TProgram.DoneScreen; +begin + Drivers.DoneVideo; + Buffer:=nil; +end;} + + +{--TProgram-----------------------------------------------------------------} +{ InitDeskTop -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.InitDesktop; +VAR R: TRect; +BEGIN + GetExtent(R); { Get view extent } + If (MenuBar <> Nil) Then Inc(R.A.Y); { Adjust top down } + If (StatusLine <> Nil) Then Dec(R.B.Y); { Adjust bottom up } + DeskTop := New(PDesktop, Init(R)); { Create desktop } +END; + +{--TProgram-----------------------------------------------------------------} +{ OutOfMemory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.OutOfMemory; +BEGIN { Abstract method } +END; + +{--TProgram-----------------------------------------------------------------} +{ InitMenuBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.InitMenuBar; +VAR R: TRect; +BEGIN + GetExtent(R); { Get view extents } + R.B.Y := R.A.Y + 1; { One line high } + MenuBar := New(PMenuBar, Init(R, Nil)); { Create menu bar } +END; + +{--TProgram-----------------------------------------------------------------} +{ InitStatusLine -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.InitStatusLine; +VAR R: TRect; +BEGIN + GetExtent(R); { Get view extents } + R.A.Y := R.B.Y - 1; { One line high } + New(StatusLine, Init(R, + NewStatusDef(0, $FFFF, + NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit, + StdStatusKeys(Nil)), Nil))); { Default status line } +END; + +{--TProgram-----------------------------------------------------------------} +{ SetScreenMode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.SetScreenMode (Mode: Word); +var + R: TRect; +begin + HideMouse; +{ DoneMemory;} +{ InitMemory;} + InitScreen; + Buffer := Views.PVideoBuf(VideoBuf); + R.Assign(0, 0, ScreenWidth, ScreenHeight); + ChangeBounds(R); + ShowMouse; +end; + +procedure TProgram.SetScreenVideoMode(const Mode: TVideoMode); +var + R: TRect; +begin + hidemouse; +{ DoneMouse; + DoneMemory;} + ScreenMode:=Mode; +{ InitMouse; + InitMemory;} + InitScreen; + Video.SetVideoMode(Mode); + ScreenWidth:=Video.ScreenWidth; + ScreenHeight:=Video.ScreenHeight; + Buffer := Views.PVideoBuf(VideoBuf); + R.Assign(0, 0, ScreenWidth, ScreenHeight); + ChangeBounds(R); + ShowMouse; +end; + +{--TProgram-----------------------------------------------------------------} +{ PutEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.PutEvent (Var Event: TEvent); +BEGIN + Pending := Event; { Set pending event } +END; + +{--TProgram-----------------------------------------------------------------} +{ GetEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.GetEvent (Var Event: TEvent); +BEGIN + Event.What := evNothing; + If (Event.What = evNothing) Then Begin + If (Pending.What <> evNothing) Then Begin { Pending event } + Event := Pending; { Load pending event } + Pending.What := evNothing; { Clear pending event } + End Else Begin + NextQueuedEvent(Event); { Next queued event } + If (Event.What = evNothing) Then Begin + GetKeyEvent(Event); { Fetch key event } + If (Event.What = evKeyDown) then + Begin + if Event.keyCode = kbAltF12 then + ReDraw; + End; + If (Event.What = evNothing) Then Begin { No mouse event } + Drivers.GetMouseEvent(Event); { Load mouse event } + If (Event.What = evNothing) Then + begin + Drivers.GetSystemEvent(Event); { Load system event } + If (Event.What = evNothing) Then + Idle; { Idle if no event } + end; + End; + End; + End; + End; +END; + +{--TProgram-----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TProgram.HandleEvent (Var Event: TEvent); +VAR C: Char; +BEGIN + If (Event.What = evKeyDown) Then Begin { Key press event } + C := GetAltChar(Event.KeyCode); { Get alt char code } + If (C >= '1') AND (C <= '9') Then + If (Message(Desktop, evBroadCast, cmSelectWindowNum, + Pointer(Byte(C) - $30)) <> Nil) { Select window } + Then ClearEvent(Event); { Clear event } + End; + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evCommand) AND { Command event } + (Event.Command = cmQuit) Then Begin { Quit command } + EndModal(cmQuit); { Endmodal operation } + ClearEvent(Event); { Clear event } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TApplication OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TApplication-------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TApplication.Init; + +BEGIN +{ InitMemory;} { Start memory up } +{ if not(InitResource) then + begin + writeln('Fatal: Can''t init resources'); + halt(1); + end;} + initkeyboard; + if not Drivers.InitVideo then { Start video up } + begin + donekeyboard; + writeln(sVideoFailed); + halt(1); + end; + Drivers.InitEvents; { Start event drive } + Drivers.InitSysError; { Start system error } + InitHistory; { Start history up } + Inherited Init; { Call ancestor } + InitMsgBox; + { init mouse and cursor } + Video.SetCursorType(crHidden); + Mouse.SetMouseXY(1,1); +END; + +{--TApplication-------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TApplication.Done; +BEGIN + Inherited Done; { Call ancestor } + DoneHistory; { Close history } + Drivers.DoneSysError; { Close system error } + Drivers.DoneEvents; { Close event drive } + drivers.donevideo; +{ DoneMemory;} { Close memory } + donekeyboard; +{ DoneResource;} +END; + +{--TApplication-------------------------------------------------------------} +{ Tile -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TApplication.Tile; +VAR R: TRect; +BEGIN + GetTileRect(R); { Tileable area } + If (Desktop <> Nil) Then Desktop^.Tile(R); { Tile desktop } +END; + +{--TApplication-------------------------------------------------------------} +{ Cascade -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TApplication.Cascade; +VAR R: TRect; +BEGIN + GetTileRect(R); { Cascade area } + If (Desktop <> Nil) Then Desktop^.Cascade(R); { Cascade desktop } +END; + +{--TApplication-------------------------------------------------------------} +{ DosShell -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TApplication.DosShell; + +{$ifdef unix} +var s:string; +{$endif} + +BEGIN { Compatability only } + DoneSysError; + DoneEvents; + drivers.donevideo; + drivers.donekeyboard; +{ DoneDosMem;} + WriteShellMsg; +{$ifdef Unix} + s:=getenv('SHELL'); + if s='' then + s:='/bin/sh'; + exec(s,''); +{$else} + SwapVectors; + Exec(GetEnv('COMSPEC'), ''); + SwapVectors; +{$endif} +{ InitDosMem;} + drivers.initkeyboard; + drivers.initvideo; + InitScreen; + InitEvents; + InitSysError; + Redraw; +END; + +{--TApplication-------------------------------------------------------------} +{ GetTileRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TApplication.GetTileRect (Var R: TRect); +BEGIN + If (DeskTop <> Nil) Then Desktop^.GetExtent(R) { Desktop extents } + Else GetExtent(R); { Our extents } +END; + +{--TApplication-------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TApplication.HandleEvent (Var Event: TEvent); +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evCommand) Then Begin + Case Event.Command Of + cmTile: Tile; { Tile request } + cmCascade: Cascade; { Cascade request } + cmDosShell: DosShell; { DOS shell request } + Else Exit; { Unhandled exit } + End; + ClearEvent(Event); { Clear the event } + End; +END; + +procedure TApplication.WriteShellMsg; + +begin + writeln(sTypeExitOnReturn); +end; + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STANDARD MENU AND STATUS LINES ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ StdStatusKeys -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION StdStatusKeys (Next: PStatusItem): PStatusItem; +BEGIN + StdStatusKeys := + NewStatusKey('', kbAltX, cmQuit, + NewStatusKey('', kbF10, cmMenu, + NewStatusKey('', kbAltF3, cmClose, + NewStatusKey('', kbF5, cmZoom, + NewStatusKey('', kbCtrlF5, cmResize, + NewStatusKey('', kbF6, cmNext, + NewStatusKey('', kbShiftF6, cmPrev, + Next))))))); +END; + +{---------------------------------------------------------------------------} +{ StdFileMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION StdFileMenuItems (Next: PMenuItem): PMenuItem; +BEGIN + StdFileMenuItems := + NewItem('~N~ew', '', kbNoKey, cmNew, hcNew, + NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcOpen, + NewItem('~S~ave', 'F2', kbF2, cmSave, hcSave, + NewItem('S~a~ve as...', '', kbNoKey, cmSaveAs, hcSaveAs, + NewItem('Save a~l~l', '', kbNoKey, cmSaveAll, hcSaveAll, + NewLine( + NewItem('~C~hange dir...', '', kbNoKey, cmChangeDir, hcChangeDir, + NewItem('OS shell', '', kbNoKey, cmDosShell, hcDosShell, + NewItem('E~x~it', 'Alt+X', kbAltX, cmQuit, hcExit, + Next))))))))); +END; + +{---------------------------------------------------------------------------} +{ StdEditMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION StdEditMenuItems (Next: PMenuItem): PMenuItem; +BEGIN + StdEditMenuItems := + NewItem('~U~ndo', '', kbAltBack, cmUndo, hcUndo, + NewLine( + NewItem('Cu~t~', 'Shift+Del', kbShiftDel, cmCut, hcCut, + NewItem('~C~opy', 'Ctrl+Ins', kbCtrlIns, cmCopy, hcCopy, + NewItem('~P~aste', 'Shift+Ins', kbShiftIns, cmPaste, hcPaste, + NewItem('C~l~ear', 'Ctrl+Del', kbCtrlDel, cmClear, hcClear, + Next)))))); +END; + +{---------------------------------------------------------------------------} +{ StdWindowMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION StdWindowMenuItems (Next: PMenuItem): PMenuItem; +BEGIN + StdWindowMenuItems := + NewItem('~T~ile', '', kbNoKey, cmTile, hcTile, + NewItem('C~a~scade', '', kbNoKey, cmCascade, hcCascade, + NewItem('Cl~o~se all', '', kbNoKey, cmCloseAll, hcCloseAll, + NewLine( + NewItem('~S~ize/Move','Ctrl+F5', kbCtrlF5, cmResize, hcResize, + NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcZoom, + NewItem('~N~ext', 'F6', kbF6, cmNext, hcNext, + NewItem('~P~revious', 'Shift+F6', kbShiftF6, cmPrev, hcPrev, + NewItem('~C~lose', 'Alt+F3', kbAltF3, cmClose, hcClose, + Next))))))))); +END; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ RegisterApp -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterApp; +BEGIN + RegisterType(RBackground); { Register background } + RegisterType(RDesktop); { Register desktop } +END; + +END. diff --git a/packages/fv/src/asciitab.pas b/packages/fv/src/asciitab.pas new file mode 100644 index 0000000000..b3107be1a1 --- /dev/null +++ b/packages/fv/src/asciitab.pas @@ -0,0 +1,322 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of ASCIITAB.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 2002 by Pierre Muller } +{ pierre@freepascal.org } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DPMI - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WIN95/NT - FPC 0.9912+ (32 Bit) } +{ } + +UNIT AsciiTab; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES FVConsts, Objects, Drivers, Views, App; { Standard GFV units } + +{***************************************************************************} +{ PUBLIC OBJECT DEFINITIONS } +{***************************************************************************} + + +{---------------------------------------------------------------------------} +{ TTABLE OBJECT - 32x32 matrix of all chars } +{---------------------------------------------------------------------------} + +type + PTable = ^TTable; + TTable = object(TView) + procedure Draw; virtual; + procedure HandleEvent(var Event:TEvent); virtual; + private + procedure DrawCurPos(enable : boolean); + end; + +{---------------------------------------------------------------------------} +{ TREPORT OBJECT - View with details of current char } +{---------------------------------------------------------------------------} + PReport = ^TReport; + TReport = object(TView) + ASCIIChar: LongInt; + constructor Load(var S: TStream); + procedure Draw; virtual; + procedure HandleEvent(var Event:TEvent); virtual; + procedure Store(var S: TStream); + end; + +{---------------------------------------------------------------------------} +{ TASCIIChart OBJECT - the complete AsciiChar window } +{---------------------------------------------------------------------------} + + PASCIIChart = ^TASCIIChart; + TASCIIChart = object(TWindow) + Report: PReport; + Table: PTable; + constructor Init; + constructor Load(var S: TStream); + procedure Store(var S: TStream); + procedure HandleEvent(var Event:TEvent); virtual; + end; + +{---------------------------------------------------------------------------} +{ AsciiTableCommandBase } +{---------------------------------------------------------------------------} + +const + AsciiTableCommandBase: Word = 910; + +{---------------------------------------------------------------------------} +{ Registrations records } +{---------------------------------------------------------------------------} + + RTable: TStreamRec = ( + ObjType: idTable; + VmtLink: Ofs(TypeOf(TTable)^); + Load: @TTable.Load; + Store: @TTable.Store + ); + RReport: TStreamRec = ( + ObjType: idReport; + VmtLink: Ofs(TypeOf(TReport)^); + Load: @TReport.Load; + Store: @TReport.Store + ); + RASCIIChart: TStreamRec = ( + ObjType: idASCIIChart; + VmtLink: Ofs(TypeOf(TASCIIChart)^); + Load: @TASCIIChart.Load; + Store: @TASCIIChart.Store + ); + +{---------------------------------------------------------------------------} +{ Registration procedure } +{---------------------------------------------------------------------------} +procedure RegisterASCIITab; + + + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TTable OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +procedure TTable.Draw; +var + NormColor : byte; + B : TDrawBuffer; + x,y : sw_integer; +begin + NormColor:=GetColor(1); + For y:=0 to size.Y-1 do begin + For x:=0 to size.X-1 do + B[x]:=(NormColor shl 8) or ((y*Size.X+x) and $ff); + WriteLine(0,Y,Size.X,1,B); + end; + DrawCurPos(true); +end; + +procedure TTable.DrawCurPos(enable : boolean); +var + Color : byte; + B : word; +begin + Color:=GetColor(1); + { add blinking if enable } + If Enable then + Color:=((Color and $F) shl 4) or (Color shr 4); + B:=(Color shl 8) or ((Cursor.Y*Size.X+Cursor.X) and $ff); + WriteLine(Cursor.X,Cursor.Y,1,1,B); +end; + +procedure TTable.HandleEvent(var Event:TEvent); +var + CurrentPos : TPoint; + Handled : boolean; + + procedure SetTo(xpos, ypos : sw_integer); + var + newchar : ptrint; + begin + newchar:=(ypos*size.X+xpos) and $ff; + DrawCurPos(false); + SetCursor(xpos,ypos); + Message(Owner,evCommand,AsciiTableCommandBase, + pointer(newchar)); + DrawCurPos(true); + ClearEvent(Event); + end; + +begin + case Event.What of + evMouseDown : + begin + If MouseInView(Event.Where) then + begin + MakeLocal(Event.Where, CurrentPos); + SetTo(CurrentPos.X, CurrentPos.Y); + exit; + end; + end; + evKeyDown : + begin + Handled:=true; + case Event.Keycode of + kbUp : if Cursor.Y>0 then + SetTo(Cursor.X,Cursor.Y-1); + kbDown : if Cursor.Y<Size.Y-1 then + SetTo(Cursor.X,Cursor.Y+1); + kbLeft : if Cursor.X>0 then + SetTo(Cursor.X-1,Cursor.Y); + kbRight: if Cursor.X<Size.X-1 then + SetTo(Cursor.X+1,Cursor.Y); + kbHome : SetTo(0,0); + kbEnd : SetTo(Size.X-1,Size.Y-1); + else + Handled:=false; + end; + if Handled then + exit; + end; + end; + inherited HandleEvent(Event); +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TReport OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +constructor TReport.Load(var S: TStream); +begin + Inherited Load(S); + S.Read(AsciiChar,Sizeof(AsciiChar)); +end; + +procedure TReport.Draw; + var + stHex,stDec : string[3]; + s : string; +begin + Str(AsciiChar,StDec); + while length(stDec)<3 do + stDec:=' '+stDec; + stHex:=hexstr(AsciiChar,2); + s:='Char "'+chr(AsciiChar)+'" Decimal: '+ + StDec+' Hex: $'+StHex+ + ' '; // //{!ss:fill gap. FormatStr function using be better} + WriteStr(0,0,S,1); +end; + +procedure TReport.HandleEvent(var Event:TEvent); +begin + if (Event.what=evCommand) and + (Event.Command = AsciiTableCommandBase) then + begin + AsciiChar:=Event.InfoLong; + Draw; + ClearEvent(Event); + end + else inherited HandleEvent(Event); +end; + +procedure TReport.Store(var S: TStream); +begin + Inherited Store(S); + S.Write(AsciiChar,Sizeof(AsciiChar)); +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TAsciiChart OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +constructor TASCIIChart.Init; +var + R : Trect; +begin + R.Assign(0,0,34,12); + Inherited Init(R,'Ascii table',wnNoNumber); + Flags:=Flags and not (wfGrow or wfZoom); + Palette:=wpGrayWindow; + R.Assign(1,10,33,11); + New(Report,Init(R)); + Report^.Options:=Report^.Options or ofFramed; + Insert(Report); + R.Assign(1,1,33,9); + New(Table,Init(R)); + Table^.Options:=Table^.Options or (ofSelectable+ofTopSelect); + Insert(Table); + Table^.Select; +end; + +constructor TASCIIChart.Load(var S: TStream); +begin + Inherited Load(S); + GetSubViewPtr(S,Table); + GetSubViewPtr(S,Report); +end; + +procedure TASCIIChart.Store(var S: TStream); +begin + Inherited Store(S); + PutSubViewPtr(S,Table); + PutSubViewPtr(S,Report); +end; + +procedure TASCIIChart.HandleEvent(var Event:TEvent); +begin + if (Event.what=evCommand) and + (Event.Command = AsciiTableCommandBase) then + begin + Report^.HandleEvent(Event); + end + else inherited HandleEvent(Event); +end; +{---------------------------------------------------------------------------} +{ Registration procedure } +{---------------------------------------------------------------------------} +procedure RegisterASCIITab; +begin + RegisterType(RTable); + RegisterType(RReport); + RegisterType(RAsciiChart); +end; + + +END. diff --git a/packages/fv/src/buildfv.pas b/packages/fv/src/buildfv.pas new file mode 100644 index 0000000000..de7fc74ac6 --- /dev/null +++ b/packages/fv/src/buildfv.pas @@ -0,0 +1,36 @@ +{ + + Unit to build all units of Free Vision +} +unit buildfv; +interface +uses + fvcommon, + objects, + drivers, +{ memory,} + fvconsts, +{ resource,} + views, + validate, + msgbox, + dialogs, + menus, + app, + stddlg, + asciitab, + tabs, + outline, + memory, + colortxt, + statuses, + histlist, + inplong, + editors, + gadgets, + timeddlg, + time; + +implementation + +end. diff --git a/packages/fv/src/colortxt.pas b/packages/fv/src/colortxt.pas new file mode 100644 index 0000000000..4bdb6b13a9 --- /dev/null +++ b/packages/fv/src/colortxt.pas @@ -0,0 +1,126 @@ +unit ColorTxt; + +{ + TColoredText is a descendent of TStaticText designed to allow the writing + of colored text when color monitors are used. With a monochrome or BW + monitor, TColoredText acts the same as TStaticText. + + TColoredText is used in exactly the same way as TStaticText except that + the constructor has an extra Byte parameter specifying the attribute + desired. (Do not use a 0 attribute, black on black). +} + +{$i platform.inc} + +{$ifdef PPC_FPC} + {$H-} +{$else} + {$F+,O+,E+,N+} +{$endif} +{$X+,R-,I-,Q-,V-} +{$ifndef OS_UNIX} + {$S-} +{$endif} + +interface + +uses + objects, drivers, views, dialogs, app, fvconsts; + +type + PColoredText = ^TColoredText; + TColoredText = object(TStaticText) + Attr : Byte; + constructor Init(var Bounds: TRect; const AText: String; Attribute : Byte); + constructor Load(var S: TStream); + function GetTheColor : byte; virtual; + procedure Draw; virtual; + procedure Store(var S: TStream); + end; + +const + RColoredText: TStreamRec = ( + ObjType: idColoredText; + VmtLink: Ofs(TypeOf(TColoredText)^); + Load: @TColoredText.Load; + Store: @TColoredText.Store + ); + +implementation + +constructor TColoredText.Init(var Bounds: TRect; const AText: String; + Attribute : Byte); +begin +TStaticText.Init(Bounds, AText); +Attr := Attribute; +end; + +constructor TColoredText.Load(var S: TStream); +begin +TStaticText.Load(S); +S.Read(Attr, Sizeof(Attr)); +end; + +procedure TColoredText.Store(var S: TStream); +begin +TStaticText.Store(S); +S.Write(Attr, Sizeof(Attr)); +end; + +function TColoredText.GetTheColor : byte; +begin +if AppPalette = apColor then + GetTheColor := Attr +else + GetTheColor := GetColor(1); +end; + +procedure TColoredText.Draw; +var + Color: Byte; + Center: Boolean; + I, J, L, P, Y: Sw_Integer; + B: TDrawBuffer; + S: String; +begin + Color := GetTheColor; + GetText(S); + L := Length(S); + P := 1; + Y := 0; + Center := False; + while Y < Size.Y do + begin + MoveChar(B, ' ', Color, Size.X); + if P <= L then + begin + if S[P] = #3 then + begin + Center := True; + Inc(P); + end; + I := P; + repeat + J := P; + while (P <= L) and (S[P] = ' ') do Inc(P); + while (P <= L) and (S[P] <> ' ') and (S[P] <> #13) do Inc(P); + until (P > L) or (P >= I + Size.X) or (S[P] = #13); + if P > I + Size.X then + if J > I then P := J else P := I + Size.X; + if Center then J := (Size.X - P + I) div 2 else J := 0; + MoveBuf(B[J], S[I], Color, P - I); + while (P <= L) and (S[P] = ' ') do Inc(P); + if (P <= L) and (S[P] = #13) then + begin + Center := False; + Inc(P); + if (P <= L) and (S[P] = #10) then Inc(P); + end; + end; + WriteLine(0, Y, Size.X, 1, B); + Inc(Y); + end; +end; + + +end. diff --git a/packages/fv/src/dialogs.pas b/packages/fv/src/dialogs.pas new file mode 100644 index 0000000000..f91f9531c6 --- /dev/null +++ b/packages/fv/src/dialogs.pas @@ -0,0 +1,4186 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of DIALOGS.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@starwon.com.au - backup e-mail addr } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} + +UNIT Dialogs; + +{$CODEPAGE cp437} + +{2.0 compatibility} +{$ifdef VER2_0} + {$macro on} + {$define resourcestring := const} +{$endif} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES + {$IFDEF OS_WINDOWS} { WIN/NT CODE } + Windows, { Standard units } + {$ENDIF} + + {$IFDEF OS_OS2} { OS2 CODE } + OS2Def, DosCalls, PMWIN, { Standard units } + {$ENDIF} + + FVCommon, FVConsts, Objects, Drivers, Views, Validate; { Standard GFV units } + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ COLOUR PALETTE DEFINITIONS } +{---------------------------------------------------------------------------} +CONST + CGrayDialog = #32#33#34#35#36#37#38#39#40#41#42#43#44#45#46#47 + + #48#49#50#51#52#53#54#55#56#57#58#59#60#61#62#63; + CBlueDialog = #64#65#66#67#68#69#70#71#72#73#74#75#76#77#78#79 + + #80#81#82#83#84#85#86#87#88#89#90#91#92#92#94#95; + CCyanDialog = #96#97#98#99#100#101#102#103#104#105#106#107#108 + + #109#110#111#112#113#114#115#116#117#118#119#120 + + #121#122#123#124#125#126#127; + CStaticText = #6#7#8#9; + CLabel = #7#8#9#9; + CButton = #10#11#12#13#14#14#14#15; + CCluster = #16#17#18#18#31#6; + CInputLine = #19#19#20#21#14; + CHistory = #22#23; + CHistoryWindow = #19#19#21#24#25#19#20; + CHistoryViewer = #6#6#7#6#6; + + CDialog = CGrayDialog; { Default palette } + +const + { ldXXXX constants } + ldNone = $0000; + ldNew = $0001; + ldEdit = $0002; + ldDelete = $0004; + ldNewEditDelete = ldNew or ldEdit or ldDelete; + ldHelp = $0008; + ldAllButtons = ldNew or ldEdit or ldDelete or ldHelp; + ldNewIcon = $0010; + ldEditIcon = $0020; + ldDeleteIcon = $0040; + ldAllIcons = ldNewIcon or ldEditIcon or ldDeleteIcon; + ldAll = ldAllIcons or ldAllButtons; + ldNoFrame = $0080; + ldNoScrollBar = $0100; + + { ofXXXX constants } + ofNew = $0001; + ofDelete = $0002; + ofEdit = $0004; + ofNewEditDelete = ofNew or ofDelete or ofEdit; + +{---------------------------------------------------------------------------} +{ TDialog PALETTE COLOUR CONSTANTS } +{---------------------------------------------------------------------------} +CONST + dpBlueDialog = 0; { Blue dialog colour } + dpCyanDialog = 1; { Cyan dialog colour } + dpGrayDialog = 2; { Gray dialog colour } + +{---------------------------------------------------------------------------} +{ TButton FLAGS MASKS } +{---------------------------------------------------------------------------} +CONST + bfNormal = $00; { Normal displayed } + bfDefault = $01; { Default command } + bfLeftJust = $02; { Left just text } + bfBroadcast = $04; { Broadcast command } + bfGrabFocus = $08; { Grab focus } + +{---------------------------------------------------------------------------} +{ TMultiCheckBoxes FLAGS - (HiByte = Bits LoByte = Mask) } +{---------------------------------------------------------------------------} +CONST + cfOneBit = $0101; { One bit masks } + cfTwoBits = $0203; { Two bit masks } + cfFourBits = $040F; { Four bit masks } + cfEightBits = $08FF; { Eight bit masks } + +{---------------------------------------------------------------------------} +{ DIALOG BROADCAST COMMANDS } +{---------------------------------------------------------------------------} +CONST + cmRecordHistory = 60; { Record history cmd } + +{***************************************************************************} +{ RECORD DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ ITEM RECORD DEFINITION } +{---------------------------------------------------------------------------} +TYPE + PSItem = ^TSItem; + TSItem = RECORD + Value: PString; { Item string } + Next: PSItem; { Next item } + END; + +{***************************************************************************} +{ OBJECT DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TInputLine OBJECT - INPUT LINE OBJECT } +{---------------------------------------------------------------------------} +TYPE + TInputLine = OBJECT (TView) + MaxLen: Sw_Integer; { Max input length } + CurPos: Sw_Integer; { Cursor position } + FirstPos: Sw_Integer; { First position } + SelStart: Sw_Integer; { Selected start } + SelEnd: Sw_Integer; { Selected end } + Data: PString; { Input line data } + Validator: PValidator; { Validator of view } + CONSTRUCTOR Init (Var Bounds: TRect; AMaxLen: Sw_Integer); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION Valid (Command: Word): Boolean; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE DrawCursor; Virtual; + PROCEDURE SelectAll (Enable: Boolean); + PROCEDURE SetValidator (AValid: PValidator); + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PRIVATE + FUNCTION CanScroll (Delta: Sw_Integer): Boolean; + END; + PInputLine = ^TInputLine; + +{---------------------------------------------------------------------------} +{ TButton OBJECT - BUTTON ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TButton = OBJECT (TView) + AmDefault: Boolean; { If default button } + Flags : Byte; { Button flags } + Command : Word; { Button command } + Title : PString; { Button title } + CONSTRUCTOR Init (Var Bounds: TRect; ATitle: TTitleStr; ACommand: Word; + AFlags: Word); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE Press; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE DrawState (Down: Boolean); + PROCEDURE MakeDefault (Enable: Boolean); + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PRIVATE + DownFlag: Boolean; + END; + PButton = ^TButton; + +{---------------------------------------------------------------------------} +{ TCluster OBJECT - CLUSTER ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + { Palette layout } + { 1 = Normal text } + { 2 = Selected text } + { 3 = Normal shortcut } + { 4 = Selected shortcut } + { 5 = Disabled text } + + TCluster = OBJECT (TView) + Id : Sw_Integer; { New communicate id } + Sel : Sw_Integer; { Selected item } + Value : LongInt; { Bit value } + EnableMask: LongInt; { Mask enable bits } + Strings : TStringCollection; { String collection } + CONSTRUCTOR Init (Var Bounds: TRect; AStrings: PSItem); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION GetHelpCtx: Word; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION Mark (Item: Sw_Integer): Boolean; Virtual; + FUNCTION MultiMark (Item: Sw_Integer): Byte; Virtual; + FUNCTION ButtonState (Item: Sw_Integer): Boolean; + PROCEDURE Draw; Virtual; + PROCEDURE Press (Item: Sw_Integer); Virtual; + PROCEDURE MovedTo (Item: Sw_Integer); Virtual; + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE DrawMultiBox (Const Icon, Marker: String); + PROCEDURE DrawBox (Const Icon: String; Marker: Char); + PROCEDURE SetButtonState (AMask: Longint; Enable: Boolean); + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PRIVATE + FUNCTION FindSel (P: TPoint): Sw_Integer; + FUNCTION Row (Item: Sw_Integer): Sw_Integer; + FUNCTION Column (Item: Sw_Integer): Sw_Integer; + END; + PCluster = ^TCluster; + +{---------------------------------------------------------------------------} +{ TRadioButtons OBJECT - RADIO BUTTON OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Normal text } + { 2 = Selected text } + { 3 = Normal shortcut } + { 4 = Selected shortcut } + + +TYPE + TRadioButtons = OBJECT (TCluster) + FUNCTION Mark (Item: Sw_Integer): Boolean; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Press (Item: Sw_Integer); Virtual; + PROCEDURE MovedTo(Item: Sw_Integer); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + END; + PRadioButtons = ^TRadioButtons; + +{---------------------------------------------------------------------------} +{ TCheckBoxes OBJECT - CHECK BOXES OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Normal text } + { 2 = Selected text } + { 3 = Normal shortcut } + { 4 = Selected shortcut } + +TYPE + TCheckBoxes = OBJECT (TCluster) + FUNCTION Mark (Item: Sw_Integer): Boolean; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Press (Item: Sw_Integer); Virtual; + END; + PCheckBoxes = ^TCheckBoxes; + +{---------------------------------------------------------------------------} +{ TMultiCheckBoxes OBJECT - CHECK BOXES OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Normal text } + { 2 = Selected text } + { 3 = Normal shortcut } + { 4 = Selected shortcut } + +TYPE + TMultiCheckBoxes = OBJECT (TCluster) + SelRange: Byte; { Select item range } + Flags : Word; { Select flags } + States : PString; { Strings } + CONSTRUCTOR Init (Var Bounds: TRect; AStrings: PSItem; + ASelRange: Byte; AFlags: Word; Const AStates: String); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION MultiMark (Item: Sw_Integer): Byte; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Press (Item: Sw_Integer); Virtual; + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + END; + PMultiCheckBoxes = ^TMultiCheckBoxes; + +{---------------------------------------------------------------------------} +{ TListBox OBJECT - LIST BOX OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Active } + { 2 = Inactive } + { 3 = Focused } + { 4 = Selected } + { 5 = Divider } + +TYPE + TListBox = OBJECT (TListViewer) + List: PCollection; { List of strings } + CONSTRUCTOR Init (Var Bounds: TRect; ANumCols: Sw_Word; + AScrollBar: PScrollBar); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; Virtual; + PROCEDURE NewList(AList: PCollection); Virtual; + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + procedure DeleteFocusedItem; virtual; + { DeleteFocusedItem deletes the focused item and redraws the view. } + {#X FreeFocusedItem } + procedure DeleteItem (Item : Sw_Integer); virtual; + { DeleteItem deletes Item from the associated collection. } + {#X FreeItem } + procedure FreeAll; virtual; + { FreeAll deletes and disposes of all items in the associated + collection. } + { FreeFocusedItem FreeItem } + procedure FreeFocusedItem; virtual; + { FreeFocusedItem deletes and disposes of the focused item then redraws + the listbox. } + {#X FreeAll FreeItem } + procedure FreeItem (Item : Sw_Integer); virtual; + { FreeItem deletes Item from the associated collection and disposes of + it, then redraws the listbox. } + {#X FreeFocusedItem FreeAll } + function GetFocusedItem : Pointer; virtual; + { GetFocusedItem is a more readable method of returning the focused + item from the listbox. It is however slightly slower than: } + {#M+} + { + Item := ListBox^.List^.At(ListBox^.Focused); } + {#M-} + procedure Insert (Item : Pointer); virtual; + { Insert inserts Item into the collection, adjusts the listbox's range, + then redraws the listbox. } + {#X FreeItem } + procedure SetFocusedItem (Item : Pointer); virtual; + { SetFocusedItem changes the focused item to Item then redraws the + listbox. } + {# FocusItemNum } + END; + PListBox = ^TListBox; + +{---------------------------------------------------------------------------} +{ TStaticText OBJECT - STATIC TEXT OBJECT } +{---------------------------------------------------------------------------} +TYPE + TStaticText = OBJECT (TView) + Text: PString; { Text string ptr } + CONSTRUCTOR Init (Var Bounds: TRect; Const AText: String); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE GetText (Var S: String); Virtual; + END; + PStaticText = ^TStaticText; + +{---------------------------------------------------------------------------} +{ TParamText OBJECT - PARMETER STATIC TEXT OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Text } + +TYPE + TParamText = OBJECT (TStaticText) + ParamCount: Sw_Integer; { Parameter count } + ParamList : Pointer; { Parameter list } + CONSTRUCTOR Init (Var Bounds: TRect; Const AText: String; + AParamCount: Sw_Integer); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION DataSize: Sw_Word; Virtual; + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE GetText (Var S: String); Virtual; + END; + PParamText = ^TParamText; + +{---------------------------------------------------------------------------} +{ TLabel OBJECT - LABEL OBJECT } +{---------------------------------------------------------------------------} +TYPE + TLabel = OBJECT (TStaticText) + Light: Boolean; + Link: PView; { Linked view } + CONSTRUCTOR Init (Var Bounds: TRect; CONST AText: String; ALink: PView); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PLabel = ^TLabel; + +{---------------------------------------------------------------------------} +{ THistoryViewer OBJECT - HISTORY VIEWER OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Active } + { 2 = Inactive } + { 3 = Focused } + { 4 = Selected } + { 5 = Divider } + +TYPE + THistoryViewer = OBJECT (TListViewer) + HistoryId: Word; { History id } + CONSTRUCTOR Init(Var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar; + AHistoryId: Word); + FUNCTION HistoryWidth: Sw_Integer; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; Virtual; + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PHistoryViewer = ^THistoryViewer; + +{---------------------------------------------------------------------------} +{ THistoryWindow OBJECT - HISTORY WINDOW OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Frame passive } + { 2 = Frame active } + { 3 = Frame icon } + { 4 = ScrollBar page area } + { 5 = ScrollBar controls } + { 6 = HistoryViewer normal text } + { 7 = HistoryViewer selected text } + +TYPE + THistoryWindow = OBJECT (TWindow) + Viewer: PListViewer; { List viewer object } + CONSTRUCTOR Init (Var Bounds: TRect; HistoryId: Word); + FUNCTION GetSelection: String; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE InitViewer (HistoryId: Word); Virtual; + END; + PHistoryWindow = ^THistoryWindow; + +{---------------------------------------------------------------------------} +{ THistory OBJECT - HISTORY OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Arrow } + { 2 = Sides } + +TYPE + THistory = OBJECT (TView) + HistoryId: Word; + Link: PInputLine; + CONSTRUCTOR Init (Var Bounds: TRect; ALink: PInputLine; AHistoryId: Word); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION InitHistoryWindow (Var Bounds: TRect): PHistoryWindow; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE RecordHistory (CONST S: String); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PHistory = ^THistory; + + {#Z+} + PBrowseInputLine = ^TBrowseInputLine; + TBrowseInputLine = Object(TInputLine) + History: Sw_Word; + constructor Init(var Bounds: TRect; AMaxLen: Sw_Integer; AHistory: Sw_Word); + constructor Load(var S: TStream); + function DataSize: Sw_Word; virtual; + procedure GetData(var Rec); virtual; + procedure SetData(var Rec); virtual; + procedure Store(var S: TStream); + end; { of TBrowseInputLine } + + TBrowseInputLineRec = record + Text: string; + History: Sw_Word; + end; { of TBrowseInputLineRec } + {#Z+} + PBrowseButton = ^TBrowseButton; + {#Z-} + TBrowseButton = Object(TButton) + Link: PBrowseInputLine; + constructor Init(var Bounds: TRect; ATitle: TTitleStr; ACommand: Word; + AFlags: Byte; ALink: PBrowseInputLine); + constructor Load(var S: TStream); + procedure Press; virtual; + procedure Store(var S: TStream); + end; { of TBrowseButton } + + + {#Z+} + PCommandIcon = ^TCommandIcon; + {#Z-} + TCommandIcon = Object(TStaticText) + { A TCommandIcon sends an evCommand message to its owner with + Event.Command set to #Command# when it is clicked with a mouse. } + constructor Init (var Bounds : TRect; AText : String; ACommand : Word); + { Creates an instance of a TCommandIcon and sets #Command# to + ACommand. AText is the text which is displayed as the icon. If an + error occurs Init fails. } + procedure HandleEvent (var Event : TEvent); virtual; + { Captures mouse events within its borders and sends an evCommand to + its owner in response to the mouse event. } + {#X Command } + private + Command : Word; + { Command is the command sent to the command icon's owner when it is + clicked. } + end; { of TCommandIcon } + + + {#Z+} + PCommandSItem = ^TCommandSItem; + {#Z-} + TCommandSItem = record + { A TCommandSItem is the data structure used to initialize command + clusters with #NewCommandSItem# rather than the standarad #NewSItem#. + It is used to associate a command with an individual cluster item. } + {#X TCommandCheckBoxes TCommandRadioButtons } + Value : String; + { Value is the text displayed for the cluster item. } + {#X Command Next } + Command : Word; + { Command is the command broadcast when the cluster item is pressed. } + {#X Value Next } + Next : PCommandSItem; + { Next is a pointer to the next item in the cluster. } + {#X Value Command } + end; { of TCommandSItem } + + + TCommandArray = array[0..15] of Word; + { TCommandArray holds a list of commands which are associated with a + cluster. } + {#X TCommandCheckBoxes TCommandRadioButtons } + + + {#Z+} + PCommandCheckBoxes = ^TCommandCheckBoxes; + {#Z-} + TCommandCheckBoxes = Object(TCheckBoxes) + { TCommandCheckBoxes function as normal TCheckBoxes, except that when a + cluster item is pressed it broadcasts a command associated with the + cluster item to the cluster's owner. + + TCommandCheckBoxes are useful when other parts of a dialog should be + enabled or disabled in response to a check box's status. } + CommandList : TCommandArray; + { CommandList is the list of commands associated with each check box + item. } + {#X Init Load Store } + constructor Init (var Bounds : TRect; ACommandStrings : PCommandSItem); + { Init calls the inherited constructor, then sets up the #CommandList# + with the specified commands. If an error occurs Init fails. } + {#X NewCommandSItem } + constructor Load (var S : TStream); + { Load calls the inherited constructor, then loads the #CommandList# + from the stream S. If an error occurs Load fails. } + {#X Store Init } + procedure Press (Item : Sw_Integer); virtual; + { Press calls the inherited Press then broadcasts the command + associated with the cluster item that was pressed to the check boxes' + owner. } + {#X CommandList } + procedure Store (var S : TStream); { store should never be virtual;} + { Store calls the inherited Store method then writes the #CommandList# + to the stream. } + {#X Load } + end; { of TCommandCheckBoxes } + + + {#Z+} + PCommandRadioButtons = ^TCommandRadioButtons; + {#Z-} + TCommandRadioButtons = Object(TRadioButtons) + { TCommandRadioButtons function as normal TRadioButtons, except that when + a cluster item is pressed it broadcasts a command associated with the + cluster item to the cluster's owner. + + TCommandRadioButtons are useful when other parts of a dialog should be + enabled or disabled in response to a radiobutton's status. } + CommandList : TCommandArray; { commands for each possible value } + { The list of commands associated with each radio button item. } + {#X Init Load Store } + constructor Init (var Bounds : TRect; ACommandStrings : PCommandSItem); + { Init calls the inherited constructor and sets up the #CommandList# + with the specified commands. If an error occurs Init disposes of the + command strings then fails. } + {#X NewCommandSItem } + constructor Load (var S : TStream); + { Load calls the inherited constructor then loads the #CommandList# + from the stream S. If an error occurs Load fails. } + {#X Store } + procedure MovedTo (Item : Sw_Integer); virtual; + { MovedTo calls the inherited MoveTo, then broadcasts the command of + the newly selected cluster item to the cluster's owner. } + {#X Press CommandList } + procedure Press (Item : Sw_Integer); virtual; + { Press calls the inherited Press then broadcasts the command + associated with the cluster item that was pressed to the check boxes + owner. } + {#X CommandList MovedTo } + procedure Store (var S : TStream); { store should never be virtual;} + { Store calls the inherited Store method then writes the #CommandList# + to the stream. } + {#X Load } + end; { of TCommandRadioButtons } + + PEditListBox = ^TEditListBox; + TEditListBox = Object(TListBox) + CurrentField : Integer; + constructor Init (Bounds : TRect; ANumCols: Word; + AVScrollBar : PScrollBar); + constructor Load (var S : TStream); + function FieldValidator : PValidator; virtual; + function FieldWidth : Integer; virtual; + procedure GetField (InputLine : PInputLine); virtual; + function GetPalette : PPalette; virtual; + procedure HandleEvent (var Event : TEvent); virtual; + procedure SetField (InputLine : PInputLine); virtual; + function StartColumn : Integer; virtual; + PRIVATE + procedure EditField (var Event : TEvent); + end; { of TEditListBox } + + + PModalInputLine = ^TModalInputLine; + TModalInputLine = Object(TInputLine) + function Execute : Word; virtual; + procedure HandleEvent (var Event : TEvent); virtual; + procedure SetState (AState : Word; Enable : Boolean); virtual; + private + EndState : Word; + end; { of TModalInputLine } + +{---------------------------------------------------------------------------} +{ TDialog OBJECT - DIALOG OBJECT } +{---------------------------------------------------------------------------} + + { Palette layout } + { 1 = Frame passive } + { 2 = Frame active } + { 3 = Frame icon } + { 4 = ScrollBar page area } + { 5 = ScrollBar controls } + { 6 = StaticText } + { 7 = Label normal } + { 8 = Label selected } + { 9 = Label shortcut } + { 10 = Button normal } + { 11 = Button default } + { 12 = Button selected } + { 13 = Button disabled } + { 14 = Button shortcut } + { 15 = Button shadow } + { 16 = Cluster normal } + { 17 = Cluster selected } + { 18 = Cluster shortcut } + { 19 = InputLine normal text } + { 20 = InputLine selected text } + { 21 = InputLine arrows } + { 22 = History arrow } + { 23 = History sides } + { 24 = HistoryWindow scrollbar page area } + { 25 = HistoryWindow scrollbar controls } + { 26 = ListViewer normal } + { 27 = ListViewer focused } + { 28 = ListViewer selected } + { 29 = ListViewer divider } + { 30 = InfoPane } + { 31 = Cluster disabled } + { 32 = Reserved } + + PDialog = ^TDialog; + TDialog = object(TWindow) + constructor Init(var Bounds: TRect; ATitle: TTitleStr); + constructor Load(var S: TStream); + procedure Cancel (ACommand : Word); virtual; + { If the dialog is a modal dialog, Cancel calls EndModal(ACommand). If + the dialog is non-modal Cancel calls Close. + + Cancel may be overridden to provide special processing prior to + destructing the dialog. } + procedure ChangeTitle (ANewTitle : TTitleStr); virtual; + { ChangeTitle disposes of the current title, assigns ANewTitle to Title, + then redraws the dialog. } + procedure FreeSubView (ASubView : PView); virtual; + { FreeSubView deletes and disposes ASubView from the dialog. } + {#X FreeAllSubViews IsSubView } + procedure FreeAllSubViews; virtual; + { Deletes then disposes all subviews in the dialog. } + {#X FreeSubView IsSubView } + function GetPalette: PPalette; virtual; + procedure HandleEvent(var Event: TEvent); virtual; + function IsSubView (AView : PView) : Boolean; virtual; + { IsSubView returns True if AView is non-nil and is a subview of the + dialog. } + {#X FreeSubView FreeAllSubViews } + function NewButton (X, Y, W, H : Sw_Integer; ATitle : TTitleStr; + ACommand, AHelpCtx : Word; + AFlags : Byte) : PButton; + { Creates and inserts into the dialog a new TButton with the + help context AHelpCtx. + + A pointer to the new button is returned for checking validity of the + initialization. } + {#X NewInputLine NewLabel } + function NewLabel (X, Y : Sw_Integer; AText : String; + ALink : PView) : PLabel; + { NewLabel creates and inserts into the dialog a new TLabel and + associates it with ALink. } + {#X NewButton NewInputLine } + function NewInputLine (X, Y, W, AMaxLen : Sw_Integer; AHelpCtx : Word + ; AValidator : PValidator) : PInputLine; + { NewInputLine creates and inserts into the dialog a new TBSDInputLine + with the help context to AHelpCtx and the validator AValidator. + + A pointer to the inputline is returned for checking validity of the + initialization. } + {#X NewButton NewLabel } + function Valid(Command: Word): Boolean; virtual; + end; + + PListDlg = ^TListDlg; + TListDlg = object(TDialog) + { TListDlg displays a listbox of items, with optional New, Edit, and + Delete buttons displayed according to the options bit set in the + dialog. Use the ofXXXX flags declared in this unit OR'd with the + standard ofXXXX flags to set the appropriate bits in Options. + + If enabled, when the New or Edit buttons are pressed, an evCommand + message is sent to the application with a Command value of NewCommand + or EditCommand, respectively. Using this mechanism in combination with + the declared Init parameters, a standard TListDlg can be used with any + type of list displayable in a TListBox or its descendant. } + NewCommand: Word; + EditCommand: Word; + ListBox: PListBox; + ldOptions: Word; + constructor Init (ATitle: TTitleStr; Items: string; AButtons: Word; + AListBox: PListBox; AEditCommand, ANewCommand: Word); + constructor Load(var S: TStream); + procedure HandleEvent(var Event: TEvent); virtual; + procedure Store(var S: TStream); { store should never be virtual;} + end; { of TListDlg } + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ ITEM STRING ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-NewSItem----------------------------------------------------------- +Allocates memory for a new TSItem record and sets the text field +and chains to the next TSItem. This allows easy construction of +singly-linked lists of strings, to end a chain the next TSItem +should be nil. +28Apr98 LdB +---------------------------------------------------------------------} +FUNCTION NewSItem (Const Str: String; ANext: PSItem): PSItem; + +{ NewCommandSItem allocates and returns a pointer to a new #TCommandSItem# + record. The Value and Next fields of the record are set to NewStr(Str) + and ANext, respectively. The NewSItem function and the TSItem record type + allow easy construction of singly-linked lists of command strings. } +function NewCommandSItem (Str : String; ACommand : Word; + ANext : PCommandSItem) : PCommandSItem; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ DIALOG OBJECT REGISTRATION PROCEDURE } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-RegisterDialogs---------------------------------------------------- +This registers all the view type objects used in this unit. +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterDialogs; + +{***************************************************************************} +{ STREAM REGISTRATION RECORDS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TDialog STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RDialog: TStreamRec = ( + ObjType: idDialog; { Register id = 10 } + VmtLink: TypeOf(TDialog); + Load: @TDialog.Load; { Object load method } + Store: @TDialog.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TInputLine STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RInputLine: TStreamRec = ( + ObjType: idInputLine; { Register id = 11 } + VmtLink: TypeOf(TInputLine); + Load: @TInputLine.Load; { Object load method } + Store: @TInputLine.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TButton STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RButton: TStreamRec = ( + ObjType: idButton; { Register id = 12 } + VmtLink: TypeOf(TButton); + Load: @TButton.Load; { Object load method } + Store: @TButton.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TCluster STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RCluster: TStreamRec = ( + ObjType: idCluster; { Register id = 13 } + VmtLink: TypeOf(TCluster); + Load: @TCluster.Load; { Object load method } + Store: @TCluster.Store { Objects store method } + ); + +{---------------------------------------------------------------------------} +{ TRadioButtons STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RRadioButtons: TStreamRec = ( + ObjType: idRadioButtons; { Register id = 14 } + VmtLink: TypeOf(TRadioButtons); + Load: @TRadioButtons.Load; { Object load method } + Store: @TRadioButtons.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TCheckBoxes STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RCheckBoxes: TStreamRec = ( + ObjType: idCheckBoxes; { Register id = 15 } + VmtLink: TypeOf(TCheckBoxes); + Load: @TCheckBoxes.Load; { Object load method } + Store: @TCheckBoxes.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TMultiCheckBoxes STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RMultiCheckBoxes: TStreamRec = ( + ObjType: idMultiCheckBoxes; { Register id = 27 } + VmtLink: TypeOf(TMultiCheckBoxes); + Load: @TMultiCheckBoxes.Load; { Object load method } + Store: @TMultiCheckBoxes.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TListBox STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RListBox: TStreamRec = ( + ObjType: idListBox; { Register id = 16 } + VmtLink: TypeOf(TListBox); + Load: @TListBox.Load; { Object load method } + Store: @TListBox.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TStaticText STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RStaticText: TStreamRec = ( + ObjType: idStaticText; { Register id = 17 } + VmtLink: TypeOf(TStaticText); + Load: @TStaticText.Load; { Object load method } + Store: @TStaticText.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TLabel STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RLabel: TStreamRec = ( + ObjType: idLabel; { Register id = 18 } + VmtLink: TypeOf(TLabel); + Load: @TLabel.Load; { Object load method } + Store: @TLabel.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ THistory STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RHistory: TStreamRec = ( + ObjType: idHistory; { Register id = 19 } + VmtLink: TypeOf(THistory); + Load: @THistory.Load; { Object load method } + Store: @THistory.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TParamText STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RParamText: TStreamRec = ( + ObjType: idParamText; { Register id = 20 } + VmtLink: TypeOf(TParamText); + Load: @TParamText.Load; { Object load method } + Store: @TParamText.Store { Object store method } + ); + + RCommandCheckBoxes : TStreamRec = ( + ObjType : idCommandCheckBoxes; + VmtLink : Ofs(TypeOf(TCommandCheckBoxes)^); + Load : @TCommandCheckBoxes.Load; + Store : @TCommandCheckBoxes.Store); + + RCommandRadioButtons : TStreamRec = ( + ObjType : idCommandRadioButtons; + VmtLink : Ofs(TypeOf(TCommandRadioButtons)^); + Load : @TCommandRadioButtons.Load; + Store : @TCommandRadioButtons.Store); + + RCommandIcon : TStreamRec = ( + ObjType : idCommandIcon; + VmtLink : Ofs(Typeof(TCommandIcon)^); + Load : @TCommandIcon.Load; + Store : @TCommandIcon.Store); + + RBrowseButton: TStreamRec = ( + ObjType : idBrowseButton; + VmtLink : Ofs(TypeOf(TBrowseButton)^); + Load : @TBrowseButton.Load; + Store : @TBrowseButton.Store); + + REditListBox : TStreamRec = ( + ObjType : idEditListBox; + VmtLink : Ofs(TypeOf(TEditListBox)^); + Load : @TEditListBox.Load; + Store : @TEditListBox.Store); + + RListDlg : TStreamRec = ( + ObjType : idListDlg; + VmtLink : Ofs(TypeOf(TListDlg)^); + Load : @TListDlg.Load; + Store : @TListDlg.Store); + + RModalInputLine : TStreamRec = ( + ObjType : idModalInputLine; + VmtLink : Ofs(TypeOf(TModalInputLine)^); + Load : @TModalInputLine.Load; + Store : @TModalInputLine.Store); + +resourcestring slCancel='Cancel'; + slOk='O~k~'; + slYes='~Y~es'; + slNo='~N~o'; + + slHelp='~H~elp'; + slName='~N~ame'; + + slOpen='~O~pen'; + slClose='~C~lose'; + slCloseAll='Cl~o~se all'; + + slSave='~S~ave'; + slSaveAll='Save a~l~l'; + slSaveAs='S~a~ve as...'; + slSaveFileAs='~S~ave file as'; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +USES App,HistList; { Standard GFV unit } + +{***************************************************************************} +{ PRIVATE DEFINED CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ LEFT AND RIGHT ARROW CHARACTER CONSTANTS } +{---------------------------------------------------------------------------} +CONST LeftArr = '<'; RightArr = '>'; + +{---------------------------------------------------------------------------} +{ TButton MESSAGES } +{---------------------------------------------------------------------------} +CONST + cmGrabDefault = 61; { Grab default } + cmReleaseDefault = 62; { Release default } + +{---------------------------------------------------------------------------} +{ IsBlank -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION IsBlank (Ch: Char): Boolean; +BEGIN + IsBlank := (Ch = ' ') OR (Ch = #13) OR (Ch = #10); { Check for characters } +END; + +{---------------------------------------------------------------------------} +{ HotKey -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION HotKey (Const S: String): Char; +VAR I: Sw_Word; +BEGIN + HotKey := #0; { Preset fail } + If (S <> '') Then Begin { Valid string } + I := Pos('~', S); { Search for tilde } + If (I <> 0) Then HotKey := UpCase(S[I+1]); { Return hotkey } + End; +END; + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TDialog OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TDialog------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TDialog.Init (Var Bounds: TRect; ATitle: TTitleStr); +BEGIN + Inherited Init(Bounds, ATitle, wnNoNumber); { Call ancestor } + Options := Options OR ofVersion20; { Version two dialog } + GrowMode := 0; { Clear grow mode } + Flags := wfMove + wfClose; { Close/moveable flags } + Palette := dpGrayDialog; { Default gray colours } +END; + +{--TDialog------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TDialog.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + If (Options AND ofVersion = ofVersion10) Then Begin + Palette := dpGrayDialog; { Set gray palette } + Options := Options OR ofVersion20; { Update version flag } + End; +END; + +{--TDialog------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TDialog.GetPalette: PPalette; +CONST P: Array[dpBlueDialog..dpGrayDialog] Of String[Length(CBlueDialog)] = + (CBlueDialog, CCyanDialog, CGrayDialog); { Always normal string } +BEGIN + GetPalette := PPalette(@P[Palette]); { Return palette } +END; + +{--TDialog------------------------------------------------------------------} +{ Valid -> Platforms DOS/DPMI/WIN/NT/Os2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TDialog.Valid (Command: Word): Boolean; +BEGIN + If (Command = cmCancel) Then Valid := True { Cancel returns true } + Else Valid := TGroup.Valid(Command); { Call group ancestor } +END; + +{--TDialog------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TDialog.HandleEvent (Var Event: TEvent); +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evKeyDown: { Key down event } + Case Event.KeyCode Of + kbEsc, kbCtrlF4: Begin { Escape key press } + Event.What := evCommand; { Command event } + Event.Command := cmCancel; { cancel command } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + ClearEvent(Event); { Clear the event } + End; + kbCtrlF5: Begin { movement of modal dialogs } + If (State AND sfModal <> 0) Then + begin + Event.What := evCommand; + Event.Command := cmResize; + Event.InfoPtr := Nil; + PutEvent(Event); + ClearEvent(Event); + end; + End; + kbEnter: Begin { Enter key press } + Event.What := evBroadcast; { Broadcast event } + Event.Command := cmDefault; { Default command } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + ClearEvent(Event); { Clear the event } + End; + End; + evCommand: { Command event } + Case Event.Command Of + cmOk, cmCancel, cmYes, cmNo: { End dialog cmds } + If (State AND sfModal <> 0) Then Begin { View is modal } + EndModal(Event.Command); { End modal state } + ClearEvent(Event); { Clear the event } + End; + End; + End; +END; + +{****************************************************************************} +{ TDialog.Cancel } +{****************************************************************************} +procedure TDialog.Cancel (ACommand : Word); +begin + if State and sfModal = sfModal then + EndModal(ACommand) + else Close; +end; + +{****************************************************************************} +{ TDialog.ChangeTitle } +{****************************************************************************} +procedure TDialog.ChangeTitle (ANewTitle : TTitleStr); +begin + if (Title <> nil) then + DisposeStr(Title); + Title := NewStr(ANewTitle); + Frame^.DrawView; +end; + +{****************************************************************************} +{ TDialog.FreeSubView } +{****************************************************************************} +procedure TDialog.FreeSubView (ASubView : PView); +begin + if IsSubView(ASubView) then begin + Delete(ASubView); + Dispose(ASubView,Done); + DrawView; + end; +end; + +{****************************************************************************} +{ TDialog.FreeAllSubViews } +{****************************************************************************} +procedure TDialog.FreeAllSubViews; +var + P : PView; +begin + P := First; + repeat + P := First; + if (P <> nil) then begin + Delete(P); + Dispose(P,Done); + end; + until (P = nil); + DrawView; +end; + +{****************************************************************************} +{ TDialog.IsSubView } +{****************************************************************************} +function TDialog.IsSubView (AView : PView) : Boolean; +var P : PView; +begin + P := First; + while (P <> nil) and (P <> AView) do + P := P^.NextView; + IsSubView := ((P <> nil) and (P = AView)); +end; + +{****************************************************************************} +{ TDialog.NewButton } +{****************************************************************************} +function TDialog.NewButton (X, Y, W, H : Sw_Integer; ATitle : TTitleStr; + ACommand, AHelpCtx : Word; + AFlags : Byte) : PButton; +var + B : PButton; + R : TRect; +begin + R.Assign(X,Y,X+W,Y+H); + B := New(PButton,Init(R,ATitle,ACommand,AFlags)); + if (B <> nil) then begin + B^.HelpCtx := AHelpCtx; + Insert(B); + end; + NewButton := B; +end; + +{****************************************************************************} +{ TDialog.NewInputLine } +{****************************************************************************} +function TDialog.NewInputLine (X, Y, W, AMaxLen : Sw_Integer; AHelpCtx : Word + ; AValidator : PValidator) : PInputLine; +var + P : PInputLine; + R : TRect; +begin + R.Assign(X,Y,X+W,Y+1); + P := New(PInputLine,Init(R,AMaxLen)); + if (P <> nil) then begin + P^.SetValidator(AValidator); + P^.HelpCtx := AHelpCtx; + Insert(P); + end; + NewInputLine := P; +end; + +{****************************************************************************} +{ TDialog.NewLabel } +{****************************************************************************} +function TDialog.NewLabel (X, Y : Sw_Integer; AText : String; + ALink : PView) : PLabel; +var + P : PLabel; + R : TRect; +begin + R.Assign(X,Y,X+CStrLen(AText)+1,Y+1); + P := New(PLabel,Init(R,AText,ALink)); + if (P <> nil) then + Insert(P); + NewLabel := P; +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TInputLine OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TInputLine---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TInputLine.Init (Var Bounds: TRect; AMaxLen: Sw_Integer); +BEGIN + Inherited Init(Bounds); { Call ancestor } + State := State OR sfCursorVis; { Cursor visible } + Options := Options OR (ofSelectable + ofFirstClick + + ofVersion20); { Set options } + If (MaxAvail > AMaxLen + 1) Then Begin { Check enough memory } + GetMem(Data, AMaxLen + 1); { Allocate memory } + Data^ := ''; { Data = empty string } + End; + MaxLen := AMaxLen; { Hold maximum length } +END; + +{--TInputLine---------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TInputLine.Load (Var S: TStream); +VAR B: Byte; + W: Word; +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(W, sizeof(w)); MaxLen:=W; { Read max length } + S.Read(W, sizeof(w)); CurPos:=w; { Read cursor position } + S.Read(W, sizeof(w)); FirstPos:=w; { Read first position } + S.Read(W, sizeof(w)); SelStart:=w; { Read selected start } + S.Read(W, sizeof(w)); SelEnd:=w; { Read selected end } + S.Read(B, SizeOf(B)); { Read string length } + GetMem(Data, B + 1); { Allocate memory } + S.Read(Data^[1], B); { Read string data } + SetLength(Data^, B); { Xfer string length } + If (Options AND ofVersion >= ofVersion20) Then { Version 2 or above } + Validator := PValidator(S.Get); { Get any validator } + Options := Options OR ofVersion20; { Set version 2 flag } +END; + +{--TInputLine---------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TInputLine.Done; +BEGIN + If (Data <> Nil) Then FreeMem(Data, MaxLen + 1); { Release any memory } + SetValidator(Nil); { Clear any validator } + Inherited Done; { Call ancestor } +END; + +{--TInputLine---------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TInputLine.DataSize: Sw_Word; +VAR DSize: Sw_Word; +BEGIN + DSize := 0; { Preset zero datasize } + If (Validator <> Nil) AND (Data <> Nil) Then + DSize := Validator^.Transfer(Data^, Nil, + vtDataSize); { Add validator size } + If (DSize <> 0) Then DataSize := DSize { Use validtor size } + Else DataSize := MaxLen + 1; { No validator use size } +END; + +{--TInputLine---------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TInputLine.GetPalette: PPalette; +CONST P: String[Length(CInputLine)] = CInputLine; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TInputLine---------------------------------------------------------------} +{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TInputLine.Valid (Command: Word): Boolean; + + FUNCTION AppendError (AValidator: PValidator): Boolean; + BEGIN + AppendError := False; { Preset false } + If (Data <> Nil) Then + With AValidator^ Do + If (Options AND voOnAppend <> 0) AND { Check options } + (CurPos <> Length(Data^)) AND { Exceeds max length } + NOT IsValidInput(Data^, True) Then Begin { Check data valid } + Error; { Call error } + AppendError := True; { Return true } + End; + END; + +BEGIN + Valid := Inherited Valid(Command); { Call ancestor } + If (Validator <> Nil) AND (Data <> Nil) AND { Validator present } + (State AND sfDisabled = 0) Then { Not disabled } + If (Command = cmValid) Then { Valid command } + Valid := Validator^.Status = vsOk { Validator result } + Else If (Command <> cmCancel) Then { Not cancel command } + If AppendError(Validator) OR { Append any error } + NOT Validator^.Valid(Data^) Then Begin { Check validator } + Select; { Reselect view } + Valid := False; { Return false } + End; +END; + +{--TInputLine---------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.Draw; +VAR Color: Byte; L, R: Sw_Integer; + B : TDrawBuffer; +BEGIN + if Options and ofSelectable = 0 then + Color := GetColor(5) + else + If (State AND sfFocused = 0) Then + Color := GetColor(1) { Not focused colour } + Else + Color := GetColor(2); { Focused colour } + MoveChar(B, ' ', Color, Size.X); + MoveStr(B[1], Copy(Data^, FirstPos + 1, Size.X - 2), Color); + if CanScroll(1) then + MoveChar(B[Size.X - 1], RightArr, GetColor(4), 1); + if (State and sfFocused <> 0) and + (Options and ofSelectable <> 0) then + begin + if CanScroll(-1) then + MoveChar(B[0], LeftArr, GetColor(4), 1); + { Highlighted part } + L := SelStart - FirstPos; + R := SelEnd - FirstPos; + if L < 0 then + L := 0; + if R > Size.X - 2 then + R := Size.X - 2; + if L < R then + MoveChar(B[L + 1], #0, GetColor(3), R - L); + SetCursor(CurPos - FirstPos + 1, 0); + end; + WriteLine(0, 0, Size.X, Size.Y, B); +end; + + +{--TInputLine---------------------------------------------------------------} +{ DrawCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.DrawCursor; +BEGIN + If (State AND sfFocused <> 0) Then + Begin { Focused window } + Cursor.Y:=0; + Cursor.X:=CurPos-FirstPos+1; + ResetCursor; + end; +END; + +{--TInputLine---------------------------------------------------------------} +{ SelectAll -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.SelectAll (Enable: Boolean); +BEGIN + CurPos := 0; { Cursor to start } + FirstPos := 0; { First pos to start } + SelStart := 0; { Selected at start } + If Enable AND (Data <> Nil) Then + SelEnd := Length(Data^) Else SelEnd := 0; { Selected which end } + DrawView; { Now redraw the view } +END; + +{--TInputLine---------------------------------------------------------------} +{ SetValidator -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.SetValidator (AValid: PValidator); +BEGIN + If (Validator <> Nil) Then Validator^.Free; { Release validator } + Validator := AValid; { Set new validator } +END; + +{--TInputLine---------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.SetState (AState: Word; Enable: Boolean); +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState = sfSelected) OR ((AState = sfActive) + AND (State and sfSelected <> 0)) Then + SelectAll(Enable) Else { Call select all } + If (AState = sfFocused) Then DrawView; { Redraw for focus } +END; + +{--TInputLine---------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.GetData (Var Rec); +BEGIN + If (Data <> Nil) Then Begin { Data ptr valid } + If (Validator = Nil) OR (Validator^.Transfer(Data^, + @Rec, vtGetData) = 0) Then Begin { No validator/data } + FillChar(Rec, DataSize, #0); { Clear the data area } + Move(Data^, Rec, Length(Data^) + 1); { Transfer our data } + End; + End Else FillChar(Rec, DataSize, #0); { Clear the data area } +END; + +{--TInputLine---------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.SetData (Var Rec); +BEGIN + If (Data <> Nil) Then Begin { Data ptr valid } + If (Validator = Nil) OR (Validator^.Transfer( + Data^, @Rec, vtSetData) = 0) Then { No validator/data } + Move(Rec, Data^[0], DataSize); { Set our data } + End; + SelectAll(True); { Now select all } +END; + +{--TInputLine---------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.Store (Var S: TStream); +VAR w: Word; +BEGIN + TView.Store(S); { Implict TView.Store } + w:=MaxLen;S.Write(w, SizeOf(w)); { Read max length } + w:=CurPos;S.Write(w, SizeOf(w)); { Read cursor position } + w:=FirstPos;S.Write(w, SizeOf(w)); { Read first position } + w:=SelStart;S.Write(w, SizeOf(w)); { Read selected start } + w:=SelEnd;S.Write(w, SizeOf(w)); { Read selected end } + S.WriteStr(Data); { Write the data } + S.Put(Validator); { Write any validator } +END; + +{--TInputLine---------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TInputLine.HandleEvent (Var Event: TEvent); +CONST PadKeys = [$47, $4B, $4D, $4F, $73, $74]; +VAR WasAppending: Boolean; ExtendBlock: Boolean; OldData: String; +Delta, Anchor, OldCurPos, OldFirstPos, OldSelStart, OldSelEnd: Sw_Integer; + + FUNCTION MouseDelta: Sw_Integer; + VAR Mouse : TPOint; + BEGIN + MakeLocal(Event.Where, Mouse); + if Mouse.X <= 0 then + MouseDelta := -1 + else if Mouse.X >= Size.X - 1 then + MouseDelta := 1 + else + MouseDelta := 0; + END; + + FUNCTION MousePos: Sw_Integer; + VAR Pos: Sw_Integer; + Mouse : TPoint; + BEGIN + MakeLocal(Event.Where, Mouse); + if Mouse.X < 1 then Mouse.X := 1; + Pos := Mouse.X + FirstPos - 1; + if Pos < 0 then Pos := 0; + if Pos > Length(Data^) then Pos := Length(Data^); + MousePos := Pos; + END; + + PROCEDURE DeleteSelect; + BEGIN + If (SelStart <> SelEnd) Then Begin { An area selected } + If (Data <> Nil) Then + Delete(Data^, SelStart+1, SelEnd-SelStart); { Delete the text } + CurPos := SelStart; { Set cursor position } + End; + END; + + PROCEDURE AdjustSelectBlock; + BEGIN + If (CurPos < Anchor) Then Begin { Selection backwards } + SelStart := CurPos; { Start of select } + SelEnd := Anchor; { End of select } + End Else Begin + SelStart := Anchor; { Start of select } + SelEnd := CurPos; { End of select } + End; + END; + + PROCEDURE SaveState; + BEGIN + If (Validator <> Nil) Then Begin { Check for validator } + If (Data <> Nil) Then OldData := Data^; { Hold data } + OldCurPos := CurPos; { Hold cursor position } + OldFirstPos := FirstPos; { Hold first position } + OldSelStart := SelStart; { Hold select start } + OldSelEnd := SelEnd; { Hold select end } + If (Data = Nil) Then WasAppending := True { Invalid data ptr } + Else WasAppending := Length(Data^) = CurPos; { Hold appending state } + End; + END; + + PROCEDURE RestoreState; + BEGIN + If (Validator <> Nil) Then Begin { Validator valid } + If (Data <> Nil) Then Data^ := OldData; { Restore data } + CurPos := OldCurPos; { Restore cursor pos } + FirstPos := OldFirstPos; { Restore first pos } + SelStart := OldSelStart; { Restore select start } + SelEnd := OldSelEnd; { Restore select end } + End; + END; + + FUNCTION CheckValid (NoAutoFill: Boolean): Boolean; + VAR OldLen: Sw_Integer; NewData: String; + BEGIN + If (Validator <> Nil) Then Begin { Validator valid } + CheckValid := False; { Preset false return } + If (Data <> Nil) Then OldLen := Length(Data^); { Hold old length } + If (Validator^.Options AND voOnAppend = 0) OR + (WasAppending AND (CurPos = OldLen)) Then Begin + If (Data <> Nil) Then NewData := Data^ { Hold current data } + Else NewData := ''; { Set empty string } + If NOT Validator^.IsValidInput(NewData, + NoAutoFill) Then RestoreState Else Begin + If (Length(NewData) > MaxLen) Then { Exceeds maximum } + SetLength(NewData, MaxLen); { Set string length } + If (Data <> Nil) Then Data^ := NewData; { Set data value } + If (Data <> Nil) AND (CurPos >= OldLen) { Cursor beyond end } + AND (Length(Data^) > OldLen) Then { Cursor beyond string } + CurPos := Length(Data^); { Set cursor position } + CheckValid := True; { Return true result } + End; + End Else Begin + CheckValid := True; { Preset true return } + If (CurPos = OldLen) AND (Data <> Nil) Then { Lengths match } + If NOT Validator^.IsValidInput(Data^, + False) Then Begin { Check validator } + Validator^.Error; { Call error } + CheckValid := False; { Return false result } + End; + End; + End Else CheckValid := True; { No validator } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (State AND sfSelected <> 0) Then Begin { View is selected } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evMouseDown: Begin { Mouse down event } + Delta := MouseDelta; { Calc scroll value } + If CanScroll(Delta) Then Begin { Can scroll } + Repeat + If CanScroll(Delta) Then Begin { Still can scroll } + Inc(FirstPos, Delta); { Move start position } + DrawView; { Redraw the view } + End; + Until NOT MouseEvent(Event, evMouseAuto); { Until no mouse auto } + End Else If Event.Double Then { Double click } + SelectAll(True) Else Begin { Select whole text } + Anchor := MousePos; { Start of selection } + Repeat + If (Event.What = evMouseAuto) { Mouse auto event } + Then Begin + Delta := MouseDelta; { New position } + If CanScroll(Delta) Then { If can scroll } + Inc(FirstPos, Delta); + End; + CurPos := MousePos; { Set cursor position } + AdjustSelectBlock; { Adjust selected } + DrawView; { Redraw the view } + Until NOT MouseEvent(Event, evMouseMove + + evMouseAuto); { Until mouse released } + End; + ClearEvent(Event); { Clear the event } + End; + evKeyDown: Begin + SaveState; { Save state of view } + Event.KeyCode := CtrlToArrow(Event.KeyCode); { Convert keycode } + If (Event.ScanCode IN PadKeys) AND + (GetShiftState AND $03 <> 0) Then Begin { Mark selection active } + Event.CharCode := #0; { Clear char code } + If (CurPos = SelEnd) Then { Find if at end } + Anchor := SelStart Else { Anchor from start } + Anchor := SelEnd; { Anchor from end } + ExtendBlock := True; { Extended block true } + End Else ExtendBlock := False; { No extended block } + Case Event.KeyCode Of + kbLeft: If (CurPos > 0) Then Dec(CurPos); { Move cursor left } + kbRight: If (Data <> Nil) AND { Move right cursor } + (CurPos < Length(Data^)) Then Begin { Check not at end } + Inc(CurPos); { Move cursor } + CheckValid(True); { Check if valid } + End; + kbHome: CurPos := 0; { Move to line start } + kbEnd: Begin { Move to line end } + If (Data = Nil) Then CurPos := 0 { Invalid data ptr } + Else CurPos := Length(Data^); { Set cursor position } + CheckValid(True); { Check if valid } + End; + kbBack: If (Data <> Nil) AND (CurPos > 0) { Not at line start } + Then Begin + Delete(Data^, CurPos, 1); { Backspace over char } + Dec(CurPos); { Move cursor back one } + If (FirstPos > 0) Then Dec(FirstPos); { Move first position } + CheckValid(True); { Check if valid } + End; + kbDel: If (Data <> Nil) Then Begin { Delete character } + If (SelStart = SelEnd) Then { Select all on } + If (CurPos < Length(Data^)) Then Begin { Cursor not at end } + SelStart := CurPos; { Set select start } + SelEnd := CurPos + 1; { Set select end } + End; + DeleteSelect; { Deselect selection } + CheckValid(True); { Check if valid } + End; + kbIns: SetState(sfCursorIns, State AND + sfCursorIns = 0); { Flip insert state } + Else Case Event.CharCode Of + ' '..#255: If (Data <> Nil) Then Begin { Character key } + If (State AND sfCursorIns <> 0) Then + Delete(Data^, CurPos + 1, 1) Else { Overwrite character } + DeleteSelect; { Deselect selected } + If CheckValid(True) Then Begin { Check data valid } + If (Length(Data^) < MaxLen) Then { Must not exceed maxlen } + Begin + If (FirstPos > CurPos) Then + FirstPos := CurPos; { Advance first position } + Inc(CurPos); { Increment cursor } + Insert(Event.CharCode, Data^, + CurPos); { Insert the character } + End; + CheckValid(False); { Check data valid } + End; + End; + ^Y: If (Data <> Nil) Then Begin { Clear all data } + Data^ := ''; { Set empty string } + CurPos := 0; { Cursor to start } + End; + Else Exit; { Unused key } + End + End; + If ExtendBlock Then AdjustSelectBlock { Extended block } + Else Begin + SelStart := CurPos; { Set select start } + SelEnd := CurPos; { Set select end } + End; + If (FirstPos > CurPos) Then + FirstPos := CurPos; { Advance first pos } + If (Data <> Nil) Then OldData := Copy(Data^, + FirstPos+1, CurPos-FirstPos) { Text area string } + Else OldData := ''; { Empty string } + Delta := 1; { Safety = 1 char } + While (TextWidth(OldData) > (Size.X-Delta) + - TextWidth(LeftArr) - TextWidth(RightArr)) { Check text fits } + Do Begin + Inc(FirstPos); { Advance first pos } + OldData := Copy(Data^, FirstPos+1, + CurPos-FirstPos) { Text area string } + End; + DrawView; { Redraw the view } + ClearEvent(Event); { Clear the event } + End; + End; + End; +END; + +{***************************************************************************} +{ TInputLine OBJECT PRIVATE METHODS } +{***************************************************************************} +{--TInputLine---------------------------------------------------------------} +{ CanScroll -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TInputLine.CanScroll (Delta: Sw_Integer): Boolean; +VAR S: String; +BEGIN + If (Delta < 0) Then CanScroll := FirstPos > 0 { Check scroll left } + Else If (Delta > 0) Then Begin + If (Data = Nil) Then S := '' Else { Data ptr invalid } + S := Copy(Data^, FirstPos+1, Length(Data^) + - FirstPos); { Fetch max string } + CanScroll := (TextWidth(S)) > (Size.X - + TextWidth(LeftArr) - TextWidth(RightArr)); { Check scroll right } + End Else CanScroll := False; { Zero so no scroll } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TButton OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TButton------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TButton.Init (Var Bounds: TRect; ATitle: TTitleStr; + ACommand: Word; AFlags: Word); +BEGIN + Inherited Init(Bounds); { Call ancestor } + EventMask := EventMask OR evBroadcast; { Handle broadcasts } + Options := Options OR (ofSelectable + ofFirstClick + + ofPreProcess + ofPostProcess); { Set option flags } + If NOT CommandEnabled(ACommand) Then + State := State OR sfDisabled; { Check command state } + Flags := AFlags; { Hold flags } + If (AFlags AND bfDefault <> 0) Then AmDefault := True + Else AmDefault := False; { Check if default } + Title := NewStr(ATitle); { Hold title string } + Command := ACommand; { Hold button command } + TabMask := TabMask OR (tmLeft + tmRight + + tmTab + tmShiftTab + tmUp + tmDown); { Set tab masks } +END; + +{--TButton------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TButton.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + Title := S.ReadStr; { Read title } + S.Read(Command, SizeOf(Command)); { Read command } + S.Read(Flags, SizeOf(Flags)); { Read flags } + S.Read(AmDefault, SizeOf(AmDefault)); { Read if default } + If NOT CommandEnabled(Command) Then { Check command state } + State := State OR sfDisabled Else { Command disabled } + State := State AND NOT sfDisabled; { Command enabled } +END; + +{--TButton------------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TButton.Done; +BEGIN + If (Title <> Nil) Then DisposeStr(Title); { Dispose title } + Inherited Done; { Call ancestor } +END; + +{--TButton------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TButton.GetPalette: PPalette; +CONST P: String[Length(CButton)] = CButton; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Get button palette } +END; + +{--TButton------------------------------------------------------------------} +{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.Press; +VAR E: TEvent; +BEGIN + Message(Owner, evBroadcast, cmRecordHistory, Nil); { Message for history } + If (Flags AND bfBroadcast <> 0) Then { Broadcasting button } + Message(Owner, evBroadcast, Command, @Self) { Send message } + Else Begin + E.What := evCommand; { Command event } + E.Command := Command; { Set command value } + E.InfoPtr := @Self; { Pointer to self } + PutEvent(E); { Put event on queue } + End; +END; + +{--TButton------------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.Draw; +VAR I, J, Pos: Sw_Integer; + Bc: Word; Db: TDrawBuffer; + C : char; +BEGIN + If (State AND sfDisabled <> 0) Then { Button disabled } + Bc := GetColor($0404) Else Begin { Disabled colour } + Bc := GetColor($0501); { Set normal colour } + If (State AND sfActive <> 0) Then { Button is active } + If (State AND sfSelected <> 0) Then + Bc := GetColor($0703) Else { Set selected colour } + If AmDefault Then Bc := GetColor($0602); { Set is default colour } + End; + if title=nil then + begin + MoveChar(Db[0],' ',GetColor(8),1); + {No title, draw an empty button.} + for j:=sw_integer(downflag) to size.x-2 do + MoveChar(Db[j],' ',Bc,1); + end + else + {We have a title.} + begin + If (Flags AND bfLeftJust = 0) Then Begin { Not left set title } + I := CTextWidth(Title^); { Fetch title width } + I := (Size.X - I) DIV 2; { Centre in button } + End + Else + I := 1; { Left edge of button } + If DownFlag then + begin + MoveChar(Db[0],' ',GetColor(8),1); + Pos:=1; + end + else + pos:=0; + For j:=0 to I-1 do + MoveChar(Db[pos+j],' ',Bc,1); + MoveCStr(Db[I+pos], Title^, Bc); { Move title to buffer } + For j:=pos+CStrLen(Title^)+I to size.X-2 do + MoveChar(Db[j],' ',Bc,1); + end; + If not DownFlag then + Bc:=GetColor(8); + MoveChar(Db[Size.X-1],' ',Bc,1); + WriteLine(0, 0, Size.X,1, Db); { Write the title } + If Size.Y>1 then Begin + Bc:=GetColor(8); + if not DownFlag then + begin + c:='Ü'; + MoveChar(Db,c,Bc,1); + WriteLine(Size.X-1, 0, 1, 1, Db); + end; + MoveChar(Db,' ',Bc,1); + if DownFlag then c:=' ' + else c:='ß'; + MoveChar(Db[1],c,Bc,Size.X-1); + WriteLine(0, 1, Size.X, 1, Db); + End; +END; + +{--TButton------------------------------------------------------------------} +{ DrawState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.DrawState (Down: Boolean); +BEGIN + DownFlag := Down; { Set down flag } + DrawView; { Redraw the view } +END; + +{--TButton------------------------------------------------------------------} +{ MakeDefault -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.MakeDefault (Enable: Boolean); +VAR C: Word; +BEGIN + If (Flags AND bfDefault=0) Then Begin { Not default } + If Enable Then C := cmGrabDefault + Else C := cmReleaseDefault; { Change default } + Message(Owner, evBroadcast, C, @Self); { Message to owner } + AmDefault := Enable; { Set default flag } + DrawView; { Now redraw button } + End; +END; + +{--TButton------------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.SetState (AState: Word; Enable: Boolean); +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState AND (sfSelected + sfActive) <> 0) { Changing select } + Then DrawView; { Redraw required } + If (AState AND sfFocused <> 0) Then + MakeDefault(Enable); { Check for default } +END; + +{--TButton------------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.Store (Var S: TStream); +BEGIN + TView.Store(S); { Implict TView.Store } + S.WriteStr(Title); { Store title string } + S.Write(Command, SizeOf(Command)); { Store command } + S.Write(Flags, SizeOf(Flags)); { Store flags } + S.Write(AmDefault, SizeOf(AmDefault)); { Store default flag } +END; + +{--TButton------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TButton.HandleEvent (Var Event: TEvent); +VAR Down: Boolean; C: Char; ButRect: TRect; + Mouse : TPoint; +BEGIN + ButRect.A.X := 0; { Get origin point } + ButRect.A.Y := 0; { Get origin point } + ButRect.B.X := Size.X + 2; { Calc right side } + ButRect.B.Y := Size.Y + 1; { Calc bottom } + If (Event.What = evMouseDown) Then Begin { Mouse down event } + MakeLocal(Event.Where, Mouse); + If NOT ButRect.Contains(Mouse) Then Begin { If point not in view } + ClearEvent(Event); { Clear the event } + Exit; { Speed up exit } + End; + End; + If (Flags AND bfGrabFocus <> 0) Then { Check focus grab } + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evMouseDown: Begin + If (State AND sfDisabled = 0) Then Begin { Button not disabled } + Down := False; { Clear down flag } + Repeat + MakeLocal(Event.Where, Mouse); + If (Down <> ButRect.Contains(Mouse)) { State has changed } + Then Begin + Down := NOT Down; { Invert down flag } + DrawState(Down); { Redraw button } + End; + Until NOT MouseEvent(Event, evMouseMove); { Wait for mouse move } + If Down Then Begin { Button is down } + Press; { Send out command } + DrawState(False); { Draw button up } + End; + End; + ClearEvent(Event); { Event was handled } + End; + evKeyDown: Begin + If (Title <> Nil) Then C := HotKey(Title^) { Key title hotkey } + Else C := #0; { Invalid title } + If (Event.KeyCode = GetAltCode(C)) OR { Alt char } + (Owner^.Phase = phPostProcess) AND (C <> #0) + AND (Upcase(Event.CharCode) = C) OR { Matches hotkey } + (State AND sfFocused <> 0) AND { View focused } + ((Event.CharCode = ' ') OR { Space bar } + (Event.KeyCode=kbEnter)) Then Begin { Enter key } + DrawState(True); { Draw button down } + Press; { Send out command } + ClearEvent(Event); { Clear the event } + DrawState(False); { Draw button up } + End; + End; + evBroadcast: + Case Event.Command of + cmDefault: If AmDefault AND { Default command } + (State AND sfDisabled = 0) Then Begin { Button enabled } + Press; { Send out command } + ClearEvent(Event); { Clear the event } + End; + cmGrabDefault, cmReleaseDefault: { Grab and release cmd } + If (Flags AND bfDefault <> 0) Then Begin { Change button state } + AmDefault := Event.Command = cmReleaseDefault; + DrawView; { Redraw the view } + End; + cmCommandSetChanged: Begin { Command set changed } + SetState(sfDisabled, NOT + CommandEnabled(Command)); { Set button state } + DrawView; { Redraw the view } + End; + End; + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TCluster OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +CONST TvClusterClassName = 'TVCLUSTER'; + +{--TCluster-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TCluster.Init (Var Bounds: TRect; AStrings: PSItem); +VAR I: Sw_Integer; P: PSItem; +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR (ofSelectable + ofFirstClick + + ofPreProcess + ofPostProcess + ofVersion20); { Set option masks } + I := 0; { Zero string count } + P := AStrings; { First item } + While (P <> Nil) Do Begin + Inc(I); { Count 1 item } + P := P^.Next; { Move to next item } + End; + Strings.Init(I, 0); { Create collection } + While (AStrings <> Nil) Do Begin + P := AStrings; { Transfer item ptr } + Strings.AtInsert(Strings.Count, AStrings^.Value);{ Insert string } + AStrings := AStrings^.Next; { Move to next item } + Dispose(P); { Dispose prior item } + End; + Sel := 0; + SetCursor(2,0); + ShowCursor; + EnableMask := Sw_Integer($FFFFFFFF); { Enable bit masks } +END; + +{--TCluster-----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TCluster.Load (Var S: TStream); +VAR w: word; +BEGIN + Inherited Load(S); { Call ancestor } + If ((Options AND ofVersion) >= ofVersion20) Then { Version 2 TV view } + Begin + S.Read(Value, SizeOf(Value)); { Read value } + S.Read(Sel, Sizeof(Sel)); { Read select item } + S.Read(EnableMask, SizeOf(EnableMask)) { Read enable masks } + End + Else + Begin + w:=Value; + S.Read(w, SizeOf(w)); Value:=w; { Read value } + S.Read(Sel, SizeOf(Sel)); { Read select item } + EnableMask := Sw_integer($FFFFFFFF); { Enable all masks } + Options := Options OR ofVersion20; { Set version 2 mask } + End; + Strings.Load(S); { Load string data } + SetButtonState(0, True); { Set button state } +END; + +{--TCluster-----------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TCluster.Done; +BEGIN + Strings.Done; { Dispose of strings } + Inherited Done; { Call ancestor } +END; + +{--TCluster-----------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.DataSize: Sw_Word; +BEGIN + DataSize := SizeOf(Sw_Word); { Exchanges a word } +END; + +{--TCluster-----------------------------------------------------------------} +{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.GetHelpCtx: Word; +BEGIN + If (HelpCtx = hcNoContext) Then { View has no help } + GetHelpCtx := hcNoContext Else { No help context } + GetHelpCtx := HelpCtx + Sel; { Help of selected } +END; + +{--TCluster-----------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.GetPalette: PPalette; +CONST P: String[Length(CCluster)] = CCluster; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Cluster palette } +END; + +{--TCluster-----------------------------------------------------------------} +{ Mark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.Mark (Item: Sw_Integer): Boolean; +BEGIN + Mark := False; { Default false } +END; + +{--TCluster-----------------------------------------------------------------} +{ MultiMark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.MultiMark (Item: Sw_Integer): Byte; +BEGIN + MultiMark := Byte(Mark(Item) = True); { Return multi mark } +END; + +{--TCluster-----------------------------------------------------------------} +{ ButtonState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.ButtonState (Item: Sw_Integer): Boolean; +BEGIN + If (Item > 31) Then ButtonState := False Else { Impossible item } + ButtonState := ((1 SHL Item) AND EnableMask)<>0; { Return true/false } +END; + +{--TCluster-----------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.Draw; +BEGIN +END; + +{--TCluster-----------------------------------------------------------------} +{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.Press (Item: Sw_Integer); +VAR P: PView; +BEGIN + P := TopView; + If (Id <> 0) AND (P <> Nil) Then NewMessage(P, + evCommand, cmIdCommunicate, Id, Value, @Self); { Send new message } +END; + +{--TCluster-----------------------------------------------------------------} +{ MovedTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.MovedTo (Item: Sw_Integer); +BEGIN { Abstract method } +END; + +{--TCluster-----------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.SetState (AState: Word; Enable: Boolean); +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState AND sfFocused <> 0) Then Begin + DrawView; { Redraw masked areas } + End; +END; + +{--TCluster-----------------------------------------------------------------} +{ DrawMultiBox -> Platforms DOS/DPMI/WIN/NT - Updated 05Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.DrawMultiBox (Const Icon, Marker: String); +VAR I, J, Cur, Col: Sw_Integer; CNorm, CSel, CDis, Color: Word; B: TDrawBuffer; +BEGIN + CNorm := GetColor($0301); { Normal colour } + CSel := GetColor($0402); { Selected colour } + CDis := GetColor($0505); { Disabled colour } + For I := 0 To Size.Y-1 Do Begin { For each line } + MoveChar(B, ' ', Byte(CNorm), Size.X); { Fill buffer } + For J := 0 To (Strings.Count - 1) DIV Size.Y + 1 + Do Begin + Cur := J*Size.Y + I; { Current line } + If (Cur < Strings.Count) Then Begin + Col := Column(Cur); { Calc column } + If (Col + CStrLen(PString(Strings.At(Cur))^)+ + 5 < Sizeof(TDrawBuffer) DIV SizeOf(Word)) + AND (Col < Size.X) Then Begin { Text fits in column } + If NOT ButtonState(Cur) Then + Color := CDis Else If (Cur = Sel) AND { Disabled colour } + (State and sfFocused <> 0) Then + Color := CSel Else { Selected colour } + Color := CNorm; { Normal colour } + MoveChar(B[Col], ' ', Byte(Color), + Size.X-Col); { Set this colour } + MoveStr(B[Col], Icon, Byte(Color)); { Transfer icon string } + WordRec(B[Col+2]).Lo := Byte(Marker[ + MultiMark(Cur) + 1]); { Transfer marker } + MoveCStr(B[Col+5], PString(Strings.At( + Cur))^, Color); { Transfer item string } + If ShowMarkers AND (State AND sfFocused <> 0) + AND (Cur = Sel) Then Begin { Current is selected } + WordRec(B[Col]).Lo := Byte(SpecialChars[0]); + WordRec(B[Column(Cur+Size.Y)-1]).Lo + := Byte(SpecialChars[1]); { Set special character } + End; + End; + End; + End; + WriteBuf(0, I, Size.X, 1, B); { Write buffer } + End; + SetCursor(Column(Sel)+2,Row(Sel)); +END; + +{--TCluster-----------------------------------------------------------------} +{ DrawBox -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.DrawBox (Const Icon: String; Marker: Char); +BEGIN + DrawMultiBox(Icon, ' '+Marker); { Call draw routine } +END; + +{--TCluster-----------------------------------------------------------------} +{ SetButtonState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.SetButtonState (AMask: Longint; Enable: Boolean); +VAR I: Sw_Integer; M: Longint; +BEGIN + If Enable Then EnableMask := EnableMask OR AMask { Set enable bit mask } + Else EnableMask := EnableMask AND NOT AMask; { Disable bit mask } + If (Strings.Count <= 32) Then Begin { Valid string number } + M := 1; { Preset bit masks } + For I := 1 To Strings.Count Do Begin { For each item string } + If ((M AND EnableMask) <> 0) Then Begin { Bit enabled } + Options := Options OR ofSelectable; { Set selectable option } + Exit; { Now exit } + End; + M := M SHL 1; { Create newbit mask } + End; + Options := Options AND NOT ofSelectable; { Make not selectable } + End; +END; + +{--TCluster-----------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.GetData (Var Rec); +BEGIN + sw_Word(Rec) := Value; { Return current value } +END; + +{--TCluster-----------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.SetData (Var Rec); +BEGIN + Value :=sw_Word(Rec); { Set current value } + DrawView; { Redraw masked areas } +END; + +{--TCluster-----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.Store (Var S: TStream); +var + w : word; +BEGIN + TView.Store(S); { TView.Store called } + If ((Options AND ofVersion) >= ofVersion20) { Version 2 TV view } + Then Begin + S.Write(Value, SizeOf(Value)); { Write value } + S.Write(Sel, SizeOf(Sel)); { Write select item } + S.Write(EnableMask, SizeOf(EnableMask)); { Write enable masks } + End Else Begin + w:=Value; + S.Write(w, SizeOf(Word)); { Write value } + S.Write(Sel, SizeOf(Sel)); { Write select item } + End; + Strings.Store(S); { Store strings } +END; + +{--TCluster-----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCluster.HandleEvent (Var Event: TEvent); +VAR C: Char; I, S, Vh: Sw_Integer; Key: Word; Mouse: TPoint; Ts: PString; + + PROCEDURE MoveSel; + BEGIN + If (I <= Strings.Count) Then Begin + Sel := S; { Set selected item } + MovedTo(Sel); { Move to selected } + DrawView; { Now draw changes } + End; + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If ((Options AND ofSelectable) = 0) Then Exit; { Check selectable } + If (Event.What = evMouseDown) Then Begin { MOUSE EVENT } + MakeLocal(Event.Where, Mouse); { Make point local } + I := FindSel(Mouse); { Find selected item } + If (I <> -1) Then { Check in view } + If ButtonState(I) Then Sel := I; { If enabled select } + DrawView; { Now draw changes } + Repeat + MakeLocal(Event.Where, Mouse); { Make point local } + Until NOT MouseEvent(Event, evMouseMove); { Wait for mouse up } + MakeLocal(Event.Where, Mouse); { Make point local } + If (FindSel(Mouse) = Sel) AND ButtonState(Sel) { If valid/selected } + Then Begin + Press(Sel); { Call pressed } + DrawView; { Now draw changes } + End; + ClearEvent(Event); { Event was handled } + End Else If (Event.What = evKeyDown) Then Begin { KEY EVENT } + Vh := Size.Y; { View height } + S := Sel; { Hold current item } + Key := CtrlToArrow(Event.KeyCode); { Convert keystroke } + Case Key Of + kbUp, kbDown, kbRight, kbLeft: + If (State AND sfFocused <> 0) Then Begin { Focused key event } + I := 0; { Zero process count } + Repeat + Inc(I); { Inc process count } + Case Key Of + kbUp: Dec(S); { Next item up } + kbDown: Inc(S); { Next item down } + kbRight: Begin { Next column across } + Inc(S, Vh); { Move to next column } + If (S >= Strings.Count) Then { No next column check } + S := (S+1) MOD Vh; { Move to last column } + End; + kbLeft: Begin { Prior column across } + Dec(S, Vh); { Move to prior column } + If (S < 0) Then S := ((Strings.Count + + Vh - 1) DIV Vh) * Vh + S - 1; { No prior column check } + End; + End; + If (S >= Strings.Count) Then S := 0; { Roll up to top } + If (S < 0) Then S := Strings.Count - 1; { Roll down to bottom } + Until ButtonState(S) OR (I > Strings.Count); { Repeat until select } + MoveSel; { Move to selected } + ClearEvent(Event); { Event was handled } + End; + Else Begin { Not an arrow key } + For I := 0 To Strings.Count-1 Do Begin { Scan each item } + Ts := Strings.At(I); { Fetch string pointer } + If (Ts <> Nil) Then C := HotKey(Ts^) { Check for hotkey } + Else C := #0; { No valid string } + If (GetAltCode(C) = Event.KeyCode) OR { Hot key for item } + (((Owner^.Phase = phPostProcess) OR { Owner in post process } + (State AND sfFocused <> 0)) AND (C <> #0) { Non zero hotkey } + AND (UpCase(Event.CharCode) = C)) { Matches current key } + Then Begin + If ButtonState(I) Then Begin { Check mask enabled } + If Focus Then Begin { Check view focus } + Sel := I; { Set selected } + MovedTo(Sel); { Move to selected } + Press(Sel); { Call pressed } + DrawView; { Now draw changes } + End; + ClearEvent(Event); { Event was handled } + End; + Exit; { Now exit } + End; + End; + If (Event.CharCode = ' ') AND { Spacebar key } + (State AND sfFocused <> 0) AND { Check focused view } + ButtonState(Sel) Then Begin { Check item enabled } + Press(Sel); { Call pressed } + DrawView; { Now draw changes } + ClearEvent(Event); { Event was handled } + End; + End; + End; + End; +END; + +{***************************************************************************} +{ TCluster OBJECT PRIVATE METHODS } +{***************************************************************************} + +{--TCluster-----------------------------------------------------------------} +{ FindSel -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.FindSel (P: TPoint): Sw_Integer; +VAR I, S, Vh: Sw_Integer; R: TRect; +BEGIN + GetExtent(R); { Get view extents } + If R.Contains(P) Then Begin { Point in view } + Vh := Size.Y; { View height } + I := 0; { Preset zero value } + While (P.X >= Column(I+Vh)) Do Inc(I, Vh); { Inc view size } + S := I + P.Y; { Line to select } + If ((S >= 0) AND (S < Strings.Count)) { Valid selection } + Then FindSel := S Else FindSel := -1; { Return selected item } + End Else FindSel := -1; { Point outside view } +END; + +{--TCluster-----------------------------------------------------------------} +{ Row -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.Row (Item: Sw_Integer): Sw_Integer; +BEGIN + Row := Item MOD Size.Y; { Normal mod value } +END; + +{--TCluster-----------------------------------------------------------------} +{ Column -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 03Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCluster.Column (Item: Sw_Integer): Sw_Integer; +VAR I, Col, Width, L, Vh: Sw_Integer; Ts: PString; +BEGIN + Vh := Size.Y; { Vertical size } + If (Item >= Vh) Then Begin { Valid selection } + Width := 0; { Zero width } + Col := -6; { Start column at -6 } + For I := 0 To Item Do Begin { For each item } + If (I MOD Vh = 0) Then Begin { Start next column } + Inc(Col, Width + 6); { Add column width } + Width := 0; { Zero width } + End; + If (I < Strings.Count) Then Begin { Valid string } + Ts := Strings.At(I); { Transfer string } + If (Ts <> Nil) Then L := CStrLen(Ts^) { Length of string } + Else L := 0; { No string } + End; + If (L > Width) Then Width := L; { Hold longest string } + End; + Column := Col; { Return column } + End Else Column := 0; { Outside select area } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TRadioButtons OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TRadioButtons------------------------------------------------------------} +{ Mark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRadioButtons.Mark (Item: Sw_Integer): Boolean; +BEGIN + Mark := Item = Value; { True if item = value } +END; + +{--TRadioButtons------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRadioButtons.Draw; +CONST Button = ' ( ) '; +BEGIN + Inherited Draw; + DrawMultiBox(Button, ' *'); { Redraw the text } +END; + +{--TRadioButtons------------------------------------------------------------} +{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRadioButtons.Press (Item: Sw_Integer); +BEGIN + Value := Item; { Set value field } + Inherited Press(Item); { Call ancestor } +END; + +{--TRadioButtons------------------------------------------------------------} +{ MovedTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRadioButtons.MovedTo (Item: Sw_Integer); +BEGIN + Value := Item; { Set value to item } + If (Id <> 0) Then NewMessage(Owner, evCommand, + cmIdCommunicate, Id, Value, @Self); { Send new message } +END; + +{--TRadioButtons------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRadioButtons.SetData (Var Rec); +BEGIN + Sel := Sw_word(Rec); { Set selection } + Inherited SetData(Rec); { Call ancestor } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TCheckBoxes OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TCheckBoxes--------------------------------------------------------------} +{ Mark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TCheckBoxes.Mark(Item: Sw_Integer): Boolean; +BEGIN + If (Value AND (1 SHL Item) <> 0) Then { Check if item ticked } + Mark := True Else Mark := False; { Return result } +END; + +{--TCheckBoxes--------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCheckBoxes.Draw; +CONST Button = ' [ ] '; +BEGIN + Inherited Draw; + DrawMultiBox(Button, ' X'); { Redraw the text } +END; + +{--TCheckBoxes--------------------------------------------------------------} +{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TCheckBoxes.Press (Item: Sw_Integer); +BEGIN + Value := Value XOR (1 SHL Item); { Flip the item mask } + Inherited Press(Item); { Call ancestor } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMultiCheckBoxes OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Jun98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMultiCheckBoxes.Init (Var Bounds: TRect; AStrings: PSItem; +ASelRange: Byte; AFlags: Word; Const AStates: String); +BEGIN + Inherited Init(Bounds, AStrings); { Call ancestor } + SelRange := ASelRange; { Hold select range } + Flags := AFlags; { Hold flags } + States := NewStr(AStates); { Hold string } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMultiCheckBoxes.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(SelRange, SizeOf(SelRange)); { Read select range } + S.Read(Flags, SizeOf(Flags)); { Read flags } + States := S.ReadStr; { Read strings } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TMultiCheckBoxes.Done; +BEGIN + If (States <> Nil) Then DisposeStr(States); { Dispose strings } + Inherited Done; { Call ancestor } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMultiCheckBoxes.DataSize: Sw_Word; +BEGIN + DataSize := SizeOf(LongInt); { Size to exchange } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ MultiMark -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMultiCheckBoxes.MultiMark (Item: Sw_Integer): Byte; +BEGIN + MultiMark := (Value SHR (Word(Item) * + WordRec(Flags).Hi)) AND WordRec(Flags).Lo; { Return mark state } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMultiCheckBoxes.Draw; +CONST Button = ' [ ] '; +BEGIN + Inherited Draw; + DrawMultiBox(Button, States^); { Draw the items } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Press -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMultiCheckBoxes.Press (Item: Sw_Integer); +VAR CurState: ShortInt; +BEGIN + CurState := (Value SHR (Word(Item) * + WordRec(Flags).Hi)) AND WordRec(Flags).Lo; { Hold current state } + Dec(CurState); { One down } + If (CurState >= SelRange) OR (CurState < 0) Then + CurState := SelRange - 1; { Roll if needed } + Value := (Value AND NOT (LongInt(WordRec(Flags).Lo) + SHL (Word(Item) * WordRec(Flags).Hi))) OR + (LongInt(CurState) SHL (Word(Item) * + WordRec(Flags).Hi)); { Calculate value } + Inherited Press(Item); { Call ancestor } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMultiCheckBoxes.GetData (Var Rec); +BEGIN + Longint(Rec) := Value; { Return value } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMultiCheckBoxes.SetData (Var Rec); +BEGIN + Value := Longint(Rec); { Set value } + DrawView; { Redraw masked areas } +END; + +{--TMultiCheckBoxes---------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMultiCheckBoxes.Store (Var S: TStream); +BEGIN + TCluster.Store(S); { TCluster store called } + S.Write(SelRange, SizeOf(SelRange)); { Write select range } + S.Write(Flags, SizeOf(Flags)); { Write select flags } + S.WriteStr(States); { Write strings } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TListBox OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +TYPE + TListBoxRec = PACKED RECORD + List: PCollection; { List collection ptr } + Selection: sw_integer; { Selected item } + END; + +{--TListBox-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TListBox.Init (Var Bounds: TRect; ANumCols: Sw_Word; + AScrollBar: PScrollBar); +BEGIN + Inherited Init(Bounds, ANumCols, Nil, AScrollBar); { Call ancestor } + SetRange(0); { Set range to zero } +END; + +{--TListBox-----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TListBox.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + List := PCollection(S.Get); { Fetch collection } +END; + +{--TListBox-----------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/Os2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TListBox.DataSize: Sw_Word; +BEGIN + DataSize := SizeOf(TListBoxRec); { Xchg data size } +END; + +{--TListBox-----------------------------------------------------------------} +{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TListBox.GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; +VAR P: PString; +BEGIN + GetText := ''; { Preset return } + If (List <> Nil) Then Begin { A list exists } + P := PString(List^.At(Item)); { Get string ptr } + If (P <> Nil) Then GetText := P^; { Return string } + End; +END; + +{--TListBox-----------------------------------------------------------------} +{ NewList -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListBox.NewList (AList: PCollection); +BEGIN + If (List <> Nil) Then Dispose(List, Done); { Dispose old list } + List := AList; { Hold new list } + If (AList <> Nil) Then SetRange(AList^.Count) { Set new item range } + Else SetRange(0); { Set zero range } + If (Range > 0) Then FocusItem(0); { Focus first item } + DrawView; { Redraw all view } +END; + +{--TListBox-----------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListBox.GetData (Var Rec); +BEGIN + TListBoxRec(Rec).List := List; { Return current list } + TListBoxRec(Rec).Selection := Focused; { Return focused item } +END; + +{--TListBox-----------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListBox.SetData (Var Rec); +BEGIN + NewList(TListBoxRec(Rec).List); { Hold new list } + FocusItem(TListBoxRec(Rec).Selection); { Focus selected item } + DrawView; { Redraw all view } +END; + +{--TListBox-----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListBox.Store (Var S: TStream); +BEGIN + TListViewer.Store(S); { TListViewer store } + S.Put(List); { Store list to stream } +END; + +{****************************************************************************} +{ TListBox.DeleteFocusedItem } +{****************************************************************************} +procedure TListBox.DeleteFocusedItem; +begin + DeleteItem(Focused); +end; + +{****************************************************************************} +{ TListBox.DeleteItem } +{****************************************************************************} +procedure TListBox.DeleteItem (Item : Sw_Integer); +begin + if (List <> nil) and (List^.Count > 0) and + ((Item < List^.Count) and (Item > -1)) then begin + if IsSelected(Item) and (Item > 0) then + FocusItem(Item - 1); + List^.AtDelete(Item); + SetRange(List^.Count); + end; +end; + +{****************************************************************************} +{ TListBox.FreeAll } +{****************************************************************************} +procedure TListBox.FreeAll; +begin + if (List <> nil) then + begin + List^.FreeAll; + SetRange(List^.Count); + end; +end; + +{****************************************************************************} +{ TListBox.FreeFocusedItem } +{****************************************************************************} +procedure TListBox.FreeFocusedItem; +begin + FreeItem(Focused); +end; + +{****************************************************************************} +{ TListBox.FreeItem } +{****************************************************************************} +procedure TListBox.FreeItem (Item : Sw_Integer); +begin + if (Item > -1) and (Item < Range) then + begin + List^.AtFree(Item); + if (Range > 1) and (Focused >= List^.Count) then + Dec(Focused); + SetRange(List^.Count); + end; +end; + +{****************************************************************************} +{ TListBox.SetFocusedItem } +{****************************************************************************} +procedure TListBox.SetFocusedItem (Item : Pointer); +begin + FocusItem(List^.IndexOf(Item)); +end; + +{****************************************************************************} +{ TListBox.GetFocusedItem } +{****************************************************************************} +function TListBox.GetFocusedItem : Pointer; +begin + if (List = nil) or (List^.Count = 0) then + GetFocusedItem := nil + else GetFocusedItem := List^.At(Focused); +end; + +{****************************************************************************} +{ TListBox.Insert } +{****************************************************************************} +procedure TListBox.Insert (Item : Pointer); +begin + if (List <> nil) then + begin + List^.Insert(Item); + SetRange(List^.Count); + end; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStaticText OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TStaticText--------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStaticText.Init (Var Bounds: TRect; Const AText: String); +BEGIN + Inherited Init(Bounds); { Call ancestor } + Text := NewStr(AText); { Create string ptr } +END; + +{--TStaticText--------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStaticText.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + Text := S.ReadStr; { Read text string } +END; + +{--TStaticText--------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TStaticText.Done; +BEGIN + If (Text <> Nil) Then DisposeStr(Text); { Dispose string } + Inherited Done; { Call ancestor } +END; + +{--TStaticText--------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStaticText.GetPalette: PPalette; +CONST P: String[Length(CStaticText)] = CStaticText; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TStaticText--------------------------------------------------------------} +{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStaticText.Draw; +VAR Just: Byte; I, J, P, Y, L: Sw_Integer; S: String; + B : TDrawBuffer; + Color : Byte; +BEGIN + GetText(S); { Fetch text to write } + Color := GetColor(1); + P := 1; { X start position } + Y := 0; { Y start position } + L := Length(S); { Length of text } + While (Y < Size.Y) Do Begin + MoveChar(B, ' ', Color, Size.X); + if P <= L then + begin + Just := 0; { Default left justify } + If (S[P] = #2) Then Begin { Right justify char } + Just := 2; { Set right justify } + Inc(P); { Next character } + End; + If (S[P] = #3) Then Begin { Centre justify char } + Just := 1; { Set centre justify } + Inc(P); { Next character } + End; + I := P; { Start position } + repeat + J := P; + while (P <= L) and (S[P] = ' ') do + Inc(P); + while (P <= L) and (S[P] <> ' ') and (S[P] <> #13) do + Inc(P); + until (P > L) or (P >= I + Size.X) or (S[P] = #13); + If P > I + Size.X Then { Text to long } + If J > I Then + P := J + Else + P := I + Size.X; + Case Just Of + 0: J := 0; { Left justify } + 1: J := (Size.X - (P-I)) DIV 2; { Centre justify } + 2: J := Size.X - (P-I); { Right justify } + End; + MoveBuf(B[J], S[I], Color, P - I); + While (P <= L) AND (P-I <= Size.X) AND ((S[P] = #13) OR (S[P] = #10)) + Do Inc(P); { Remove CR/LF } + End; + WriteLine(0, Y, Size.X, 1, B); + Inc(Y); { Next line } + End; +END; + +{--TStaticText--------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStaticText.Store (Var S: TStream); +BEGIN + TView.Store(S); { Call TView store } + S.WriteStr(Text); { Write text string } +END; + +{--TStaticText--------------------------------------------------------------} +{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStaticText.GetText (Var S: String); +BEGIN + If (Text <> Nil) Then S := Text^ { Copy text string } + Else S := ''; { Return empty string } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TParamText OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TParamText---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TParamText.Init (Var Bounds: TRect; Const AText: String; + AParamCount: Sw_Integer); +BEGIN + Inherited Init(Bounds, AText); { Call ancestor } + ParamCount := AParamCount; { Hold param count } +END; + +{--TParamText---------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TParamText.Load (Var S: TStream); +VAR w: Word; +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(w, SizeOf(w)); ParamCount:=w; { Read parameter count } +END; + +{--TParamText---------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TParamText.DataSize: Sw_Word; +BEGIN + DataSize := ParamCount * SizeOf(Pointer); { Return data size } +END; + +{--TParamText---------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TParamText.GetData (Var Rec); +BEGIN + Pointer(Rec) := @ParamList; { Return parm ptr } +END; + +{--TParamText---------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TParamText.SetData (Var Rec); +BEGIN + ParamList := @Rec; { Fetch parameter list } + DrawView; { Redraw all the view } +END; + +{--TParamText---------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TParamText.Store (Var S: TStream); +VAR w: Word; +BEGIN + TStaticText.Store(S); { Statictext store } + w:=ParamCount;S.Write(w, SizeOf(w)); { Store param count } +END; + +{--TParamText---------------------------------------------------------------} +{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TParamText.GetText (Var S: String); +BEGIN + If (Text = Nil) Then S := '' Else { Return empty string } + FormatStr(S, Text^, ParamList^); { Return text string } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TLabel OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TLabel-------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TLabel.Init (Var Bounds: TRect; CONST AText: String; ALink: PView); +BEGIN + Inherited Init(Bounds, AText); { Call ancestor } + Link := ALink; { Hold link } + Options := Options OR (ofPreProcess+ofPostProcess);{ Set pre/post process } + EventMask := EventMask OR evBroadcast; { Sees broadcast events } +END; + +{--TLabel-------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TLabel.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + GetPeerViewPtr(S, Link); { Load link view } +END; + +{--TLabel-------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TLabel.GetPalette: PPalette; +CONST P: String[Length(CLabel)] = CLabel; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TLabel-------------------------------------------------------------------} +{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TLabel.Draw; +VAR SCOff: Byte; Color: Word; B: TDrawBuffer; +BEGIN + If Light Then Begin { Light colour select } + Color := GetColor($0402); { Choose light colour } + SCOff := 0; { Zero offset } + End Else Begin + Color := GetColor($0301); { Darker colour } + SCOff := 4; { Set offset } + End; + MoveChar(B[0], ' ', Byte(Color), Size.X); { Clear the buffer } + If (Text <> Nil) Then MoveCStr(B[1], Text^, Color);{ Transfer label text } + If ShowMarkers Then WordRec(B[0]).Lo := Byte( + SpecialChars[SCOff]); { Show marker if req } + WriteLine(0, 0, Size.X, 1, B); { Write the text } +END; + +{--TLabel-------------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TLabel.Store (Var S: TStream); +BEGIN + TStaticText.Store(S); { TStaticText.Store } + PutPeerViewPtr(S, Link); { Store link view } +END; + +{--TLabel-------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TLabel.HandleEvent (Var Event: TEvent); +VAR C: Char; + + PROCEDURE FocusLink; + BEGIN + If (Link <> Nil) AND (Link^.Options AND + ofSelectable <> 0) Then Link^.Focus; { Focus link view } + ClearEvent(Event); { Clear the event } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evMouseDown: FocusLink; { Focus link view } + evKeyDown: + Begin + if assigned(text) then + begin + C := HotKey(Text^); { Check for hotkey } + If (GetAltCode(C) = Event.KeyCode) OR { Alt plus char } + ((C <> #0) AND (Owner^.Phase = phPostProcess) { Post process phase } + AND (UpCase(Event.CharCode) = C)) Then { Upper case match } + FocusLink; { Focus link view } + end; + end; + evBroadcast: If ((Event.Command = cmReceivedFocus) + OR (Event.Command = cmReleasedFocus)) AND { Focus state change } + (Link <> Nil) Then Begin + Light := Link^.State AND sfFocused <> 0; { Change light state } + DrawView; { Now redraw change } + End; + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ THistoryViewer OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--THistoryViewer-----------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR THistoryViewer.Init (Var Bounds: TRect; AHScrollBar, +AVScrollBar: PScrollBar; AHistoryId: Word); +BEGIN + Inherited Init(Bounds, 1, AHScrollBar, + AVScrollBar); { Call ancestor } + HistoryId := AHistoryId; { Hold history id } + SetRange(HistoryCount(AHistoryId)); { Set history range } + If (Range > 1) Then FocusItem(1); { Set to item 1 } + If (HScrollBar <> Nil) Then + HScrollBar^.SetRange(1, HistoryWidth-Size.X + 3);{ Set scrollbar range } +END; + +{--THistoryViewer-----------------------------------------------------------} +{ HistoryWidth -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistoryViewer.HistoryWidth: Sw_Integer; +VAR Width, T, Count, I: Sw_Integer; +BEGIN + Width := 0; { Zero width variable } + Count := HistoryCount(HistoryId); { Hold count value } + For I := 0 To Count-1 Do Begin { For each item } + T := Length(HistoryStr(HistoryId, I)); { Get width of item } + If (T > Width) Then Width := T; { Set width to max } + End; + HistoryWidth := Width; { Return max item width } +END; + +{--THistoryViewer-----------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistoryViewer.GetPalette: PPalette; +CONST P: String[Length(CHistoryViewer)] = CHistoryViewer;{ Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--THistoryViewer-----------------------------------------------------------} +{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistoryViewer.GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; +BEGIN + GetText := HistoryStr(HistoryId, Item); { Return history string } +END; + +{--THistoryViewer-----------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THistoryViewer.HandleEvent (Var Event: TEvent); +BEGIN + If ((Event.What = evMouseDown) AND (Event.Double)) { Double click mouse } + OR ((Event.What = evKeyDown) AND + (Event.KeyCode = kbEnter)) Then Begin { Enter key press } + EndModal(cmOk); { End with cmOk } + ClearEvent(Event); { Event was handled } + End Else If ((Event.What = evKeyDown) AND + (Event.KeyCode = kbEsc)) OR { Esc key press } + ((Event.What = evCommand) AND + (Event.Command = cmCancel)) Then Begin { Cancel command } + EndModal(cmCancel); { End with cmCancel } + ClearEvent(Event); { Event was handled } + End Else Inherited HandleEvent(Event); { Call ancestor } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ THistoryWindow OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--THistoryWindow-----------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR THistoryWindow.Init (Var Bounds: TRect; HistoryId: Word); +BEGIN + Inherited Init(Bounds, '', wnNoNumber); { Call ancestor } + Flags := wfClose; { Close flag only } + InitViewer(HistoryId); { Create list view } +END; + +{--THistoryWindow-----------------------------------------------------------} +{ GetSelection -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistoryWindow.GetSelection: String; +BEGIN + If (Viewer = Nil) Then GetSelection := '' Else { Return empty string } + GetSelection := Viewer^.GetText(Viewer^.Focused, + 255); { Get focused string } +END; + +{--THistoryWindow-----------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistoryWindow.GetPalette: PPalette; +CONST P: String[Length(CHistoryWindow)] = CHistoryWindow;{ Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return the palette } +END; + +{--THistoryWindow-----------------------------------------------------------} +{ InitViewer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THistoryWindow.InitViewer(HistoryId: Word); +VAR R: TRect; +BEGIN + GetExtent(R); { Get extents } + R.Grow(-1,-1); { Grow inside } + Viewer := New(PHistoryViewer, Init(R, + StandardScrollBar(sbHorizontal + sbHandleKeyboard), + StandardScrollBar(sbVertical + sbHandleKeyboard), + HistoryId)); { Create the viewer } + If (Viewer <> Nil) Then Insert(Viewer); { Insert viewer } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ THistory OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--THistory-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR THistory.Init (Var Bounds: TRect; ALink: PInputLine; +AHistoryId: Word); +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR ofPostProcess; { Set post process } + EventMask := EventMask OR evBroadcast; { See broadcast events } + Link := ALink; { Hold link view } + HistoryId := AHistoryId; { Hold history id } +END; + +{--THistory-----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR THistory.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + GetPeerViewPtr(S, Link); { Load link view } + S.Read(HistoryId, SizeOf(HistoryId)); { Read history id } +END; + +{--THistory-----------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistory.GetPalette: PPalette; +CONST P: String[Length(CHistory)] = CHistory; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return the palette } +END; + +{--THistory-----------------------------------------------------------------} +{ InitHistoryWindow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION THistory.InitHistoryWindow (Var Bounds: TRect): PHistoryWindow; +VAR P: PHistoryWindow; +BEGIN + P := New(PHistoryWindow, Init(Bounds, HistoryId)); { Create history window } + If (Link <> Nil) Then + P^.HelpCtx := Link^.HelpCtx; { Set help context } + InitHistoryWindow := P; { Return history window } +END; + +PROCEDURE THistory.Draw; +VAR B: TDrawBuffer; +BEGIN + MoveCStr(B,#222'~v~'#221, GetColor($0102)); { Set buffer data } + WriteLine(0, 0, Size.X, Size.Y, B); { Write buffer } +END; + +{--THistory-----------------------------------------------------------------} +{ RecordHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THistory.RecordHistory (CONST S: String); +BEGIN + HistoryAdd(HistoryId, S); { Add to history } +END; + +{--THistory-----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THistory.Store (Var S: TStream); +BEGIN + TView.Store(S); { TView.Store called } + PutPeerViewPtr(S, Link); { Store link view } + S.Write(HistoryId, SizeOf(HistoryId)); { Store history id } +END; + +{--THistory-----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THistory.HandleEvent (Var Event: TEvent); +VAR C: Word; Rslt: String; R, P: TRect; HistoryWindow: PHistoryWindow; +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Link = Nil) Then Exit; { No link view exits } + If (Event.What = evMouseDown) OR { Mouse down event } + ((Event.What = evKeyDown) AND + (CtrlToArrow(Event.KeyCode) = kbDown) AND { Down arrow key } + (Link^.State AND sfFocused <> 0)) Then Begin { Link view selected } + If NOT Link^.Focus Then Begin + ClearEvent(Event); { Event was handled } + Exit; { Now exit } + End; + RecordHistory(Link^.Data^); { Record current data } + Link^.GetBounds(R); { Get view bounds } + Dec(R.A.X); { One char in from us } + Inc(R.B.X); { One char short of us } + Inc(R.B.Y, 7); { Seven lines down } + Dec(R.A.Y,1); { One line below us } + Owner^.GetExtent(P); { Get owner extents } + R.Intersect(P); { Intersect views } + Dec(R.B.Y,1); { Shorten length by one } + HistoryWindow := InitHistoryWindow(R); { Create history window } + If (HistoryWindow <> Nil) Then Begin { Window crested okay } + C := Owner^.ExecView(HistoryWindow); { Execute this window } + If (C = cmOk) Then Begin { Result was okay } + Rslt := HistoryWindow^.GetSelection; { Get history selection } + If Length(Rslt) > Link^.MaxLen Then + SetLength(Rslt, Link^.MaxLen); { Hold new length } + Link^.Data^ := Rslt; { Hold new selection } + Link^.SelectAll(True); { Select all string } + Link^.DrawView; { Redraw link view } + End; + Dispose(HistoryWindow, Done); { Dispose of window } + End; + ClearEvent(Event); { Event was handled } + End Else If (Event.What = evBroadcast) Then { Broadcast event } + If ((Event.Command = cmReleasedFocus) AND + (Event.InfoPtr = Link)) OR + (Event.Command = cmRecordHistory) Then { Record command } + RecordHistory(Link^.Data^); { Record the history } +END; + +{****************************************************************************} +{ TBrowseButton Object } +{****************************************************************************} +{****************************************************************************} +{ TBrowseButton.Init } +{****************************************************************************} +constructor TBrowseButton.Init(var Bounds: TRect; ATitle: TTitleStr; + ACommand: Word; AFlags: Byte; ALink: PBrowseInputLine); +begin + if not inherited Init(Bounds,ATitle,ACommand,AFlags) then + Fail; + Link := ALink; +end; + +{****************************************************************************} +{ TBrowseButton.Load } +{****************************************************************************} +constructor TBrowseButton.Load(var S: TStream); +begin + if not inherited Load(S) then + Fail; + GetPeerViewPtr(S,Link); +end; + +{****************************************************************************} +{ TBrowseButton.Press } +{****************************************************************************} +procedure TBrowseButton.Press; +var + E: TEvent; +begin + Message(Owner, evBroadcast, cmRecordHistory, nil); + if Flags and bfBroadcast <> 0 then + Message(Owner, evBroadcast, Command, Link) else + begin + E.What := evCommand; + E.Command := Command; + E.InfoPtr := Link; + PutEvent(E); + end; +end; + +{****************************************************************************} +{ TBrowseButton.Store } +{****************************************************************************} +procedure TBrowseButton.Store(var S: TStream); +begin + inherited Store(S); + PutPeerViewPtr(S,Link); +end; + + +{****************************************************************************} +{ TBrowseInputLine Object } +{****************************************************************************} +{****************************************************************************} +{ TBrowseInputLine.Init } +{****************************************************************************} +constructor TBrowseInputLine.Init(var Bounds: TRect; AMaxLen: Sw_Integer; AHistory: Sw_Word); +begin + if not inherited Init(Bounds,AMaxLen) then + Fail; + History := AHistory; +end; + +{****************************************************************************} +{ TBrowseInputLine.Load } +{****************************************************************************} +constructor TBrowseInputLine.Load(var S: TStream); +begin + if not inherited Load(S) then + Fail; + S.Read(History,SizeOf(History)); + if (S.Status <> stOk) then + Fail; +end; + +{****************************************************************************} +{ TBrowseInputLine.DataSize } +{****************************************************************************} +function TBrowseInputLine.DataSize: Sw_Word; +begin + DataSize := SizeOf(TBrowseInputLineRec); +end; + +{****************************************************************************} +{ TBrowseInputLine.GetData } +{****************************************************************************} +procedure TBrowseInputLine.GetData(var Rec); +var + LocalRec: TBrowseInputLineRec absolute Rec; +begin + if (Validator = nil) or + (Validator^.Transfer(Data^,@LocalRec.Text, vtGetData) = 0) then + begin + FillChar(LocalRec.Text, DataSize, #0); + Move(Data^, LocalRec.Text, Length(Data^) + 1); + end; + LocalRec.History := History; +end; + +{****************************************************************************} +{ TBrowseInputLine.SetData } +{****************************************************************************} +procedure TBrowseInputLine.SetData(var Rec); +var + LocalRec: TBrowseInputLineRec absolute Rec; +begin + if (Validator = nil) or + (Validator^.Transfer(Data^, @LocalRec.Text, vtSetData) = 0) then + Move(LocalRec.Text, Data^[0], MaxLen + 1); + History := LocalRec.History; + SelectAll(True); +end; + +{****************************************************************************} +{ TBrowseInputLine.Store } +{****************************************************************************} +procedure TBrowseInputLine.Store(var S: TStream); +begin + inherited Store(S); + S.Write(History,SizeOf(History)); +end; + + +{****************************************************************************} +{ TCommandCheckBoxes Object } +{****************************************************************************} +{****************************************************************************} +{ TCommandCheckBoxes.Init } +{****************************************************************************} +constructor TCommandCheckBoxes.Init (var Bounds : TRect; + ACommandStrings : PCommandSItem); +var StartSItem, S : PSItem; + CItems : PCommandSItem; + i : Sw_Integer; +begin + if ACommandStrings = nil then + Fail; + { set up string list } + StartSItem := NewSItem(ACommandStrings^.Value,nil); + S := StartSItem; + CItems := ACommandStrings^.Next; + while (CItems <> nil) do begin + S^.Next := NewSItem(CItems^.Value,nil); + S := S^.Next; + CItems := CItems^.Next; + end; + { construct check boxes } + if not TCheckBoxes.Init(Bounds,StartSItem) then begin + while (StartSItem <> nil) do begin + S := StartSItem; + StartSItem := StartSItem^.Next; + if (S^.Value <> nil) then + DisposeStr(S^.Value); + Dispose(S); + end; + Fail; + end; + { set up CommandList and dispose of memory used by ACommandList } + i := 0; + while (ACommandStrings <> nil) do begin + CommandList[i] := ACommandStrings^.Command; + CItems := ACommandStrings; + ACommandStrings := ACommandStrings^.Next; + Dispose(CItems); + Inc(i); + end; +end; + +{****************************************************************************} +{ TCommandCheckBoxes.Load } +{****************************************************************************} +constructor TCommandCheckBoxes.Load (var S : TStream); +begin + if not TCheckBoxes.Load(S) then + Fail; + S.Read(CommandList,SizeOf(CommandList)); + if (S.Status <> stOk) then begin + TCheckBoxes.Done; + Fail; + end; +end; + +{****************************************************************************} +{ TCommandCheckBoxes.Press } +{****************************************************************************} +procedure TCommandCheckBoxes.Press (Item : Sw_Integer); +var Temp : Sw_Integer; +begin + Temp := Value; + TCheckBoxes.Press(Item); + if (Value <> Temp) then { value changed - notify peers } + Message(Owner,evCommand,CommandList[Item],@Value); +end; + +{****************************************************************************} +{ TCommandCheckBoxes.Store } +{****************************************************************************} +procedure TCommandCheckBoxes.Store (var S : TStream); +begin + TCheckBoxes.Store(S); + S.Write(CommandList,SizeOf(CommandList)); +end; + +{****************************************************************************} +{ TCommandIcon Object } +{****************************************************************************} +{****************************************************************************} +{ TCommandIcon.Init } +{****************************************************************************} +constructor TCommandIcon.Init (var Bounds : TRect; AText : String; + ACommand : Word); +begin + if not TStaticText.Init(Bounds,AText) then + Fail; + Options := Options or ofPostProcess; + Command := ACommand; +end; + +{****************************************************************************} +{ TCommandIcon.HandleEvent } +{****************************************************************************} +procedure TCommandIcon.HandleEvent (var Event : TEvent); +begin + if ((Event.What = evMouseDown) and MouseInView(MouseWhere)) then begin + ClearEvent(Event); + Message(Owner,evCommand,Command,nil); + end; + TStaticText.HandleEvent(Event); +end; + +{****************************************************************************} +{ TCommandInputLine Object } +{****************************************************************************} +{****************************************************************************} +{ TCommandInputLine.Changed } +{****************************************************************************} +{procedure TCommandInputLine.Changed; +begin + Message(Owner,evBroadcast,cmInputLineChanged,@Self); +end; } + +{****************************************************************************} +{ TCommandInputLine.HandleEvent } +{****************************************************************************} +{procedure TCommandInputLine.HandleEvent (var Event : TEvent); +var E : TEvent; +begin + E := Event; + TBSDInputLine.HandleEvent(Event); + if ((E.What and evKeyBoard = evKeyBoard) and (Event.KeyCode = kbEnter)) + then Changed; +end; } + +{****************************************************************************} +{ TCommandRadioButtons Object } +{****************************************************************************} + +{****************************************************************************} +{ TCommandRadioButtons.Init } +{****************************************************************************} +constructor TCommandRadioButtons.Init (var Bounds : TRect; + ACommandStrings : PCommandSItem); +var + StartSItem, S : PSItem; + CItems : PCommandSItem; + i : Sw_Integer; +begin + if ACommandStrings = nil + then Fail; + { set up string list } + StartSItem := NewSItem(ACommandStrings^.Value,nil); + S := StartSItem; + CItems := ACommandStrings^.Next; + while (CItems <> nil) do begin + S^.Next := NewSItem(CItems^.Value,nil); + S := S^.Next; + CItems := CItems^.Next; + end; + { construct check boxes } + if not TRadioButtons.Init(Bounds,StartSItem) then begin + while (StartSItem <> nil) do begin + S := StartSItem; + StartSItem := StartSItem^.Next; + if (S^.Value <> nil) then + DisposeStr(S^.Value); + Dispose(S); + end; + Fail; + end; + { set up command list } + i := 0; + while (ACommandStrings <> nil) do begin + CommandList[i] := ACommandStrings^.Command; + CItems := ACommandStrings; + ACommandStrings := ACommandStrings^.Next; + Dispose(CItems); + Inc(i); + end; +end; + +{****************************************************************************} +{ TCommandRadioButtons.Load } +{****************************************************************************} +constructor TCommandRadioButtons.Load (var S : TStream); +begin + if not TRadioButtons.Load(S) then + Fail; + S.Read(CommandList,SizeOf(CommandList)); + if (S.Status <> stOk) then begin + TRadioButtons.Done; + Fail; + end; +end; + +{****************************************************************************} +{ TCommandRadioButtons.MoveTo } +{****************************************************************************} +procedure TCommandRadioButtons.MovedTo (Item : Sw_Integer); +var Temp : Sw_Integer; +begin + Temp := Value; + TRadioButtons.MovedTo(Item); + if (Value <> Temp) then { value changed - notify peers } + Message(Owner,evCommand,CommandList[Item],@Value); +end; + +{****************************************************************************} +{ TCommandRadioButtons.Press } +{****************************************************************************} +procedure TCommandRadioButtons.Press (Item : Sw_Integer); +var Temp : Sw_Integer; +begin + Temp := Value; + TRadioButtons.Press(Item); + if (Value <> Temp) then { value changed - notify peers } + Message(Owner,evCommand,CommandList[Item],@Value); +end; + +{****************************************************************************} +{ TCommandRadioButtons.Store } +{****************************************************************************} +procedure TCommandRadioButtons.Store (var S : TStream); +begin + TRadioButtons.Store(S); + S.Write(CommandList,SizeOf(CommandList)); +end; + +{****************************************************************************} +{ TEditListBox Object } +{****************************************************************************} +{****************************************************************************} +{ TEditListBox.Init } +{****************************************************************************} +constructor TEditListBox.Init (Bounds : TRect; ANumCols: Word; + AVScrollBar : PScrollBar); + +begin + if not inherited Init(Bounds,ANumCols,AVScrollBar) + then Fail; + CurrentField := 1; +end; + +{****************************************************************************} +{ TEditListBox.Load } +{****************************************************************************} +constructor TEditListBox.Load (var S : TStream); +begin + if not inherited Load(S) + then Fail; + CurrentField := 1; +end; + +{****************************************************************************} +{ TEditListBox.EditField } +{****************************************************************************} +procedure TEditListBox.EditField (var Event : TEvent); +var R : TRect; + InputLine : PModalInputLine; +begin + R.Assign(StartColumn,(Origin.Y + Focused - TopItem), + (StartColumn + FieldWidth + 2),(Origin.Y + Focused - TopItem + 1)); + Owner^.MakeGlobal(R.A,R.A); + Owner^.MakeGlobal(R.B,R.B); + InputLine := New(PModalInputLine,Init(R,FieldWidth)); + InputLine^.SetValidator(FieldValidator); + if InputLine <> nil + then begin + { Use TInputLine^.SetData so that data validation occurs } + { because TInputLine.Data is allocated memory large enough } + { to hold a string of MaxLen. It is also faster. } + GetField(InputLine); + if (Application^.ExecView(InputLine) = cmOk) + then SetField(InputLine); + Dispose(InputLine,done); + end; +end; + +{****************************************************************************} +{ TEditListBox.FieldValidator } +{****************************************************************************} +function TEditListBox.FieldValidator : PValidator; + { In a multiple field listbox FieldWidth should return the width } + { appropriate for Field. The default is an inputline for editing } + { a string of length large enough to fill the listbox field. } +begin + FieldValidator := nil; +end; + +{****************************************************************************} +{ TEditListBox.FieldWidth } +{****************************************************************************} +function TEditListBox.FieldWidth : Integer; + { In a multiple field listbox FieldWidth should return the width } + { appropriate for CurrentField. } +begin + FieldWidth := Size.X - 2; +end; + +{****************************************************************************} +{ TEditListBox.GetField } +{****************************************************************************} +procedure TEditListBox.GetField (InputLine : PInputLine); + { Places a string appropriate to Field and Focused into InputLine that } + { will be edited. Override this method for complex data types. } +begin + InputLine^.SetData(PString(List^.At(Focused))^); +end; + +{****************************************************************************} +{ TEditListBox.GetPalette } +{****************************************************************************} +function TEditListBox.GetPalette : PPalette; +begin + GetPalette := inherited GetPalette; +end; + +{****************************************************************************} +{ TEditListBox.HandleEvent } +{****************************************************************************} +procedure TEditListBox.HandleEvent (var Event : TEvent); +begin + if (Event.What = evKeyboard) and (Event.KeyCode = kbAltE) + then begin { edit field } + EditField(Event); + DrawView; + ClearEvent(Event); + end; + inherited HandleEvent(Event); +end; + +{****************************************************************************} +{ TEditListBox.SetField } +{****************************************************************************} +procedure TEditListBox.SetField (InputLine : PInputLine); + { Override this method for field types other than PStrings. } +var Item : PString; +begin + Item := NewStr(InputLine^.Data^); + if Item <> nil + then begin + List^.AtFree(Focused); + List^.Insert(Item); + SetFocusedItem(Item); + end; +end; + +{****************************************************************************} +{ TEditListBox.StartColumn } +{****************************************************************************} +function TEditListBox.StartColumn : Integer; +begin + StartColumn := Origin.X; +end; + +{****************************************************************************} +{ TListDlg Object } +{****************************************************************************} +{****************************************************************************} +{ TListDlg.Init } +{****************************************************************************} +constructor TListDlg.Init (ATitle : TTitleStr; Items: + String; AButtons: Word; AListBox: PListBox; AEditCommand, ANewCommand : + Word); +var + Bounds: TRect; + b: Byte; + ButtonCount: Byte; + i, j, Gap, Line: Integer; + Scrollbar: PScrollbar; + HasFrame: Boolean; + HasButtons: Boolean; + HasScrollBar: Boolean; + HasItems: Boolean; +begin + if AListBox = nil then + Fail + else + ListBox := AListBox; + HasFrame := ((AButtons and ldNoFrame) = 0); + HasButtons := ((AButtons and ldAllButtons) <> 0); + HasScrollBar := ((AButtons and ldNoScrollBar) = 0); + HasItems := (Items <> ''); + ButtonCount := 2; + for b := 0 to 3 do + if (AButtons and ($0001 shl 1)) <> 0 then + Inc(ButtonCount); + { Make sure dialog is large enough for buttons } + ListBox^.GetExtent(Bounds); + Bounds.Move(ListBox^.Origin.X,ListBox^.Origin.Y); + if HasFrame then + begin + Inc(Bounds.B.X,2); + Inc(Bounds.B.Y,2); + end; + if HasButtons then + begin + Inc(Bounds.B.X,14); + if Bounds.B.Y < (ButtonCount * 2) + 4 then + Bounds.B.Y := (ButtonCount * 2) + 5; + end; + if HasItems then + Inc(Bounds.B.Y,1); + if not TDialog.Init(Bounds,ATitle) then + Fail; + NewCommand := ANewCommand; + EditCommand := AEditCommand; + Options := Options or ofNewEditDelete; + if (not HasFrame) and (Frame <> nil) then + begin + Delete(Frame); + Dispose(Frame,Done); + Frame := nil; + Options := Options and not ofFramed; + end; + HelpCtx := hcListDlg; + { position and insert ListBox } + ListBox := AListBox; + Insert(ListBox); + if HasItems then + if HasFrame then + ListBox^.MoveTo(2,2) + else ListBox^.MoveTo(0,2) + else + if HasFrame then + ListBox^.MoveTo(1,1) + else ListBox^.MoveTo(0,0); + if HasButtons then + if ListBox^.Size.Y < (ButtonCount * 2) then + ListBox^.GrowTo(ListBox^.Size.X,ButtonCount * 2); + { do Items } + if HasItems then + begin + Bounds.Assign(1,1,CStrLen(Items)+2,2); + Insert(New(PLabel,Init(Bounds,Items,ListBox))); + end; + { do scrollbar } + if HasScrollBar then + begin + Bounds.Assign(ListBox^.Size.X+ListBox^.Origin.X,ListBox^.Origin.Y, + ListBox^.Size.X + ListBox^.Origin.X + 1, + ListBox^.Size.Y + ListBox^.Origin.Y { origin }); + ScrollBar := New(PScrollBar,Init(Bounds)); + Bounds.Assign(Origin.X,Origin.Y,Origin.X + Size.X + 1, Origin.Y + Size.Y); + ChangeBounds(Bounds); + Insert(Scrollbar); + end; + if HasButtons then + begin { do buttons } + j := $0001; + Gap := 0; + for i := 0 to 3 do + if ((j shl i) and AButtons) <> 0 then + Inc(Gap); + Gap := ((Size.Y - 2) div (Gap + 2)); + if Gap < 2 then + Gap := 2; + { Insert Buttons } + Line := 2; + if (AButtons and ldNew) = ldNew then + begin + Insert(NewButton(Size.X - 12,Line,10,2,'~N~ew',cmNew,hcInsert,bfNormal)); + Inc(Line,Gap); + end; + if (AButtons and ldEdit) = ldEdit then + begin + Insert(NewButton(Size.X - 12,Line,10,2,'~E~dit',cmEdit,hcEdit, + bfNormal)); + Inc(Line,Gap); + end; + if (AButtons and ldDelete) = ldDelete then + begin + Insert(NewButton(Size.X - 12,Line,10,2,'~D~elete',cmDelete,hcDelete, + bfNormal)); + Inc(Line,Gap); + end; + Insert(NewButton(Size.X - 12,Line,10,2,'O~k~',cmOK,hcOk,bfDefault or + bfNormal)); + Inc(Line,Gap); + Insert(NewButton(Size.X - 12,Line,10,2,'Cancel',cmCancel,hcCancel, + bfNormal)); + if (AButtons and ldHelp) = ldHelp then + begin + Inc(Line,Gap); + Insert(NewButton(Size.X - 12,Line,10,2,'~H~elp',cmHelp,hcNoContext, + bfNormal)); + end; + end; + if HasFrame and ((AButtons and ldAllIcons) <> 0) then + begin + Line := 2; + if (AButtons and ldNewIcon) = ldNewIcon then + begin + Bounds.Assign(Line,Size.Y-1,Line+5,Size.Y); + Insert(New(PCommandIcon,Init(Bounds,' Ins ',cmNew))); + Inc(Line,5); + if (AButtons and (ldEditIcon or ldDeleteIcon)) <> 0 then + begin + Bounds.Assign(Line,Size.Y-1,Line+1,Size.Y); + Insert(New(PStaticText,Init(Bounds,'/'))); + Inc(Line,1); + end; + end; + if (AButtons and ldEditIcon) = ldEditIcon then + begin + Bounds.Assign(Line,Size.Y-1,Line+6,Size.Y); + Insert(New(PCommandIcon,Init(Bounds,' Edit ',cmEdit))); + Inc(Line,6); + if (AButtons and ldDeleteIcon) <> 0 then + begin + Bounds.Assign(Line,Size.Y-1,Line+1,Size.Y); + Insert(New(PStaticText,Init(Bounds,'/'))); + Inc(Line,1); + end; + end; + if (AButtons and ldNewIcon) = ldNewIcon then + begin + Bounds.Assign(Line,Size.Y-1,Line+5,Size.Y); + Insert(New(PCommandIcon,Init(Bounds,' Del ',cmDelete))); + end; + end; + { Set focus to list boLine when dialog opens } + SelectNext(False); +end; + +{****************************************************************************} +{ TListDlg.Load } +{****************************************************************************} +constructor TListDlg.Load (var S : TStream); +begin + if not TDialog.Load(S) then + Fail; + S.Read(NewCommand,SizeOf(NewCommand)); + S.Read(EditCommand,SizeOf(EditCommand)); + GetSubViewPtr(S,ListBox); +end; + +{****************************************************************************} +{ TListDlg.HandleEvent } +{****************************************************************************} +procedure TListDlg.HandleEvent (var Event : TEvent); +const + TargetCommands: TCommandSet = [cmNew, cmEdit, cmDelete]; +begin + if ((Event.What and evCommand) <> 0) and + (Event.Command in TargetCommands) then + case Event.Command of + cmDelete: + if Options and ofDelete = ofDelete then + begin + ListBox^.FreeFocusedItem; + ListBox^.DrawView; + ClearEvent(Event); + end; + cmNew: + if Options and ofNew = ofNew then + begin + Message(Application,evCommand,NewCommand,nil); + ListBox^.SetRange(ListBox^.List^.Count); + ListBox^.DrawView; + ClearEvent(Event); + end; + cmEdit: + if Options and ofEdit = ofEdit then + begin + Message(Application,evCommand,EditCommand,ListBox^.GetFocusedItem); + ListBox^.DrawView; + ClearEvent(Event); + end; + end; + if (Event.What and evBroadcast > 0) and + (Event.Command = cmListItemSelected) then + begin { use PutEvent instead of Message so that a window list box works } + Event.What := evCommand; + Event.Command := cmOk; + Event.InfoPtr := nil; + PutEvent(Event); + end; + TDialog.HandleEvent(Event); +end; + +{****************************************************************************} +{ TListDlg.Store } +{****************************************************************************} +procedure TListDlg.Store (var S : TStream); +begin + TDialog.Store(S); + S.Write(NewCommand,SizeOf(NewCommand)); + S.Write(EditCommand,SizeOf(EditCommand)); + PutSubViewPtr(S,ListBox); +end; + +{****************************************************************************} +{ TModalInputLine Object } +{****************************************************************************} +{****************************************************************************} +{ TModalInputLine.Execute } +{****************************************************************************} +function TModalInputLine.Execute : Word; +var Event : TEvent; +begin + repeat + EndState := 0; + repeat + GetEvent(Event); + HandleEvent(Event); + if Event.What <> evNothing + then Owner^.EventError(Event); { may change this to ClearEvent } + until (EndState <> 0); + until Valid(EndState); + Execute := EndState; +end; + +{****************************************************************************} +{ TModalInputLine.HandleEvent } +{****************************************************************************} +procedure TModalInputLine.HandleEvent (var Event : TEvent); +begin + case Event.What of + evKeyboard : case Event.KeyCode of + kbUp, kbDown : EndModal(cmCancel); + kbEnter : EndModal(cmOk); + else inherited HandleEvent(Event); + end; + evMouse : if MouseInView(Event.Where) + then inherited HandleEvent(Event) + else EndModal(cmCancel); + else inherited HandleEvent(Event); + end; +end; + +{****************************************************************************} +{ TModalInputLine.SetState } +{****************************************************************************} +procedure TModalInputLine.SetState (AState : Word; Enable : Boolean); +var Pos : Integer; +begin + if (AState = sfSelected) + then begin + Pos := CurPos; + inherited SetState(AState,Enable); + CurPos := Pos; + SelStart := CurPos; + SelEnd := CurPos; + BlockCursor; + DrawView; + end + else inherited SetState(AState,Enable); +end; + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ ITEM STRING ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ NewSItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28Apr98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewSItem (Const Str: String; ANext: PSItem): PSItem; +VAR Item: PSItem; +BEGIN + New(Item); { Allocate item } + Item^.Value := NewStr(Str); { Hold item string } + Item^.Next := ANext; { Chain the ptr } + NewSItem := Item; { Return item } +END; + +{****************************************************************************} +{ NewCommandSItem } +{****************************************************************************} +function NewCommandSItem (Str : String; ACommand : Word; + ANext : PCommandSItem) : PCommandSItem; +var Temp : PCommandSItem; +begin + New(Temp); + if (Temp <> nil) then + begin + Temp^.Value := Str; + Temp^.Command := ACommand; + Temp^.Next := ANext; + end; + NewCommandSItem := Temp; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ DIALOG OBJECT REGISTRATION ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ RegisterDialogs -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterDialogs; +BEGIN + RegisterType(RDialog); { Register dialog } + RegisterType(RInputLine); { Register inputline } + RegisterType(RButton); { Register button } + RegisterType(RCluster); { Register cluster } + RegisterType(RRadioButtons); { Register radiobutton } + RegisterType(RCheckBoxes); { Register check boxes } + RegisterType(RMultiCheckBoxes); { Register multi boxes } + RegisterType(RListBox); { Register list box } + RegisterType(RStaticText); { Register static text } + RegisterType(RLabel); { Register label } + RegisterType(RHistory); { Register history } + RegisterType(RParamText); { Register parm text } + RegisterType(RCommandCheckBoxes); + RegisterType(RCommandIcon); + RegisterType(RCommandRadioButtons); + RegisterType(REditListBox); + RegisterType(RModalInputLine); + RegisterType(RListDlg); +END; + +END. diff --git a/packages/fv/src/drivers.pas b/packages/fv/src/drivers.pas new file mode 100644 index 0000000000..a3426e6f0b --- /dev/null +++ b/packages/fv/src/drivers.pas @@ -0,0 +1,1578 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent clone of DRIVERS.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999, 2000 } +{ by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@projectent.com.au - backup e-mail addr } +{ } +{ Original FormatStr kindly donated by Marco Schmidt } +{ } +{ Mouse callback hook under FPC with kind assistance of } +{ Pierre Muller, Gertjan Schouten & Florian Klaempfl. } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} + +UNIT Drivers; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$IFNDEF OS_UNIX} +{$S-} { Disable Stack Checking } +{$ENDIF} +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +{$ifdef CPU68K} + {$DEFINE ENDIAN_BIG} +{$endif CPU68K} + +{$ifdef FPC} + {$INLINE ON} +{$endif} + +USES + {$IFDEF OS_WINDOWS} { WIN/NT CODE } + Windows, { Standard unit } + {$ENDIF} + + {$ifdef OS_DOS} + Dos, + {$endif OS_DOS} + + {$IFDEF OS_OS2} { OS2 CODE } + {$IFDEF PPC_Virtual} { VIRTUAL PASCAL UNITS } + OS2Def, OS2Base, OS2PMAPI, { Standard units } + {$ENDIF} + {$IFDEF PPC_Speed} { SPEED PASCAL UNITS } + BseDos, Os2Def, { Standard units } + {$ENDIF} + {$IFDEF PPC_FPC} { FPC UNITS } + DosCalls, Os2Def, { Standard units } + {$ENDIF} + {$ENDIF} + + {$IFDEF OS_UNIX} + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix, + {$endif} + {$ENDIF} + + {$IFDEF OS_NETWARE_LIBC} + libc, + {$ENDIF} + {$IFDEF OS_NETWARE_CLIB} + nwserv, + {$ENDIF} + + video, + SysMsg, + FVCommon, Objects; { GFV standard units } + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ EVENT TYPE MASKS } +{---------------------------------------------------------------------------} +CONST + evMouseDown = $0001; { Mouse down event } + evMouseUp = $0002; { Mouse up event } + evMouseMove = $0004; { Mouse move event } + evMouseAuto = $0008; { Mouse auto event } + evKeyDown = $0010; { Key down event } + evCommand = $0100; { Command event } + evBroadcast = $0200; { Broadcast event } + +{---------------------------------------------------------------------------} +{ EVENT CODE MASKS } +{---------------------------------------------------------------------------} +CONST + evNothing = $0000; { Empty event } + evMouse = $000F; { Mouse event } + evKeyboard = $0010; { Keyboard event } + evMessage = $FF00; { Message event } + +{---------------------------------------------------------------------------} +{ EXTENDED KEY CODES } +{---------------------------------------------------------------------------} +CONST + kbNoKey = $0000; kbAltEsc = $0100; kbEsc = $011B; + kbAltSpace = $0200; kbCtrlIns = $0400; kbShiftIns = $0500; + kbCtrlDel = $0600; kbShiftDel = $0700; kbAltBack = $0800; + kbAltShiftBack= $0900; kbBack = $0E08; kbCtrlBack = $0E7F; + kbShiftTab = $0F00; kbTab = $0F09; kbAltQ = $1000; + kbCtrlQ = $1011; kbAltW = $1100; kbCtrlW = $1117; + kbAltE = $1200; kbCtrlE = $1205; kbAltR = $1300; + kbCtrlR = $1312; kbAltT = $1400; kbCtrlT = $1414; + kbAltY = $1500; kbCtrlY = $1519; kbAltU = $1600; + kbCtrlU = $1615; kbAltI = $1700; kbCtrlI = $1709; + kbAltO = $1800; kbCtrlO = $180F; kbAltP = $1900; + kbCtrlP = $1910; kbAltLftBrack = $1A00; kbAltRgtBrack = $1B00; + kbCtrlEnter = $1C0A; kbEnter = $1C0D; kbAltA = $1E00; + kbCtrlA = $1E01; kbAltS = $1F00; kbCtrlS = $1F13; + kbAltD = $2000; kbCtrlD = $2004; kbAltF = $2100; + kbCtrlF = $2106; kbAltG = $2200; kbCtrlG = $2207; + kbAltH = $2300; kbCtrlH = $2308; kbAltJ = $2400; + kbCtrlJ = $240A; kbAltK = $2500; kbCtrlK = $250B; + kbAltL = $2600; kbCtrlL = $260C; kbAltSemiCol = $2700; + kbAltQuote = $2800; kbAltOpQuote = $2900; kbAltBkSlash = $2B00; + kbAltZ = $2C00; kbCtrlZ = $2C1A; kbAltX = $2D00; + kbCtrlX = $2D18; kbAltC = $2E00; kbCtrlC = $2E03; + kbAltV = $2F00; kbCtrlV = $2F16; kbAltB = $3000; + kbCtrlB = $3002; kbAltN = $3100; kbCtrlN = $310E; + kbAltM = $3200; kbCtrlM = $320D; kbAltComma = $3300; + kbAltPeriod = $3400; kbAltSlash = $3500; kbAltGreyAst = $3700; + kbSpaceBar = $3920; kbF1 = $3B00; kbF2 = $3C00; + kbF3 = $3D00; kbF4 = $3E00; kbF5 = $3F00; + kbF6 = $4000; kbF7 = $4100; kbF8 = $4200; + kbF9 = $4300; kbF10 = $4400; kbHome = $4700; + kbUp = $4800; kbPgUp = $4900; kbGrayMinus = $4A2D; + kbLeft = $4B00; kbCenter = $4C00; kbRight = $4D00; + kbAltGrayPlus = $4E00; kbGrayPlus = $4E2B; kbEnd = $4F00; + kbDown = $5000; kbPgDn = $5100; kbIns = $5200; + kbDel = $5300; kbShiftF1 = $5400; kbShiftF2 = $5500; + kbShiftF3 = $5600; kbShiftF4 = $5700; kbShiftF5 = $5800; + kbShiftF6 = $5900; kbShiftF7 = $5A00; kbShiftF8 = $5B00; + kbShiftF9 = $5C00; kbShiftF10 = $5D00; kbCtrlF1 = $5E00; + kbCtrlF2 = $5F00; kbCtrlF3 = $6000; kbCtrlF4 = $6100; + kbCtrlF5 = $6200; kbCtrlF6 = $6300; kbCtrlF7 = $6400; + kbCtrlF8 = $6500; kbCtrlF9 = $6600; kbCtrlF10 = $6700; + kbAltF1 = $6800; kbAltF2 = $6900; kbAltF3 = $6A00; + kbAltF4 = $6B00; kbAltF5 = $6C00; kbAltF6 = $6D00; + kbAltF7 = $6E00; kbAltF8 = $6F00; kbAltF9 = $7000; + kbAltF10 = $7100; kbCtrlPrtSc = $7200; kbCtrlLeft = $7300; + kbCtrlRight = $7400; kbCtrlEnd = $7500; kbCtrlPgDn = $7600; + kbCtrlHome = $7700; kbAlt1 = $7800; kbAlt2 = $7900; + kbAlt3 = $7A00; kbAlt4 = $7B00; kbAlt5 = $7C00; + kbAlt6 = $7D00; kbAlt7 = $7E00; kbAlt8 = $7F00; + kbAlt9 = $8000; kbAlt0 = $8100; kbAltMinus = $8200; + kbAltEqual = $8300; kbCtrlPgUp = $8400; kbF11 = $8500; + kbF12 = $8600; kbShiftF11 = $8700; kbShiftF12 = $8800; + kbCtrlF11 = $8900; kbCtrlF12 = $8A00; kbAltF11 = $8B00; + kbAltF12 = $8C00; kbCtrlUp = $8D00; kbCtrlMinus = $8E00; + kbCtrlCenter = $8F00; kbCtrlGreyPlus= $9000; kbCtrlDown = $9100; + kbCtrlTab = $9400; kbAltHome = $9700; kbAltUp = $9800; + kbAltPgUp = $9900; kbAltLeft = $9B00; kbAltRight = $9D00; + kbAltEnd = $9F00; kbAltDown = $A000; kbAltPgDn = $A100; + kbAltIns = $A200; kbAltDel = $A300; kbAltTab = $A500; + +{ ------------------------------- REMARK ------------------------------ } +{ New keys not initially defined by Borland in their unit interface. } +{ ------------------------------ END REMARK --- Leon de Boer, 15May96 - } + kbFullStop = $342E; kbComma = $332C; kbBackSlash = $352F; + kbApostrophe = $2827; kbSemiColon = $273B; kbEqual = $0D3D; + kbGreaterThan = $343E; kbLessThan = $333C; kbQuestion = $353F; + kbQuote = $2822; kbColon = $273A; kbPlus = $0D2B; + kbPipe = $2B7C; kbSlash = $2B5C; kbExclaim = $0221; + kbAt = $0340; kbNumber = $0423; kbPercent = $0625; + kbCaret = $075E; kbAmpersand = $0826; kbAsterix = $092A; + kbLeftBracket = $0A28; kbRightBracket= $0B29; kbApprox = $2960; + kbTilde = $297E; kbDollar = $0524; kbMinus = $0C2D; + kbUnderline = $0C5F; kbLeftSqBr = $1A5B; kbRightSqBr = $1B5D; + kbLeftCurlyBr = $1A7B; kbRightCurlyBr= $1B7D; + +{---------------------------------------------------------------------------} +{ KEYBOARD STATE AND SHIFT MASKS } +{---------------------------------------------------------------------------} +CONST + kbRightShift = $0001; { Right shift key } + kbLeftShift = $0002; { Left shift key } + kbCtrlShift = $0004; { Control key down } + kbAltShift = $0008; { Alt key down } + kbScrollState = $0010; { Scroll lock on } + kbNumState = $0020; { Number lock on } + kbCapsState = $0040; { Caps lock on } + kbInsState = $0080; { Insert mode on } + + kbBothShifts = kbRightShift + kbLeftShift; { Right & Left shifts } + +{---------------------------------------------------------------------------} +{ MOUSE BUTTON STATE MASKS } +{---------------------------------------------------------------------------} +CONST + mbLeftButton = $01; { Left mouse button } + mbRightButton = $02; { Right mouse button } + mbMiddleButton = $04; { Middle mouse button } + +{---------------------------------------------------------------------------} +{ SCREEN CRT MODE CONSTANTS } +{---------------------------------------------------------------------------} +CONST + smBW80 = $0002; { Black and white } + smCO80 = $0003; { Colour mode } + smMono = $0007; { Monochrome mode } + smFont8x8 = $0100; { 8x8 font mode } + +{***************************************************************************} +{ PUBLIC TYPE DEFINITIONS } +{***************************************************************************} + +{ ******************************* REMARK ****************************** } +{ The TEvent definition is completely compatable with all existing } +{ code but adds two new fields ID and Data into the message record } +{ which helps with WIN/NT and OS2 message processing. } +{ ****************************** END REMARK *** Leon de Boer, 11Sep97 * } + +{---------------------------------------------------------------------------} +{ EVENT RECORD DEFINITION } +{---------------------------------------------------------------------------} +TYPE + TEvent = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + What: Sw_Word; { Event type } + Case Sw_Word Of + evNothing: (); { ** NO EVENT ** } + evMouse: ( + Buttons: Byte; { Mouse buttons } + Double: Boolean; { Double click state } + Where: TPoint); { Mouse position } + evKeyDown: ( + { ** KEY EVENT ** } + Case Sw_Integer Of + 0: (KeyCode: Word); { Full key code } + 1: ( +{$ifdef ENDIAN_BIG} + ScanCode: Byte; + CharCode: Char; +{$else not ENDIAN_BIG} + CharCode: Char; { Char code } + ScanCode: Byte; { Scan code } +{$endif not ENDIAN_BIG} + KeyShift: byte)); { Shift states } + evMessage: ( { ** MESSAGE EVENT ** } + Command: Sw_Word; { Message command } + Id : Sw_Word; { Message id } + Data : Real; { Message data } + Case Sw_Word Of + 0: (InfoPtr: Pointer); { Message pointer } + 1: (InfoLong: Longint); { Message longint } + 2: (InfoWord: Word); { Message Sw_Word } + 3: (InfoInt: Integer); { Message Sw_Integer } + 4: (InfoByte: Byte); { Message byte } + 5: (InfoChar: Char)); { Message character } + END; + PEvent = ^TEvent; + + TVideoMode = Video.TVideoMode; { Screen mode } + +{---------------------------------------------------------------------------} +{ ERROR HANDLER FUNCTION DEFINITION } +{---------------------------------------------------------------------------} +TYPE + TSysErrorFunc = FUNCTION (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{ Get Dos counter ticks } +Function GetDosTicks:longint; { returns ticks at 18.2 Hz, just like DOS } + + +procedure GiveUpTimeSlice; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ BUFFER MOVE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-CStrLen------------------------------------------------------------ +Returns the length of string S, where S is a control string using tilde +characters ('~') to designate shortcut characters. The tildes are +excluded from the length of the string, as they will not appear on +the screen. For example, given the string '~B~roccoli' as its +parameter, CStrLen returns 8. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION CStrLen (Const S: String): Sw_Integer; + +{-MoveStr------------------------------------------------------------ +Moves a string into a buffer for use with a view's WriteBuf or WriteLine. +Dest must be a TDrawBuffer (or an equivalent array of Sw_Words). The +characters in Str are moved into the low bytes of corresponding Sw_Words +in Dest. The high bytes of the Sw_Words are set to Attr, or remain +unchanged if Attr is zero. +25May96 LdB +---------------------------------------------------------------------} +PROCEDURE MoveStr (Var Dest; Const Str: String; Attr: Byte); + +{-MoveCStr----------------------------------------------------------- +The characters in Str are moved into the low bytes of corresponding +Sw_Words in Dest. The high bytes of the Sw_Words are set to Lo(Attr) or +Hi(Attr). Tilde characters (~) in the string toggle between the two +attribute bytes passed in the Attr Sw_Word. +25May96 LdB +---------------------------------------------------------------------} +PROCEDURE MoveCStr (Var Dest; Const Str: String; Attrs: Word); + +{-MoveBuf------------------------------------------------------------ +Count bytes are moved from Source into the low bytes of corresponding +Sw_Words in Dest. The high bytes of the Sw_Words in Dest are set to Attr, +or remain unchanged if Attr is zero. +25May96 LdB +---------------------------------------------------------------------} +PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; Count: Sw_Word); + +{-MoveChar------------------------------------------------------------ +Moves characters into a buffer for use with a view's WriteBuf or +WriteLine. Dest must be a TDrawBuffer (or an equivalent array of Sw_Words). +The low bytes of the first Count Sw_Words of Dest are set to C, or +remain unchanged if Ord(C) is zero. The high bytes of the Sw_Words are +set to Attr, or remain unchanged if Attr is zero. +25May96 LdB +---------------------------------------------------------------------} +PROCEDURE MoveChar (Var Dest; C: Char; Attr: Byte; Count: Sw_Word); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ KEYBOARD SUPPORT ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-GetAltCode--------------------------------------------------------- +Returns the scancode corresponding to Alt+Ch key that is given. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION GetAltCode (Ch: Char): Word; + +{-GetCtrlCode-------------------------------------------------------- +Returns the scancode corresponding to Alt+Ch key that is given. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION GetCtrlCode (Ch: Char): Word; + +{-GetAltChar--------------------------------------------------------- +Returns the ascii character for the Alt+Key scancode that was given. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION GetAltChar (KeyCode: Word): Char; + +{-GetCtrlChar-------------------------------------------------------- +Returns the ascii character for the Ctrl+Key scancode that was given. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION GetCtrlChar (KeyCode: Word): Char; + +{-CtrlToArrow-------------------------------------------------------- +Converts a WordStar-compatible control key code to the corresponding +cursor key code. +25May96 LdB +---------------------------------------------------------------------} +FUNCTION CtrlToArrow (KeyCode: Word): Word; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ KEYBOARD CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-GetShiftState------------------------------------------------------ +Returns a byte containing the current Shift key state. The return +value contains a combination of the kbXXXX constants for shift states. +08Jul96 LdB +---------------------------------------------------------------------} +FUNCTION GetShiftState: Byte; + +{-GetKeyEvent-------------------------------------------------------- +Checks whether a keyboard event is available. If a key has been pressed, +Event.What is set to evKeyDown and Event.KeyCode is set to the scan +code of the key. Otherwise, Event.What is set to evNothing. +19May98 LdB +---------------------------------------------------------------------} +PROCEDURE GetKeyEvent (Var Event: TEvent); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MOUSE CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-ShowMouse---------------------------------------------------------- +Decrements the hide counter and if zero the mouse is shown on screen. +30Jun98 LdB +---------------------------------------------------------------------} +PROCEDURE ShowMouse; + +{-HideMouse---------------------------------------------------------- +If mouse hide counter is zero it removes the cursor from the screen. +The hide counter is then incremented by one count. +30Jun98 LdB +---------------------------------------------------------------------} +PROCEDURE HideMouse; + +{-GetMouseEvent------------------------------------------------------ +Checks whether a mouse event is available. If a mouse event has occurred, +Event.What is set to evMouseDown, evMouseUp, evMouseMove, or evMouseAuto +and the button and double click variables are set appropriately. +06Jan97 LdB +---------------------------------------------------------------------} +PROCEDURE GetMouseEvent (Var Event: TEvent); + +{-GetSystemEvent------------------------------------------------------ +Checks whether a system event is available. If a system event has occurred, +Event.What is set to evCommand appropriately +10Oct2000 PM +---------------------------------------------------------------------} +procedure GetSystemEvent (Var Event: TEvent); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ EVENT HANDLER CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-InitEvents--------------------------------------------------------- +Initializes the event manager, enabling the mouse handler routine and +under DOS/DPMI shows the mouse on screen. It is called automatically +by TApplication.Init. +02May98 LdB +---------------------------------------------------------------------} +PROCEDURE InitEvents; + +{-DoneEvents--------------------------------------------------------- +Terminates event manager and disables the mouse and under DOS hides +the mouse. It is called automatically by TApplication.Done. +02May98 LdB +---------------------------------------------------------------------} +PROCEDURE DoneEvents; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ VIDEO CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-Initkeyboard------------------------------------------------------- +Initializes the keyboard. Before it is called read(ln)/write(ln) +are functional, after it is called FV's keyboard routines are +functional. +---------------------------------------------------------------------} + +procedure initkeyboard; + +{-Donekeyboard------------------------------------------------------- +Restores keyboard to original state. FV's keyboard routines may not +be used after a call to this. Read(ln)/write(ln) can be used again. +---------------------------------------------------------------------} + +procedure donekeyboard; + +{-InitVideo--------------------------------------------------------- +Initializes the video manager, Saves the current screen mode in +StartupMode, and switches to the mode indicated by ScreenMode. +19May98 LdB +---------------------------------------------------------------------} +function InitVideo:boolean; + +{-DoneVideo--------------------------------------------------------- +Terminates the video manager by restoring the initial screen mode +(given by StartupMode), clearing the screen, and restoring the cursor. +Called automatically by TApplication.Done. +03Jan97 LdB +---------------------------------------------------------------------} +PROCEDURE DoneVideo; + +{-ClearScreen-------------------------------------------------------- +Does nothing provided for compatability purposes only. +04Jan97 LdB +---------------------------------------------------------------------} +PROCEDURE ClearScreen; + +{-SetVideoMode------------------------------------------------------- +Does nothing provided for compatability purposes only. +04Jan97 LdB +---------------------------------------------------------------------} +PROCEDURE SetVideoMode (Mode: Sw_Word); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ ERROR CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-InitSysError------------------------------------------------------- +Error handling is not yet implemented so this simply sets +SysErrActive=True (ie it lies) and exits. +20May98 LdB +---------------------------------------------------------------------} +PROCEDURE InitSysError; + +{-DoneSysError------------------------------------------------------- +Error handling is not yet implemented so this simply sets +SysErrActive=False and exits. +20May98 LdB +---------------------------------------------------------------------} +PROCEDURE DoneSysError; + +{-SystemError--------------------------------------------------------- +Error handling is not yet implemented so this simply drops through. +20May98 LdB +---------------------------------------------------------------------} +FUNCTION SystemError (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STRING FORMAT ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-PrintStr----------------------------------------------------------- +Does nothing provided for compatability purposes only. +30Jun98 LdB +---------------------------------------------------------------------} +PROCEDURE PrintStr (CONST S: String); + +{-FormatStr---------------------------------------------------------- +A string formatting routine that given a string that includes format +specifiers and a list of parameters in Params, FormatStr produces a +formatted output string in Result. +18Feb99 LdB +---------------------------------------------------------------------} +PROCEDURE FormatStr (Var Result: String; CONST Format: String; Var Params); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ >> NEW QUEUED EVENT HANDLER ROUTINES << } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-PutEventInQueue----------------------------------------------------- +If there is room in the queue the event is placed in the next vacant +position in the queue manager. +17Mar98 LdB +---------------------------------------------------------------------} +FUNCTION PutEventInQueue (Var Event: TEvent): Boolean; + +{-NextQueuedEvent---------------------------------------------------- +If there are queued events the next event is loaded into event else +evNothing is returned. +17Mar98 LdB +---------------------------------------------------------------------} +PROCEDURE NextQueuedEvent(Var Event: TEvent); + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + +PROCEDURE HideMouseCursor; +PROCEDURE ShowMouseCursor; + + +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +CONST + CheckSnow : Boolean = False; { Compatability only } + MouseEvents : Boolean = False; { Mouse event state } + MouseReverse : Boolean = False; { Mouse reversed } + HiResScreen : Boolean = False; { Compatability only } + CtrlBreakHit : Boolean = False; { Compatability only } + SaveCtrlBreak: Boolean = False; { Compatability only } + SysErrActive : Boolean = False; { Compatability only } + FailSysErrors: Boolean = False; { Compatability only } + ButtonCount : Byte = 0; { Mouse button count } + DoubleDelay : Sw_Word = 8; { Double click delay } + RepeatDelay : Sw_Word = 8; { Auto mouse delay } + SysColorAttr : Sw_Word = $4E4F; { System colour attr } + SysMonoAttr : Sw_Word = $7070; { System mono attr } + StartupMode : Sw_Word = $FFFF; { Compatability only } + CursorLines : Sw_Word = $FFFF; { Compatability only } + ScreenBuffer : Pointer = Nil; { Compatability only } + SaveInt09 : Pointer = Nil; { Compatability only } + SysErrorFunc : TSysErrorFunc = {$ifdef FPC}@{$endif}SystemError; { System error ptr } + + +{***************************************************************************} +{ UNINITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +VAR + MouseIntFlag: Byte; { Mouse in int flag } + MouseButtons: Byte; { Mouse button state } + ScreenWidth : Byte; { Screen text width } + ScreenHeight: Byte; { Screen text height } + ScreenMode : TVideoMode; { Screen mode } + MouseWhere : TPoint; { Mouse position } + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} +{ API Units } + USES + FVConsts, + Keyboard,Mouse; + +{***************************************************************************} +{ PRIVATE INTERNAL CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ DOS/DPMI MOUSE INTERRUPT EVENT QUEUE SIZE } +{---------------------------------------------------------------------------} +CONST EventQSize = 16; { Default int bufsize } + +{---------------------------------------------------------------------------} +{ DOS/DPMI/WIN/NT/OS2 NEW EVENT QUEUE MAX SIZE } +{---------------------------------------------------------------------------} +CONST QueueMax = 64; { Max new queue size } + +{---------------------------------------------------------------------------} +{ MAX WIEW WIDTH to avoid TDrawBuffer overrun in views unit } +{---------------------------------------------------------------------------} +CONST MaxViewWidth = 255; { Max view width } + +{***************************************************************************} +{ PRIVATE INTERNAL TYPES } +{***************************************************************************} + +{***************************************************************************} +{ PRIVATE INTERNAL INITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ DOS/DPMI/WIN/NT/OS2 ALT KEY SCANCODES FROM KEYS (0-127) } +{---------------------------------------------------------------------------} +CONST AltCodes: Array [0..127] Of Byte = ( + $00, $00, $00, $00, $00, $00, $00, $00, { $00 - $07 } + $00, $00, $00, $00, $00, $00, $00, $00, { $08 - $0F } + $00, $00, $00, $00, $00, $00, $00, $00, { $10 - $17 } + $00, $00, $00, $00, $00, $00, $00, $00, { $18 - $1F } + $00, $00, $00, $00, $00, $00, $00, $00, { $20 - $27 } + $00, $00, $00, $00, $00, $82, $00, $00, { $28 - $2F } + $81, $78, $79, $7A, $7B, $7C, $7D, $7E, { $30 - $37 } + $7F, $80, $00, $00, $00, $83, $00, $00, { $38 - $3F } + $00, $1E, $30, $2E, $20, $12, $21, $22, { $40 - $47 } + $23, $17, $24, $25, $26, $32, $31, $18, { $48 - $4F } + $19, $10, $13, $1F, $14, $16, $2F, $11, { $50 - $57 } + $2D, $15, $2C, $00, $00, $00, $00, $00, { $58 - $5F } + $00, $00, $00, $00, $00, $00, $00, $00, { $60 - $67 } + $00, $00, $00, $00, $00, $00, $00, $00, { $68 - $6F } + $00, $00, $00, $00, $00, $00, $00, $00, { $70 - $77 } + $00, $00, $00, $00, $00, $00, $00, $00); { $78 - $7F } + +{***************************************************************************} +{ PRIVATE INTERNAL INITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ NEW CONTROL VARIABLES } +{---------------------------------------------------------------------------} +CONST + HideCount : Sw_Integer = 0; { Cursor hide count } + QueueCount: Sw_Word = 0; { Queued message count } + QueueHead : Sw_Word = 0; { Queue head pointer } + QueueTail : Sw_Word = 0; { Queue tail pointer } + +{***************************************************************************} +{ PRIVATE INTERNAL UNINITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ UNINITIALIZED DOS/DPMI/API VARIABLES } +{---------------------------------------------------------------------------} +VAR + LastDouble : Boolean; { Last double buttons } + LastButtons: Byte; { Last button state } + DownButtons: Byte; { Last down buttons } + EventCount : Sw_Word; { Events in queue } + AutoDelay : Sw_Word; { Delay time count } + DownTicks : Sw_Word; { Down key tick count } + AutoTicks : Sw_Word; { Held key tick count } + LastWhereX : Sw_Word; { Last x position } + LastWhereY : Sw_Word; { Last y position } + DownWhereX : Sw_Word; { Last x position } + DownWhereY : Sw_Word; { Last y position } + LastWhere : TPoint; { Last mouse position } + DownWhere : TPoint; { Last down position } + EventQHead : Pointer; { Head of queue } + EventQTail : Pointer; { Tail of queue } + EventQueue : Array [0..EventQSize - 1] Of TEvent; { Event queue } + EventQLast : RECORD END; { Simple end marker } + StartupScreenMode : TVideoMode; + +{---------------------------------------------------------------------------} +{ GetDosTicks (18.2 Hz) } +{---------------------------------------------------------------------------} + +Function GetDosTicks:longint; { returns ticks at 18.2 Hz, just like DOS } +{$IFDEF OS_OS2} + const + QSV_MS_COUNT = 14; + var + L: longint; + begin + DosQuerySysInfo (QSV_MS_COUNT, QSV_MS_COUNT, L, 4); + GetDosTicks := L div 55; + end; +{$ENDIF} +{$IFDEF OS_UNIX} + var + tv : TimeVal; + { tz : TimeZone;} + begin + {$ifdef ver1_0} + GetTimeOfDay(tv{,tz}); + GetDosTicks:=((tv.Sec mod 86400) div 60)*1092+((tv.Sec mod 60)*1000000+tv.USec) div 54945; + {$else} + FPGetTimeOfDay(@tv,nil{,tz}); + GetDosTicks:=((tv.tv_Sec mod 86400) div 60)*1092+((tv.tv_Sec mod 60)*1000000+tv.tv_USec) div 54945; + + {$endif} + end; +{$ENDIF OS_UNIX} +{$IFDEF OS_WINDOWS} + begin + GetDosTicks:=GetTickCount div 55; + end; +{$ENDIF OS_WINDOWS} +{$IFDEF OS_DOS} + begin + GetDosTicks:=MemL[$40:$6c]; + end; +{$ENDIF OS_DOS} +{$IFDEF OS_NETWARE_LIBC} +var + tv : TTimeVal; + tz : TTimeZone; + begin + fpGetTimeOfDay(tv,tz); + GetDosTicks:=((tv.tv_sec mod 86400) div 60)*1092+((tv.tv_Sec mod 60)*1000000+tv.tv_USec) div 549 + end; +{$ENDIF} +{$IFDEF OS_NETWARE_CLIB} + begin + GetDosTicks := Nwserv.GetCurrentTicks; + end; +{$ENDIF} + + +procedure GiveUpTimeSlice; +{$IFDEF OS_DOS} +var r: registers; +begin + Intr ($28, R); (* This is supported everywhere. *) + r.ax:=$1680; + intr($2f,r); +end; +{$ENDIF} +{$IFDEF OS_UNIX} + var + req,rem : timespec; +begin + req.tv_sec:=0; + req.tv_nsec:=10000000;{ 10 ms } + {$ifdef ver1_0}nanosleep(req,rem){$else}fpnanosleep(@req,@rem){$endif}; +end; +{$ENDIF} +{$IFDEF OS_OS2} +begin + DosSleep (5); +end; +{$ENDIF} +{$IFDEF OS_WINDOWS} +begin + { if the return value of this call is non zero then + it means that a ReadFileEx or WriteFileEx have completed + unused for now ! } + { wait for 10 ms } + if SleepEx(10,true)=WAIT_IO_COMPLETION then + begin + { here we should handle the completion of the routines + if we use them } + end; +end; +{$ENDIF} +{$IFDEF OS_NETWARE_LIBC} + begin + Delay (10); + end; +{$ENDIF} +{$IFDEF OS_NETWARE_CLIB} + begin + Delay (10); + end; +{$ENDIF} + + +{---------------------------------------------------------------------------} +{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +VAR + SaveExit: Pointer; { Saved exit pointer } + Queue : Array [0..QueueMax-1] Of TEvent; { New message queue } + +{***************************************************************************} +{ PRIVATE INTERNAL ROUTINES } +{***************************************************************************} + +PROCEDURE ShowMouseCursor;inline; +BEGIN + ShowMouse; +END; + +PROCEDURE HideMouseCursor;inline; +BEGIN + HideMouse; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ DOS/DPMI/WIN/NT/OS2 PRIVATE INTERNAL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ ExitDrivers -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jun98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE ExitDrivers; {$IFNDEF PPC_FPC}{$IFNDEF OS_UNIX} FAR; {$ENDIF}{$ENDIF} +BEGIN + DoneSysError; { Relase error trap } + DoneEvents; { Close event driver } +{ DoneKeyboard;} + DoneVideo; + ExitProc := SaveExit; { Restore old exit } +END; + +{---------------------------------------------------------------------------} +{ DetectVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} + +procedure DetectVideo; +VAR + CurrMode : TVideoMode; +begin + { Video.InitVideo; Incompatible with BP + and forces a screen clear which is often a bad thing PM } + GetVideoMode(CurrMode); + ScreenMode:=CurrMode; +end; + +{---------------------------------------------------------------------------} +{ DetectMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +FUNCTION DetectMouse: Byte;inline; +begin + DetectMouse:=Mouse.DetectMouse; +end; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ BUFFER MOVE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ CStrLen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION CStrLen (Const S: String): Sw_Integer; +VAR I, J: Sw_Integer; +BEGIN + J := 0; { Set result to zero } + For I := 1 To Length(S) Do + If (S[I] <> '~') Then Inc(J); { Inc count if not ~ } + CStrLen := J; { Return length } +END; + +{---------------------------------------------------------------------------} +{ MoveStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE MoveStr (Var Dest; Const Str: String; Attr: Byte); +VAR I: Word; P: PWord; +BEGIN + For I := 1 To Length(Str) Do Begin { For each character } + P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word } + If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute } + WordRec(P^).Lo := Byte(Str[I]); { Copy string char } + End; +END; + +{---------------------------------------------------------------------------} +{ MoveCStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE MoveCStr (Var Dest; Const Str: String; Attrs: Word); +VAR B: Byte; I, J: Sw_Word; P: PWord; +BEGIN + J := 0; { Start position } + For I := 1 To Length(Str) Do Begin { For each character } + If (Str[I] <> '~') Then Begin { Not tilde character } + P := @TWordArray(Dest)[J]; { Pointer to Sw_Word } + If (Lo(Attrs) <> 0) Then + WordRec(P^).Hi := Lo(Attrs); { Copy attribute } + WordRec(P^).Lo := Byte(Str[I]); { Copy string char } + Inc(J); { Next position } + End Else Begin + B := Hi(Attrs); { Hold attribute } + WordRec(Attrs).Hi := Lo(Attrs); { Copy low to high } + WordRec(Attrs).Lo := B; { Complete exchange } + End; + End; +END; + +{---------------------------------------------------------------------------} +{ MoveBuf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; Count: Sw_Word); +VAR I: Word; P: PWord; +BEGIN + For I := 1 To Count Do Begin + P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word } + If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute } + WordRec(P^).Lo := TByteArray(Source)[I-1]; { Copy source data } + End; +END; + +{---------------------------------------------------------------------------} +{ MoveChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE MoveChar (Var Dest; C: Char; Attr: Byte; Count: Sw_Word); +VAR I: Word; P: PWord; +BEGIN + For I := 1 To Count Do Begin + P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word } + If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute } + If (Ord(C) <> 0) Then WordRec(P^).Lo := Byte(C); { Copy character } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ KEYBOARD SUPPORT ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ GetAltCode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetAltCode (Ch: Char): Word; +BEGIN + GetAltCode := 0; { Preset zero return } + Ch := UpCase(Ch); { Convert upper case } + If (Ch < #128) Then + GetAltCode := AltCodes[Ord(Ch)] SHL 8 { Return code } + Else If (Ch = #240) Then GetAltCode := $0200 { Return code } + Else GetAltCode := 0; { Return zero } +END; + +{---------------------------------------------------------------------------} +{ GetCtrlCode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetCtrlCode (Ch: Char): Word; +BEGIN + GetCtrlCode := GetAltCode(Ch) OR (Ord(Ch) - $40); { Ctrl+key code } +END; + +{---------------------------------------------------------------------------} +{ GetAltChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetAltChar (KeyCode: Word): Char; +VAR I: Sw_Integer; +BEGIN + GetAltChar := #0; { Preset fail return } + If (Lo(KeyCode) = 0) Then Begin { Extended key } + If (Hi(KeyCode) <= $83) Then Begin { Highest value in list } + I := 0; { Start at first } + While (I < 128) AND (Hi(KeyCode) <> AltCodes[I]) + Do Inc(I); { Search for match } + If (I < 128) Then GetAltChar := Chr(I); { Return character } + End Else + If (Hi(KeyCode)=$02) Then GetAltChar := #240; { Return char } + End; +END; + +{---------------------------------------------------------------------------} +{ GetCtrlChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetCtrlChar (KeyCode: Word): Char; +VAR C: Char; +BEGIN + C := #0; { Preset #0 return } + If (Lo(KeyCode) > 0) AND (Lo(KeyCode) <= 26) Then { Between 1-26 } + C := Chr(Lo(KeyCode) + $40); { Return char A-Z } + GetCtrlChar := C; { Return result } +END; + +{---------------------------------------------------------------------------} +{ CtrlToArrow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB } +{---------------------------------------------------------------------------} +FUNCTION CtrlToArrow (KeyCode: Word): Word; +CONST NumCodes = 11; + CtrlCodes : Array [0..NumCodes-1] Of Char = + (#19, #4, #5, #24, #1, #6, #7, #22, #18, #3, #8); + ArrowCodes: Array [0..NumCodes-1] Of Sw_Word = + (kbLeft, kbRight, kbUp, kbDown, kbHome, kbEnd, kbDel, kbIns, + kbPgUp, kbPgDn, kbBack); +VAR I: Sw_Integer; +BEGIN + CtrlToArrow := KeyCode; { Preset key return } + For I := 0 To NumCodes - 1 Do + If WordRec(KeyCode).Lo = Byte(CtrlCodes[I]) { Matches a code } + Then Begin + CtrlToArrow := ArrowCodes[I]; { Return key stroke } + Exit; { Now exit } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ KEYBOARD CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ GetShiftState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul96 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetShiftState: Byte; +begin + GetShiftState:=Keyboard.GetKeyEventShiftState(Keyboard.PollShiftStateEvent); +end; + +{---------------------------------------------------------------------------} +{ GetKeyEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} +procedure GetKeyEvent (Var Event: TEvent); +var + key : TKeyEvent; + keycode : Word; + keyshift : byte; +begin + if Keyboard.PollKeyEvent<>0 then + begin + key:=Keyboard.GetKeyEvent; + keycode:=Keyboard.GetKeyEventCode(key); + keyshift:=KeyBoard.GetKeyEventShiftState(key); + { fixup shift-keys } + if keyshift and kbShift<>0 then + begin + case keycode of + $5200 : keycode:=kbShiftIns; + $5300 : keycode:=kbShiftDel; + $8500 : keycode:=kbShiftF1; + $8600 : keycode:=kbShiftF2; + end; + end + { fixup ctrl-keys } + else if keyshift and kbCtrl<>0 then + begin + case keycode of + $5200, + $9200 : keycode:=kbCtrlIns; + $5300, + $9300 : keycode:=kbCtrlDel; + end; + end + { fixup alt-keys } + else if keyshift and kbAlt<>0 then + begin + case keycode of + $0e08, + $0e00 : keycode:=kbAltBack; + end; + end + { fixup normal keys } + else + begin + case keycode of + $e00d : keycode:=kbEnter; + end; + end; + Event.What:=evKeyDown; + Event.KeyCode:=keycode; +{$ifdef ENDIAN_LITTLE} + Event.CharCode:=chr(keycode and $ff); + Event.ScanCode:=keycode shr 8; +{$endif ENDIAN_LITTLE} + Event.KeyShift:=keyshift; + end + else + Event.What:=evNothing; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MOUSE CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ HideMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun98 LdB } +{---------------------------------------------------------------------------} +procedure HideMouse; +begin +{ Is mouse hidden yet? + If (HideCount = 0) Then} + Mouse.HideMouse; +{ Inc(HideCount);} +end; + +{---------------------------------------------------------------------------} +{ ShowMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun98 LdB } +{---------------------------------------------------------------------------} +procedure ShowMouse; +begin +{ if HideCount>0 then + dec(HideCount); + if (HideCount=0) then} + Mouse.ShowMouse; +end; + +{---------------------------------------------------------------------------} +{ GetMouseEvent -> Platforms DOS/DPMI/WINDOWS/OS2 - Updated 30Jun98 LdB } +{---------------------------------------------------------------------------} +procedure GetMouseEvent (Var Event: TEvent); +var + e : Mouse.TMouseEvent; +begin + if Mouse.PollMouseEvent(e) then + begin + Mouse.GetMouseEvent(e); + MouseWhere.X:=e.x; + MouseWhere.Y:=e.y; + Event.Double:=false; + case e.Action of + MouseActionMove : + Event.What:=evMouseMove; + MouseActionDown : + begin + Event.What:=evMouseDown; + if (DownButtons=e.Buttons) and (LastWhere.X=MouseWhere.X) and (LastWhere.Y=MouseWhere.Y) and + (GetDosTicks-DownTicks<=DoubleDelay) then + Event.Double:=true; + DownButtons:=e.Buttons; + DownWhere.X:=MouseWhere.x; + DownWhere.Y:=MouseWhere.y; + DownTicks:=GetDosTicks; + AutoTicks:=GetDosTicks; + if AutoTicks=0 then + AutoTicks:=1; + AutoDelay:=RepeatDelay; + end; + MouseActionUp : + begin + AutoTicks:=0; + Event.What:=evMouseUp; + AutoTicks:=0; + end; + end; + Event.Buttons:=e.Buttons; + Event.Where.X:=MouseWhere.x; + Event.Where.Y:=MouseWhere.y; + LastButtons:=Event.Buttons; + LastWhere.x:=Event.Where.x; + LastWhere.y:=Event.Where.y; + end + else if (AutoTicks <> 0) and (GetDosTicks >= AutoTicks + AutoDelay) then + begin + Event.What:=evMouseAuto; + Event.Buttons:=LastButtons; + Event.Where.X:=LastWhere.x; + Event.Where.Y:=LastWhere.y; + AutoTicks:=GetDosTicks; + AutoDelay:=1; + end + else + FillChar(Event,sizeof(TEvent),0); + if MouseReverse and ((Event.Buttons and 3) in [1,2]) then + Event.Buttons := Event.Buttons xor 3; +end; + +{---------------------------------------------------------------------------} +{ GetSystemEvent } +{---------------------------------------------------------------------------} +procedure GetSystemEvent (Var Event: TEvent); +var + SysEvent : TsystemEvent; +begin + if PollSystemEvent(SysEvent) then + begin + SysMsg.GetSystemEvent(SysEvent); + case SysEvent.typ of + SysNothing : + Event.What:=evNothing; + SysSetFocus : + begin + Event.What:=evBroadcast; + Event.Command:=cmReceivedFocus; + end; + SysReleaseFocus : + begin + Event.What:=evBroadcast; + Event.Command:=cmReleasedFocus; + end; + SysClose : + begin + Event.What:=evCommand; + Event.Command:=cmQuitApp; + end; + SysResize : + begin + Event.What:=evCommand; + Event.Command:=cmResizeApp; + Event.Id:=SysEvent.x; + Event.InfoWord:=SysEvent.y; + end; + else + Event.What:=evNothing; + end; + end + else + Event.What:=evNothing; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ EVENT HANDLER CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ InitEvents -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 07Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE InitEvents; +BEGIN + If (ButtonCount <> 0) Then + begin { Mouse is available } + Mouse.InitMouse; { Hook the mouse } + { this is required by the use of HideCount variable } + Mouse.ShowMouse; { visible by default } + { HideCount:=0; } + LastButtons := 0; { Clear last buttons } + DownButtons := 0; { Clear down buttons } + MouseWhere.X:=Mouse.GetMouseX; + MouseWhere.Y:=Mouse.GetMouseY; { Get mouse position } + LastWhere.x:=MouseWhere.x; + LastWhereX:=MouseWhere.x; + LastWhere.y:=MouseWhere.y; + LastWhereY:=MouseWhere.y; + MouseEvents := True; { Set initialized flag } + end; + InitSystemMsg; +END; + +{---------------------------------------------------------------------------} +{ DoneEvents -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DoneEvents; +BEGIN + DoneSystemMsg; + Mouse.DoneMouse; + MouseEvents:=false; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ VIDEO CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +const + VideoInitialized : boolean = false; + +{---------------------------------------------------------------------------} +{ InitKeyboard -> Platforms ALL - 07May06 DM } +{---------------------------------------------------------------------------} + +procedure initkeyboard;inline; + +begin + keyboard.initkeyboard; +end; + +{---------------------------------------------------------------------------} +{ DoneKeyboard -> Platforms ALL - 07May06 DM } +{---------------------------------------------------------------------------} + +procedure donekeyboard;inline; + +begin + keyboard.donekeyboard; +end; + +{---------------------------------------------------------------------------} +{ InitVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Nov99 LdB } +{---------------------------------------------------------------------------} +function InitVideo:boolean; + +var StoreScreenMode : TVideoMode; + +begin + initvideo:=false; + if VideoInitialized then + begin + StoreScreenMode:=ScreenMode; + DoneVideo; + end + else + StoreScreenMode.Col:=0; + + Video.InitVideo; + if video.errorcode<>viook then + exit; + GetVideoMode(StartupScreenMode); + GetVideoMode(ScreenMode); +{$ifdef win32} + { Force the console to the current screen mode } + Video.SetVideoMode(ScreenMode); +{$endif win32} + + If (StoreScreenMode.Col<>0) and + ((StoreScreenMode.color<>ScreenMode.color) or + (StoreScreenMode.row<>ScreenMode.row) or + (StoreScreenMode.col<>ScreenMode.col)) then + begin + Video.SetVideoMode(StoreScreenMode); + GetVideoMode(ScreenMode); + end; + + if ScreenWidth > MaxViewWidth then + ScreenWidth := MaxViewWidth; + ScreenWidth:=Video.ScreenWidth; + ScreenHeight:=Video.ScreenHeight; + VideoInitialized:=true; + initvideo:=true; +end; + +{---------------------------------------------------------------------------} +{ DoneVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DoneVideo; +BEGIN + if not VideoInitialized then + exit; + Video.SetVideoMode(StartupScreenMode); + Video.ClearScreen; + Video.SetCursorPos(0,0); + Video.DoneVideo; + VideoInitialized:=false; +END; + +{---------------------------------------------------------------------------} +{ ClearScreen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Jan97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE ClearScreen; +BEGIN + Video.ClearScreen; +END; + +{---------------------------------------------------------------------------} +{ SetVideoMode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Nov99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE SetVideoMode (Mode: Sw_Word); +BEGIN +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ ERROR CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ InitSysError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE InitSysError; +BEGIN + SysErrActive := True; { Set active flag } +END; + +{---------------------------------------------------------------------------} +{ DoneSysError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DoneSysError; +BEGIN + SysErrActive := False; { Clear active flag } +END; + +{---------------------------------------------------------------------------} +{ SystemError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION SystemError (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer; +BEGIN + If (FailSysErrors = False) Then Begin { Check error ignore } + + End Else SystemError := 1; { Return 1 for ignored } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STRING FORMAT ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ PrintStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Feb99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE PrintStr (CONST S: String); +BEGIN + Write(S); { Write to screen } +END; + +{---------------------------------------------------------------------------} +{ FormatStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 13Jul99 LdB } +{---------------------------------------------------------------------------} +procedure FormatStr (Var Result: String; CONST Format: String; Var Params); +TYPE TLongArray = Array[0..0] Of PtrInt; +VAR W, ResultLength : integer; + FormatIndex, Justify, Wth: Byte; + Fill: Char; S: String; + + FUNCTION LongToStr (L: Longint; Radix: Byte): String; + CONST HexChars: Array[0..15] Of Char = + ('0', '1', '2', '3', '4', '5', '6', '7', + '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'); + VAR I: LongInt; S: String; Sign: String[1]; + begin + LongToStr := ''; { Preset empty return } + If (L < 0) Then begin { If L is negative } + Sign := '-'; { Sign is negative } + L := Abs(L); { Convert to positive } + end Else Sign := ''; { Sign is empty } + S := ''; { Preset empty string } + Repeat + I := L MOD Radix; { Radix mod of value } + S := HexChars[I] + S; { Add char to string } + L := L DIV Radix; { Divid by radix } + Until (L = 0); { Until no remainder } + LongToStr := Sign + S; { Return result } + end; + + procedure HandleParameter (I : LongInt); + begin + While (FormatIndex <= Length(Format)) Do begin { While length valid } + if ResultLength>=High(Result) then + exit; + While (FormatIndex <= Length(Format)) and + (Format[FormatIndex] <> '%') { Param char not found } + Do begin + Result[ResultLength+1] := Format[FormatIndex]; { Transfer character } + Inc(ResultLength); { One character added } + Inc(FormatIndex); { Next param char } + end; + If (FormatIndex < Length(Format)) and { Not last char and } + (Format[FormatIndex] = '%') Then begin { '%' char found } + Fill := ' '; { Default fill char } + Justify := 0; { Default justify } + Wth := 0; { Default 0=no width } + Inc(FormatIndex); { Next character } + If (Format[FormatIndex] = '0') Then + Fill := '0'; { Fill char to zero } + If (Format[FormatIndex] = '-') Then begin { Optional just char } + Justify := 1; { Right justify } + Inc(FormatIndex); { Next character } + end; + While ((FormatIndex <= Length(Format)) and { Length still valid } + (Format[FormatIndex] >= '0') and + (Format[FormatIndex] <= '9')) Do begin { Numeric character } + Wth := Wth * 10; { Multiply x10 } + Wth := Wth + Ord(Format[FormatIndex])-$30; { Add numeric value } + Inc(FormatIndex); { Next character } + end; + If ((FormatIndex <= Length(Format)) and { Length still valid } + (Format[FormatIndex] = '#')) Then begin { Parameter marker } + Inc(FormatIndex); { Next character } + HandleParameter(Wth); { Width is param idx } + end; + If (FormatIndex <= Length(Format)) Then begin{ Length still valid } + Case Format[FormatIndex] Of + '%': begin { Literal % } + S := '%'; + Inc(FormatIndex); + Move(S[1], Result[ResultLength+1], 1); + Inc(ResultLength,Length(S)); + Continue; + end; + 'c': S := Char(TLongArray(Params)[I]); { Character parameter } + 'd': S := LongToStr(TLongArray(Params)[I], + 10); { Decimal parameter } + 's': S := PString(TLongArray(Params)[I])^;{ String parameter } + 'x': S := LongToStr(TLongArray(Params)[I], + 16); { Hex parameter } + end; + Inc(FormatIndex); { Next character } + If (Wth > 0) Then begin { Width control active } + If (Length(S) > Wth) Then begin { We must shorten S } + If (Justify=1) Then { Check right justify } + S := Copy(S, Length(S)-Wth+1, Wth) { Take right side data } + Else S := Copy(S, 1, Wth); { Take left side data } + end Else begin { We must pad out S } + If (Justify=1) Then { Right justify } + While (Length(S) < Wth) Do + S := S+Fill Else { Right justify fill } + While (Length(S) < Wth) Do + S := Fill + S; { Left justify fill } + end; + end; + W:=Length(S); + if W+ResultLength+1>High(Result) then + W:=High(Result)-ResultLength; + Move(S[1], Result[ResultLength+1], + W); { Move data to result } + Inc(ResultLength,W); { Adj result length } + Inc(I); + end; + end; + end; + end; + +begin + ResultLength := 0; { Zero result length } + FormatIndex := 1; { Format index to 1 } + HandleParameter(0); { Handle parameter } + Result[0] := Chr(ResultLength); { Set string length } +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ NEW QUEUED EVENT HANDLER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ PutEventInQueue -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Mar98 LdB } +{---------------------------------------------------------------------------} +FUNCTION PutEventInQueue (Var Event: TEvent): Boolean; +BEGIN + If (QueueCount < QueueMax) Then Begin { Check room in queue } + Queue[QueueHead] := Event; { Store event } + Inc(QueueHead); { Inc head position } + If (QueueHead = QueueMax) Then QueueHead := 0; { Roll to start check } + Inc(QueueCount); { Inc queue count } + PutEventInQueue := True; { Return successful } + End Else PutEventInQueue := False; { Return failure } +END; + +{---------------------------------------------------------------------------} +{ NextQueuedEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Mar98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE NextQueuedEvent(Var Event: TEvent); +BEGIN + If (QueueCount > 0) Then Begin { Check queued event } + Event := Queue[QueueTail]; { Fetch next event } + Inc(QueueTail); { Inc tail position } + If (QueueTail = QueueMax) Then QueueTail := 0; { Roll to start check } + Dec(QueueCount); { Dec queue count } + End Else Event.What := evNothing; { Return empty event } +END; + +{***************************************************************************} +{ UNIT INITIALIZATION ROUTINE } +{***************************************************************************} +BEGIN + ButtonCount := DetectMouse; { Detect mouse } + DetectVideo; { Detect video } +{ InitKeyboard;} + InitSystemMsg; +{$ifdef win32} + SetFileApisToOEM; +{$endif} + + SaveExit := ExitProc; { Save old exit } + ExitProc := @ExitDrivers; { Set new exit } +END. diff --git a/packages/fv/src/editors.pas b/packages/fv/src/editors.pas new file mode 100644 index 0000000000..4503b8359c --- /dev/null +++ b/packages/fv/src/editors.pas @@ -0,0 +1,3797 @@ +unit Editors; + +{$i platform.inc} + +{$ifdef PPC_FPC} + {$H-} +{$else} + {$F+,O+,E+,N+} +{$endif} +{$X+,R-,I-,Q-,V-} +{$ifndef OS_UNIX} + {$S-} +{$endif} + + +{$define UNIXLF} + +{2.0 compatibility} +{$ifdef VER2_0} + {$macro on} + {$define resourcestring := const} +{$endif} + +interface + +uses + Objects, Drivers,Views,Dialogs,FVCommon,FVConsts; + +const + { Length constants. } + Tab_Stop_Length = 74; + +{$ifdef PPC_BP} + MaxLineLength = 1024; + MinBufLength = $1000; + MaxBufLength = $ff00; + NotFoundValue = $ffff; + LineInfoGrow = 256; + MaxLines = 16000; +{$else} + MaxLineLength = 4096; + MinBufLength = $1000; + MaxBufLength = $7fffff00; + NotFoundValue = $ffffffff; + LineInfoGrow = 1024; + MaxLines = $7ffffff; +{$endif} + + + { Editor constants for dialog boxes. } + edOutOfMemory = 0; + edReadError = 1; + edWriteError = 2; + edCreateError = 3; + edSaveModify = 4; + edSaveUntitled = 5; + edSaveAs = 6; + edFind = 7; + edSearchFailed = 8; + edReplace = 9; + edReplacePrompt = 10; + + edJumpToLine = 11; + edPasteNotPossible = 12; + edReformatDocument = 13; + edReformatNotAllowed = 14; + edReformNotPossible = 15; + edReplaceNotPossible = 16; + edRightMargin = 17; + edSetTabStops = 18; + edWrapNotPossible = 19; + + { Editor flag constants for dialog options. } + efCaseSensitive = $0001; + efWholeWordsOnly = $0002; + efPromptOnReplace = $0004; + efReplaceAll = $0008; + efDoReplace = $0010; + efBackupFiles = $0100; + + { Constants for object palettes. } + CIndicator = #2#3; + CEditor = #6#7; + CMemo = #26#27; + +type + TEditorDialog = function (Dialog : Integer; Info : Pointer) : Word; + + PIndicator = ^TIndicator; + TIndicator = object (TView) + Location : Objects.TPoint; + Modified : Boolean; + AutoIndent : Boolean; { Added boolean for AutoIndent mode. } + WordWrap : Boolean; { Added boolean for WordWrap mode. } + constructor Init (var Bounds : TRect); + procedure Draw; virtual; + function GetPalette : PPalette; virtual; + procedure SetState (AState : Word; Enable : Boolean); virtual; + procedure SetValue (ALocation : Objects.TPoint; IsAutoIndent : Boolean; + IsModified : Boolean; + IsWordWrap : Boolean); + end; + + TLineInfoRec = record + Len,Attr : Sw_word; + end; + TLineInfoArr = array[0..MaxLines] of TLineInfoRec; + PLineInfoArr = ^TLineInfoArr; + + PLineInfo = ^TLineInfo; + TLineInfo = object + Info : PLineInfoArr; + MaxPos : Sw_Word; + constructor Init; + destructor Done; + procedure Grow(pos:Sw_word); + procedure SetLen(pos,val:Sw_Word); + procedure SetAttr(pos,val:Sw_Word); + function GetLen(pos:Sw_Word):Sw_Word; + function GetAttr(pos:Sw_Word):Sw_Word; + end; + + + PEditBuffer = ^TEditBuffer; + TEditBuffer = array[0..MaxBufLength] of Char; + + PEditor = ^TEditor; + TEditor = object (TView) + HScrollBar : PScrollBar; + VScrollBar : PScrollBar; + Indicator : PIndicator; + Buffer : PEditBuffer; + BufSize : Sw_Word; + BufLen : Sw_Word; + GapLen : Sw_Word; + SelStart : Sw_Word; + SelEnd : Sw_Word; + CurPtr : Sw_Word; + CurPos : Objects.TPoint; + Delta : Objects.TPoint; + Limit : Objects.TPoint; + DrawLine : Sw_Integer; + DrawPtr : Sw_Word; + DelCount : Sw_Word; + InsCount : Sw_Word; + Flags : Longint; + IsReadOnly : Boolean; + IsValid : Boolean; + CanUndo : Boolean; + Modified : Boolean; + Selecting : Boolean; + Overwrite : Boolean; + AutoIndent : Boolean; + NoSelect : Boolean; + TabSize : Sw_Word; { tabsize for displaying } + BlankLine : Sw_Word; { First blank line after a paragraph. } + Word_Wrap : Boolean; { Added boolean to toggle wordwrap on/off. } + Line_Number : string[8]; { Holds line number to jump to. } + Right_Margin : Sw_Integer; { Added integer to set right margin. } + Tab_Settings : String[Tab_Stop_Length]; { Added string to hold tab stops. } + + constructor Init (var Bounds : TRect; AHScrollBar, AVScrollBar : PScrollBar; + AIndicator : PIndicator; ABufSize : Sw_Word); + constructor Load (var S : Objects.TStream); + destructor Done; virtual; + function BufChar (P : Sw_Word) : Char; + function BufPtr (P : Sw_Word) : Sw_Word; + procedure ChangeBounds (var Bounds : TRect); virtual; + procedure ConvertEvent (var Event : Drivers.TEvent); virtual; + function CursorVisible : Boolean; + procedure DeleteSelect; + procedure DoneBuffer; virtual; + procedure Draw; virtual; + procedure FormatLine (var DrawBuf; LinePtr : Sw_Word; Width : Sw_Integer; Colors : Word);virtual; + function GetPalette : PPalette; virtual; + procedure HandleEvent (var Event : Drivers.TEvent); virtual; + procedure InitBuffer; virtual; + function InsertBuffer (var P : PEditBuffer; Offset, Length : Sw_Word;AllowUndo, SelectText : Boolean) : Boolean; + function InsertFrom (Editor : PEditor) : Boolean; virtual; + function InsertText (Text : Pointer; Length : Sw_Word; SelectText : Boolean) : Boolean; + procedure ScrollTo (X, Y : Sw_Integer); + function Search (const FindStr : String; Opts : Word) : Boolean; + function SetBufSize (NewSize : Sw_Word) : Boolean; virtual; + procedure SetCmdState (Command : Word; Enable : Boolean); + procedure SetSelect (NewStart, NewEnd : Sw_Word; CurStart : Boolean); + procedure SetCurPtr (P : Sw_Word; SelectMode : Byte); + procedure SetState (AState : Word; Enable : Boolean); virtual; + procedure Store (var S : Objects.TStream); + procedure TrackCursor (Center : Boolean); + procedure Undo; + procedure UpdateCommands; virtual; + function Valid (Command : Word) : Boolean; virtual; + + private + KeyState : Integer; + LockCount : Byte; + UpdateFlags : Byte; + Place_Marker : Array [1..10] of Sw_Word; { Inserted array to hold place markers. } + Search_Replace : Boolean; { Added boolean to test for Search and Replace insertions. } + + procedure Center_Text (Select_Mode : Byte); + function CharPos (P, Target : Sw_Word) : Sw_Integer; + function CharPtr (P : Sw_Word; Target : Sw_Integer) : Sw_Word; + procedure Check_For_Word_Wrap (Select_Mode : Byte; Center_Cursor : Boolean); + function ClipCopy : Boolean; + procedure ClipCut; + procedure ClipPaste; + procedure DeleteRange (StartPtr, EndPtr : Sw_Word; DelSelect : Boolean); + procedure DoSearchReplace; + procedure DoUpdate; + function Do_Word_Wrap (Select_Mode : Byte; Center_Cursor : Boolean) : Boolean; + procedure DrawLines (Y, Count : Sw_Integer; LinePtr : Sw_Word); + procedure Find; + function GetMousePtr (Mouse : Objects.TPoint) : Sw_Word; + function HasSelection : Boolean; + procedure HideSelect; + procedure Insert_Line (Select_Mode : Byte); + function IsClipboard : Boolean; + procedure Jump_Place_Marker (Element : Byte; Select_Mode : Byte); + procedure Jump_To_Line (Select_Mode : Byte); + function LineEnd (P : Sw_Word) : Sw_Word; + function LineMove (P : Sw_Word; Count : Sw_Integer) : Sw_Word; + function LineStart (P : Sw_Word) : Sw_Word; + function LineNr (P : Sw_Word) : Sw_Word; + procedure Lock; + function NewLine (Select_Mode : Byte) : Boolean; + function NextChar (P : Sw_Word) : Sw_Word; + function NextLine (P : Sw_Word) : Sw_Word; + function NextWord (P : Sw_Word) : Sw_Word; + function PrevChar (P : Sw_Word) : Sw_Word; + function PrevLine (P : Sw_Word) : Sw_Word; + function PrevWord (P : Sw_Word) : Sw_Word; + procedure Reformat_Document (Select_Mode : Byte; Center_Cursor : Boolean); + function Reformat_Paragraph (Select_Mode : Byte; Center_Cursor : Boolean) : Boolean; + procedure Remove_EOL_Spaces (Select_Mode : Byte); + procedure Replace; + procedure Scroll_Down; + procedure Scroll_Up; + procedure Select_Word; + procedure SetBufLen (Length : Sw_Word); + procedure Set_Place_Marker (Element : Byte); + procedure Set_Right_Margin; + procedure Set_Tabs; + procedure StartSelect; + procedure Tab_Key (Select_Mode : Byte); + procedure ToggleInsMode; + procedure Unlock; + procedure Update (AFlags : Byte); + procedure Update_Place_Markers (AddCount : Word; KillCount : Word; StartPtr,EndPtr : Sw_Word); + end; + + TMemoData = record + Length : Sw_Word; + Buffer : TEditBuffer; + end; + + PMemo = ^TMemo; + TMemo = object (TEditor) + constructor Load (var S : Objects.TStream); + function DataSize : Sw_Word; virtual; + procedure GetData (var Rec); virtual; + function GetPalette : PPalette; virtual; + procedure HandleEvent (var Event : Drivers.TEvent); virtual; + procedure SetData (var Rec); virtual; + procedure Store (var S : Objects.TStream); + end; + + PFileEditor = ^TFileEditor; + TFileEditor = object (TEditor) + FileName : FNameStr; + constructor Init (var Bounds : TRect; AHScrollBar, AVScrollBar : PScrollBar; + AIndicator : PIndicator; AFileName : FNameStr); + constructor Load (var S : Objects.TStream); + procedure DoneBuffer; virtual; + procedure HandleEvent (var Event : Drivers.TEvent); virtual; + procedure InitBuffer; virtual; + function LoadFile : Boolean; + function Save : Boolean; + function SaveAs : Boolean; + function SaveFile : Boolean; + function SetBufSize (NewSize : Sw_Word) : Boolean; virtual; + procedure Store (var S : Objects.TStream); + procedure UpdateCommands; virtual; + function Valid (Command : Word) : Boolean; virtual; + end; + + PEditWindow = ^TEditWindow; + TEditWindow = object (TWindow) + Editor : PFileEditor; + constructor Init (var Bounds : TRect; FileName : FNameStr; ANumber : Integer); + constructor Load (var S : Objects.TStream); + procedure Close; virtual; + function GetTitle (MaxSize : Sw_Integer) : TTitleStr; virtual; + procedure HandleEvent (var Event : Drivers.TEvent); virtual; + procedure SizeLimits(var Min, Max: TPoint); virtual; + procedure Store (var S : Objects.TStream); + end; + + +function DefEditorDialog (Dialog : Integer; Info : Pointer) : Word; +function CreateFindDialog: PDialog; +function CreateReplaceDialog: PDialog; +function JumpLineDialog : PDialog; +function ReformDocDialog : PDialog; +function RightMarginDialog : PDialog; +function TabStopDialog : Dialogs.PDialog; +function StdEditorDialog(Dialog: Integer; Info: Pointer): Word; + +const + WordChars : set of Char = ['!'..#255]; + + LineBreak : string[2]= +{$ifdef UNIXLF} + #10; +{$else} + #13#10; +{$endif} + + + { The Allow_Reformat boolean is a programmer hook. } + { I've placed this here to allow programmers to } + { determine whether or not paragraph and document } + { reformatting are allowed if Word_Wrap is not } + { active. Some people say don't allow, and others } + { say allow it. I've left it up to the programmer. } + { Set to FALSE if not allowed, or TRUE if allowed. } + Allow_Reformat : Boolean = True; + + EditorDialog : TEditorDialog = {$ifdef fpc}@{$endif}DefEditorDialog; + EditorFlags : Word = efBackupFiles + efPromptOnReplace; + FindStr : String[80] = ''; + ReplaceStr : String[80] = ''; + Clipboard : PEditor = nil; + + ToClipCmds : TCommandSet = ([cmCut,cmCopy,cmClear]); + FromClipCmds : TCommandSet = ([cmPaste]); + UndoCmds : TCommandSet = ([cmUndo,cmRedo]); + +TYPE + TFindDialogRec = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + Find : String[80]; + Options : Word; + end; + + TReplaceDialogRec = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + Find : String[80]; + Replace : String[80]; + Options : Word; + end; + + TRightMarginRec = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + Margin_Position : String[3]; + end; + + TTabStopRec = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + Tab_String : String [Tab_Stop_Length]; + end; + +CONST + { VMT constants. } + REditor : TStreamRec = (ObjType : 70; + VmtLink : Ofs (TypeOf (TEditor)^); + Load : @TEditor.Load; + Store : @TEditor.Store); + + RMemo : TStreamRec = (ObjType : 71; + VmtLink : Ofs (TypeOf (TMemo)^); + Load : @TMemo.Load; + Store : @TMemo.Store); + + RFileEditor : TStreamRec = (ObjType : 72; + VmtLink : Ofs (TypeOf (TFileEditor)^); + Load : @TFileEditor.Load; + Store : @TFileEditor.Store); + + RIndicator : TStreamRec = (ObjType : 73; + VmtLink : Ofs (TypeOf (TIndicator)^); + Load : @TIndicator.Load; + Store : @TIndicator.Store); + + REditWindow : TStreamRec = (ObjType : 74; + VmtLink : Ofs (TypeOf (TEditWindow)^); + Load : @TEditWindow.Load; + Store : @TEditWindow.Store); + +procedure RegisterEditors; + + +{**************************************************************************** + Implementation +****************************************************************************} + +implementation + +uses + Dos, App, StdDlg, MsgBox{, Resource}; + +type + pword = ^word; + +resourcestring sClipboard='Clipboard'; + sFileCreateError='Error creating file %s'; + sFileReadError='Error reading file %s'; + sFileUntitled='Save untitled file?'; + sFileWriteError='Error writing to file %s'; + sFind='Find'; + sJumpTo='Jump To'; + sModified=''#3'%s'#13#10#13#3'has been modified. Save?'; + sOutOfMemory='Not enough memory for this operation.'; + sPasteNotPossible='Wordwrap on: Paste not possible in current margins when at end of line.'; + sReformatDocument='Reformat Document'; + sReformatNotPossible='Paragraph reformat not possible while trying to wrap current line with current margins.'; + sReformattingTheDocument='Reformatting the document:'; + sReplaceNotPossible='Wordwrap on: Replace not possible in current margins when at end of line.'; + sReplaceThisOccurence='Replace this occurence?'; + sRightMargin='Right Margin'; + sSearchStringNotFound='Search string not found.'; + sSelectWhereToBegin='Please select where to begin.'; + sSetting='Setting:'; + sTabSettings='Tab Settings'; + sUnknownDialog='Unknown dialog requested!'; + sUntitled='Untitled'; + sWordWrapNotPossible='Wordwrap on: Wordwrap not possible in current margins with continuous line.'; + sWordWrapOff='You must turn on wordwrap before you can reformat.'; + + slCaseSensitive='~C~ase sensitive'; + slCurrentLine='~C~urrent line'; + slEntireDocument='~E~ntire document'; + slLineNumber='~L~ine number'; + slNewText='~N~ew text'; + slPromptOnReplace='~P~rompt on replace'; + slReplace='~R~eplace'; + slReplaceAll='~R~eplace all'; + slTextToFind='~T~ext to find'; + slWholeWordsOnly='~W~hole words only'; + + +CONST + { Update flag constants. } + ufUpdate = $01; + ufLine = $02; + ufView = $04; + ufStats = $05; + + { SelectMode constants. } + smExtend = $01; + smDouble = $02; + + sfSearchFailed = NotFoundValue; + + { Arrays that hold all the command keys and options. } + FirstKeys : array[0..46 * 2] of Word = (46, Ord (^A), cmWordLeft, + Ord (^B), cmReformPara, + Ord (^C), cmPageDown, + Ord (^D), cmCharRight, + Ord (^E), cmLineUp, + Ord (^F), cmWordRight, + Ord (^G), cmDelChar, + Ord (^H), cmBackSpace, + Ord (^I), cmTabKey, + Ord (^J), $FF04, + Ord (^K), $FF02, + Ord (^L), cmSearchAgain, + Ord (^M), cmNewLine, + Ord (^N), cmInsertLine, + Ord (^O), $FF03, + Ord (^Q), $FF01, + Ord (^R), cmPageUp, + Ord (^S), cmCharLeft, + Ord (^T), cmDelWord, + Ord (^U), cmUndo, + Ord (^V), cmInsMode, + Ord (^W), cmScrollUp, + Ord (^X), cmLineDown, + Ord (^Y), cmDelLine, + Ord (^Z), cmScrollDown, + kbLeft, cmCharLeft, + kbRight, cmCharRight, + kbCtrlLeft, cmWordLeft, + kbCtrlRight, cmWordRight, + kbHome, cmLineStart, + kbEnd, cmLineEnd, + kbCtrlHome, cmHomePage, + kbCtrlEnd, cmEndPage, + kbUp, cmLineUp, + kbDown, cmLineDown, + kbPgUp, cmPageUp, + kbPgDn, cmPageDown, + kbCtrlPgUp, cmTextStart, + kbCtrlPgDn, cmTextEnd, + kbIns, cmInsMode, + kbDel, cmDelChar, + kbCtrlBack, cmDelStart, + kbShiftIns, cmPaste, + kbShiftDel, cmCut, + kbCtrlIns, cmCopy, + kbCtrlDel, cmClear); + + { SCRLUP - Stop. } { Added ^W to scroll screen up. } + { SCRLDN - Stop. } { Added ^Z to scroll screen down. } + { REFORM - Stop. } { Added ^B for paragraph reformatting. } + { PRETAB - Stop. } { Added ^I for preset tabbing. } + { JLINE - Stop. } { Added ^J to jump to a line number. } + { INSLIN - Stop. } { Added ^N to insert line at cursor. } + { INDENT - Stop. } { Removed ^O and put it into ^QI. } + { HOMEND - Stop. } { Added kbCtrlHome and kbCtrlEnd pages. } + { CTRLBK - Stop. } { Added kbCtrlBack same as ^QH. } + + QuickKeys : array[0..21 * 2] of Word = (21, Ord ('0'), cmJumpMark0, + Ord ('1'), cmJumpMark1, + Ord ('2'), cmJumpMark2, + Ord ('3'), cmJumpMark3, + Ord ('4'), cmJumpMark4, + Ord ('5'), cmJumpMark5, + Ord ('6'), cmJumpMark6, + Ord ('7'), cmJumpMark7, + Ord ('8'), cmJumpMark8, + Ord ('9'), cmJumpMark9, + Ord ('A'), cmReplace, + Ord ('C'), cmTextEnd, + Ord ('D'), cmLineEnd, + Ord ('F'), cmFind, + Ord ('H'), cmDelStart, + Ord ('I'), cmIndentMode, + Ord ('L'), cmUndo, + Ord ('R'), cmTextStart, + Ord ('S'), cmLineStart, + Ord ('U'), cmReformDoc, + Ord ('Y'), cmDelEnd); + + { UNDO - Stop. } { Added IDE undo feature of ^QL. } + { REFDOC - Stop. } { Added document reformat feature if ^QU pressed. } + { MARK - Stop. } { Added cmJumpMark# to allow place marking. } + { INDENT - Stop. } { Moved IndentMode here from Firstkeys. } + + BlockKeys : array[0..20 * 2] of Word = (20, Ord ('0'), cmSetMark0, + Ord ('1'), cmSetMark1, + Ord ('2'), cmSetMark2, + Ord ('3'), cmSetMark3, + Ord ('4'), cmSetMark4, + Ord ('5'), cmSetMark5, + Ord ('6'), cmSetMark6, + Ord ('7'), cmSetMark7, + Ord ('8'), cmSetMark8, + Ord ('9'), cmSetMark9, + Ord ('B'), cmStartSelect, + Ord ('C'), cmPaste, + Ord ('D'), cmSave, + Ord ('F'), cmSaveAs, + Ord ('H'), cmHideSelect, + Ord ('K'), cmCopy, + Ord ('S'), cmSave, + Ord ('T'), cmSelectWord, + Ord ('Y'), cmCut, + Ord ('X'), cmSaveDone); + + { SELWRD - Stop. } { Added ^KT to select word only. } + { SAVE - Stop. } { Added ^KD, ^KF, ^KS, ^KX key commands. } + { MARK - Stop. } { Added cmSetMark# to allow place marking. } + + FormatKeys : array[0..5 * 2] of Word = (5, Ord ('C'), cmCenterText, + Ord ('T'), cmCenterText, + Ord ('I'), cmSetTabs, + Ord ('R'), cmRightMargin, + Ord ('W'), cmWordWrap); + + { WRAP - Stop. } { Added Wordwrap feature if ^OW pressed. } + { RMSET - Stop. } { Added set right margin feature if ^OR pressed. } + { PRETAB - Stop. } { Added preset tab feature if ^OI pressed. } + { CENTER - Stop. } { Added center text option ^OC for a line. } + + JumpKeys : array[0..1 * 2] of Word = (1, Ord ('L'), cmJumpLine); + + { JLINE - Stop. } { Added jump to line number feature if ^JL pressed. } + + KeyMap : array[0..4] of Pointer = (@FirstKeys, + @QuickKeys, + @BlockKeys, + @FormatKeys, + @JumpKeys); + + { WRAP - Stop. } { Added @FormatKeys for new ^O? keys. } + { PRETAB - Stop. } { Added @FormatKeys for new ^O? keys. } + { JLINE - Stop. } { Added @JumpKeys for new ^J? keys. } + { CENTER - Stop. } { Added @FormatKeys for new ^O? keys. } + + +{**************************************************************************** + Dialogs +****************************************************************************} + +function DefEditorDialog (Dialog : Integer; Info : Pointer) : Word; +begin + DefEditorDialog := cmCancel; +end; { DefEditorDialog } + + +function CreateFindDialog: PDialog; +var + D: PDialog; + Control: PView; + R: TRect; +begin + R.Assign(0, 0, 38, 12); + D := New(PDialog, Init(R,sFind)); + with D^ do + begin + Options := Options or ofCentered; + + R.Assign(3, 3, 32, 4); + Control := New(PInputLine, Init(R, 80)); + Control^.HelpCtx := hcDFindText; + Insert(Control); + R.Assign(2, 2, 15, 3); + Insert(New(PLabel, Init(R, slTextToFind, Control))); + R.Assign(32, 3, 35, 4); + Insert(New(PHistory, Init(R, PInputLine(Control), 10))); + + R.Assign(3, 5, 35, 7); + Control := New(PCheckBoxes, Init(R, + NewSItem (slCaseSensitive, + NewSItem (slWholeWordsOnly,nil)))); + Control^.HelpCtx := hcCCaseSensitive; + Insert(Control); + + R.Assign(14, 9, 24, 11); + Control := New (PButton, Init(R,slOK,cmOk,bfDefault)); + Control^.HelpCtx := hcDOk; + Insert (Control); + + Inc(R.A.X, 12); Inc(R.B.X, 12); + Control := New (PButton, Init(R,slCancel,cmCancel, bfNormal)); + Control^.HelpCtx := hcDCancel; + Insert (Control); + + SelectNext(False); + end; + CreateFindDialog := D; +end; + + +function CreateReplaceDialog: PDialog; +var + D: PDialog; + Control: PView; + R: TRect; +begin + R.Assign(0, 0, 40, 16); + D := New(PDialog, Init(R,slReplace)); + with D^ do + begin + Options := Options or ofCentered; + + R.Assign(3, 3, 34, 4); + Control := New(PInputLine, Init(R, 80)); + Control^.HelpCtx := hcDFindText; + Insert(Control); + R.Assign(2, 2, 15, 3); + Insert(New(PLabel, Init(R,slTextToFind, Control))); + R.Assign(34, 3, 37, 4); + Insert(New(PHistory, Init(R, PInputLine(Control), 10))); + + R.Assign(3, 6, 34, 7); + Control := New(PInputLine, Init(R, 80)); + Control^.HelpCtx := hcDReplaceText; + Insert(Control); + R.Assign(2, 5, 12, 6); + Insert(New(PLabel, Init(R,slNewText, Control))); + R.Assign(34, 6, 37, 7); + Insert(New(PHistory, Init(R, PInputLine(Control), 11))); + + R.Assign(3, 8, 37, 12); + Control := New (Dialogs.PCheckBoxes, Init (R, + NewSItem (slCasesensitive, + NewSItem (slWholewordsonly, + NewSItem (slPromptonreplace, + NewSItem (slReplaceall, nil)))))); + Control^.HelpCtx := hcCCaseSensitive; + Insert (Control); + + R.Assign (8, 13, 18, 15); + Control := New (PButton, Init (R,slOK, cmOk, bfDefault)); + Control^.HelpCtx := hcDOk; + Insert (Control); + + R.Assign (22, 13, 32, 15); + Control := New (PButton, Init (R,slCancel, cmCancel, bfNormal)); + Control^.HelpCtx := hcDCancel; + Insert (Control); + + SelectNext(False); + end; + CreateReplaceDialog := D; +end; + + +function JumpLineDialog : PDialog; +VAR + D : PDialog; + R : TRect; + Control: PView; +Begin + R.Assign (0, 0, 26, 8); + D := New(PDialog, Init(R,sJumpTo)); + with D^ do + begin + Options := Options or ofCentered; + + R.Assign (3, 2, 15, 3); + Control := New (Dialogs.PStaticText, Init (R,slLineNumber)); + Insert (Control); + + R.Assign (15, 2, 21, 3); + Control := New (Dialogs.PInputLine, Init (R, 4)); + Control^.HelpCtx := hcDLineNumber; + Insert (Control); + + R.Assign (21, 2, 24, 3); + Insert (New (Dialogs.PHistory, Init (R, Dialogs.PInputLine (Control), 12))); + + R.Assign (2, 5, 12, 7); + Control := New (Dialogs.PButton, Init (R, slOK, cmOK, Dialogs.bfDefault)); + Control^.HelpCtx := hcDOk; + Insert (Control); + + R.Assign (14, 5, 24, 7); + Control := New (Dialogs.PButton, Init (R, slCancel, cmCancel, Dialogs.bfNormal)); + Control^.HelpCtx := hcDCancel; + Insert (Control); + + SelectNext (False); + end; + JumpLineDialog := D; +end; { JumpLineDialog } + + +function ReformDocDialog : Dialogs.PDialog; + { This is a local function that brings up a dialog box } + { that asks where to start reformatting the document. } +VAR + R : TRect; + D : Dialogs.PDialog; + Control : PView; +Begin + R.Assign (0, 0, 32, 11); + D := New (Dialogs.PDialog, Init (R, sReformatDocument)); + with D^ do + begin + Options := Options or ofCentered; + + R.Assign (2, 2, 30, 3); + Control := New (Dialogs.PStaticText, Init (R, sSelectWhereToBegin)); + Insert (Control); + + R.Assign (3, 3, 29, 4); + Control := New (Dialogs.PStaticText, Init (R, sReformattingTheDocument)); + Insert (Control); + + R.Assign (50, 5, 68, 6); + Control := New (Dialogs.PLabel, Init (R, sReformatDocument, Control)); + Insert (Control); + + R.Assign (5, 5, 26, 7); + Control := New (Dialogs.PRadioButtons, Init (R, + NewSItem (slCurrentLine, + NewSItem (slEntireDocument, Nil)))); + Control^.HelpCtx := hcDReformDoc; + Insert (Control); + + R.Assign (4, 8, 14, 10); + Control := New (Dialogs.PButton, Init (R, slOK, cmOK, Dialogs.bfDefault)); + Control^.HelpCtx := hcDOk; + Insert (Control); + + R.Assign (17, 8, 27, 10); + Control := New (Dialogs.PButton, Init (R, slCancel, cmCancel, Dialogs.bfNormal)); + Control^.HelpCtx := hcDCancel; + Insert (Control); + + SelectNext (False); + end; + ReformDocDialog := D; +end; { ReformDocDialog } + + +function RightMarginDialog : Dialogs.PDialog; + { This is a local function that brings up a dialog box } + { that allows the user to change the Right_Margin. } +VAR + R : TRect; + D : PDialog; + Control : PView; +Begin + R.Assign (0, 0, 26, 8); + D := New (Dialogs.PDialog, Init (R, sRightMargin)); + with D^ do + begin + Options := Options or ofCentered; + + R.Assign (5, 2, 13, 3); + Control := New (Dialogs.PStaticText, Init (R, sSetting)); + Insert (Control); + + R.Assign (13, 2, 18, 3); + Control := New (Dialogs.PInputLine, Init (R, 3)); + Control^.HelpCtx := hcDRightMargin; + Insert (Control); + + R.Assign (18, 2, 21, 3); + Insert (New (Dialogs.PHistory, Init (R, Dialogs.PInputLine (Control), 13))); + + R.Assign (2, 5, 12, 7); + Control := New (Dialogs.PButton, Init (R, slOK, cmOK, Dialogs.bfDefault)); + Control^.HelpCtx := hcDOk; + Insert (Control); + + R.Assign (14, 5, 24, 7); + Control := New (Dialogs.PButton, Init (R, slCancel, cmCancel, Dialogs.bfNormal)); + Control^.HelpCtx := hcDCancel; + Insert (Control); + + SelectNext (False); + end; + RightMarginDialog := D; +end; { RightMarginDialog; } + + +function TabStopDialog : Dialogs.PDialog; + { This is a local function that brings up a dialog box } + { that allows the user to set their own tab stops. } +VAR + Index : Sw_Integer; { Local Indexing variable. } + R : TRect; + D : PDialog; + Control : PView; + Tab_Stop : String[2]; { Local string to print tab column number. } +Begin + R.Assign (0, 0, 80, 8); + D := New (Dialogs.PDialog, Init (R, sTabSettings)); + with D^ do + begin + Options := Options or ofCentered; + + R.Assign (2, 2, 77, 3); + Control := New (Dialogs.PStaticText, Init (R, + ' ....|....|....|....|....|....|....|....|....|....|....|....|....|....|....')); + Insert (Control); + + for Index := 1 to 7 do + begin + R.Assign (Index * 10 + 1, 1, Index * 10 + 3, 2); + Str (Index * 10, Tab_Stop); + Control := New (Dialogs.PStaticText, Init (R, Tab_Stop)); + Insert (Control); + end; + + R.Assign (2, 3, 78, 4); + Control := New (Dialogs.PInputLine, Init (R, 74)); + Control^.HelpCtx := hcDTabStops; + Insert (Control); + + R.Assign (38, 5, 41, 6); + Insert (New (Dialogs.PHistory, Init (R, Dialogs.PInputLine (Control), 14))); + + R.Assign (27, 5, 37, 7); + Control := New (Dialogs.PButton, Init (R, slOK, cmOK, Dialogs.bfDefault)); + Control^.HelpCtx := hcDOk; + Insert (Control); + + R.Assign (42, 5, 52, 7); + Control := New (Dialogs.PButton, Init (R, slCancel, cmCancel, Dialogs.bfNormal)); + Control^.HelpCtx := hcDCancel; + Insert (Control); + SelectNext (False); + end; + TabStopDialog := D; +end { TabStopDialog }; + + +function StdEditorDialog(Dialog: Integer; Info: Pointer): Word; +var + R: TRect; + T: TPoint; +begin + case Dialog of + edOutOfMemory: + StdEditorDialog := MessageBox(sOutOfMemory, nil, mfError + mfOkButton); + edReadError: + StdEditorDialog := MessageBox(sFileReadError, @Info, mfError + mfOkButton); + edWriteError: + StdEditorDialog := MessageBox(sFileWriteError, @Info, mfError + mfOkButton); + edCreateError: + StdEditorDialog := MessageBox(sFileCreateError, @Info, mfError + mfOkButton); + edSaveModify: + StdEditorDialog := MessageBox(sModified, @Info, mfInformation + mfYesNoCancel); + edSaveUntitled: + StdEditorDialog := MessageBox(sFileUntitled, nil, mfInformation + mfYesNoCancel); + edSaveAs: + StdEditorDialog := Application^.ExecuteDialog(New(PFileDialog, Init('*.*', + slSaveFileAs, slName, fdOkButton, 101)), Info); + edFind: + StdEditorDialog := Application^.ExecuteDialog(CreateFindDialog, Info); + edSearchFailed: + StdEditorDialog := MessageBox(sSearchStringNotFound, nil, mfError + mfOkButton); + edReplace: + StdEditorDialog := Application^.ExecuteDialog(CreateReplaceDialog, Info); + edReplacePrompt: + begin + { Avoid placing the dialog on the same line as the cursor } + R.Assign(0, 1, 40, 8); + R.Move((Desktop^.Size.X - R.B.X) div 2, 0); + Desktop^.MakeGlobal(R.B, T); + Inc(T.Y); + if PPoint(Info)^.Y <= T.Y then + R.Move(0, Desktop^.Size.Y - R.B.Y - 2); + StdEditorDialog := MessageBoxRect(R, sReplaceThisOccurence, + nil, mfYesNoCancel + mfInformation); + end; + edJumpToLine: + StdEditorDialog := Application^.ExecuteDialog(JumpLineDialog, Info); + edSetTabStops: + StdEditorDialog := Application^.ExecuteDialog(TabStopDialog, Info); + edPasteNotPossible: + StdEditorDialog := MessageBox (sPasteNotPossible, nil, mfError + mfOkButton); + edReformatDocument: + StdEditorDialog := Application^.ExecuteDialog(ReformDocDialog, Info); + edReformatNotAllowed: + StdEditorDialog := MessageBox (sWordWrapOff, nil, mfError + mfOkButton); + edReformNotPossible: + StdEditorDialog := MessageBox (sReformatNotPossible, nil, mfError + mfOkButton); + edReplaceNotPossible: + StdEditorDialog := MessageBox (sReplaceNotPossible, nil, mfError + mfOkButton); + edRightMargin: + StdEditorDialog := Application^.ExecuteDialog(RightMarginDialog, Info); + edWrapNotPossible: + StdEditorDialog := MessageBox (sWordWrapNotPossible, nil, mfError + mfOKButton); + else + StdEditorDialog := MessageBox (sUnknownDialog, nil, mfError + mfOkButton); + end; +end; + + +{**************************************************************************** + Helpers +****************************************************************************} + +function CountLines(var Buf; Count: sw_Word): sw_Integer; +var + p : pchar; + lines : sw_word; +begin + p:=pchar(@buf); + lines:=0; + while (count>0) do + begin + if p^ in [#10,#13] then + begin + inc(lines); + if ord((p+1)^)+ord(p^)=23 then + begin + inc(p); + dec(count); + if count=0 then + break; + end; + end; + inc(p); + dec(count); + end; + CountLines:=Lines; +end; + + +procedure GetLimits(var Buf; Count: sw_Word;var lim:objects.TPoint); +{ Get the limits needed for Buf, its an extended version of countlines (lim.y), + which also gets the maximum line length in lim.x } +var + p : pchar; + len : sw_word; +begin + lim.x:=0; + lim.y:=0; + len:=0; + p:=pchar(@buf); + while (count>0) do + begin + if p^ in [#10,#13] then + begin + if len>lim.x then + lim.x:=len; + inc(lim.y); + if ord((p+1)^)+ord(p^)=23 then + begin + inc(p); + dec(count); + end; + len:=0; + end + else + inc(len); + inc(p); + dec(count); + end; +end; + + +function ScanKeyMap(KeyMap: Pointer; KeyCode: Word): Word; +var + p : pword; + count : sw_word; +begin + p:=keymap; + count:=p^; + inc(p); + while (count>0) do + begin + if (lo(p^)=lo(keycode)) and + ((hi(p^)=0) or (hi(p^)=hi(keycode))) then + begin + inc(p); + scankeymap:=p^; + exit; + end; + inc(p,2); + dec(count); + end; + scankeymap:=0; +end; + + +Type + Btable = Array[0..255] of Byte; +Procedure BMMakeTable(const s:string; Var t : Btable); +{ Makes a Boyer-Moore search table. s = the search String t = the table } +Var + x : sw_integer; +begin + FillChar(t,sizeof(t),length(s)); + For x := length(s) downto 1 do + if (t[ord(s[x])] = length(s)) then + t[ord(s[x])] := length(s) - x; +end; + + +function Scan(var Block; Size: Sw_Word;const Str: String): Sw_Word; +Var + buffer : Array[0..MaxBufLength-1] of Byte Absolute block; + s2 : String; + len, + numb : Sw_Word; + found : Boolean; + bt : Btable; +begin + BMMakeTable(str,bt); + len:=length(str); + s2[0]:=chr(len); { sets the length to that of the search String } + found:=False; + numb:=pred(len); + While (not found) and (numb<(size-len)) do + begin + { partial match } + if buffer[numb] = ord(str[len]) then + begin + { less partial! } + if buffer[numb-pred(len)] = ord(str[1]) then + begin + move(buffer[numb-pred(len)],s2[1],len); + if (str=s2) then + begin + found:=true; + break; + end; + end; + inc(numb); + end + else + inc(numb,Bt[buffer[numb]]); + end; + if not found then + Scan := NotFoundValue + else + Scan := numb - pred(len); +end; + + +function IScan(var Block; Size: Sw_Word;const Str: String): Sw_Word; +Var + buffer : Array[0..MaxBufLength-1] of Char Absolute block; + s : String; + len, + numb, + x : Sw_Word; + found : Boolean; + bt : Btable; + p : pchar; + c : char; +begin + len:=length(str); + if (len=0) or (len>size) then + begin + IScan := NotFoundValue; + exit; + end; + { create uppercased string } + s[0]:=chr(len); + for x:=1 to len do + begin + if str[x] in ['a'..'z'] then + s[x]:=chr(ord(str[x])-32) + else + s[x]:=str[x]; + end; + BMMakeTable(s,bt); + found:=False; + numb:=pred(len); + While (not found) and (numb<(size-len)) do + begin + { partial match } + c:=buffer[numb]; + if c in ['a'..'z'] then + c:=chr(ord(c)-32); + if (c=s[len]) then + begin + { less partial! } + p:=@buffer[numb-pred(len)]; + x:=1; + while (x<=len) do + begin + if not(((p^ in ['a'..'z']) and (chr(ord(p^)-32)=s[x])) or + (p^=s[x])) then + break; + inc(p); + inc(x); + end; + if (x>len) then + begin + found:=true; + break; + end; + inc(numb); + end + else + inc(numb,Bt[ord(c)]); + end; + if not found then + IScan := NotFoundValue + else + IScan := numb - pred(len); +end; + + +{**************************************************************************** + TIndicator +****************************************************************************} + +constructor TIndicator.Init (var Bounds : TRect); +begin + Inherited Init (Bounds); + GrowMode := gfGrowLoY + gfGrowHiY; +end; { TIndicator.Init } + + +procedure TIndicator.Draw; +VAR + Color : Byte; + Frame : Char; + L : array[0..1] of Longint; + S : String[15]; + B : TDrawBuffer; +begin + if State and sfDragging = 0 then + begin + Color := GetColor (1); + Frame := #205; + end + else + begin + Color := GetColor (2); + Frame := #196; + end; + MoveChar (B, Frame, Color, Size.X); + { If the text has been modified, put an 'M' in the TIndicator display. } + if Modified then + WordRec (B[1]).Lo := 77; + { If WordWrap is active put a 'W' in the TIndicator display. } + if WordWrap then + WordRec (B[2]).Lo := 87 + else + WordRec (B[2]).Lo := Byte (Frame); + { If AutoIndent is active put an 'I' in TIndicator display. } + if AutoIndent then + WordRec (B[0]).Lo := 73 + else + WordRec (B[0]).Lo := Byte (Frame); + L[0] := Location.Y + 1; + L[1] := Location.X + 1; + FormatStr (S, ' %d:%d ', L); + MoveStr (B[9 - Pos (':', S)], S, Color); { Changed original 8 to 9. } + WriteBuf (0, 0, Size.X, 1, B); +end; { TIndicator.Draw } + + +function TIndicator.GetPalette : PPalette; +const + P : string[Length (CIndicator)] = CIndicator; +begin + GetPalette := PPalette(@P); +end; { TIndicator.GetPalette } + + +procedure TIndicator.SetState (AState : Word; Enable : Boolean); +begin + Inherited SetState (AState, Enable); + if AState = sfDragging then + DrawView; +end; { TIndicator.SetState } + + +procedure TIndicator.SetValue (ALocation : Objects.TPoint; IsAutoIndent : Boolean; + IsModified : Boolean; + IsWordWrap : Boolean); +begin + if (Location.X<>ALocation.X) or + (Location.Y<>ALocation.Y) or + (AutoIndent <> IsAutoIndent) or + (Modified <> IsModified) or + (WordWrap <> IsWordWrap) then + begin + Location := ALocation; + AutoIndent := IsAutoIndent; { Added provisions to show AutoIndent. } + Modified := IsModified; + WordWrap := IsWordWrap; { Added provisions to show WordWrap. } + DrawView; + end; +end; { TIndicator.SetValue } + + +{**************************************************************************** + TLineInfo +****************************************************************************} + +constructor TLineInfo.Init; +begin + MaxPos:=0; + Grow(1); +end; + + +destructor TLineInfo.Done; +begin + FreeMem(Info,MaxPos*sizeof(TLineInfoRec)); + Info := nil; +end; + + +procedure TLineInfo.Grow(pos:Sw_word); +var + NewSize : Sw_word; + P : pointer; +begin + NewSize:=(Pos+LineInfoGrow-(Pos mod LineInfoGrow)); + GetMem(P,NewSize*sizeof(TLineInfoRec)); + FillChar(P^,NewSize*sizeof(TLineInfoRec),0); + Move(Info^,P^,MaxPos*sizeof(TLineInfoRec)); + Freemem(Info,MaxPos*sizeof(TLineInfoRec)); + Info:=P; +end; + + +procedure TLineInfo.SetLen(pos,val:Sw_Word); +begin + if pos>=MaxPos then + Grow(Pos); + Info^[Pos].Len:=val +end; + + +procedure TLineInfo.SetAttr(pos,val:Sw_Word); +begin + if pos>=MaxPos then + Grow(Pos); + Info^[Pos].Attr:=val +end; + + +function TLineInfo.GetLen(pos:Sw_Word):Sw_Word; +begin + GetLen:=Info^[Pos].Len; +end; + + +function TLineInfo.GetAttr(pos:Sw_Word):Sw_Word; +begin + GetAttr:=Info^[Pos].Attr; +end; + + + +{**************************************************************************** + TEditor +****************************************************************************} + +constructor TEditor.Init (var Bounds : TRect; + AHScrollBar, AVScrollBar : PScrollBar; + AIndicator : PIndicator; ABufSize : Sw_Word); +var + Element : Byte; { Place_Marker array element to initialize array with. } +begin + Inherited Init (Bounds); + GrowMode := gfGrowHiX + gfGrowHiY; + Options := Options or ofSelectable; + Flags := EditorFlags; + EventMask := evMouseDown + evKeyDown + evCommand + evBroadcast; + ShowCursor; + + HScrollBar := AHScrollBar; + VScrollBar := AVScrollBar; + + Indicator := AIndicator; + BufSize := ABufSize; + CanUndo := True; + InitBuffer; + + if assigned(Buffer) then + IsValid := True + else + begin + EditorDialog (edOutOfMemory, nil); + BufSize := 0; + end; + + SetBufLen (0); + + for Element := 1 to 10 do + Place_Marker[Element] := 0; + + Element := 1; + while Element <= 70 do + begin + if Element mod 5 = 0 then + Insert ('x', Tab_Settings, Element) + else + Insert (#32, Tab_Settings, Element); + Inc (Element); + end; + { Default Right_Margin value. Change it if you want another. } + Right_Margin := 76; + TabSize:=8; +end; { TEditor.Init } + + +constructor TEditor.Load (var S : Objects.TStream); +begin + Inherited Load (S); + GetPeerViewPtr (S, HScrollBar); + GetPeerViewPtr (S, VScrollBar); + GetPeerViewPtr (S, Indicator); + S.Read (BufSize, SizeOf (BufSize)); + S.Read (CanUndo, SizeOf (CanUndo)); + S.Read (AutoIndent, SizeOf (AutoIndent)); + S.Read (Line_Number, SizeOf (Line_Number)); + S.Read (Place_Marker, SizeOf (Place_Marker)); + S.Read (Right_Margin, SizeOf (Right_Margin)); + S.Read (Tab_Settings, SizeOf (Tab_Settings)); + S.Read (Word_Wrap, SizeOf (Word_Wrap)); + InitBuffer; + if Assigned(Buffer) then + IsValid := True + else + begin + EditorDialog (edOutOfMemory, nil); + BufSize := 0; + end; + Lock; + SetBufLen (0); +end; { TEditor.Load } + + +destructor TEditor.Done; +begin + DoneBuffer; + Inherited Done; +end; { TEditor.Done } + + +function TEditor.BufChar(P: Sw_Word): Char; +begin + if P>=CurPtr then + inc(P,Gaplen); + BufChar:=Buffer^[P]; +end; + + +function TEditor.BufPtr(P: Sw_Word): Sw_Word; +begin + if P>=CurPtr then + BufPtr:=P+GapLen + else + BufPtr:=P; +end; + + +procedure TEditor.Center_Text (Select_Mode : Byte); +{ This procedure will center the current line of text. } +{ Centering is based on the current Right_Margin. } +{ If the Line_Length exceeds the Right_Margin, or the } +{ line is just a blank line, we exit and do nothing. } +VAR + Spaces : array [1..80] of Char; { Array to hold spaces we'll insert. } + Index : Byte; { Index into Spaces array. } + Line_Length : Sw_Integer; { Holds the length of the line. } + E,S : Sw_Word; { End of the current line. } +begin + E := LineEnd (CurPtr); + S := LineStart (CurPtr); + { If the line is blank (only a CR/LF on it) then do noting. } + if E = S then + Exit; + { Set CurPtr to start of line. Check if line begins with a space. } + { We must strip out any spaces from the beginning, or end of lines. } + { If line does not start with space, make sure line length does not } + { exceed the Right_Margin. If it does, then do nothing. } + SetCurPtr (S, Select_Mode); + Remove_EOL_Spaces (Select_Mode); + if Buffer^[CurPtr] = #32 then + begin + { If the next word is greater than the end of line then do nothing. } + { If the line length is greater than Right_Margin then do nothing. } + { Otherwise, delete all spaces at the start of line. } + { Then reset end of line and put CurPtr at start of modified line. } + E := LineEnd (CurPtr); + if NextWord (CurPtr) > E then + Exit; + if E - NextWord (CurPtr) > Right_Margin then + Exit; + DeleteRange (CurPtr, NextWord (CurPtr), True); + E := LineEnd (CurPtr); + SetCurPtr (LineStart (CurPtr), Select_Mode); + end + else + if E - CurPtr > Right_Margin then + Exit; + { Now we determine the real length of the line. } + { Then we subtract the Line_Length from Right_Margin. } + { Dividing the result by two tells us how many spaces } + { must be inserted at start of line to center it. } + { When we're all done, set the CurPtr to end of line. } + Line_Length := E - CurPtr; + for Index := 1 to ((Right_Margin - Line_Length) shr 1) do + Spaces[Index] := #32; + InsertText (@Spaces, Index, False); + SetCurPtr (LineEnd (CurPtr), Select_Mode); +end; { TEditor.Center_Text } + + +procedure TEditor.ChangeBounds (var Bounds : TRect); +begin + SetBounds (Bounds); + Delta.X := Max (0, Min (Delta.X, Limit.X - Size.X)); + Delta.Y := Max (0, Min (Delta.Y, Limit.Y - Size.Y)); + Update (ufView); +end; { TEditor.ChangeBounds } + + +function TEditor.CharPos (P, Target : Sw_Word) : Sw_Integer; +VAR + Pos : Sw_Integer; +begin + Pos := 0; + while P < Target do + begin + if BufChar (P) = #9 then + Pos := Pos or 7; + Inc (Pos); + Inc (P); + end; + CharPos := Pos; +end; { TEditor.CharPos } + + +function TEditor.CharPtr (P : Sw_Word; Target : Sw_Integer) : Sw_Word; +VAR + Pos : Sw_Integer; +begin + Pos := 0; + while (Pos < Target) and (P < BufLen) and not(BufChar (P) in [#10,#13]) do + begin + if BufChar (P) = #9 then + Pos := Pos or 7; + Inc (Pos); + Inc (P); + end; + if Pos > Target then + Dec (P); + CharPtr := P; +end; { TEditor.CharPtr } + + +procedure TEditor.Check_For_Word_Wrap (Select_Mode : Byte; + Center_Cursor : Boolean); +{ This procedure checks if CurPos.X > Right_Margin. } +{ If it is, then we Do_Word_Wrap. Simple, eh? } +begin + if CurPos.X > Right_Margin then + Do_Word_Wrap (Select_Mode, Center_Cursor); +end; {Check_For_Word_Wrap} + + +function TEditor.ClipCopy : Boolean; +begin + ClipCopy := False; + if Assigned(Clipboard) and (Clipboard <> @Self) then + begin + ClipCopy := Clipboard^.InsertFrom (@Self); + Selecting := False; + Update (ufUpdate); + end; +end; { TEditor.ClipCopy } + + +procedure TEditor.ClipCut; +begin + if ClipCopy then + begin + Update_Place_Markers (0, + Self.SelEnd - Self.SelStart, + Self.SelStart, + Self.SelEnd); + DeleteSelect; + end; +end; { TEditor.ClipCut } + + +procedure TEditor.ClipPaste; +begin + if Assigned(Clipboard) and (Clipboard <> @Self) then + begin + { Do not allow paste operations that will exceed } + { the Right_Margin when Word_Wrap is active and } + { cursor is at EOL. } + if Word_Wrap and (CurPos.X > Right_Margin) then + begin + EditorDialog (edPasteNotPossible, nil); + Exit; + end; + { The editor will not copy selected text if the CurPtr } + { is not the same value as the SelStart. However, it } + { does return an InsCount. This may, or may not, be a } + { bug. We don't want to update the Place_Marker if } + { there's no text copied. } + if CurPtr = SelStart then + Update_Place_Markers (Clipboard^.SelEnd - Clipboard^.SelStart, + 0, + Clipboard^.SelStart, + Clipboard^.SelEnd); + InsertFrom (Clipboard); + end; +end; { TEditor.ClipPaste } + + +procedure TEditor.ConvertEvent (var Event : Drivers.TEvent); +VAR + ShiftState : Byte; + Key : Word; +begin + ShiftState:=GetShiftState; + if Event.What = evKeyDown then + begin + if (ShiftState and $03 <> 0) + and (Event.ScanCode >= $47) + and (Event.ScanCode <= $51) then + Event.CharCode := #0; + Key := Event.KeyCode; + if KeyState <> 0 then + begin + if (Lo (Key) >= $01) and (Lo (Key) <= $1A) then + Inc (Key, $40); + if (Lo (Key) >= $61) and (Lo (Key) <= $7A) then + Dec (Key, $20); + end; + Key := ScanKeyMap (KeyMap[KeyState], Key); + KeyState := 0; + if Key <> 0 then + if Hi (Key) = $FF then + begin + KeyState := Lo (Key); + ClearEvent (Event); + end + else + begin + Event.What := evCommand; + Event.Command := Key; + end; + end; +end; { TEditor.ConvertEvent } + + +function TEditor.CursorVisible : Boolean; +begin + CursorVisible := (CurPos.Y >= Delta.Y) and (CurPos.Y < Delta.Y + Size.Y); +end; { TEditor.CursorVisible } + + +procedure TEditor.DeleteRange (StartPtr, EndPtr : Sw_Word; DelSelect : Boolean); +begin + { This will update Place_Marker for all deletions. } + { EXCEPT the Remove_EOL_Spaces deletion. } + Update_Place_Markers (0, EndPtr - StartPtr, StartPtr, EndPtr); + if HasSelection and DelSelect then + DeleteSelect + else + begin + SetSelect (CurPtr, EndPtr, True); + DeleteSelect; + SetSelect (StartPtr, CurPtr, False); + DeleteSelect; + end; +end; { TEditor.DeleteRange } + + +procedure TEditor.DeleteSelect; +begin + InsertText (nil, 0, False); +end; { TEditor.DeleteSelect } + + +procedure TEditor.DoneBuffer; +begin + ReAllocMem(Buffer, 0); +end; { TEditor.DoneBuffer } + + +procedure TEditor.DoSearchReplace; +VAR + I : Sw_Word; + C : Objects.TPoint; +begin + repeat + I := cmCancel; + if not Search (FindStr, Flags) then + begin + if Flags and (efReplaceAll + efDoReplace) <> (efReplaceAll + efDoReplace) then + EditorDialog (edSearchFailed, nil) + end + else + if Flags and efDoReplace <> 0 then + begin + I := cmYes; + if Flags and efPromptOnReplace <> 0 then + begin + MakeGlobal (Cursor, C); + I := EditorDialog (edReplacePrompt, Pointer(@C)); + end; + if I = cmYes then + begin + { If Word_Wrap is active and we are at EOL } + { disallow replace by bringing up a dialog } + { stating that replace is not possible. } + if Word_Wrap and + ((CurPos.X + (Length (ReplaceStr) - Length (FindStr))) > Right_Margin) then + EditorDialog (edReplaceNotPossible, nil) + else + begin + Lock; + Search_Replace := True; + if length (ReplaceStr) < length (FindStr) then + Update_Place_Markers (0, + Length (FindStr) - Length (ReplaceStr), + CurPtr - Length (FindStr) + Length (ReplaceStr), + CurPtr) + else + if length (ReplaceStr) > length (FindStr) then + Update_Place_Markers (Length (ReplaceStr) - Length (FindStr), + 0, + CurPtr, + CurPtr + (Length (ReplaceStr) - Length (FindStr))); + InsertText (@ReplaceStr[1], Length (ReplaceStr), False); + Search_Replace := False; + TrackCursor (False); + Unlock; + end; + end; + end; + until (I = cmCancel) or (Flags and efReplaceAll = 0); +end; { TEditor.DoSearchReplace } + + +procedure TEditor.DoUpdate; +begin + if UpdateFlags <> 0 then + begin + SetCursor (CurPos.X - Delta.X, CurPos.Y - Delta.Y); + if UpdateFlags and ufView <> 0 then + DrawView + else + if UpdateFlags and ufLine <> 0 then + DrawLines (CurPos.Y - Delta.Y, 1, LineStart (CurPtr)); + if assigned(HScrollBar) then + HScrollBar^.SetParams (Delta.X, 0, Limit.X - Size.X, Size.X div 2, 1); + if assigned(VScrollBar) then + VScrollBar^.SetParams (Delta.Y, 0, Limit.Y - Size.Y, Size.Y - 1, 1); + if assigned(Indicator) then + Indicator^.SetValue (CurPos, AutoIndent, Modified, Word_Wrap); + if State and sfActive <> 0 then + UpdateCommands; + UpdateFlags := 0; + end; +end; { TEditor.DoUpdate } + + +function TEditor.Do_Word_Wrap (Select_Mode : Byte; + Center_Cursor : Boolean) : Boolean; +{ This procedure does the actual wordwrap. It always assumes the CurPtr } +{ is at Right_Margin + 1. It makes several tests for special conditions } +{ and processes those first. If they all fail, it does a normal wrap. } +VAR + A : Sw_Word; { Distance between line start and first word on line. } + C : Sw_Word; { Current pointer when we come into procedure. } + L : Sw_Word; { BufLen when we come into procedure. } + P : Sw_Word; { Position of pointer at any given moment. } + S : Sw_Word; { Start of a line. } +begin + Do_Word_Wrap := False; + Select_Mode := 0; + if BufLen >= (BufSize - 1) then + exit; + C := CurPtr; + L := BufLen; + S := LineStart (CurPtr); + { If first character in the line is a space and autoindent mode is on } + { then we check to see if NextWord(S) exceeds the CurPtr. If it does, } + { we set CurPtr as the AutoIndent marker. If it doesn't, we will set } + { NextWord(S) as the AutoIndent marker. If neither, we set it to S. } + if AutoIndent and (Buffer^[S] = ' ') then + begin + if NextWord (S) > CurPtr then + A := CurPtr + else + A := NextWord (S); + end + else + A := NextWord (S); + { Though NewLine will remove EOL spaces, we do it here too. } + { This catches the instance where a user may try to space } + { completely across the line, in which case CurPtr.X = 0. } + Remove_EOL_Spaces (Select_Mode); + if CurPos.X = 0 then + begin + NewLine (Select_Mode); + Do_Word_Wrap := True; + Exit; + end; + { At this point we have one of five situations: } + { } + { 1) AutoIndent is on and this line is all spaces before CurPtr. } + { 2) AutoIndent is off and this line is all spaces before CurPtr. } + { 3) AutoIndent is on and this line is continuous characters before CurPtr. } + { 4) AutoIndent is off and this line is continuous characters before CurPtr. } + { 5) This is just a normal line of text. } + { } + { Conditions 1 through 4 have to be taken into account before condition 5. } + { First, we see if there are all spaces and/or all characters. } + { Then we determine which one it really is. Finally, we take } + { a course of action based on the state of AutoIndent. } + if PrevWord (CurPtr) <= S then + begin + P := CurPtr - 1; + while ((Buffer^[P] <> ' ') and (P > S)) do + Dec (P); + { We found NO SPACES. Conditions 4 and 5 are treated the same. } + { We can NOT do word wrap and put up a dialog box stating such. } + { Delete character just entered so we don't exceed Right_Margin. } + if P = S then + begin + EditorDialog (edWrapNotPossible, nil); + DeleteRange (PrevChar (CurPtr), CurPtr, True); + Exit; + end + else + begin + { There are spaces. Now find out if they are all spaces. } + { If so, see if AutoIndent is on. If it is, turn it off, } + { do a NewLine, and turn it back on. Otherwise, just do } + { the NewLine. We go through all of these gyrations for } + { AutoIndent. Being way out here with a preceding line } + { of spaces and wrapping with AutoIndent on is real dumb! } + { However, the user expects something. The wrap will NOT } + { autoindent, but they had no business being here anyway! } + P := CurPtr - 1; + while ((Buffer^[P] = ' ') and (P > S)) do + Dec (P); + if P = S then + begin + if Autoindent then + begin + AutoIndent := False; + NewLine (Select_Mode); + AutoIndent := True; + end + else + NewLine (Select_Mode); + end; { AutoIndent } + end; { P = S for spaces } + end { P = S for no spaces } + else { PrevWord (CurPtr) <= S } + begin + { Hooray! We actually had a plain old line of text to wrap! } + { Regardless if we are pushing out a line beyond the Right_Margin, } + { or at the end of a line itself, the following will determine } + { exactly where to do the wrap and re-set the cursor accordingly. } + { However, if P = A then we can't wrap. Show dialog and exit. } + P := CurPtr; + while P - S > Right_Margin do + P := PrevWord (P); + if (P = A) then + begin + EditorDialog (edReformNotPossible, nil); + SetCurPtr (P, Select_Mode); + Exit; + end; + SetCurPtr (P, Select_Mode); + NewLine (Select_Mode); + end; { PrevWord (CurPtr <= S } + { Track the cursor here (it is at CurPos.X = 0) so the view } + { will redraw itself at column 0. This eliminates having it } + { redraw starting at the current cursor and not being able } + { to see text before the cursor. Of course, we also end up } + { redrawing the view twice, here and back in HandleEvent. } + { } + { Reposition cursor so user can pick up where they left off. } + TrackCursor (Center_Cursor); + SetCurPtr (C - (L - BufLen), Select_Mode); + Do_Word_Wrap := True; +end; { TEditor.Do_Word_Wrap } + + +procedure TEditor.Draw; +begin + if DrawLine <> Delta.Y then + begin + DrawPtr := LineMove (DrawPtr, Delta.Y - DrawLine); + DrawLine := Delta.Y; + end; + DrawLines (0, Size.Y, DrawPtr); +end; { TEditor.Draw } + + +procedure TEditor.DrawLines (Y, Count : Sw_Integer; LinePtr : Sw_Word); +VAR + Color : Word; + B : array[0..MaxLineLength - 1] of Sw_Word; +begin + Color := GetColor ($0201); + while Count > 0 do + begin + FormatLine (B, LinePtr, Delta.X + Size.X, Color); + WriteBuf (0, Y, Size.X, 1, B[Delta.X]); + LinePtr := NextLine (LinePtr); + Inc (Y); + Dec (Count); + end; +end; { TEditor.DrawLines } + + +procedure TEditor.Find; +VAR + FindRec : TFindDialogRec; +begin + with FindRec do + begin + Find := FindStr; + Options := Flags; + if EditorDialog (edFind, @FindRec) <> cmCancel then + begin + FindStr := Find; + Flags := Options and not efDoReplace; + DoSearchReplace; + end; + end; +end; { TEditor.Find } + + +procedure TEditor.FormatLine (var DrawBuf; LinePtr : Sw_Word; + Width : Sw_Integer; + Colors : Word); +var + outptr : pword; + outcnt, + idxpos : Sw_Word; + attr : Word; + + procedure FillSpace(i:Sw_Word); + var + w : word; + begin + inc(OutCnt,i); + w:=32 or attr; + while (i>0) do + begin + OutPtr^:=w; + inc(OutPtr); + dec(i); + end; + end; + + function FormatUntil(endpos:Sw_word):boolean; + var + p : pchar; + begin + FormatUntil:=false; + p:=pchar(Buffer)+idxpos; + while endpos>idxpos do + begin + if OutCnt>=Width then + exit; + case p^ of + #9 : + FillSpace(Tabsize-(outcnt mod Tabsize)); + #10,#13 : + begin + FillSpace(Width-OutCnt); + FormatUntil:=true; + exit; + end; + else + begin + inc(OutCnt); + OutPtr^:=ord(p^) or attr; + inc(OutPtr); + end; + end; { case } + inc(p); + inc(idxpos); + end; + end; + +begin + OutCnt:=0; + OutPtr:=@DrawBuf; + idxPos:=LinePtr; + attr:=lo(Colors) shl 8; + if FormatUntil(SelStart) then + exit; + attr:=hi(Colors) shl 8; + if FormatUntil(CurPtr) then + exit; + inc(idxPos,GapLen); + if FormatUntil(SelEnd+GapLen) then + exit; + attr:=lo(Colors) shl 8; + if FormatUntil(BufSize) then + exit; +{ fill up until width } + FillSpace(Width-OutCnt); +end; {TEditor.FormatLine} + + +function TEditor.GetMousePtr (Mouse : Objects.TPoint) : Sw_Word; +begin + MakeLocal (Mouse, Mouse); + Mouse.X := Max (0, Min (Mouse.X, Size.X - 1)); + Mouse.Y := Max (0, Min (Mouse.Y, Size.Y - 1)); + GetMousePtr := CharPtr (LineMove (DrawPtr, Mouse.Y + Delta.Y - DrawLine), + Mouse.X + Delta.X); +end; { TEditor.GetMousePtr } + + +function TEditor.GetPalette : PPalette; +CONST + P : String[Length (CEditor)] = CEditor; +begin + GetPalette := PPalette(@P); +end; { TEditor.GetPalette } + + +procedure TEditor.HandleEvent (var Event : Drivers.TEvent); +VAR + ShiftState : Byte; + CenterCursor : Boolean; + SelectMode : Byte; + D : Objects.TPoint; + Mouse : Objects.TPoint; + + function CheckScrollBar (P : PScrollBar; var D : Sw_Integer) : Boolean; + begin + CheckScrollBar := FALSE; + if (Event.InfoPtr = P) and (P^.Value <> D) then + begin + D := P^.Value; + Update (ufView); + CheckScrollBar := TRUE; + end; + end; {CheckScrollBar} + +begin + Inherited HandleEvent (Event); + ConvertEvent (Event); + CenterCursor := not CursorVisible; + SelectMode := 0; + ShiftState:=GetShiftState; + if Selecting or (ShiftState and $03 <> 0) then + SelectMode := smExtend; + case Event.What of + Drivers.evMouseDown: + begin + if Event.Double then + SelectMode := SelectMode or smDouble; + repeat + Lock; + if Event.What = evMouseAuto then + begin + MakeLocal (Event.Where, Mouse); + D := Delta; + if Mouse.X < 0 then + Dec (D.X); + if Mouse.X >= Size.X then + Inc (D.X); + if Mouse.Y < 0 then + Dec (D.Y); + if Mouse.Y >= Size.Y then + Inc (D.Y); + ScrollTo (D.X, D.Y); + end; + SetCurPtr (GetMousePtr (Event.Where), SelectMode); + SelectMode := SelectMode or smExtend; + Unlock; + until not MouseEvent (Event, evMouseMove + evMouseAuto); + end; { Drivers.evMouseDown } + + Drivers.evKeyDown: + case Event.CharCode of + #32..#255: + begin + Lock; + if Overwrite and not HasSelection then + if CurPtr <> LineEnd (CurPtr) then + SelEnd := NextChar (CurPtr); + InsertText (@Event.CharCode, 1, False); + if Word_Wrap then + Check_For_Word_Wrap (SelectMode, CenterCursor); + TrackCursor (CenterCursor); + Unlock; + end; + + else + Exit; + end; { Drivers.evKeyDown } + + Drivers.evCommand: + case Event.Command of + cmFind : Find; + cmReplace : Replace; + cmSearchAgain : DoSearchReplace; + else + begin + Lock; + case Event.Command of + cmCut : ClipCut; + cmCopy : ClipCopy; + cmPaste : ClipPaste; + cmUndo : Undo; + cmClear : DeleteSelect; + cmCharLeft : SetCurPtr (PrevChar (CurPtr), SelectMode); + cmCharRight : SetCurPtr (NextChar (CurPtr), SelectMode); + cmWordLeft : SetCurPtr (PrevWord (CurPtr), SelectMode); + cmWordRight : SetCurPtr (NextWord (CurPtr), SelectMode); + cmLineStart : SetCurPtr (LineStart (CurPtr), SelectMode); + cmLineEnd : SetCurPtr (LineEnd (CurPtr), SelectMode); + cmLineUp : SetCurPtr (LineMove (CurPtr, -1), SelectMode); + cmLineDown : SetCurPtr (LineMove (CurPtr, 1), SelectMode); + cmPageUp : SetCurPtr (LineMove (CurPtr, - (Size.Y - 1)), SelectMode); + cmPageDown : SetCurPtr (LineMove (CurPtr, Size.Y - 1), SelectMode); + cmTextStart : SetCurPtr (0, SelectMode); + cmTextEnd : SetCurPtr (BufLen, SelectMode); + cmNewLine : NewLine (SelectMode); + cmBackSpace : DeleteRange (PrevChar (CurPtr), CurPtr, True); + cmDelChar : DeleteRange (CurPtr, NextChar (CurPtr), True); + cmDelWord : DeleteRange (CurPtr, NextWord (CurPtr), False); + cmDelStart : DeleteRange (LineStart (CurPtr), CurPtr, False); + cmDelEnd : DeleteRange (CurPtr, LineEnd (CurPtr), False); + cmDelLine : DeleteRange (LineStart (CurPtr), NextLine (CurPtr), False); + cmInsMode : ToggleInsMode; + cmStartSelect : StartSelect; + cmHideSelect : HideSelect; + cmIndentMode : begin + AutoIndent := not AutoIndent; + Update (ufStats); + end; { Added provision to update TIndicator if ^QI pressed. } + cmCenterText : Center_Text (SelectMode); + cmEndPage : SetCurPtr (LineMove (CurPtr, Delta.Y - CurPos.Y + Size.Y - 1), SelectMode); + cmHomePage : SetCurPtr (LineMove (CurPtr, -(CurPos.Y - Delta.Y)), SelectMode); + cmInsertLine : Insert_Line (SelectMode); + cmJumpLine : Jump_To_Line (SelectMode); + cmReformDoc : Reformat_Document (SelectMode, CenterCursor); + cmReformPara : Reformat_Paragraph (SelectMode, CenterCursor); + cmRightMargin : Set_Right_Margin; + cmScrollDown : Scroll_Down; + cmScrollUp : Scroll_Up; + cmSelectWord : Select_Word; + cmSetTabs : Set_Tabs; + cmTabKey : Tab_Key (SelectMode); + cmWordWrap : begin + Word_Wrap := not Word_Wrap; + Update (ufStats); + end; { Added provision to update TIndicator if ^OW pressed. } + cmSetMark0 : Set_Place_Marker (10); + cmSetMark1 : Set_Place_Marker (1); + cmSetMark2 : Set_Place_Marker (2); + cmSetMark3 : Set_Place_Marker (3); + cmSetMark4 : Set_Place_Marker (4); + cmSetMark5 : Set_Place_Marker (5); + cmSetMark6 : Set_Place_Marker (6); + cmSetMark7 : Set_Place_Marker (7); + cmSetMark8 : Set_Place_Marker (8); + cmSetMark9 : Set_Place_Marker (9); + cmJumpMark0 : Jump_Place_Marker (10, SelectMode); + cmJumpMark1 : Jump_Place_Marker (1, SelectMode); + cmJumpMark2 : Jump_Place_Marker (2, SelectMode); + cmJumpMark3 : Jump_Place_Marker (3, SelectMode); + cmJumpMark4 : Jump_Place_Marker (4, SelectMode); + cmJumpMark5 : Jump_Place_Marker (5, SelectMode); + cmJumpMark6 : Jump_Place_Marker (6, SelectMode); + cmJumpMark7 : Jump_Place_Marker (7, SelectMode); + cmJumpMark8 : Jump_Place_Marker (8, SelectMode); + cmJumpMark9 : Jump_Place_Marker (9, SelectMode); + else + Unlock; + Exit; + end; { Event.Command (Inner) } + TrackCursor (CenterCursor); + { If the user presses any key except cmNewline or cmBackspace } + { we need to check if the file has been modified yet. There } + { can be no spaces at the end of a line, or wordwrap doesn't } + { work properly. We don't want to do this if the file hasn't } + { been modified because the user could be bringing in an ASCII } + { file from an editor that allows spaces at the EOL. If we } + { took them out in that scenario the "M" would appear on the } + { TIndicator line and the user would get upset or confused. } + if (Event.Command <> cmNewLine) and + (Event.Command <> cmBackSpace) and + (Event.Command <> cmTabKey) and + Modified then + Remove_EOL_Spaces (SelectMode); + Unlock; + end; { Event.Command (Outer) } + end; { Drivers.evCommand } + + Drivers.evBroadcast: + case Event.Command of + cmScrollBarChanged: + if (Event.InfoPtr = HScrollBar) or + (Event.InfoPtr = VScrollBar) then + begin + CheckScrollBar (HScrollBar, Delta.X); + CheckScrollBar (VScrollBar, Delta.Y); + end + else + exit; + else + Exit; + end; { Drivers.evBroadcast } + + end; + ClearEvent (Event); +end; { TEditor.HandleEvent } + + +function TEditor.HasSelection : Boolean; +begin + HasSelection := SelStart <> SelEnd; +end; { TEditor.HasSelection } + + +procedure TEditor.HideSelect; +begin + Selecting := False; + SetSelect (CurPtr, CurPtr, False); +end; { TEditor.HideSelect } + + +procedure TEditor.InitBuffer; +begin + Assert(Buffer = nil, 'TEditor.InitBuffer: Buffer is not nil'); + ReAllocMem(Buffer, BufSize); +end; { TEditor.InitBuffer } + + +function TEditor.InsertBuffer (var P : PEditBuffer; + Offset, Length : Sw_Word; + AllowUndo, SelectText : Boolean) : Boolean; +VAR + SelLen : Sw_Word; + DelLen : Sw_Word; + SelLines : Sw_Word; + Lines : Sw_Word; + NewSize : Longint; +begin + InsertBuffer := True; + Selecting := False; + SelLen := SelEnd - SelStart; + if (SelLen = 0) and (Length = 0) then + Exit; + DelLen := 0; + if AllowUndo then + if CurPtr = SelStart then + DelLen := SelLen + else + if SelLen > InsCount then + DelLen := SelLen - InsCount; + NewSize := Longint (BufLen + DelCount - SelLen + DelLen) + Length; + if NewSize > BufLen + DelCount then + if (NewSize > MaxBufLength) or not SetBufSize (NewSize) then + begin + EditorDialog (edOutOfMemory, nil); + InsertBuffer := False; + SelEnd := SelStart; + Exit; + end; + SelLines := CountLines (Buffer^[BufPtr (SelStart)], SelLen); + if CurPtr = SelEnd then + begin + if AllowUndo then + begin + if DelLen > 0 then + Move (Buffer^[SelStart], Buffer^[CurPtr + GapLen - DelCount - DelLen], DelLen); + Dec (InsCount, SelLen - DelLen); + end; + CurPtr := SelStart; + Dec (CurPos.Y, SelLines); + end; + if Delta.Y > CurPos.Y then + begin + Dec (Delta.Y, SelLines); + if Delta.Y < CurPos.Y then + Delta.Y := CurPos.Y; + end; + if Length > 0 then + Move (P^[Offset], Buffer^[CurPtr], Length); + Lines := CountLines (Buffer^[CurPtr], Length); + Inc (CurPtr, Length); + Inc (CurPos.Y, Lines); + DrawLine := CurPos.Y; + DrawPtr := LineStart (CurPtr); + CurPos.X := CharPos (DrawPtr, CurPtr); + if not SelectText then + SelStart := CurPtr; + SelEnd := CurPtr; + if Length>Sellen then + begin + Inc (BufLen, Length - SelLen); + Dec (GapLen, Length - SelLen); + end + else + begin + Dec (BufLen, Sellen - Length); + Inc (GapLen, Sellen - Length); + end; + if AllowUndo then + begin + Inc (DelCount, DelLen); + Inc (InsCount, Length); + end; + Inc (Limit.Y, Lines - SelLines); + Delta.Y := Max (0, Min (Delta.Y, Limit.Y - Size.Y)); + if not IsClipboard then + Modified := True; + SetBufSize (BufLen + DelCount); + if (SelLines = 0) and (Lines = 0) then + Update (ufLine) + else + Update (ufView); +end; { TEditor.InsertBuffer } + + +function TEditor.InsertFrom (Editor : PEditor) : Boolean; +begin + InsertFrom := InsertBuffer (Editor^.Buffer, + Editor^.BufPtr (Editor^.SelStart), + Editor^.SelEnd - Editor^.SelStart, CanUndo, IsClipboard); +end; { TEditor.InsertFrom } + + +procedure TEditor.Insert_Line (Select_Mode : Byte); +{ This procedure inserts a newline at the current cursor position } +{ if a ^N is pressed. Unlike cmNewLine, the cursor will return } +{ to its original position. If the cursor was at the end of a } +{ line, and its spaces were removed, the cursor returns to the } +{ end of the line instead. } +begin + NewLine (Select_Mode); + SetCurPtr (LineEnd (LineMove (CurPtr, -1)), Select_Mode); +end; { TEditor.Insert_Line } + + +function TEditor.InsertText (Text : Pointer; + Length : Sw_Word; + SelectText : Boolean) : Boolean; +begin + if assigned(Text) and not Search_Replace then + Update_Place_Markers (Length, 0, Self.SelStart, Self.SelEnd); + InsertText := InsertBuffer (PEditBuffer (Text), + 0, Length, CanUndo, SelectText); +end; { TEditor.InsertText } + + +function TEditor.IsClipboard : Boolean; +begin + IsClipboard := Clipboard = @Self; +end; { TEditor.IsClipboard } + + +procedure TEditor.Jump_Place_Marker (Element : Byte; Select_Mode : Byte); +{ This procedure jumps to a place marker if ^Q# is pressed. } +{ We don't go anywhere if Place_Marker[Element] is not zero. } +begin + if (not IsClipboard) and (Place_Marker[Element] <> 0) then + SetCurPtr (Place_Marker[Element], Select_Mode); +end; { TEditor.Jump_Place_Marker } + + +procedure TEditor.Jump_To_Line (Select_Mode : Byte); +{ This function brings up a dialog box that allows } +{ the user to select a line number to jump to. } +VAR + Code : Integer; { Used for Val conversion. } + Temp_Value : Longint; { Holds converted dialog value. } +begin + if EditorDialog (edJumpToLine, @Line_Number) <> cmCancel then + begin + { Convert the Line_Number string to an interger. } + { Put it into Temp_Value. If the number is not } + { in the range 1..9999 abort. If the number is } + { our current Y position, abort. Otherwise, } + { go to top of document, and jump to the line. } + { There are faster methods. This one's easy. } + { Note that CurPos.Y is always 1 less than what } + { the TIndicator line says. } + val (Line_Number, Temp_Value, Code); + if (Temp_Value < 1) or (Temp_Value > 9999999) then + Exit; + if Temp_Value = CurPos.Y + 1 then + Exit; + SetCurPtr (0, Select_Mode); + SetCurPtr (LineMove (CurPtr, Temp_Value - 1), Select_Mode); + end; +end; {TEditor.Jump_To_Line} + + +function TEditor.LineEnd (P : Sw_Word) : Sw_Word; +var + start, + i : Sw_word; + pc : pchar; +begin + if P<CurPtr then + begin + i:=CurPtr-P; + pc:=pchar(Buffer)+P; + while (i>0) do + begin + if pc^ in [#10,#13] then + begin + LineEnd:=pc-pchar(Buffer); + exit; + end; + inc(pc); + dec(i); + end; + start:=CurPtr; + end + else + start:=P; + i:=BufLen-Start; + pc:=pchar(Buffer)+GapLen+start; + while (i>0) do + begin + if pc^ in [#10,#13] then + begin + LineEnd:=pc-(pchar(Buffer)+Gaplen); + exit; + end; + inc(pc); + dec(i); + end; + LineEnd:=pc-(pchar(Buffer)+Gaplen); +end; { TEditor.LineEnd } + + +function TEditor.LineMove (P : Sw_Word; Count : Sw_Integer) : Sw_Word; +VAR + Pos : Sw_Integer; + I : Sw_Word; +begin + I := P; + P := LineStart (P); + Pos := CharPos (P, I); + while Count <> 0 do + begin + I := P; + if Count < 0 then + begin + P := PrevLine (P); + Inc (Count); + end + else + begin + P := NextLine (P); + Dec (Count); + end; + end; + if P <> I then + P := CharPtr (P, Pos); + LineMove := P; +end; { TEditor.LineMove } + + +function TEditor.LineStart (P : Sw_Word) : Sw_Word; +var + i : Sw_word; + start,pc : pchar; + oc : char; +begin + if P>CurPtr then + begin + start:=pchar(Buffer)+GapLen; + pc:=start; + i:=P-CurPtr; + dec(pc); + while (i>0) do + begin + if pc^ in [#10,#13] then + break; + dec(pc); + dec(i); + end; + end + else + i:=0; + if i=0 then + begin + start:=pchar(Buffer); + i:=P; + pc:=start+p; + dec(pc); + while (i>0) do + begin + if pc^ in [#10,#13] then + break; + dec(pc); + dec(i); + end; + if i=0 then + begin + LineStart:=0; + exit; + end; + end; + oc:=pc^; + LineStart:=pc-start+1; +end; { TEditor.LineStart } + + +function TEditor.LineNr (P : Sw_Word) : Sw_Word; +var + pc,endp : pchar; + lines : sw_word; +begin + endp:=pchar(Buffer)+BufPtr(P); + pc:=pchar(Buffer); + lines:=0; + while (pc<endp) do + begin + if pc^ in [#10,#13] then + begin + inc(lines); + if ord((pc+1)^)+ord(pc^)=23 then + begin + inc(pc); + if (pc>=endp) then + break; + end; + end; + inc(pc); + end; + LineNr:=Lines; +end; + + +procedure TEditor.Lock; +begin + Inc (LockCount); +end; { TEditor.Lock } + + +function TEditor.NewLine (Select_Mode : Byte) : Boolean; +VAR + I : Sw_Word; { Used to track spaces for AutoIndent. } + P : Sw_Word; { Position of Cursor when we arrive and after Newline. } +begin + P := LineStart (CurPtr); + I := P; + { The first thing we do is remove any End Of Line spaces. } + { Then we check to see how many spaces are on beginning } + { of a line. We need this check to add them after CR/LF } + { if AutoIndenting. Last of all we insert spaces required } + { for the AutoIndenting, if it was on. } + Remove_EOL_Spaces (Select_Mode); + while (I < CurPtr) and ((Buffer^[I] in [#9,' '])) do + Inc (I); + if InsertText (@LineBreak[1], length(LineBreak), False) = FALSE then + exit; + if AutoIndent then + InsertText (@Buffer^[P], I - P, False); + { Remember where the CurPtr is at this moment. } + { Remember the length of the buffer at the moment. } + { Go to the previous line and remove EOL spaces. } + { Once removed, re-set the cursor to where we were } + { minus any spaces that might have been removed. } + I := BufLen; + P := CurPtr; + SetCurPtr (LineMove (CurPtr, - 1), Select_Mode); + Remove_EOL_Spaces (Select_Mode); + if I - BufLen <> 0 then + SetCurPtr (P - (I - BufLen), Select_Mode) + else + SetCurPtr (P, Select_Mode); + NewLine:=true; +end; { TEditor.NewLine } + + +function TEditor.NextChar (P : Sw_Word) : Sw_Word; +var + pc : pchar; +begin + if P<>BufLen then + begin + inc(P); + if P<>BufLen then + begin + pc:=pchar(Buffer); + if P>=CurPtr then + inc(pc,GapLen); + inc(pc,P-1); + if ord(pc^)+ord((pc+1)^)=23 then + inc(p); + end; + end; + NextChar:=P; +end; { TEditor.NextChar } + + +function TEditor.NextLine (P : Sw_Word) : Sw_Word; +begin + NextLine := NextChar (LineEnd (P)); +end; { TEditor.NextLine } + + +function TEditor.NextWord (P : Sw_Word) : Sw_Word; +begin + { skip word } + while (P < BufLen) and (BufChar (P) in WordChars) do + P := NextChar (P); + { skip spaces } + while (P < BufLen) and not (BufChar (P) in WordChars) do + P := NextChar (P); + NextWord := P; +end; { TEditor.NextWord } + + +function TEditor.PrevChar (P : Sw_Word) : Sw_Word; +var + pc : pchar; +begin + if p<>0 then + begin + dec(p); + if p<>0 then + begin + pc:=pchar(Buffer); + if P>=CurPtr then + inc(pc,GapLen); + inc(pc,P-1); + if ord(pc^)+ord((pc+1)^)=23 then + dec(p); + end; + end; + PrevChar:=P; +end; { TEditor.PrevChar } + + +function TEditor.PrevLine (P : Sw_Word) : Sw_Word; +begin + PrevLine := LineStart (PrevChar (P)); +end; { TEditor.PrevLine } + + +function TEditor.PrevWord (P : Sw_Word) : Sw_Word; +begin + { skip spaces } + while (P > 0) and not (BufChar (PrevChar (P)) in WordChars) do + P := PrevChar (P); + { skip word } + while (P > 0) and (BufChar (PrevChar (P)) in WordChars) do + P := PrevChar (P); + PrevWord := P; +end; { TEditor.PrevWord } + + +procedure TEditor.Reformat_Document (Select_Mode : Byte; Center_Cursor : Boolean); +{ This procedure will do a reformat of the entire document, or just } +{ from the current line to the end of the document, if ^QU is pressed. } +{ It simply brings up the correct dialog box, and then calls the } +{ TEditor.Reformat_Paragraph procedure to do the actual reformatting. } +CONST + efCurrentLine = $0000; { Radio button #1 selection for dialog box. } + efWholeDocument = $0001; { Radio button #2 selection for dialog box. } +VAR + Reformat_Options : Word; { Holds the dialog options for reformatting. } +begin + { Check if Word_Wrap is toggled on. If NOT on, check if programmer } + { allows reformatting of document and if not show user dialog that } + { says reformatting is not permissable. } + if not Word_Wrap then + begin + if not Allow_Reformat then + begin + EditorDialog (edReformatNotAllowed, nil); + Exit; + end; + Word_Wrap := True; + Update (ufStats); + end; + { Default radio button option to 1st one. Bring up dialog box. } + Reformat_Options := efCurrentLine; + if EditorDialog (edReformatDocument, @Reformat_Options) <> cmCancel then + begin + { If the option to reformat the whole document was selected } + { we need to go back to start of document. Otherwise we stay } + { on the current line. Call Reformat_Paragraph until we get } + { to the end of the document to do the reformatting. } + if Reformat_Options and efWholeDocument <> 0 then + SetCurPtr (0, Select_Mode); + Unlock; + repeat + Lock; + if NOT Reformat_Paragraph (Select_Mode, Center_Cursor) then + Exit; + TrackCursor (False); + Unlock; + until CurPtr = BufLen; + end; +end; { TEditor.Reformat_Document } + + +function TEditor.Reformat_Paragraph (Select_Mode : Byte; + Center_Cursor : Boolean) : Boolean; +{ This procedure will do a reformat of the current paragraph if ^B pressed. } +{ The feature works regardless if wordrap is on or off. It also supports } +{ the AutoIndent feature. Reformat is not possible if the CurPos exceeds } +{ the Right_Margin. Right_Margin is where the EOL is considered to be. } +CONST + Space : array [1..2] of Char = #32#32; +VAR + C : Sw_Word; { Position of CurPtr when we come into procedure. } + E : Sw_Word; { End of a line. } + S : Sw_Word; { Start of a line. } +begin + Reformat_Paragraph := False; + { Check if Word_Wrap is toggled on. If NOT on, check if programmer } + { allows reformatting of paragraph and if not show user dialog that } + { says reformatting is not permissable. } + if not Word_Wrap then + begin + if not Allow_Reformat then + begin + EditorDialog (edReformatNotAllowed, nil); + Exit; + end; + Word_Wrap := True; + Update (ufStats); + end; + C := CurPtr; + E := LineEnd (CurPtr); + S := LineStart (CurPtr); + { Reformat possible only if current line is NOT blank! } + if E <> S then + begin + { Reformat is NOT possible if the first word } + { on the line is beyond the Right_Margin. } + S := LineStart (CurPtr); + if NextWord (S) - S >= Right_Margin - 1 then + begin + EditorDialog (edReformNotPossible, nil); + Exit; + end; + { First objective is to find the first blank line } + { after this paragraph so we know when to stop. } + { That could be the end of the document. } + Repeat + SetCurPtr (LineMove (CurPtr, 1), Select_Mode); + E := LineEnd (CurPtr); + S := LineStart (CurPtr); + BlankLine := E; + until ((CurPtr = BufLen) or (E = S)); + SetCurPtr (C, Select_Mode); + repeat + { Set CurPtr to LineEnd and remove the EOL spaces. } + { Pull up the next line and remove its EOL space. } + { First make sure the next line is not BlankLine! } + { Insert spaces as required between the two lines. } + SetCurPtr (LineEnd (CurPtr), Select_Mode); + Remove_EOL_Spaces (Select_Mode); + if CurPtr <> Blankline - 2 then + DeleteRange (CurPtr, Nextword (CurPtr), True); + Remove_EOL_Spaces (Select_Mode); + case Buffer^[CurPtr-1] of + '!' : InsertText (@Space, 2, False); + '.' : InsertText (@Space, 2, False); + ':' : InsertText (@Space, 2, False); + '?' : InsertText (@Space, 2, False); + else + InsertText (@Space, 1, False); + end; + { Reset CurPtr to EOL. While line length is > Right_Margin } + { go Do_Word_Wrap. If wordrap failed, exit routine. } + SetCurPtr (LineEnd (CurPtr), Select_Mode); + while LineEnd (CurPtr) - LineStart (CurPtr) > Right_Margin do + if not Do_Word_Wrap (Select_Mode, Center_Cursor) then + Exit; + { If LineEnd - LineStart > Right_Margin then set CurPtr } + { to Right_Margin on current line. Otherwise we set the } + { CurPtr to LineEnd. This gyration sets up the conditions } + { to test for time of loop exit. } + if LineEnd (CurPtr) - LineStart (CurPtr) > Right_Margin then + SetCurPtr (LineStart (CurPtr) + Right_Margin, Select_Mode) + else + SetCurPtr (LineEnd (CurPtr), Select_Mode); + until ((CurPtr >= BufLen) or (CurPtr >= BlankLine - 2)); + end; + { If not at the end of the document reset CurPtr to start of next line. } + { This should be a blank line between paragraphs. } + if CurPtr < BufLen then + SetCurPtr (LineMove (CurPtr, 1), Select_Mode); + Reformat_Paragraph := True; +end; { TEditor.Reformat_Paragraph } + + +procedure TEditor.Remove_EOL_Spaces (Select_Mode : Byte); +{ This procedure tests to see if there are consecutive spaces } +{ at the end of a line (EOL). If so, we delete all spaces } +{ after the last non-space character to the end of line. } +{ We then reset the CurPtr to where we ended up at. } +VAR + C : Sw_Word; { Current pointer when we come into procedure. } + E : Sw_Word; { End of line. } + P : Sw_Word; { Position of pointer at any given moment. } + S : Sw_Word; { Start of a line. } +begin + C := CurPtr; + E := LineEnd (CurPtr); + P := E; + S := LineStart (CurPtr); + { Start at the end of a line and move towards the start. } + { Find first non-space character in that direction. } + while (P > S) and (BufChar (PrevChar (P)) = #32) do + P := PrevChar (P); + { If we found any spaces then delete them. } + if P < E then + begin + SetSelect (P, E, True); + DeleteSelect; + Update_Place_Markers (0, E - P, P, E); + end; + { If C, our pointer when we came into this procedure, } + { is less than the CurPtr then reset CurPtr to C so } + { cursor is where we started. Otherwise, set it to } + { the new CurPtr, for we have deleted characters. } + if C < CurPtr then + SetCurPtr (C, Select_Mode) + else + SetCurPtr (CurPtr, Select_Mode); +end; { TEditor.Remove_EOL_Spaces } + + +procedure TEditor.Replace; +VAR + ReplaceRec : TReplaceDialogRec; +begin + with ReplaceRec do + begin + Find := FindStr; + Replace := ReplaceStr; + Options := Flags; + if EditorDialog (edReplace, @ReplaceRec) <> cmCancel then + begin + FindStr := Find; + ReplaceStr := Replace; + Flags := Options or efDoReplace; + DoSearchReplace; + end; + end; +end; { TEditor.Replace } + + +procedure TEditor.Scroll_Down; +{ This procedure will scroll the screen up, and always keep } +{ the cursor on the CurPos.Y position, but not necessarily on } +{ the CurPos.X. If CurPos.Y scrolls off the screen, the cursor } +{ will stay in the upper left corner of the screen. This will } +{ simulate the same process in the IDE. The CurPos.X coordinate } +{ only messes up if we are on long lines and we then encounter } +{ a shorter or blank line beneath the current one as we scroll. } +{ In that case, it goes to the end of the new line. } +VAR + C : Sw_Word; { Position of CurPtr when we enter procedure. } + P : Sw_Word; { Position of CurPtr at any given time. } + W : Objects.TPoint; { CurPos.Y of CurPtr and P ('.X and '.Y). } +begin + { Remember current cursor position. Remember current CurPos.Y position. } + { Now issue the equivalent of a [Ctrl]-[End] command so the cursor will } + { go to the bottom of the current screen. Reset the cursor to this new } + { position and then send FALSE to TrackCursor so we fool it into } + { incrementing Delta.Y by only +1. If we didn't do this it would try } + { to center the cursor on the screen by fiddling with Delta.Y. } + C := CurPtr; + W.X := CurPos.Y; + P := LineMove (CurPtr, Delta.Y - CurPos.Y + Size.Y); + SetCurPtr (P, 0); + TrackCursor (False); + { Now remember where the new CurPos.Y is. See if distance between new } + { CurPos.Y and old CurPos.Y are greater than the current screen size. } + { If they are, we need to move cursor position itself down by one. } + { Otherwise, send the cursor back to our original CurPtr. } + W.Y := CurPos.Y; + if W.Y - W.X > Size.Y - 1 then + SetCurPtr (LineMove (C, 1), 0) + else + SetCurPtr (C, 0); +end; { TEditor.Scroll_Down } + + +procedure TEditor.Scroll_Up; +{ This procedure will scroll the screen down, and always keep } +{ the cursor on the CurPos.Y position, but not necessarily on } +{ the CurPos.X. If CurPos.Y scrolls off the screen, the cursor } +{ will stay in the bottom left corner of the screen. This will } +{ simulate the same process in the IDE. The CurPos.X coordinate } +{ only messes up if we are on long lines and we then encounter } +{ a shorter or blank line beneath the current one as we scroll. } +{ In that case, it goes to the end of the new line. } +VAR + C : Sw_Word; { Position of CurPtr when we enter procedure. } + P : Sw_Word; { Position of CurPtr at any given time. } + W : Objects.TPoint; { CurPos.Y of CurPtr and P ('.X and '.Y). } +begin + { Remember current cursor position. Remember current CurPos.Y position. } + { Now issue the equivalent of a [Ctrl]-[Home] command so the cursor will } + { go to the top of the current screen. Reset the cursor to this new } + { position and then send FALSE to TrackCursor so we fool it into } + { decrementing Delta.Y by only -1. If we didn't do this it would try } + { to center the cursor on the screen by fiddling with Delta.Y. } + C := CurPtr; + W.Y := CurPos.Y; + P := LineMove (CurPtr, -(CurPos.Y - Delta.Y + 1)); + SetCurPtr (P, 0); + TrackCursor (False); + { Now remember where the new CurPos.Y is. See if distance between new } + { CurPos.Y and old CurPos.Y are greater than the current screen size. } + { If they are, we need to move the cursor position itself up by one. } + { Otherwise, send the cursor back to our original CurPtr. } + W.X := CurPos.Y; + if W.Y - W.X > Size.Y - 1 then + SetCurPtr (LineMove (C, -1), 0) + else + SetCurPtr (C, 0); +end; { TEditor.Scroll_Up } + + +procedure TEditor.ScrollTo (X, Y : Sw_Integer); +begin + X := Max (0, Min (X, Limit.X - Size.X)); + Y := Max (0, Min (Y, Limit.Y - Size.Y)); + if (X <> Delta.X) or (Y <> Delta.Y) then + begin + Delta.X := X; + Delta.Y := Y; + Update (ufView); + end; +end; { TEditor.ScrollTo } + + +function TEditor.Search (const FindStr : String; Opts : Word) : Boolean; +VAR + I,Pos : Sw_Word; +begin + Search := False; + Pos := CurPtr; + repeat + if Opts and efCaseSensitive <> 0 then + I := Scan (Buffer^[BufPtr (Pos)], BufLen - Pos, FindStr) + else + I := IScan (Buffer^[BufPtr (Pos)], BufLen - Pos, FindStr); + if (I <> sfSearchFailed) then + begin + Inc (I, Pos); + if (Opts and efWholeWordsOnly = 0) or + not (((I <> 0) and (BufChar (I - 1) in WordChars)) or + ((I + Length (FindStr) <> BufLen) and + (BufChar (I + Length (FindStr)) in WordChars))) then + begin + Lock; + SetSelect (I, I + Length (FindStr), False); + TrackCursor (not CursorVisible); + Unlock; + Search := True; + Exit; + end + else + Pos := I + 1; + end; + until I = sfSearchFailed; +end; { TEditor.Search } + + +procedure TEditor.Select_Word; +{ This procedure will select the a word to put into the clipboard. } +{ I've added it just to maintain compatibility with the IDE editor. } +{ Note that selection starts at the current cursor position and ends } +{ when a space or the end of line is encountered. } +VAR + E : Sw_Word; { End of the current line. } + Select_Mode : Byte; { Allows us to turn select mode on inside procedure. } +begin + E := LineEnd (CurPtr); + { If the cursor is on a space or at the end of a line, abort. } + { Stupid action on users part for you can't select blanks! } + if (BufChar (CurPtr) = #32) or (CurPtr = E) then + Exit; + { Turn on select mode and tell editor to start selecting text. } + { As long as we have a character > a space (this is done to } + { exclude CR/LF pairs at end of a line) and we are NOT at the } + { end of a line, set the CurPtr to the next character. } + { Once we find a space or CR/LF, selection is done and we } + { automatically put the selected word into the Clipboard. } + Select_Mode := smExtend; + StartSelect; + while (BufChar (NextChar (CurPtr)) > #32) and (CurPtr < E) do + SetCurPtr (NextChar (CurPtr), Select_Mode); + SetCurPtr (NextChar (CurPtr), Select_Mode); + ClipCopy; +end; {TEditor.Select_Word } + + +procedure TEditor.SetBufLen (Length : Sw_Word); +begin + BufLen := Length; + GapLen := BufSize - Length; + SelStart := 0; + SelEnd := 0; + CurPtr := 0; + CurPos.X:=0; + CurPos.Y:=0; + Delta.X:=0; + Delta.Y:=0; + GetLimits(Buffer^[GapLen], BufLen,Limit); + inc(Limit.X); + inc(Limit.Y); + DrawLine := 0; + DrawPtr := 0; + DelCount := 0; + InsCount := 0; + Modified := False; + Update (ufView); +end; { TEditor.SetBufLen } + + +function TEditor.SetBufSize (NewSize : Sw_Word) : Boolean; +begin + ReAllocMem(Buffer, NewSize); + BufSize := NewSize; + SetBufSize := True; +end; { TEditor.SetBufSize } + + +procedure TEditor.SetCmdState (Command : Word; Enable : Boolean); +VAR + S : TCommandSet; +begin + S := [Command]; + if Enable and (State and sfActive <> 0) then + EnableCommands (S) + else + DisableCommands (S); +end; { TEditor.SetCmdState } + + +procedure TEditor.SetCurPtr (P : Sw_Word; SelectMode : Byte); +VAR + Anchor : Sw_Word; +begin + if SelectMode and smExtend = 0 then + Anchor := P + else + if CurPtr = SelStart then + Anchor := SelEnd + else + Anchor := SelStart; + if P < Anchor then + begin + if SelectMode and smDouble <> 0 then + begin + P := PrevLine (NextLine (P)); + Anchor := NextLine (PrevLine (Anchor)); + end; + SetSelect (P, Anchor, True); + end + else + begin + if SelectMode and smDouble <> 0 then + begin + P := NextLine (P); + Anchor := PrevLine (NextLine (Anchor)); + end; + SetSelect (Anchor, P, False); + end; +end; { TEditor.SetCurPtr } + + +procedure TEditor.Set_Place_Marker (Element : Byte); +{ This procedure sets a place marker for the CurPtr if ^K# is pressed. } +begin + if not IsClipboard then + Place_Marker[Element] := CurPtr; +end; { TEditor.Set_Place_Marker } + + +procedure TEditor.Set_Right_Margin; +{ This procedure will bring up a dialog box } +{ that allows the user to set Right_Margin. } +{ Values must be < MaxLineLength and > 9. } +VAR + Code : Integer; { Used for Val conversion. } + Margin_Data : TRightMarginRec; { Holds dialog results. } + Temp_Value : Sw_Integer; { Holds converted dialog value. } +begin + with Margin_Data do + begin + Str (Right_Margin, Margin_Position); + if EditorDialog (edRightMargin, @Margin_Position) <> cmCancel then + begin + val (Margin_Position, Temp_Value, Code); + if (Temp_Value <= MaxLineLength) and (Temp_Value > 9) then + Right_Margin := Temp_Value; + end; + end; +end; { TEditor.Set_Right_Margin } + + +procedure TEditor.SetSelect (NewStart, NewEnd : Sw_Word; CurStart : Boolean); +VAR + UFlags : Byte; + P : Sw_Word; + L : Sw_Word; +begin + if CurStart then + P := NewStart + else + P := NewEnd; + UFlags := ufUpdate; + if (NewStart <> SelStart) or (NewEnd <> SelEnd) then + if (NewStart <> NewEnd) or (SelStart <> SelEnd) then + UFlags := ufView; + if P <> CurPtr then + begin + if P > CurPtr then + begin + L := P - CurPtr; + Move (Buffer^[CurPtr + GapLen], Buffer^[CurPtr], L); + Inc (CurPos.Y, CountLines (Buffer^[CurPtr], L)); + CurPtr := P; + end + else + begin + L := CurPtr - P; + CurPtr := P; + Dec (CurPos.Y, CountLines (Buffer^[CurPtr], L)); + Move (Buffer^[CurPtr], Buffer^[CurPtr + GapLen], L); + end; + DrawLine := CurPos.Y; + DrawPtr := LineStart (P); + CurPos.X := CharPos (DrawPtr, P); + DelCount := 0; + InsCount := 0; + SetBufSize (BufLen); + end; + SelStart := NewStart; + SelEnd := NewEnd; + Update (UFlags); +end; { TEditor.Select } + + +procedure TEditor.SetState (AState : Word; Enable : Boolean); +begin + Inherited SetState (AState, Enable); + case AState of + sfActive: begin + if assigned(HScrollBar) then + HScrollBar^.SetState (sfVisible, Enable); + if assigned(VScrollBar) then + VScrollBar^.SetState (sfVisible, Enable); + if assigned(Indicator) then + Indicator^.SetState (sfVisible, Enable); + UpdateCommands; + end; + sfExposed: if Enable then Unlock; + end; +end; { TEditor.SetState } + + +procedure TEditor.Set_Tabs; +{ This procedure will bring up a dialog box } +{ that allows the user to set tab stops. } +VAR + Index : Sw_Integer; { Index into string array. } + Tab_Data : TTabStopRec; { Holds dialog results. } +begin + with Tab_Data do + begin + { Assign current Tab_Settings to Tab_String. } + { Bring up the tab dialog so user can set tabs. } + Tab_String := Copy (Tab_Settings, 1, Tab_Stop_Length); + if EditorDialog (edSetTabStops, @Tab_String) <> cmCancel then + begin + { If Tab_String comes back as empty then set Tab_Settings to nil. } + { Otherwise, find the last character in Tab_String that is not } + { a space and copy Tab_String into Tab_Settings up to that spot. } + if Length (Tab_String) = 0 then + begin + FillChar (Tab_Settings, SizeOf (Tab_Settings), #0); + Tab_Settings[0] := #0; + Exit; + end + else + begin + Index := Length (Tab_String); + while Tab_String[Index] <= #32 do + Dec (Index); + Tab_Settings := Copy (Tab_String, 1, Index); + end; + end; + end; +end; { TEditor.Set_Tabs } + + +procedure TEditor.StartSelect; +begin + HideSelect; + Selecting := True; +end; { TEditor.StartSelect } + + +procedure TEditor.Store (var S : Objects.TStream); +begin + Inherited Store (S); + PutPeerViewPtr (S, HScrollBar); + PutPeerViewPtr (S, VScrollBar); + PutPeerViewPtr (S, Indicator); + S.Write (BufSize, SizeOf (BufSize)); + S.Write (Canundo, SizeOf (Canundo)); + S.Write (AutoIndent, SizeOf (AutoIndent)); + S.Write (Line_Number, SizeOf (Line_Number)); + S.Write (Place_Marker, SizeOf (Place_Marker)); + S.Write (Right_Margin, SizeOf (Right_Margin)); + S.Write (Tab_Settings, SizeOf (Tab_Settings)); + S.Write (Word_Wrap, SizeOf (Word_Wrap)); +end; { Editor.Store } + + +procedure TEditor.Tab_Key (Select_Mode : Byte); +{ This function determines if we are in overstrike or insert mode, } +{ and then moves the cursor if overstrike, or adds spaces if insert. } +VAR + E : Sw_Word; { End of current line. } + Index : Sw_Integer; { Loop counter. } + Position : Sw_Integer; { CurPos.X position. } + S : Sw_Word; { Start of current line. } + Spaces : array [1..80] of Char; { Array to hold spaces for insertion. } +begin + E := LineEnd (CurPtr); + S := LineStart (CurPtr); + { Find the current horizontal cursor position. } + { Now loop through the Tab_Settings string and } + { find the next available tab stop. } + Position := CurPos.X + 1; + repeat + Inc (Position); + until (Tab_Settings[Position] <> #32) or (Position >= Ord (Tab_Settings[0])); + E := CurPos.X; + Index := 1; + { Now we enter a loop to go to the next tab position. } + { If we are in overwrite mode, we just move the cursor } + { through the text to the next tab stop. If we are in } + { insert mode, we add spaces to the Spaces array for } + { the number of times we loop. } + while Index < Position - E do + begin + if Overwrite then + begin + if (Position > LineEnd (CurPtr) - LineStart (CurPtr)) + or (Position > Ord (Tab_Settings[0])) then + begin + SetCurPtr (LineStart (LineMove (CurPtr, 1)), Select_Mode); + Exit; + end + else + if CurPtr < BufLen then + SetCurPtr (NextChar (CurPtr), Select_Mode); + end + else + begin + if (Position > Right_Margin) or (Position > Ord (Tab_Settings[0])) then + begin + SetCurPtr (LineStart (LineMove (CurPtr, 1)), Select_Mode); + Exit; + end + else + Spaces[Index] := #32; + end; + Inc (Index); + end; + { If we are insert mode, we insert spaces to the next tab stop. } + { When we're all done, the cursor will be sitting on the new tab stop. } + if not OverWrite then + InsertText (@Spaces, Index - 1, False); +end; { TEditor.Tab_Key } + + +procedure TEditor.ToggleInsMode; +begin + Overwrite := not Overwrite; + SetState (sfCursorIns, not GetState (sfCursorIns)); +end; { TEditor.ToggleInsMode } + + +procedure TEditor.TrackCursor (Center : Boolean); +begin + if Center then + ScrollTo (CurPos.X - Size.X + 1, CurPos.Y - Size.Y div 2) + else + ScrollTo (Max (CurPos.X - Size.X + 1, Min (Delta.X, CurPos.X)), + Max (CurPos.Y - Size.Y + 1, Min (Delta.Y, CurPos.Y))); +end; { TEditor.TrackCursor } + + +procedure TEditor.Undo; +VAR + Length : Sw_Word; +begin + if (DelCount <> 0) or (InsCount <> 0) then + begin + Update_Place_Markers (DelCount, 0, CurPtr, CurPtr + DelCount); + SelStart := CurPtr - InsCount; + SelEnd := CurPtr; + Length := DelCount; + DelCount := 0; + InsCount := 0; + InsertBuffer (Buffer, CurPtr + GapLen - Length, Length, False, True); + end; +end; { TEditor.Undo } + + +procedure TEditor.Unlock; +begin + if LockCount > 0 then + begin + Dec (LockCount); + if LockCount = 0 then + DoUpdate; + end; +end; { TEditor.Unlock } + + +procedure TEditor.Update (AFlags : Byte); +begin + UpdateFlags := UpdateFlags or AFlags; + if LockCount = 0 then + DoUpdate; +end; { TEditor.Update } + + +procedure TEditor.UpdateCommands; +begin + SetCmdState (cmUndo, (DelCount <> 0) or (InsCount <> 0)); + if not IsClipboard then + begin + SetCmdState (cmCut, HasSelection); + SetCmdState (cmCopy, HasSelection); + SetCmdState (cmPaste, assigned(Clipboard) and (Clipboard^.HasSelection)); + end; + SetCmdState (cmClear, HasSelection); + SetCmdState (cmFind, True); + SetCmdState (cmReplace, True); + SetCmdState (cmSearchAgain, True); +end; { TEditor.UpdateCommands } + + +procedure TEditor.Update_Place_Markers (AddCount : Word; KillCount : Word; + StartPtr,EndPtr : Sw_Word); +{ This procedure updates the position of the place markers } +{ as the user inserts and deletes text in the document. } +VAR + Element : Byte; { Place_Marker array element to traverse array with. } +begin + for Element := 1 to 10 do + begin + if AddCount > 0 then + begin + if (Place_Marker[Element] >= Curptr) + and (Place_Marker[Element] <> 0) then + Place_Marker[Element] := Place_Marker[Element] + AddCount; + end + else + begin + if Place_Marker[Element] >= StartPtr then + begin + if (Place_Marker[Element] >= StartPtr) and + (Place_Marker[Element] < EndPtr) then + Place_marker[Element] := 0 + else + begin + if integer (Place_Marker[Element]) - integer (KillCount) > 0 then + Place_Marker[Element] := Place_Marker[Element] - KillCount + else + Place_Marker[Element] := 0; + end; + end; + end; + end; + if AddCount > 0 then + BlankLine := BlankLine + AddCount + else + begin + if integer (BlankLine) - Integer (KillCount) > 0 then + BlankLine := BlankLine - KillCount + else + BlankLine := 0; + end; +end; { TEditor.Update_Place_Markers } + + +function TEditor.Valid (Command : Word) : Boolean; +begin + Valid := IsValid; +end; { TEditor.Valid } + + +{**************************************************************************** + TMEMO +****************************************************************************} + +constructor TMemo.Load (var S : Objects.TStream); +VAR + Length : Sw_Word; +begin + Inherited Load (S); + S.Read (Length, SizeOf (Length)); + if IsValid then + begin + S.Read (Buffer^[BufSize - Length], Length); + SetBufLen (Length); + end + else + S.Seek (S.GetPos + Length); +end; { TMemo.Load } + + +function TMemo.DataSize : Sw_Word; +begin + DataSize := BufSize + SizeOf (Sw_Word); +end; { TMemo.DataSize } + + +procedure TMemo.GetData (var Rec); +VAR + Data : TMemoData absolute Rec; +begin + Data.Length := BufLen; + Move (Buffer^, Data.Buffer, CurPtr); + Move (Buffer^[CurPtr + GapLen], Data.Buffer[CurPtr], BufLen - CurPtr); + FillChar (Data.Buffer[BufLen], BufSize - BufLen, 0); +end; { TMemo.GetData } + + +function TMemo.GetPalette : PPalette; +CONST + P : String[Length (CMemo)] = CMemo; +begin + GetPalette := PPalette(@P); +end; { TMemo.GetPalette } + + +procedure TMemo.HandleEvent (var Event : Drivers.TEvent); +begin + if (Event.What <> Drivers.evKeyDown) or (Event.KeyCode <> Drivers.kbTab) then + Inherited HandleEvent (Event); +end; { TMemo.HandleEvent } + + +procedure TMemo.SetData (var Rec); +VAR + Data : TMemoData absolute Rec; +begin + Move (Data.Buffer, Buffer^[BufSize - Data.Length], Data.Length); + SetBufLen (Data.Length); +end; { TMemo.SetData } + + +procedure TMemo.Store (var S : Objects.TStream); +begin + Inherited Store (S); + S.Write (BufLen, SizeOf (BufLen)); + S.Write (Buffer^, CurPtr); + S.Write (Buffer^[CurPtr + GapLen], BufLen - CurPtr); +end; { TMemo.Store } + + +{**************************************************************************** + TFILEEDITOR +****************************************************************************} + + +constructor TFileEditor.Init (var Bounds : TRect; + AHScrollBar, AVScrollBar : PScrollBar; + AIndicator : PIndicator; + AFileName : FNameStr); +begin + Inherited Init (Bounds, AHScrollBar, AVScrollBar, AIndicator, 0); + if AFileName <> '' then + begin + FileName := FExpand (AFileName); + if IsValid then + IsValid := LoadFile; + end; +end; { TFileEditor.Init } + + +constructor TFileEditor.Load (var S : Objects.TStream); +VAR + SStart,SEnd,Curs : Sw_Word; +begin + Inherited Load (S); + BufSize := 0; + S.Read (FileName[0], SizeOf (Byte)); + S.Read (Filename[1], Length (FileName)); + if IsValid then + IsValid := LoadFile; + S.Read (SStart, SizeOf (SStart)); + S.Read (SEnd, SizeOf (SEnd)); + S.Read (Curs, SizeOf (Curs)); + if IsValid and (SEnd <= BufLen) then + begin + SetSelect (SStart, SEnd, Curs = SStart); + TrackCursor (True); + end; +end; { TFileEditor.Load } + + +procedure TFileEditor.DoneBuffer; +begin + ReAllocMem(Buffer, 0); +end; { TFileEditor.DoneBuffer } + + +procedure TFileEditor.HandleEvent (var Event : Drivers.TEvent); +begin + Inherited HandleEvent (Event); + case Event.What of + Drivers.evCommand: + case Event.Command of + cmSave : Save; + cmSaveAs : SaveAs; + cmSaveDone : if Save then + Message (Owner, Drivers.evCommand, cmClose, nil); + else + Exit; + end; + else + Exit; + end; + ClearEvent (Event); +end; { TFileEditor.HandleEvent } + + +procedure TFileEditor.InitBuffer; +begin + Assert(Buffer = nil, 'TFileEditor.InitBuffer: Buffer is not nil'); + ReAllocMem(Buffer, MinBufLength); + BufSize := MinBufLength; +end; { TFileEditor.InitBuffer } + + +function TFileEditor.LoadFile: Boolean; +VAR + Length : Sw_Word; + FSize : Longint; + FRead : Sw_Integer; + F : File; +begin + LoadFile := False; + Length := 0; + Assign(F, FileName); + Reset(F, 1); + if IOResult <> 0 then + EditorDialog(edReadError, @FileName) + else + begin + FSize := FileSize(F); + if (FSize > MaxBufLength) or not SetBufSize(FSize) then + EditorDialog(edOutOfMemory, nil) + else + begin + BlockRead(F, Buffer^[BufSize-FSize], FSize, FRead); + if (IOResult <> 0) or (FRead<>FSize) then + EditorDialog(edReadError, @FileName) + else + begin + LoadFile := True; + Length := FRead; + end; + end; + Close(F); + end; + SetBufLen(Length); +end; { TFileEditor.LoadFile } + + +function TFileEditor.Save : Boolean; +begin + if FileName = '' then + Save := SaveAs + else + Save := SaveFile; +end; { TFileEditor.Save } + + +function TFileEditor.SaveAs : Boolean; +begin + SaveAs := False; + if EditorDialog (edSaveAs, @FileName) <> cmCancel then + begin + FileName := FExpand (FileName); + Message (Owner, Drivers.evBroadcast, cmUpdateTitle, nil); + SaveAs := SaveFile; + if IsClipboard then + FileName := ''; + end; +end; { TFileEditor.SaveAs } + + +function TFileEditor.SaveFile : Boolean; +VAR + F : File; + BackupName : Objects.FNameStr; + D : DOS.DirStr; + N : DOS.NameStr; + E : DOS.ExtStr; +begin + SaveFile := False; + if Flags and efBackupFiles <> 0 then + begin + FSplit (FileName, D, N, E); + BackupName := D + N + '.bak'; + Assign (F, BackupName); + Erase (F); + Assign (F, FileName); + Rename (F, BackupName); + InOutRes := 0; + end; + Assign (F, FileName); + Rewrite (F, 1); + if IOResult <> 0 then + EditorDialog (edCreateError, @FileName) + else + begin + BlockWrite (F, Buffer^, CurPtr); + BlockWrite (F, Buffer^[CurPtr + GapLen], BufLen - CurPtr); + if IOResult <> 0 then + EditorDialog (edWriteError, @FileName) + else + begin + Modified := False; + Update (ufUpdate); + SaveFile := True; + end; + Close (F); + end; +end; { TFileEditor.SaveFile } + + +function TFileEditor.SetBufSize (NewSize : Sw_Word) : Boolean; +VAR + N : Sw_Word; +begin + SetBufSize := False; + if NewSize = 0 then + NewSize := MinBufLength + else + if NewSize > (MaxBufLength-MinBufLength) then + NewSize := MaxBufLength + else + NewSize := (NewSize + (MinBufLength-1)) and (MaxBufLength and (not (MinBufLength-1))); + if NewSize <> BufSize then + begin + if NewSize > BufSize then ReAllocMem(Buffer, NewSize); + N := BufLen - CurPtr + DelCount; + Move(Buffer^[BufSize - N], Buffer^[NewSize - N], N); + if NewSize < BufSize then ReAllocMem(Buffer, NewSize); + BufSize := NewSize; + GapLen := BufSize - BufLen; + end; + SetBufSize := True; +end; { TFileEditor.SetBufSize } + + +procedure TFileEditor.Store (var S : Objects.TStream); +begin + Inherited Store (S); + S.Write (FileName, Length (FileName) + 1); + S.Write (SelStart, SizeOf (SelStart)); + S.Write (SelEnd, SizeOf (SelEnd)); + S.Write (CurPtr, SizeOf (CurPtr)); +end; { TFileEditor.Store } + + +procedure TFileEditor.UpdateCommands; +begin + Inherited UpdateCommands; + SetCmdState (cmSave, True); + SetCmdState (cmSaveAs, True); + SetCmdState (cmSaveDone, True); +end; { TFileEditor.UpdateCommands } + + +function TFileEditor.Valid (Command : Word) : Boolean; +VAR + D : Integer; +begin + if Command = cmValid then + Valid := IsValid + else + begin + Valid := True; + if Modified then + begin + if FileName = '' then + D := edSaveUntitled + else + D := edSaveModify; + case EditorDialog (D, @FileName) of + cmYes : Valid := Save; + cmNo : Modified := False; + cmCancel : Valid := False; + end; + end; + end; +end; { TFileEditor.Valid } + + +{**************************************************************************** + TEDITWINDOW +****************************************************************************} + +constructor TEditWindow.Init (var Bounds : TRect; + FileName : Objects.FNameStr; + ANumber : Integer); +var + HScrollBar : PScrollBar; + VScrollBar : PScrollBar; + Indicator : PIndicator; + R : TRect; +begin + Inherited Init (Bounds, '', ANumber); + Options := Options or ofTileable; + + R.Assign (18, Size.Y - 1, Size.X - 2, Size.Y); + HScrollBar := New (PScrollBar, Init (R)); + HScrollBar^.Hide; + Insert (HScrollBar); + + R.Assign (Size.X - 1, 1, Size.X, Size.Y - 1); + VScrollBar := New (PScrollBar, Init (R)); + VScrollBar^.Hide; + Insert (VScrollBar); + + R.Assign (2, Size.Y - 1, 16, Size.Y); + Indicator := New (PIndicator, Init (R)); + Indicator^.Hide; + Insert (Indicator); + + GetExtent (R); + R.Grow (-1, -1); + Editor := New (PFileEditor, Init (R, HScrollBar, VScrollBar, Indicator, FileName)); + Insert (Editor); +end; { TEditWindow.Init } + + +constructor TEditWindow.Load (var S : Objects.TStream); +begin + Inherited Load (S); + GetSubViewPtr (S, Editor); +end; { TEditWindow.Load } + + +procedure TEditWindow.Close; +begin + if Editor^.IsClipboard then + Hide + else + Inherited Close; +end; { TEditWindow.Close } + + +function TEditWindow.GetTitle (MaxSize : Sw_Integer) : TTitleStr; +begin + if Editor^.IsClipboard then + GetTitle := sClipboard + else + if Editor^.FileName = '' then + GetTitle := sUntitled + else + GetTitle := Editor^.FileName; +end; { TEditWindow.GetTile } + + +procedure TEditWindow.HandleEvent (var Event : Drivers.TEvent); +begin + Inherited HandleEvent (Event); + if (Event.What = Drivers.evBroadcast) then + { and (Event.Command = cmUpdateTitle) then } + { Changed if statement above so I could test for cmBlugeonStats. } + { Stats would not show up when loading a file until a key was pressed. } + case Event.Command of + cmUpdateTitle : + begin + Frame^.DrawView; + ClearEvent (Event); + end; + cmBludgeonStats : + begin + Editor^.Update (ufStats); + ClearEvent (Event); + end; + end; +end; { TEditWindow.HandleEvent } + + +procedure TEditWindow.SizeLimits(var Min, Max: TPoint); +begin + inherited SizeLimits(Min, Max); + Min.X := 23; +end; + + +procedure TEditWindow.Store (var S : Objects.TStream); +begin + Inherited Store (S); + PutSubViewPtr (S, Editor); +end; { TEditWindow.Store } + + +procedure RegisterEditors; +begin + RegisterType (REditor); + RegisterType (RMemo); + RegisterType (RFileEditor); + RegisterType (RIndicator); + RegisterType (REditWindow); +end; { RegisterEditors } + + +end. { Unit NewEdit } diff --git a/packages/fv/src/fvcommon.pas b/packages/fv/src/fvcommon.pas new file mode 100644 index 0000000000..9e1ba4a10c --- /dev/null +++ b/packages/fv/src/fvcommon.pas @@ -0,0 +1,371 @@ +{********************[ COMMON UNIT ]***********************} +{ } +{ System independent COMMON TYPES & DEFINITIONS } +{ } +{ Parts Copyright (c) 1997 by Balazs Scheidler } +{ bazsi@balabit.hu } +{ } +{ Parts Copyright (c) 1999, 2000 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@projectent.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ - Speed Pascal 1.0+ (32 Bit) } +{ - C'T patch to BP (16 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Who Fix } +{ ------- -------- --- ---------------------------- } +{ 0.1 12 Jul 97 Bazsi Initial implementation } +{ 0.2 18 Jul 97 Bazsi Linux specific error codes } +{ 0.2.2 28 Jul 97 Bazsi Base error code for Video } +{ 0.2.3 29 Jul 97 Bazsi Basic types added (PByte etc) } +{ 0.2.5 08 Aug 97 Bazsi Error handling code added } +{ 0.2.6 06 Sep 97 Bazsi Base code for keyboard } +{ 0.2.7 06 Nov 97 Bazsi Base error code for filectrl } +{ 0.2.8 21 Jan 99 LdB Max data sizes added. } +{ 0.2.9 22 Jan 99 LdB General array types added. } +{ 0.3.0 27 Oct 99 LdB Delphi3+ MaxAvail, MemAvail } +{ 0.4.0 14 Nov 00 LdB Revamp of whole unit } +{**********************************************************} + +UNIT FVCommon; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{$ifdef win32} + uses + Windows; +{$endif} + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ SYSTEM ERROR BASE CONSTANTS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ The following ranges have been defined for error codes: } +{---------------------------------------------------------------------------} +{ 0 - 1000 OS dependant error codes } +{ 1000 - 10000 API reserved error codes } +{ 10000 - Add-On unit error codes } +{---------------------------------------------------------------------------} + +{---------------------------------------------------------------------------} +{ DEFINED BASE ERROR CONSTANTS } +{---------------------------------------------------------------------------} +CONST + errOk = 0; { No error } + errVioBase = 1000; { Video base offset } + errKbdBase = 1010; { Keyboard base offset } + errFileCtrlBase = 1020; { File IO base offset } + errMouseBase = 1030; { Mouse base offset } + +{---------------------------------------------------------------------------} +{ MAXIUM DATA SIZES } +{---------------------------------------------------------------------------} +CONST +{$IFDEF BIT_16} { 16 BIT DEFINITION } + MaxBytes = 65520; { Maximum data size } +{$ENDIF} +{$IFDEF BIT_32} { 32 BIT DEFINITION } + MaxBytes = 128*1024*1024; { Maximum data size } +{$ENDIF} + MaxWords = MaxBytes DIV SizeOf(Word); { Max words } + MaxInts = MaxBytes DIV SizeOf(Integer); { Max integers } + MaxLongs = MaxBytes DIV SizeOf(LongInt); { Max longints } + MaxPtrs = MaxBytes DIV SizeOf(Pointer); { Max pointers } + MaxReals = MaxBytes DIV SizeOf(Real); { Max reals } + MaxStr = MaxBytes DIV SizeOf(String); { Max strings } + +{***************************************************************************} +{ PUBLIC TYPE DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ CPU TYPE DEFINITIONS } +{---------------------------------------------------------------------------} +TYPE +{$IFDEF BIT_32} { 32 BIT CODE } + CPUWord = Longint; { CPUWord is 32 bit } + CPUInt = Longint; { CPUInt is 32 bit } +{$ELSE} { 16 BIT CODE } + CPUWord = Word; { CPUWord is 16 bit } + CPUInt = Integer; { CPUInt is 16 bit } +{$ENDIF} + +{---------------------------------------------------------------------------} +{ 16/32 BIT SWITCHED TYPE CONSTANTS } +{---------------------------------------------------------------------------} +TYPE +{$IFDEF BIT_16} { 16 BIT DEFINITIONS } + Sw_Word = Word; { Standard word } + Sw_Integer = Integer; { Standard integer } +{$ENDIF} +{$IFDEF BIT_32} { 32 BIT DEFINITIONS } + Sw_Word = Cardinal; { Long integer now } + Sw_Integer = LongInt; { Long integer now } +{$ENDIF} + +{---------------------------------------------------------------------------} +{ GENERAL ARRAYS } +{---------------------------------------------------------------------------} +TYPE + TByteArray = ARRAY [0..MaxBytes-1] Of Byte; { Byte array } + PByteArray = ^TByteArray; { Byte array pointer } + + TWordArray = ARRAY [0..MaxWords-1] Of Word; { Word array } + PWordArray = ^TWordArray; { Word array pointer } + + TIntegerArray = ARRAY [0..MaxInts-1] Of Integer; { Integer array } + PIntegerArray = ^TIntegerArray; { Integer array pointer } + + TLongIntArray = ARRAY [0..MaxLongs-1] Of LongInt; { LongInt array } + PLongIntArray = ^TLongIntArray; { LongInt array pointer } + + TRealArray = Array [0..MaxReals-1] Of Real; { Real array } + PRealarray = ^TRealArray; { Real array pointer } + + TPointerArray = Array [0..MaxPtrs-1] Of Pointer; { Pointer array } + PPointerArray = ^TPointerArray; { Pointer array ptr } + + TStrArray = Array [0..MaxStr-1] Of String; { String array } + PStrArray = ^TStrArray; { String array ptr } + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{-GetErrorCode------------------------------------------------------- +Returns the last error code and resets ErrorCode to errOk. +07/12/97 Bazsi +---------------------------------------------------------------------} +FUNCTION GetErrorCode: LongInt; + +{-GetErrorInfo------------------------------------------------------- +Returns the info assigned to the previous error, doesn't reset the +value to nil. Would usually only be called if ErrorCode <> errOk. +07/12/97 Bazsi +---------------------------------------------------------------------} +FUNCTION GetErrorInfo: Pointer; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MINIMUM AND MAXIMUM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +FUNCTION Min (I, J: Sw_Integer): Sw_Integer; +FUNCTION Max (I, J: Sw_Integer): Sw_Integer; + +{-MinimumOf---------------------------------------------------------- +Given two real numbers returns the minimum real of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MinimumOf (A, B: Real): Real; + +{-MaximumOf---------------------------------------------------------- +Given two real numbers returns the maximum real of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MaximumOf (A, B: Real): Real; + +{-MinIntegerOf------------------------------------------------------- +Given two integer values returns the lowest integer of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MinIntegerOf (A, B: Integer): Integer; + +{-MaxIntegerof------------------------------------------------------- +Given two integer values returns the biggest integer of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MaxIntegerOf (A, B: Integer): Integer; + +{-MinLongIntOf------------------------------------------------------- +Given two long integers returns the minimum longint of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MinLongIntOf (A, B: LongInt): LongInt; + +{-MaxLongIntOf------------------------------------------------------- +Given two long integers returns the maximum longint of the two. +04Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MaxLongIntOf (A, B: LongInt): LongInt; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MISSING DELPHI3 ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{ ******************************* REMARK ****************************** } +{ Delphi 3+ does not define these standard routines so I have made } +{ some public functions here to complete compatability. } +{ ****************************** END REMARK *** Leon de Boer, 14Aug98 * } + +{-MemAvail----------------------------------------------------------- +Returns the free memory available under Delphi 3+. +14Aug98 LdB +---------------------------------------------------------------------} +FUNCTION MemAvail: LongInt; + +{-MaxAvail----------------------------------------------------------- +Returns the max free memory block size available under Delphi 3+. +14Aug98 LdB +---------------------------------------------------------------------} +FUNCTION MaxAvail: LongInt; + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +CONST + ErrorCode: Longint = errOk; { Last error code } + ErrorInfo: Pointer = Nil; { Last error info } + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{$IFDEF PPC_DELPHI3} { DELPHI 3+ COMPILER } +USES WinTypes, WinProcs; { Stardard units } +{$ENDIF} + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ GetErrorCode -> Platforms ALL - Updated 12Jul97 Bazsi } +{---------------------------------------------------------------------------} +FUNCTION GetErrorCode: LongInt; +BEGIN + GetErrorCode := ErrorCode; { Return last error } + ErrorCode := 0; { Now clear errorcode } +END; + +{---------------------------------------------------------------------------} +{ GetErrorInfo -> Platforms ALL - Updated 12Jul97 Bazsi } +{---------------------------------------------------------------------------} +FUNCTION GetErrorInfo: Pointer; +BEGIN + GetErrorInfo := ErrorInfo; { Return errorinfo ptr } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MINIMUM AND MAXIMUM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +FUNCTION Min (I, J: Sw_Integer): Sw_Integer; +BEGIN + If (I < J) Then Min := I Else Min := J; { Select minimum } +END; + +FUNCTION Max (I, J: Sw_Integer): Sw_Integer; +BEGIN + If (I > J) Then Max := I Else Max := J; { Select maximum } +END; + + +{---------------------------------------------------------------------------} +{ MinimumOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MinimumOf (A, B: Real): Real; +BEGIN + If (B < A) Then MinimumOf := B { B smaller take it } + Else MinimumOf := A; { Else take A } +END; + +{---------------------------------------------------------------------------} +{ MaximumOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MaximumOf (A, B: Real): Real; +BEGIN + If (B > A) Then MaximumOf := B { B bigger take it } + Else MaximumOf := A; { Else take A } +END; + +{---------------------------------------------------------------------------} +{ MinIntegerOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MinIntegerOf (A, B: Integer): Integer; +BEGIN + If (B < A) Then MinIntegerOf := B { B smaller take it } + Else MinIntegerOf := A; { Else take A } +END; + +{---------------------------------------------------------------------------} +{ MaxIntegerOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MaxIntegerOf (A, B: Integer): Integer; +BEGIN + If (B > A) Then MaxIntegerOf := B { B bigger take it } + Else MaxIntegerOf := A; { Else take A } +END; + +{---------------------------------------------------------------------------} +{ MinLongIntOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MinLongIntOf (A, B: LongInt): LongInt; +BEGIN + If (B < A) Then MinLongIntOf := B { B smaller take it } + Else MinLongIntOf := A; { Else take A } +END; + +{---------------------------------------------------------------------------} +{ MaxLongIntOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MaxLongIntOf (A, B: LongInt): LongInt; +BEGIN + If (B > A) Then MaxLongIntOf := B { B bigger take it } + Else MaxLongIntOf := A; { Else take A } +END; + +FUNCTION MemAvail: LongInt; +BEGIN + { Unlimited } + MemAvail:=high(longint); +END; + +{---------------------------------------------------------------------------} +{ MaxAvail -> Platforms WIN/NT - Updated 14Aug98 LdB } +{---------------------------------------------------------------------------} +FUNCTION MaxAvail: LongInt; +BEGIN + { Unlimited } + MaxAvail:=high(longint); +END; + +END. diff --git a/packages/fv/src/fvconsts.pas b/packages/fv/src/fvconsts.pas new file mode 100644 index 0000000000..5d3c82f421 --- /dev/null +++ b/packages/fv/src/fvconsts.pas @@ -0,0 +1,642 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of DIALOGS.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@starwon.com.au - backup e-mail addr } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} +unit FVConsts; +interface + +{ + The FVConsts unit declares constants for all object type IDs used in the + FreeVision library. They have been moved here for easier management. No + values for views declared in TV 2.0 have been changed from so that original + resource files may still be used. +} +const + { Views Unit } + idView = 1; + idFrame = 2; + idScrollBar = 3; + idScroller = 4; + idListViewer = 5; + idGroup = 6; + idWindow = 7; + + { Dialogs Unit 10 - ? } + idDialog = 10; + idInputLine = 11; + idButton = 12; + idCluster = 13; + idRadioButtons = 14; + idCheckBoxes = 15; + idListBox = 16; + idStaticText = 17; + idLabel = 18; + idHistory = 19; + idParamText = 20; + idCommandCheckBoxes = 21; + idCommandRadioButtons = 22; + idCommandIcon = 23; + idBrowseButton = 24; + idEditListBox = 25; + idModalInputLine = 26; + idMultiCheckBoxes = 27; + idListDlg = 28; + + { App Unit } + idBackground = 30; + idDesktop = 31; + + { Config Unit } + idConfig = 32; + idMouseDlg = 33; + idVideoDlg = 34; + idClickTester = 35; + + { Menus Unit } + idMenuBar = 40; + idMenuBox = 41; + idStatusLine = 42; + idMenuPopup = 43; + idMenuButton = 44; + + { Objects Unit } + idCollection = 50; + idStringCollection = 51; + idStringList = 52; + idStrListMaker = 52; + idStrCollection = 69; + + { Resource Unit } + idMemStringList = 52; + + { Tabs Unit } + idTab = 55; + + { StdDlg Unit } + idFileInputLine = 60; + idFileCollection = 61; + idFileList = 62; + idFileInfoPane = 63; + idFileDialog = 64; + idDirCollection = 65; + idDirListBox = 66; + idChDirDialog = 67; + idSortedListBox = 68; + idEditChDirDialog = 69; + + { Editors Unit 70 - ? } + idEditor = 70; + idMemo = 71; + idFileEditor = 72; + idIndicator = 73; + idEditWindow = 74; + idEditWindowCollection = 75; { this value may need to be changed } + idEditorEngine = 76; + + { Validate Unit } + idPXPictureValidator = 80; + idFilterValidator = 81; + idRangeValidator = 82; + idStringLookupValidator = 83; + idRealValidator = 84; + idByteValidator = 85; + idIntegerValidator = 86; + idSingleValidator = 87; + idWordValidator = 88; + idDateValidator = 89; + idTimeValidator = 90; + + { Outline Unit } + idOutline = 91; + + { ColorSel Unit } + idColorSelector = 92; + idMonoSelector = 93; + idColorDisplay = 94; + idColorGroupList = 95; + idColorItemList = 96; + idColorDialog = 97; + + { TimedDlg Unit } + idTimedDialog = 98; + idTimedDialogText = 99; + + { Statuses Unit } + idStatus = 300; + idStatusDlg = 301; + idStatusMessageDlg = 302; + idGauge = 303; + idArrowGauge = 304; + idBarGauge = 305; + idPercentGauge = 306; + idSpinnerGauge = 307; + idAppStatus = 308; + idHeapMinAvail = 309; + idHeapMemAvail = 310; + + { FVList Unit } + + { ColorTxt Unit } + idColoredText = 611; + + { InpLong Unit } + idInputLong = 711; + + { ASCIITab Unit } + idTable = 10030; + idReport = 10031; + idASCIIChart = 10032; + +{ + The FVConsts unit contains all command constants used in the FreeVision + library. They have been extracted from their original units and placed here + for easier maintainence and modification to remove conflicts, such as Borland + created with the cmChangeDir constant in the StdDlg and App units. +} + +const + { App Unit } + cmNew = 30; + cmOpen = 31; + cmSave = 32; + cmSaveAs = 33; + cmSaveAll = 34; + cmSaveDone = 39; {! Needs to match value in app.pas} + cmChangeDir = 35; {!} + cmDosShell = 36; {!} + cmCloseAll = 37; + cmDelete = 38; + cmEdit = 40; + cmAbout = 41; + cmDesktopLoad = 42; + cmDesktopStore = 43; + cmNewDesktop = 44; + cmNewMenuBar = 45; + cmNewStatusLine = 46; + cmNewVideo = 47; + cmTransfer = 48; + cmResizeApp = 49; + cmQuitApp = 57; + + cmRecordHistory = 60; + cmGrabDefault = 61; + cmReleaseDefault = 62; + + cmHelpContents = 256; + cmHelpIndex = 257; + cmHelpTopic = 258; + cmHelpPrev = 259; + cmHelpUsingHelp = 260; + cmHelpAbout = 261; + + cmBrowseDir = 262; + cmBrowseFile = 263; + + { Views Unit } + cmValid = 0; + cmQuit = 1; + cmError = 2; + cmMenu = 3; + cmClose = 4; + cmZoom = 5; + cmResize = 6; + cmNext = 7; + cmPrev = 8; + cmHelp = 9; + cmOK = 10; + cmCancel = 11; + cmYes = 12; + cmNo = 13; + cmDefault = 14; + cmCut = 20; + cmCopy = 21; + cmPaste = 22; + cmUndo = 23; + cmClear = 24; + cmTile = 25; + cmCascade = 26; + cmHide = 27; + cmReceivedFocus = 50; + cmReleasedFocus = 51; + cmCommandSetChanged = 52; + cmScrollBarChanged = 53; + cmScrollBarClicked = 54; + cmSelectWindowNum = 55; + cmListItemSelected = 56; + + { ColorSel Unit } + cmColorForegroundChanged = 71; + cmColorBackgroundChanged = 72; + cmColorSet = 73; + cmNewColorItem = 74; + cmNewColorIndex = 75; + cmSaveColorIndex = 76; + + { StdDlg Unit 800 - ? } + cmFileOpen = 800; { Returned from TFileDialog when Open pressed } + cmFileReplace = 801; { Returned from TFileDialog when Replace pressed } + cmFileClear = 802; { Returned from TFileDialog when Clear pressed } + cmFileInit = 803; { Used by TFileDialog internally } + cmRevert = 805; { Used by TChDirDialog internally } + cmFileFocused = 806; { A new file was focused in the TFileList } + cmFileDoubleClicked = 807; { A file was selected in the TFileList } + + { Config Unit 130-140, 900-999 } + cmConfigMouse = 130; { Mouse command disabled by Init if no mouse } + cmConfigOpen = 900; + cmConfigSave = 901; + cmConfigSaveAs = 902; + cmConfigMenu = 903; + cmConfigColors = 904; + cmConfigVideo = 905; + cmConfigCO80 = 906; + cmConfigBW80 = 907; + cmConfigMono = 908; + cmClock = 909; + cmClockSetFormat = 910; + + { Editors Unit } + cmFind = 82; + cmReplace = 83; + cmSearchAgain = 84; + cmPrint = 85; + cmRedo = 86; + cmJumpLine = 87; + cmWindowList = 88; + cmCharLeft = 500; + cmCharRight = 501; + cmWordLeft = 502; + cmWordRight = 503; + cmLineStart = 504; + cmLineEnd = 505; + cmLineUp = 506; + cmLineDown = 507; + cmPageUp = 508; + cmPageDown = 509; + cmTextStart = 510; + cmTextEnd = 511; + cmNewLine = 512; + cmBackSpace = 513; + cmDelChar = 514; + cmDelWord = 515; + cmDelStart = 516; + cmDelEnd = 517; + cmDelLine = 518; + cmInsMode = 519; + cmStartSelect = 520; + cmHideSelect = 521; + cmEndSelect = 522; + cmIndentMode = 523; + cmUpdateTitle = 524; + cmReformPara = 525; + cmTabKey = 526; + cmInsertLine = 527; + cmScrollUp = 528; + cmScrollDown = 529; + cmHomePage = 530; + cmEndPage = 531; + cmJumpMark0 = 532; + cmJumpMark1 = 533; + cmJumpMark2 = 534; + cmJumpMark3 = 535; + cmJumpMark4 = 536; + cmJumpMark5 = 537; + cmJumpMark6 = 538; + cmJumpMark7 = 539; + cmJumpMark8 = 540; + cmJumpMark9 = 541; + cmReformDoc = 542; + cmSetMark0 = 543; + cmSetMark1 = 544; + cmSetMark2 = 545; + cmSetMark3 = 546; + cmSetMark4 = 547; + cmSetMark5 = 548; + cmSetMark6 = 549; + cmSetMark7 = 550; + cmSetMark8 = 551; + cmSetMark9 = 552; + cmSelectWord = 553; + cmSaveExit = 554; + cmCenterText = 555; + cmSetTabs = 556; + cmRightMargin = 557; + cmWordwrap = 558; + cmBludgeonStats = 559; + cmPrinterSetup = 560; + cmClipboard = 561; + cmSpellCheck = 562; + cmCopyBlock = 563; + cmMoveBlock = 564; + cmDelSelect = 565; + cmIdentBlock = 566; + cmUnidentBlock = 567; + cmFileHistory = 600; + + { Statuses Unit } + cmStatusUpdate = 300; { note - need to set to valid value } + cmStatusDone = 301; + cmStatusPause = 302; + cmStatusResume = 303; + + cmCursorChanged = 700; + + +{ + The FVConsts unit declares standard help contexts used in FreeVision. By + placing all help contexts in one unit, duplicate help contexts are more + easily prevented +} + +const + + hcNoContext = 0; + hcDragging = 1; + hcOk = 2; + hcCancel = 3; + hcEdit = 4; + hcDelete = 5; + hcInsert = 6; + + { App Unit } + hcNew = 65281; hcFileNew = hcNew; + hcOpen = 65282; hcFileOpen = hcOpen; + hcSave = 65283; hcFileSave = hcSave; + hcSaveAs = 65284; hcFileSaveAs = hcSaveAs; + hcSaveAll = 65285; hcFileSaveAll = hcSaveAll; + hcChangeDir = 65286; hcFileChangeDir = hcChangeDir; + hcDosShell = 65287; hcFileDOSShell = hcDosShell; + hcExit = 65288; hcFileExit = hcExit; + hcEditMenu = 65289; + hcHelpMenu = 65291; + hcHelpContents = 65292; + hcHelpIndex = 65293; + hcHelpTopic = 65294; + hcHelpPrev = 65295; + hcHelpUsingHelp = 65296; + hcHelpAbout = 65297; + hcWindowMenu = 65298; + hcUndo = $FF10; + hcCut = $FF11; + hcCopy = $FF12; + hcPaste = $FF13; + hcClear = $FF14; + hcTile = $FF20; + hcCascade = $FF21; + hcCloseAll = $FF22; + hcResize = $FF23; + hcZoom = $FF24; + hcNext = $FF25; + hcPrev = $FF26; + hcClose = $FF27; + hcHide = $FF28; + hcFileMenu = 65320; + hcSearchAndReplace =65325; + + { Editors Unit } + hcFile_Menu = 2100; +{ hcOpen = 2101; } +{ hcNew = 2102; } +{ hcSave = 2103; } + hcSaveDone = 2104; +{ hcSaveAs = 2105; } +{ hcChangeDir = 2106; } +{ hcShellToDos = 2107; } +{ hcExit = 2108; } + hcFile_Menu_Items = hcExit; + + hcEdit_Menu = 2200; +{ hcUndo = 2201; } +{ hcCopy = 2202; } +{ hcCut = 2203; } +{ hcPaste = 2204; } + hcClipboard = 2205; +{ hcClear = 2206; } + hcSpellCheck = 2207; + hcEdit_Menu_Items = hcSpellCheck; + + hcSearch_Menu = 2300; + hcFind = 2301; + hcReplace = 2302; + hcAgain = 2303; + hcSearch_Menu_Items = hcAgain; + + hcWindows_Menu = 2400; +{ hcResize = 2401; } +{ hcZoom = 2402; } +{ hcPrev = 2403; } +{ hcNext = 2404; } +{ hcClose = 2405; } +{ hcTile = 2406; } +{ hcCascade = 2407; } + hcWindows_Menu_Items = hcCascade; + + hcDesktop_Menu = 2500; + hcLoadDesktop = 2501; + hcSaveDesktop = 2502; + hcToggleVideo = 2503; + hcDesktop_Menu_Items = hcToggleVideo; + + hcMisc_Commands = 2600; + hckbShift = 2601; + hckbCtrl = 2602; + hckbAlt = 2603; + hcMisc_Items = hckbAlt; + + hcEditor_Commands = 2700; + hcCursor = 2701; + hcDeleting = 2702; + hcFormatting = 2703; + hcMarking = 2704; + hcMoving = 2705; + hcSaving = 2706; + hcSelecting = 2707; + hcTabbing = 2708; + hcBackSpace = 2709; + hcCenterText = 2710; + hcCharLeft = 2711; + hcCharRight = 2712; + hcDelChar = 2713; + hcDelEnd = 2714; + hcDelLine = 2715; + hcDelStart = 2716; + hcDelWord = 2717; + hcEndPage = 2718; + hcHideSelect = 2719; + hcHomePage = 2720; + hcIndentMode = 2721; + hcInsertLine = 2722; + hcInsMode = 2723; + hcJumpLine = 2724; + hcLineDown = 2725; + hcLineEnd = 2726; + hcLineStart = 2727; + hcLineUp = 2728; + hcNewLine = 2729; + hcPageDown = 2730; + hcPageUp = 2731; + hcReformDoc = 2732; + hcReformPara = 2733; + hcRightMargin = 2734; + hcScrollDown = 2735; + hcScrollUp = 2736; + hcSearchAgain = 2737; + hcSelectWord = 2738; + hcSetTabs = 2739; + hcStartSelect = 2740; + hcTabKey = 2741; + hcTextEnd = 2742; + hcTextStart = 2743; + hcWordLeft = 2744; + hcWordRight = 2745; + hcWordWrap = 2746; + + hcJMarker_Menu = 2750; + hcJumpMark1 = 2751; + hcJumpMark2 = 2752; + hcJumpMark3 = 2753; + hcJumpMark4 = 2754; + hcJumpMark5 = 2755; + hcJumpMark6 = 2756; + hcJumpMark7 = 2757; + hcJumpMark8 = 2758; + hcJumpMark9 = 2759; + hcJumpMark0 = 2760; + hcJMarker_Menu_Items = 2761; + + hcSMarker_Menu = 2770; + hcSetMark1 = 2771; + hcSetMark2 = 2772; + hcSetMark3 = 2773; + hcSetMark4 = 2774; + hcSetMark5 = 2775; + hcSetMark6 = 2776; + hcSetMark7 = 2777; + hcSetMark8 = 2778; + hcSetMark9 = 2779; + hcSetMark0 = 2780; + hcSMarker_Menu_Items = 2781; + + hcEditor_Items = hcSMarker_Menu_Items; + + { Dialog } + hcDialogs = 2800; + hcDCancel = 2801; + hcDNo = 2802; + hcDOk = 2803; + hcDYes = 2804; + hcDAbout = 2805; + hcDDirName = 2806; + hcDDirTree = 2807; + hcDChDir = 2808; + hcDRevert = 2809; + hcDName = 2810; + hcDFiles = 2811; + hcDFindText = 2812; + hcDLineNumber = 2813; + hcDReformDoc = 2814; + hcDReplaceTExt = 2815; + hcDRightMargin = 2816; + hcDTabStops = 2817; + hcListDlg = 2818; + + { Checkbox help } + hcCCaseSensitive = 2900; + hcCWholeWords = 2901; + hcCPromptReplace = 2902; + hcCReplaceAll = 2903; + hcCReformCurrent = 2904; + hcCReformEntire = 2905; + + { Statuses unit } + hcStatusPause = 2950; + hcStatusResume = 2951; + + { Glossary } + Glossary = 3000; + GCloseIcon = 3001; + GDesktop = 3002; + GDialogBox = 3003; + GHistoryIcon = 3004; + GInputLine = 3005; + GMemIndicator = 3006; + GMenuBar = 3007; + GPulldownMenu = 3008; + GResizeCorner = 3009; + GSelectedText = 3010; + GStatusBar = 3011; + GTitleBar = 3012; + GWindowBorder = 3013; + GZoomIcon = 3014; + hcGlossary_Items = GZoomIcon; + + { INI Unit } + hcDateFormatDlg = 1; + hcDateParts = 1; + hcDateOrder = 1; + hcTimeFormatDlg = 1; + hcClockFormatDlg = 1; + hcClockDateParts = 1; + hcClockTimeFormat = 1; + + hcListViewer = 1; + + { Options Help Contexts } + hcConfigMenu = 100; + hcConfigColors = hcConfigMenu + 1; + hcConfigDate = hcConfigColors + 1; + hcConfigEnvironment = hcConfigDate + 1; + hcConfigMouse = hcConfigEnvironment + 1; + hcConfigOpen = hcConfigMouse + 1; + hcConfigSave = hcConfigOpen + 1; + hcConfigSaveAs = hcConfigSave + 1; + hcConfigTime = hcConfigSaveAs + 1; + hcConfigVideo = hcConfigTime + 1; + hcConfigDesktopDlg = hcConfigVideo + 1; + hcConfigMouseDlg = hcConfigDesktopDlg + 1; + hcConfigTimeFormatDlg = hcConfigMouseDlg + 1; + hcConfigTimeSeparator = hcConfigTimeFormatDlg + 1; + hcConfigTimeComponents = hcConfigTimeSeparator + 1; + hcConfigTimeStyle = hcConfigTimeComponents + 1; + hcConfigClock = hcConfigTimeStyle + 1; + hcBrowseDir = 1; + hcBrowseFile = 1; + + +{ + The FVConsts unit contains all history list constants used in the FreeVision + Library. +} + +const + hiConfig = 1; + hiDirectories = 2; { non-specific } + hiDesktop = 3; + hiCurrentDirectories = 1; + hiFiles = 4; + +implementation + +end. diff --git a/packages/fv/src/gadgets.pas b/packages/fv/src/gadgets.pas new file mode 100644 index 0000000000..b802f4f888 --- /dev/null +++ b/packages/fv/src/gadgets.pas @@ -0,0 +1,306 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of GADGETS.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@starwon.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ } +{*******************[ DOCUMENTATION ]**********************} +{ } +{ This unit had to be for GFV due to some problems with } +{ the original Borland International implementation. } +{ } +{ First it used the DOS unit for it's time calls in the } +{ TClockView object. Since this unit can not be compiled } +{ under WIN/NT/OS2 we use a new unit TIME.PAS which was } +{ created and works under these O/S. } +{ } +{ Second the HeapView object accessed MemAvail from in } +{ the Draw call. As GFV uses heap memory during the Draw } +{ call the OldMem value always met the test condition in } +{ the update procedure. The consequence was the view } +{ would continually redraw. By moving the memavail call } +{ the update procedure this eliminates this problem. } +{ } +{ Finally the original object relied on the font char } +{ blocks being square to erase it's entire view area as } +{ it used a simple writeline call in the Draw method. } +{ Under GFV font blocks are not necessarily square and } +{ so both objects had their Draw routines rewritten. As } +{ the Draw had to be redone it was done in the GFV split } +{ drawing method to accelerate the graphical speed. } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Fix } +{ ------- --------- --------------------------------- } +{ 1.00 12 Nov 99 First multi platform release } +{**********************************************************} + +UNIT Gadgets; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Near calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES FVConsts, Time, Objects, Drivers, Views, App; { Standard GFV units } + +{***************************************************************************} +{ PUBLIC OBJECT DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ THeapView OBJECT - ANCESTOR VIEW OBJECT } +{---------------------------------------------------------------------------} +TYPE + THeapViewMode=(HVNormal,HVComma,HVKb,HVMb); + + THeapView = OBJECT (TView) + Mode : THeapViewMode; + OldMem: LongInt; { Last memory count } + constructor Init(var Bounds: TRect); + constructor InitComma(var Bounds: TRect); + constructor InitKb(var Bounds: TRect); + constructor InitMb(var Bounds: TRect); + PROCEDURE Update; + PROCEDURE Draw; Virtual; + Function Comma ( N : LongInt ) : String; + END; + PHeapView = ^THeapView; { Heapview pointer } + +{---------------------------------------------------------------------------} +{ TClockView OBJECT - ANCESTOR VIEW OBJECT } +{---------------------------------------------------------------------------} +TYPE + TClockView = OBJECT (TView) + am : Char; + Refresh : Byte; { Refresh rate } + LastTime: Longint; { Last time displayed } + TimeStr : String[10]; { Time string } + CONSTRUCTOR Init (Var Bounds: TRect); + FUNCTION FormatTimeStr (H, M, S: Word): String; Virtual; + PROCEDURE Update; Virtual; + PROCEDURE Draw; Virtual; + END; + PClockView = ^TClockView; { Clockview ptr } + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ THeapView OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +constructor THeapView.Init(var Bounds: TRect); +begin + inherited Init(Bounds); + mode:=HVNormal; + OldMem := 0; +end; + +constructor THeapView.InitComma(var Bounds: TRect); +begin + inherited Init(Bounds); + mode:=HVComma; + OldMem := 0; +end; + +constructor THeapView.InitKb(var Bounds: TRect); +begin + inherited Init(Bounds); + mode:=HVKb; + OldMem := 0; +end; + +constructor THeapView.InitMb(var Bounds: TRect); +begin + inherited Init(Bounds); + mode:=HVMb; + OldMem := 0; +end; + +{--THeapView----------------------------------------------------------------} +{ Update -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THeapView.Update; +var + status : TFPCHeapStatus; +BEGIN + status:=GetFPCHeapStatus; + If (OldMem <> status.CurrHeapUsed) Then Begin { Memory differs } + OldMem := status.CurrHeapUsed; { Hold memory avail } + DrawView; { Now redraw } + End; +END; + +{--THeapView----------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE THeapView.Draw; +VAR + C : Byte; + S : String; + B : TDrawBuffer; +begin + case mode of + HVNormal : + Str(OldMem:Size.X, S); + HVComma : + S:=Comma(OldMem); + HVKb : + begin + Str(OldMem shr 10:Size.X-1, S); + S:=S+'K'; + end; + HVMb : + begin + Str(OldMem shr 20:Size.X-1, S); + S:=S+'M'; + end; + end; + C:=GetColor(2); + MoveChar(B,' ',C,Size.X); + MoveStr(B,S,C); + WriteLine(0,0,Size.X,1,B); +END; + +Function THeapView.Comma ( n : LongInt) : String; +Var + num, loc : Byte; + s : String; + t : String; +Begin + Str (n,s); + Str (n:Size.X,t); + + num := length(s) div 3; + if (length(s) mod 3) = 0 then dec (num); + + delete (t,1,num); + loc := length(t)-2; + + while num > 0 do + Begin + Insert (',',t,loc); + dec (num); + dec (loc,3); + End; + + Comma := t; +End; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TClockView OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TClockView---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TClockView.Init (Var Bounds: TRect); +BEGIN + Inherited Init(Bounds); { Call ancestor } + FillChar(LastTime, SizeOf(LastTime), #$FF); { Fill last time } + TimeStr := ''; { Empty time string } + Refresh := 1; { Refresh per second } +END; + +{--TClockView---------------------------------------------------------------} +{ FormatStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TClockView.FormatTimeStr (H, M, S: Word): String; +VAR Hs, Ms, Ss: String; +BEGIN + Str(H, Hs); { Convert hour string } + While (Length(Hs) < 2) Do Hs := '0' + Hs; { Add lead zero's } + Str(M, Ms); { Convert min string } + While (Length(Ms) < 2) Do Ms := '0' + Ms; { Add lead zero's } + Str(S, Ss); { Convert sec string } + While (Length(Ss) < 2) Do Ss := '0' + Ss; { Add lead zero's } + FormatTimeStr := Hs + ':'+ Ms + ':' + Ss; { Return string } +END; + +{--TClockView---------------------------------------------------------------} +{ Update -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TClockView.Update; +VAR Hour, Min, Sec, Sec100: Word; +BEGIN + GetTime(Hour, Min, Sec, Sec100); { Get current time } + If (Abs(Sec - LastTime) >= Refresh) Then Begin { Refresh time elapsed } + LastTime := Sec; { Hold second } + TimeStr := FormatTimeStr(Hour, Min, Sec); { Create time string } + DrawView; { Now redraw } + End; +END; + +{--TClockView---------------------------------------------------------------} +{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TClockView.Draw; +VAR + C : Byte; + B : TDrawBuffer; +BEGIN + C:=GetColor(2); + MoveChar(B,' ',C,Size.X); + MoveStr(B,TimeStr,C); + WriteLine(0,0,Size.X,1,B); +END; + +END. diff --git a/packages/fv/src/go32smsg.inc b/packages/fv/src/go32smsg.inc new file mode 100644 index 0000000000..e2876ab08e --- /dev/null +++ b/packages/fv/src/go32smsg.inc @@ -0,0 +1,93 @@ +{ + + System independent system interface for go32v2 + + Copyright (c) 2000 by Pierre Muller + + 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. +} + +Const + SystemEventActive : Boolean = false; + + +procedure InitSystemMsg; +var + res : word; +begin + if SystemEventActive then + exit; + { enable close } + asm + movl $0x168f,%eax + movl $1,%edx + int $0x2f + movw %ax,Res + end; + SystemEventActive:=(Res=0); +end; + + +procedure DoneSystemMsg; +begin + if not SystemEventActive then + exit; + { disable close } + asm + movl $0x168f,%eax + movl $0,%edx + int $0x2f + end; + SystemEventActive:=false; +end; + +procedure GetSystemEvent(var SystemEvent: TSystemEvent); +begin + PollSystemEvent(SystemEvent); +end; + +function PollSystemEvent(var SystemEvent: TSystemEvent):boolean; +var + CloseState : word; +begin + SystemEvent.typ:=SysNothing; + if not SystemEventActive then + exit(false); + { Query close } + asm + movl $0x168f,%eax + movl $100,%edx + int $0x2f + movw %ax,CloseState + end; + if (CloseState = 0) then + begin + { acknowledge Close } + asm + movl $0x168f,%eax + movl $200,%edx + int $0x2f + movw %ax,CloseState + end; + { non zero means error ! } + if CloseState=0 then + begin + PollSystemEvent:=true; + SystemEvent.typ:=SysClose; + end; + end; +end; + diff --git a/packages/fv/src/histlist.pas b/packages/fv/src/histlist.pas new file mode 100644 index 0000000000..3b99a24b79 --- /dev/null +++ b/packages/fv/src/histlist.pas @@ -0,0 +1,416 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of HISTLIST.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@starwon.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Fix } +{ ------- --------- --------------------------------- } +{ 1.00 11 Nov 96 First DOS/DPMI platform release. } +{ 1.10 13 Jul 97 Windows platform code added. } +{ 1.20 29 Aug 97 Platform.inc sort added. } +{ 1.30 13 Oct 97 Delphi 2 32 bit code added. } +{ 1.40 05 May 98 Virtual pascal 2.0 code added. } +{ 1.50 30 Sep 99 Complete recheck preformed } +{ 1.51 03 Nov 99 FPC windows support added } +{**********************************************************} + +UNIT HistList; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Short calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES FVCommon, Objects; { Standard GFV units } + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY SYSTEM CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-InitHistory-------------------------------------------------------- +Initializes the history system usually called from Application.Init +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE InitHistory; + +{-DoneHistory-------------------------------------------------------- +Destroys the history system usually called from Application.Done +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE DoneHistory; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY ITEM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-HistoryCount------------------------------------------------------- +Returns the number of strings in the history list with ID number Id. +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION HistoryCount (Id: Byte): Word; + +{-HistoryStr--------------------------------------------------------- +Returns the Index'th string in the history list with ID number Id. +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION HistoryStr (Id: Byte; Index: Sw_Integer): String; + +{-ClearHistory------------------------------------------------------- +Removes all strings from all history lists. +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE ClearHistory; + +{-HistoryAdd--------------------------------------------------------- +Adds the string Str to the history list indicated by Id. +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE HistoryAdd (Id: Byte; Const Str: String); + +function HistoryRemove(Id: Byte; Index: Sw_Integer): boolean; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY STREAM STORAGE AND RETREIVAL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-LoadHistory-------------------------------------------------------- +Reads the application's history block from the stream S by reading the +size of the block, then the block itself. Sets HistoryUsed to the end +of the block read. Use LoadHistory to restore a history block saved +with StoreHistory +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE LoadHistory (Var S: TStream); + +{-StoreHistory-------------------------------------------------------- +Writes the currently used portion of the history block to the stream +S, first writing the length of the block then the block itself. Use +the LoadHistory procedure to restore the history block. +30Sep99 LdB +---------------------------------------------------------------------} +PROCEDURE StoreHistory (Var S: TStream); + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +CONST + HistorySize: sw_integer = 64*1024; { Maximum history size } + HistoryUsed: sw_integer = 0; { History used } + HistoryBlock: Pointer = Nil; { Storage block } + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{***************************************************************************} +{ PRIVATE RECORD DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ THistRec RECORD DEFINITION + + Zero 1 byte, start marker + Id 1 byte, History id + <shortstring> 1 byte length+string data, Contents +} + +{***************************************************************************} +{ UNINITIALIZED PRIVATE VARIABLES } +{***************************************************************************} +{---------------------------------------------------------------------------} +{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +VAR + CurId: Byte; { Current history id } + CurString: PString; { Current string } + +{***************************************************************************} +{ PRIVATE UNIT ROUTINES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ StartId -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE StartId (Id: Byte); +BEGIN + CurId := Id; { Set current id } + CurString := HistoryBlock; { Set current string } +END; + +{---------------------------------------------------------------------------} +{ DeleteString -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DeleteString; +VAR Len: Sw_Integer; P, P2: PChar; +BEGIN + P := PChar(CurString); { Current string } + P2 := PChar(CurString); { Current string } + Len := PByte(P2)^+3; { Length of data } + Dec(P, 2); { Correct position } + Inc(P2, PByte(P2)^+1); { Next hist record } + { Shuffle history } + Move(P2^, P^, Pointer(HistoryBlock) + HistoryUsed - Pointer(P2) ); + Dec(HistoryUsed, Len); { Adjust history used } +END; + +{---------------------------------------------------------------------------} +{ AdvanceStringPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE AdvanceStringPtr; +VAR P: PChar; +BEGIN + While (CurString <> Nil) Do Begin + If (Pointer(CurString) >= Pointer(HistoryBlock) + HistoryUsed) Then Begin{ Last string check } + CurString := Nil; { Clear current string } + Exit; { Now exit } + End; + Inc(PChar(CurString), PByte(CurString)^+1); { Move to next string } + If (Pointer(CurString) >= Pointer(HistoryBlock) + HistoryUsed) Then Begin{ Last string check } + CurString := Nil; { Clear current string } + Exit; { Now exit } + End; + P := PChar(CurString); { Transfer record ptr } + Inc(PChar(CurString), 2); { Move to string } + if (P^<>#0) then + RunError(215); + Inc(P); + If (P^ = Chr(CurId)) Then Exit; { Found the string } + End; +END; + +{---------------------------------------------------------------------------} +{ InsertString -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE InsertString (Id: Byte; Const Str: String); +VAR P, P1, P2: PChar; +BEGIN + while (HistoryUsed+Length(Str)+3>HistorySize) do + begin + P:=PChar(HistoryBlock); + while Pointer(P)<Pointer(HistoryBlock)+HistorySize do + begin + if Pointer(P)+Length(PShortString(P+2)^)+6+Length(Str) > + Pointer(HistoryBlock)+HistorySize then + begin + Dec(HistoryUsed,Length(PShortString(P+2)^)+3); + FillChar(P^,Pointer(HistoryBlock)+HistorySize-Pointer(P),#0); + break; + end; + Inc(P,Length(PShortString(P+2)^)+3); + end; + end; + P1 := PChar(HistoryBlock)+1; { First history record } + P2 := P1+Length(Str)+3; { History record after } + Move(P1^, P2^, HistoryUsed - 1); { Shuffle history data } + P1^:=#0; { Set marker byte } + Inc(P1); + P1^:=Chr(Id); { Set history id } + Inc(P1); + Move(Str[0], P1^, Length(Str)+1); { Set history string } + Inc(HistoryUsed, Length(Str)+3); { Inc history used } +END; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY SYSTEM CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ InitHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE InitHistory; +BEGIN + if HistorySize>0 then + GetMem(HistoryBlock, HistorySize); { Allocate block } + ClearHistory; { Clear the history } +END; + +{---------------------------------------------------------------------------} +{ DoneHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DoneHistory; +BEGIN + If (HistoryBlock <> Nil) Then { History block valid } + begin + FreeMem(HistoryBlock); { Release history block } + HistoryBlock:=nil; + end; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY ITEM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ HistoryCount -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION HistoryCount(Id: Byte): Word; +VAR Count: Word; +BEGIN + StartId(Id); { Set to first record } + Count := 0; { Clear count } + If (HistoryBlock <> Nil) Then Begin { History initalized } + AdvanceStringPtr; { Move to first string } + While (CurString <> Nil) Do Begin + Inc(Count); { Add one to count } + AdvanceStringPtr; { Move to next string } + End; + End; + HistoryCount := Count; { Return history count } +END; + +{---------------------------------------------------------------------------} +{ HistoryStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION HistoryStr(Id: Byte; Index: Sw_Integer): String; +VAR I: Sw_Integer; +BEGIN + StartId(Id); { Set to first record } + If (HistoryBlock <> Nil) Then Begin { History initalized } + For I := 0 To Index Do AdvanceStringPtr; { Find indexed string } + If (CurString <> Nil) Then + HistoryStr := CurString^ Else { Return string } + HistoryStr := ''; { Index not found } + End Else HistoryStr := ''; { History uninitialized } +END; + +{---------------------------------------------------------------------------} +{ ClearHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE ClearHistory; +BEGIN + If (HistoryBlock <> Nil) Then Begin { History initiated } + PChar(HistoryBlock)^ := #0; { Clear first byte } + HistoryUsed := 1; { Set position } + End; +END; + +{---------------------------------------------------------------------------} +{ HistoryAdd -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE HistoryAdd (Id: Byte; Const Str: String); +BEGIN + If (Str = '') Then Exit; { Empty string exit } + If (HistoryBlock = Nil) Then Exit; { History uninitialized } + StartId(Id); { Set current data } + AdvanceStringPtr; { Find the string } + While (CurString <> nil) Do Begin + If (Str = CurString^) Then DeleteString; { Delete duplicates } + AdvanceStringPtr; { Find next string } + End; + InsertString(Id, Str); { Add new history item } +END; + +function HistoryRemove(Id: Byte; Index: Sw_Integer): boolean; +var + I: Sw_Integer; +begin + StartId(Id); + for I := 0 to Index do + AdvanceStringPtr; { Find the string } + if CurString <> nil then + begin + DeleteString; + HistoryRemove:=true; + end + else + HistoryRemove:=false; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ HISTORY STREAM STORAGE AND RETREIVAL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ LoadHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE LoadHistory (Var S: TStream); +VAR Size: sw_integer; +BEGIN + S.Read(Size, sizeof(Size)); { Read history size } + If (HistoryBlock <> Nil) Then Begin { History initialized } + If (Size <= HistorySize) Then Begin + S.Read(HistoryBlock^, Size); { Read the history } + HistoryUsed := Size; { History used } + End Else S.Seek(S.GetPos + Size); { Move stream position } + End Else S.Seek(S.GetPos + Size); { Move stream position } +END; + +{---------------------------------------------------------------------------} +{ StoreHistory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE StoreHistory (Var S: TStream); +VAR Size: sw_integer; +BEGIN + If (HistoryBlock = Nil) Then Size := 0 Else { No history data } + Size := HistoryUsed; { Size of history data } + S.Write(Size, sizeof(Size)); { Write history size } + If (Size > 0) Then S.Write(HistoryBlock^, Size); { Write history data } +END; + +END. diff --git a/packages/fv/src/inplong.pas b/packages/fv/src/inplong.pas new file mode 100644 index 0000000000..dc2da1a3fd --- /dev/null +++ b/packages/fv/src/inplong.pas @@ -0,0 +1,305 @@ +Unit InpLong; + +(*-- +TInputLong is a derivitave of TInputline designed to accept LongInt +numeric input. Since both the upper and lower limit of acceptable numeric +input can be set, TInputLong may be used for Integer, Word, or Byte input +as well. Option flag bits allow optional hex input and display. A blank +field may optionally be rejected or interpreted as zero. + +Methods + +constructor Init(var R : TRect; AMaxLen : Integer; + LowerLim, UpperLim : LongInt; Flgs : Word); + +Calls TInputline.Init and saves the desired limits and Flags. Flags may +be a combination of: + +ilHex will accept hex input (preceded by '$') as well as decimal. +ilBlankEqZero if set, will interpret a blank field as '0'. +ilDisplayHex if set, will display numeric as hex when possible. + + +constructor Load(var S : TStream); +procedure Store(var S : TStream); + +The usual Load and Store routines. Be sure to call RegisterType(RInputLong) +to register the type. + + +FUNCTION DataSize : Word; virtual; +PROCEDURE GetData(var Rec); virtual; +PROCEDURE SetData(var Rec); virtual; + +The transfer methods. DataSize is Sizeof(LongInt) and Rec should be +the address of a LongInt. + + +FUNCTION RangeCheck : Boolean; virtual; + +Returns True if the entered string evaluates to a number >= LowerLim and +<= UpperLim. + + +PROCEDURE Error; virtual; + +Error is called when RangeCheck fails. It displays a messagebox indicating +the label (if any) of the faulting view, as well as the allowable range. + + +PROCEDURE HandleEvent(var Event : TEvent); virtual; + +HandleEvent filters out characters which are not appropriate to numeric +input. Tab and Shift Tab cause a call to RangeCheck and a call to Error +if RangeCheck returns false. The input must be valid to Tab from the view. +There's no attempt made to stop moving to another view with the mouse. + + +FUNCTION Valid(Cmd : Word) : Boolean; virtual; + +if TInputline.Valid is true and Cmd is neither cmValid or cmCancel, Valid +then calls RangeCheck. If RangeCheck is false, then Error is called and +Valid returns False. + +----*) + +{$i platform.inc} + +{$ifdef PPC_FPC} + {$H-} +{$else} + {$F+,O+,E+,N+} +{$endif} +{$X+,R-,I-,Q-,V-} +{$ifndef OS_UNIX} + {$S-} +{$endif} + +Interface +uses objects, drivers, views, dialogs, msgbox, fvconsts; + +{flags for TInputLong constructor} +const + ilHex = 1; {will enable hex input with leading '$'} + ilBlankEqZero = 2; {No input (blank) will be interpreted as '0'} + ilDisplayHex = 4; {Number displayed as hex when possible} +Type + TInputLong = Object(TInputLine) + ILOptions : Word; + LLim, ULim : LongInt; + constructor Init(var R : TRect; AMaxLen : Sw_Integer; + LowerLim, UpperLim : LongInt; Flgs : Word); + constructor Load(var S : TStream); + procedure Store(var S : TStream); + FUNCTION DataSize : Sw_Word; virtual; + PROCEDURE GetData(var Rec); virtual; + PROCEDURE SetData(var Rec); virtual; + FUNCTION RangeCheck : Boolean; virtual; + PROCEDURE Error; virtual; + PROCEDURE HandleEvent(var Event : TEvent); virtual; + FUNCTION Valid(Cmd : Word) : Boolean; virtual; + end; + PInputLong = ^TInputLong; + +const + RInputLong : TStreamRec = ( + ObjType: idInputLong; + VmtLink: Ofs(Typeof(TInputLong)^); + Load : @TInputLong.Load; + Store : @TInputLong.Store); + +Implementation + +{-----------------TInputLong.Init} +constructor TInputLong.Init(var R : TRect; AMaxLen : Sw_Integer; + LowerLim, UpperLim : LongInt; Flgs : Word); +begin +if not TInputLine.Init(R, AMaxLen) then fail; +ULim := UpperLim; +LLim := LowerLim; +if Flgs and ilDisplayHex <> 0 then Flgs := Flgs or ilHex; +ILOptions := Flgs; +if ILOptions and ilBlankEqZero <> 0 then Data^ := '0'; +end; + +{-------------------TInputLong.Load} +constructor TInputLong.Load(var S : TStream); +begin +TInputLine.Load(S); +S.Read(ILOptions, Sizeof(ILOptions)); +S.Read(LLim, Sizeof(LLim)); +S.Read(ULim, Sizeof(ULim)); +end; + +{-------------------TInputLong.Store} +procedure TInputLong.Store(var S : TStream); +begin +TInputLine.Store(S); +S.Write(ILOptions, Sizeof(ILOptions)); +S.Write(LLim, Sizeof(LLim)); +S.Write(ULim, Sizeof(ULim)); +end; + +{-------------------TInputLong.DataSize} +FUNCTION TInputLong.DataSize:Sw_Word; +begin +DataSize := Sizeof(LongInt); +end; + +{-------------------TInputLong.GetData} +PROCEDURE TInputLong.GetData(var Rec); +var code : Integer; +begin +Val(Data^, LongInt(Rec), code); +end; + +FUNCTION Hex2(B : Byte) : String; +Const + HexArray : array[0..15] of char = '0123456789ABCDEF'; +begin +Hex2[0] := #2; +Hex2[1] := HexArray[B shr 4]; +Hex2[2] := HexArray[B and $F]; +end; + +FUNCTION Hex4(W : Word) : String; +begin Hex4 := Hex2(Hi(W))+Hex2(Lo(W)); end; + +FUNCTION Hex8(L : LongInt) : String; +begin Hex8 := Hex4(LongRec(L).Hi)+Hex4(LongRec(L).Lo); end; + +function FormHexStr(L : LongInt) : String; +var + Minus : boolean; + S : string[20]; +begin +Minus := L < 0; +if Minus then L := -L; +S := Hex8(L); +while (Length(S) > 1) and (S[1] = '0') do Delete(S, 1, 1); +S := '$' + S; +if Minus then System.Insert('-', S, 2); +FormHexStr := S; +end; + +{-------------------TInputLong.SetData} +PROCEDURE TInputLong.SetData(var Rec); +var + L : LongInt; + S : string; +begin +L := LongInt(Rec); +if L > ULim then L := ULim +else if L < LLim then L := LLim; +if ILOptions and ilDisplayHex <> 0 then + S := FormHexStr(L) +else + Str(L : -1, S); +if Length(S) > MaxLen then S[0] := chr(MaxLen); +Data^ := S; +end; + +{-------------------TInputLong.RangeCheck} +FUNCTION TInputLong.RangeCheck : Boolean; +var + L : LongInt; + code : Integer; +begin +if (Data^ = '') and (ILOptions and ilBlankEqZero <> 0) then + Data^ := '0'; +Val(Data^, L, code); +RangeCheck := (Code = 0) and (L >= LLim) and (L <= ULim); +end; + +{-------------------TInputLong.Error} +PROCEDURE TInputLong.Error; +var + SU, SL : string[40]; + PMyLabel : PLabel; + Labl : string; + I : Integer; + + function FindIt(P : PView) : boolean;{$ifdef PPC_BP}far;{$endif} + begin + FindIt := (Typeof(P^) = Typeof(TLabel)) and (PLabel(P)^.Link = PView(@Self)); + end; + +begin +Str(LLim : -1, SL); +Str(ULim : -1, SU); +if ILOptions and ilHex <> 0 then + begin + SL := SL+'('+FormHexStr(LLim)+')'; + SU := SU+'('+FormHexStr(ULim)+')'; + end; +if Owner <> Nil then + PMyLabel := PLabel(Owner^.FirstThat(@FindIt)) +else PMyLabel := Nil; +if PMyLabel <> Nil then PMyLabel^.GetText(Labl) +else Labl := ''; +if Labl <> '' then + begin + I := Pos('~', Labl); + while I > 0 do + begin + System.Delete(Labl, I, 1); + I := Pos('~', Labl); + end; + Labl := '"'+Labl+'"'; + end; +MessageBox(Labl + ^M^J'Value not within range '+SL+' to '+SU, Nil, + mfError+mfOKButton); +end; + +{-------------------TInputLong.HandleEvent} +PROCEDURE TInputLong.HandleEvent(var Event : TEvent); +begin +if (Event.What = evKeyDown) then + begin + case Event.KeyCode of + kbTab, kbShiftTab + : if not RangeCheck then + begin + Error; + SelectAll(True); + ClearEvent(Event); + end; + end; + if Event.CharCode <> #0 then {a character key} + begin + Event.Charcode := Upcase(Event.Charcode); + case Event.Charcode of + '0'..'9', #1..#$1B : ; {acceptable} + + '-' : if (LLim >= 0) or (CurPos <> 0) then + ClearEvent(Event); + '$' : if ILOptions and ilHex = 0 then ClearEvent(Event); + 'A'..'F' : if Pos('$', Data^) = 0 then ClearEvent(Event); + + else ClearEvent(Event); + end; + end; + end; +TInputLine.HandleEvent(Event); +end; + +{-------------------TInputLong.Valid} +FUNCTION TInputLong.Valid(Cmd : Word) : Boolean; +var + Rslt : boolean; +begin +Rslt := TInputLine.Valid(Cmd); +if Rslt and (Cmd <> 0) and (Cmd <> cmCancel) then + begin + Rslt := RangeCheck; + if not Rslt then + begin + Error; + Select; + SelectAll(True); + end; + end; +Valid := Rslt; +end; + +end. diff --git a/packages/fv/src/memory.pas b/packages/fv/src/memory.pas new file mode 100644 index 0000000000..79607d6cd5 --- /dev/null +++ b/packages/fv/src/memory.pas @@ -0,0 +1,875 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent clone of MEMORY.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@starwon.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Fix } +{ ------- --------- --------------------------------- } +{ 1.00 19 feb 96 Initial DOS/DPMI code released. } +{ 1.10 18 Jul 97 Windows conversion added. } +{ 1.20 29 Aug 97 Platform.inc sort added. } +{ 1.30 05 May 98 Virtual pascal 2.0 code added. } +{ 1.40 01 Oct 99 Complete multiplatform rewrite } +{ 1.41 03 Nov 99 FPC Windows support added } +{**********************************************************} + +UNIT Memory; + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F+} { Force far calls } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES FVCommon; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MEMORY ACCESS ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-MemAlloc----------------------------------------------------------- +Allocates the requested size of memory if this takes memory free below +the safety pool then a nil pointer is returned. +01Oct99 LdB +---------------------------------------------------------------------} +FUNCTION MemAlloc (Size: Word): Pointer; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MEMORY MANAGER SYSTEM CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-LowMemory---------------------------------------------------------- +Returns if the free memory left is below the safety pool value. +01Oct99 LdB +---------------------------------------------------------------------} +FUNCTION LowMemory: Boolean; + +{-InitMemory--------------------------------------------------------- +Initializes the memory and safety pool manager. This should be called +prior to using any of the memory manager routines. +01Oct99 LdB +---------------------------------------------------------------------} +PROCEDURE InitMemory; + +{-DoneMemory--------------------------------------------------------- +Closes the memory and safety pool manager. This should be called after +using the memory manager routines so as to clean up. +01Oct99 LdB +---------------------------------------------------------------------} +PROCEDURE DoneMemory; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ CACHE MEMORY ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-NewCache----------------------------------------------------------- +Create a new cache of given size in pointer P failure will return nil. +01Oct99 LdB +---------------------------------------------------------------------} +PROCEDURE NewCache (Var P: Pointer; Size: Word); + +{-DisposeCache------------------------------------------------------- +Dispose of a cache buffer given by pointer P. +01Oct99 LdB +---------------------------------------------------------------------} +PROCEDURE DisposeCache (P: Pointer); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ BUFFER MEMORY ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-GetBufferSize------------------------------------------------------ +Returns the size of memory buffer given by pointer P. +01Oct99 LdB +---------------------------------------------------------------------} +FUNCTION GetBufferSize (P: Pointer): Word; + +{-SetBufferSize------------------------------------------------------ +Change the size of buffer given by pointer P to the size requested. +01Oct99 LdB +---------------------------------------------------------------------} +FUNCTION SetBufferSize (var P: Pointer; Size: Word): Boolean; + +{-DisposeBuffer------------------------------------------------------ +Dispose of buffer given by pointer P. +01Oct99 LdB +---------------------------------------------------------------------} +PROCEDURE DisposeBuffer (P: Pointer); + +{-NewBuffer---------------------------------------------------------- +Create a new buffer of given size in ptr P failure will return nil. +01Oct99 LdB +---------------------------------------------------------------------} +PROCEDURE NewBuffer (Var P: Pointer; Size: Word); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ DOS MEMORY CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-InitDosMem--------------------------------------------------------- +Initialize memory manager routine for a shell to launch a DOS window. +Interface for compatability only under DPMI/WIN/NT/OS2 platforms. +01Oct99 LdB +---------------------------------------------------------------------} +PROCEDURE InitDosMem; + +{-DoneDosMem--------------------------------------------------------- +Finished shell to a DOS window so reset memory manager again. +Interface for compatability only under DPMI/WIN/NT/OS2 platforms. +01Oct99 LdB +---------------------------------------------------------------------} +PROCEDURE DoneDosMem; + +{***************************************************************************} +{ PUBLIC INITIALIZED VARIABLES } +{***************************************************************************} +CONST + LowMemSize : Word = 4096 DIV 16; { 4K } + SafetyPoolSize: Word = 8192; { Safety pool size } +{$IFDEF PROC_REAL} { REAL MODE DOS CODE } + MaxHeapSize : Word = 655360 DIV 16; { 640K } + MaxBufMem : Word = 65536 DIV 16; { 64K } +{$ENDIF} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} +{$IFDEF OS_WINDOWS} { WIN/NT CODE } + {$IFDEF PPC_FPC} { FPC WINDOWS COMPILER } + USES Windows; { Standard unit } + {$ELSE} { OTHER COMPILERS } + USES WinProcs, WinTypes; { Standard units } + {$ENDIF} +{$ENDIF} + +{$IFDEF OS_OS2} { OS2 CODE } + {$IFDEF PPC_FPC} + USES DosCalls; { Standard unit } + {$ELSE} + USES Os2Base; { Standard unit } + {$ENDIF} +{$ENDIF} + +{***************************************************************************} +{ PRIVATE RECORD TYPE DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TBuffer RECORD DEFINITION } +{---------------------------------------------------------------------------} +TYPE + PBuffer = ^TBuffer; { Buffer pointer } + TBuffer = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + {$IFDEF PROC_REAL} { REAL MODE DOS CODE } + Size : Word; { Buffer size } + Master: ^Word; { Master buffer } + {$ELSE} { DPMI/WIN/NT/OS2 CODE } + Next: PBuffer; { Next buffer } + Size: Word; { Buffer size } + Data: RECORD END; { Buffer data } + {$ENDIF} + END; + +{---------------------------------------------------------------------------} +{ POINTER TYPE CONVERSION RECORDS } +{---------------------------------------------------------------------------} +TYPE + PtrRec = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Ofs, Seg: Word; { Pointer to words } + END; + +{---------------------------------------------------------------------------} +{ TCache RECORD DEFINITION } +{---------------------------------------------------------------------------} +TYPE + PCache = ^TCache; { Cache pointer } +{$IFDEF PROC_REAL} { REAL MODE DOS CODE } + TCache = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Size : Word; { Cache size } + Master: ^Pointer; { Master cache } + Data : RECORD END; { Cache data } + END; +{$ELSE} { DPMI/WIN/NT/OS2 CODE } + TCache = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Next : PCache; { Next cache } + Master: ^Pointer; { Master cache } + Size : Word; { Size of cache } + Data : RECORD END; { Cache data } + End; +{$ENDIF} + +{***************************************************************************} +{ INITIALIZED PRIVATE VARIABLES } +{***************************************************************************} +CONST + DisablePool: Boolean = False; { Disable safety pool } + SafetyPool : Pointer = Nil; { Safety pool memory } +{$IFDEF PROC_REAL} { REAL MODE DOS CODE } + HeapResult: Integer = 0; { Heap result } + BufHeapPtr: Word = 0; { Heap position } + BufHeapEnd: Word = 0; { Heap end } + CachePtr : Pointer = Nil; { Cache list } +{$ELSE} { DPMI/WIN/NT/OS2 CODE } + CacheList : PCache = Nil; { Cache list } + BufferList: PBuffer = Nil; { Buffer list } +{$ENDIF} + +{***************************************************************************} +{ PRIVATE UNIT ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ PRIVATE UNIT ROUTINES - REAL MODE DOS PLATFORMS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{$IFDEF PROC_REAL} { REAL MODE DOS CODE } +{---------------------------------------------------------------------------} +{ GetBufSize -> Platforms DOS REAL MODE - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetBufSize (P: PBuffer): Word; {$IFNDEF PPC_FPC}FAR;{$ENDIF} +BEGIN + GetBufSize := (P^.Size + 15) SHR 4 + 1; { Buffer paragraphs } +END; + +{---------------------------------------------------------------------------} +{ FreeCacheMem -> Platforms DOS REAL MODE - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE FreeCacheMem; {$IFNDEF PPC_FPC}FAR;{$ENDIF} +BEGIN + While (CachePtr <> HeapEnd) Do + DisposeCache(CachePtr); { Release blocks } +END; + +{---------------------------------------------------------------------------} +{ SetMemTop -> Platforms DOS REAL MODE - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE SetMemTop (MemTop: Pointer); ASSEMBLER; +ASM + MOV BX, MemTop.Word[0]; { Top of memory } + ADD BX, 15; + MOV CL, 4; + SHR BX, CL; { Size in paragraphs } + ADD BX, MemTop.Word[2]; + MOV AX, PrefixSeg; { Add prefix seg } + SUB BX, AX; + MOV ES, AX; + MOV AH, 4AH; + INT 21H; { Call to DOS } +END; + +{---------------------------------------------------------------------------} +{ MoveSeg -> Platforms DOS REAL MODE - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE MoveSeg (Source, Dest, Size: Word); NEAR; ASSEMBLER; +ASM + PUSH DS; { Save register } + MOV AX, Source; + MOV DX, Dest; { Destination } + MOV BX, Size; + CMP AX, DX; { Does Source=Dest? } + JB @@3; + CLD; { Go forward } +@@1: + MOV CX, 0FFFH; + CMP CX, BX; + JB @@2; + MOV CX, BX; +@@2: + MOV DS, AX; + MOV ES, DX; + ADD AX, CX; + ADD DX, CX; + SUB BX, CX; + SHL CX, 3; { Mult x8 } + XOR SI, SI; + XOR DI, DI; + REP MOVSW; + OR BX, BX; + JNE @@1; + JMP @@6; +@@3: { Source=Dest } + ADD AX, BX; { Hold register } + ADD DX, BX; { Must go backwards } + STD; +@@4: + MOV CX, 0FFFH; + CMP CX, BX; + JB @@5; + MOV CX, BX; +@@5: + SUB AX, CX; + SUB DX, CX; + SUB BX, CX; + MOV DS, AX; + MOV ES, DX; + SHL CX, 3; { Mult x8 } + MOV SI, CX; + DEC SI; + SHL SI, 1; + MOV DI, SI; + REP MOVSW; { Move data } + OR BX, BX; + JNE @@4; +@@6: + POP DS; { Recover register } +END; + +{---------------------------------------------------------------------------} +{ SetBufSize -> Platforms DOS REAL MODE - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE SetBufSize (P: PBuffer; NewSize: Word); {$IFNDEF PPC_FPC}FAR;{$ENDIF} +VAR CurSize: Word; +BEGIN + CurSize := GetBufSize(P); { Current size } + MoveSeg(PtrRec(P).Seg + CurSize, PtrRec(P).Seg+ + NewSize, BufHeapPtr - PtrRec(P).Seg - CurSize); { Move data } + Inc(BufHeapPtr, NewSize - CurSize); { Adjust heap space } + Inc(PtrRec(P).Seg, NewSize); { Adjust pointer } + While PtrRec(P).Seg < BufHeapPtr Do Begin + Inc(P^.Master^, NewSize - CurSize); { Adjust master } + Inc(PtrRec(P).Seg, (P^.Size + 15) SHR 4 + 1); { Adjust paragraphs } + End; +END; +{$ENDIF} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ PRIVATE UNIT ROUTINES - DPMI/WIN/NT/OS2 PLATFORMS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{$IFNDEF PROC_REAL} { DPMI/WIN/NT/OS2 CODE } +{---------------------------------------------------------------------------} +{ FreeCache -> Platforms DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION FreeCache: Boolean; {$IFNDEF PPC_FPC}FAR;{$ENDIF} +BEGIN + FreeCache := False; { Preset fail } + If (CacheList <> Nil) Then Begin + DisposeCache(CacheList^.Next^.Master^); { Dispose cache } + FreeCache := True; { Return success } + End; +END; + +{---------------------------------------------------------------------------} +{ FreeCache -> Platforms DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION FreeSafetyPool: Boolean; {$IFNDEF PPC_FPC}FAR;{$ENDIF} +BEGIN + FreeSafetyPool := False; { Preset fail } + If (SafetyPool <> Nil) Then Begin { Pool exists } + FreeMem(SafetyPool, SafetyPoolSize); { Release memory } + SafetyPool := Nil; { Clear pointer } + FreeSafetyPool := True; { Return true } + End; +END; +{$ENDIF} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ PRIVATE UNIT ROUTINES - ALL PLATFORMS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ HeapNotify -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION HeapNotify (Size: Word): Integer; {$IFNDEF PPC_FPC}FAR;{$ENDIF} +{$IFDEF PROC_REAL} { REAL MODE DOS CODE } +ASSEMBLER; +ASM + CMP Size, 0; { Check for zero size } + JNE @@3; { Exit if size = zero } +@@1: + MOV AX, CachePtr.Word[2]; + CMP AX, HeapPtr.Word[2]; { Compare segments } + JA @@3; + JB @@2; + MOV AX, CachePtr.Word[0]; + CMP AX, HeapPtr.Word[0]; { Compare offsets } + JAE @@3; +@@2: + XOR AX, AX; { Clear register } + PUSH AX; { Push zero } + PUSH AX; { Push zero } + CALL DisposeCache; { Dispose cache } + JMP @@1; +@@3: + MOV AX, HeapResult; { Return result } +END; +{$ELSE} { DPMI/WIN/NT/OS2 } +BEGIN + If FreeCache Then HeapNotify := 2 Else { Release cache } + If DisablePool Then HeapNotify := 1 Else { Safetypool disabled } + If FreeSafetyPool Then HeapNotify := 2 Else { Free safety pool } + HeapNotify := 0; { Return success } +END; +{$ENDIF} + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MEMORY ACCESS ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ MemAlloc -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MemAlloc (Size: Word): Pointer; +VAR P: Pointer; +BEGIN + {$IFDEF PROC_REAL} { REAL MODE DOS CODE } + HeapResult := 1; { Stop error calls } + GetMem(P, Size); { Get memory } + HeapResult := 0; { Reset error calls } + If (P <> Nil) AND LowMemory Then Begin { Low memory } + FreeMem(P, Size); { Release memory } + P := Nil; { Clear pointer } + End; + MemAlloc := P; { Return result } + {$ELSE} { DPMI/WIN/NT/OS2 } + DisablePool := True; { Disable safety } + GetMem(P, Size); { Allocate memory } + DisablePool := False; { Enable safety } + MemAlloc := P; { Return result } + {$ENDIF} +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MEMORY MANAGER SYSTEM CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ LowMemory -> Platforms DOS/DPMI/WIN/NT/OS2 - Checked 29Jun98 LdB } +{---------------------------------------------------------------------------} +FUNCTION LowMemory: Boolean; +{$IFDEF PROC_REAL} { REAL MODE DOS CODE } +ASSEMBLER; +ASM + MOV AX, HeapEnd.Word[2]; { Get heap end } + SUB AX, HeapPtr.Word[2]; + SUB AX, LowMemSize; { Subtract size } + SBB AX, AX; + NEG AX; { Return result } +END; +{$ELSE} { DPMI/WIN/NT/OS2 CODE } +BEGIN + LowMemory := False; { Preset false } + If (SafetyPool = Nil) Then Begin { Not initialized } + SafetyPool := MemAlloc(SafetyPoolSize); { Allocate safety pool } + If (SafetyPool = Nil) Then LowMemory := True; { Return if low memory } + End; +END; +{$ENDIF} + +{---------------------------------------------------------------------------} +{ InitMemory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE InitMemory; +{$IFDEF PROC_REAL} VAR HeapSize: Word; {$ENDIF} +BEGIN + {$IFDEF PROC_REAL} { REAL MODE DOS CODE } + HeapError := @HeapNotify; { Point to error proc } + If (BufHeapPtr = 0) Then Begin + HeapSize := PtrRec(HeapEnd).Seg + - PtrRec(HeapOrg).Seg; { Calculate size } + If (HeapSize > MaxHeapSize) Then + HeapSize := MaxHeapSize; { Restrict max size } + BufHeapEnd := PtrRec(HeapEnd).Seg; { Set heap end } + PtrRec(HeapEnd).Seg := PtrRec(HeapOrg).Seg + + HeapSize; { Add heapsize } + BufHeapPtr := PtrRec(HeapEnd).Seg; { Set heap pointer } + End; + CachePtr := HeapEnd; { Cache starts at end } + {$ELSE} { DPMI/WIN/NT/OS2 CODE } + {$IFNDEF PPC_FPC} + HeapError := @HeapNotify; { Set heap error proc } + {$ENDIF} + SafetyPoolSize := LowMemSize * 16; { Fix safety pool size } + LowMemory; { Check for low memory } + {$ENDIF} +END; + +{---------------------------------------------------------------------------} +{ DoneMemory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DoneMemory; +BEGIN + {$IFDEF PROC_REAL} { REAl MODE DOS CODE } + FreeCacheMem; { Release cache memory } + {$ELSE} { DPMI/WIN/NT/OS2 } + While FreeCache Do; { Free cache memory } + FreeSafetyPool; { Release safety pool } + {$ENDIF} +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ CACHE MEMORY ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ NewCache -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE NewCache (Var P: Pointer; Size: Word); +{$IFDEF PROC_REAL} { REAL MODE DOS CODE } +ASSEMBLER; +ASM + LES DI, P; { Addres of var P } + MOV AX, Size; + ADD AX, (TYPE TCache)+15; { Add offset } + MOV CL, 4; + SHR AX, CL; + MOV DX, CachePtr.Word[2]; { Reteive cache ptr } + SUB DX, AX; + JC @@1; + CMP DX, HeapPtr.Word[2]; { Heap ptr end } + JBE @@1; + MOV CX, HeapEnd.Word[2]; + SUB CX, DX; + CMP CX, MaxBufMem; { Compare to maximum } + JA @@1; + MOV CachePtr.Word[2], DX; { Exchange ptr } + PUSH DS; + MOV DS, DX; + XOR SI, SI; + MOV DS:[SI].TCache.Size, AX; { Get cache size } + MOV DS:[SI].TCache.Master.Word[0], DI; + MOV DS:[SI].TCache.Master.Word[2], ES; { Get master ptr } + POP DS; + MOV AX, OFFSET TCache.Data; + JMP @@2; +@@1: + XOR AX, AX; + CWD; { Make double word } +@@2: + CLD; + STOSW; { Write low word } + XCHG AX, DX; + STOSW; { Write high word } +END; +{$ELSE} { DPMI/WIN/NT/OS2 CODE } +VAR Cache: PCache; +BEGIN + Inc(Size, SizeOf(TCache)); { Add cache size } + If (MaxAvail >= Size) Then GetMem(Cache, Size) { Allocate memory } + Else Cache := Nil; { Not enough memory } + If (Cache <> Nil) Then Begin { Cache is valid } + If (CacheList = Nil) Then Cache^.Next := Cache + Else Begin + Cache^.Next := CacheList^.Next; { Insert in list } + CacheList^.Next := Cache; { Complete link } + End; + CacheList := Cache; { Hold cache ptr } + Cache^.Size := Size; { Hold cache size } + Cache^.Master := @P; { Hold master ptr } +{$ifdef fpc} + Inc(Pointer(Cache), SizeOf(TCache)); { Set cache offset } +{$else fpc} + Inc(PtrRec(Cache).Ofs, SizeOf(TCache)); { Set cache offset } +{$endif fpc} + End; + P := Cache; { Return pointer } +END; +{$ENDIF} + +{---------------------------------------------------------------------------} +{ DisposeCache -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DisposeCache (P: Pointer); +{$IFDEF PROC_REAL} { REAL MODE DOS CODE } +ASSEMBLER; +ASM + MOV AX, CachePtr.Word[2]; { Cache high word } + XOR BX, BX; + XOR CX, CX; + MOV DX, P.Word[2]; { P high word } +@@1: + MOV ES, AX; + CMP AX, DX; { Check for match } + JE @@2; + ADD AX, ES:[BX].TCache.Size; { Move to next cache } + CMP AX, HeapEnd.Word[2]; + JE @@2; { Are we at heap end } + PUSH ES; + INC CX; { No so try next } + JMP @@1; +@@2: + PUSH ES; + LES DI, ES:[BX].TCache.Master; { Pointe to master } + XOR AX, AX; + CLD; + STOSW; { Clear master ptr } + STOSW; + POP ES; + MOV AX, ES:[BX].TCache.Size; { Next cache } + JCXZ @@4; +@@3: + POP DX; + PUSH DS; + PUSH CX; { Hold registers } + MOV DS, DX; + ADD DX, AX; + MOV ES, DX; + MOV SI, DS:[BX].TCache.Size; { Get cache size } + MOV CL, 3; + SHL SI, CL; { Multiply x8 } + MOV CX, SI; + SHL SI, 1; + DEC SI; { Adjust position } + DEC SI; + MOV DI, SI; + STD; + REP MOVSW; { Move cache memory } + LDS SI, ES:[BX].TCache.Master; + MOV DS:[SI].Word[2], ES; { Store new master } + POP CX; + POP DS; { Recover registers } + LOOP @@3; +@@4: + ADD CachePtr.Word[2], AX; { Add offset } +END; +{$ELSE} { DPMI/WIN/NT/OS2 CODE } +VAR Cache, C: PCache; +BEGIN +{$ifdef fpc} + Cache:=pointer(p)-SizeOf(TCache); +{$else fpc} + PtrRec(Cache).Ofs := PtrRec(P).Ofs-SizeOf(TCache); { Previous cache } + PtrRec(Cache).Seg := PtrRec(P).Seg; { Segment } +{$endif fpc} + C := CacheList; { Start at 1st cache } + While (C^.Next <> Cache) AND (C^.Next <> CacheList) + Do C := C^.Next; { Find previous } + If (C^.Next = Cache) Then Begin { Cache found } + If (C = Cache) Then CacheList := Nil Else Begin { Only cache in list } + If CacheList = Cache Then CacheList := C; { First in list } + C^.Next := Cache^.Next; { Remove from list } + End; + Cache^.Master^ := Nil; { Clear master } + FreeMem(Cache, Cache^.Size); { Release memory } + End; +END; +{$ENDIF} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ BUFFER MEMORY ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ GetBufferSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION GetBufferSize (P: Pointer): Word; +BEGIN + {$IFDEF PROC_REAL} { DOS CODE } + Dec(PtrRec(P).Seg); { Segment prior } + GetBufferSize := PBuffer(P)^.Size; { Size of this buffer } + {$ELSE} { DPMI/WIN/NT/OS2 CODE } + If (P <> Nil) Then { Check pointer } + Begin +{$ifdef fpc} + Dec(Pointer(P),SizeOf(TBuffer)); { Correct to buffer } +{$else fpc} + Dec(PtrRec(P).Ofs,SizeOf(TBuffer)); { Correct to buffer } +{$endif fpc} + GetBufferSize := PBuffer(P)^.Size; { Return buffer size } + End + Else + GetBufferSize := 0; { Invalid pointer } + {$ENDIF} +END; + +{---------------------------------------------------------------------------} +{ SetBufferSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +FUNCTION SetBufferSize (var P: Pointer; Size: Word): Boolean; +VAR NewSize: Word; +BEGIN + SetBufferSize := False; { Preset failure } + {$IFDEF PROC_REAL} { REAL MODE DOS CODE } + Dec(PtrRec(P).Seg); { Prior segment } + NewSize := (Size + 15) SHR 4 + 1; { Paragraph size } + If (BufHeapPtr+NewSize-GetBufSize(P)<=BufHeapEnd) { Check enough heap } + Then Begin + SetBufSize(P, NewSize); { Set the buffer size } + PBuffer(P)^.Size := Size; { Set the size } + SetBufferSize := True; { Return success } + End; + {$ELSE} { DPMI/WIN/NT/OS2 CODE } + {$ifdef fpc} + Dec(Pointer(P),SizeOf(TBuffer)); { Correct to buffer } + SetBufferSize := ReAllocMem(P, Size + SizeOf(TBuffer)) <> nil; + if SetBufferSize then + TBuffer(P^).Size := Size + SizeOf(TBuffer); + Inc(Pointer(P), SizeOf(TBuffer)); { Correct to buffer } +{$endif fpc} + {$ENDIF} +END; + +{---------------------------------------------------------------------------} +{ DisposeBuffer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DisposeBuffer (P: Pointer); +{$IFNDEF PROC_REAL} VAR Buffer,PrevBuf: PBuffer; {$ENDIF} +BEGIN + If (P <> Nil) Then Begin + {$IFDEF PROC_REAL} { REAL MODE DOS CODE } + Dec(PtrRec(P).Seg); { Prior segement } + SetBufSize(P, 0); { Release memory } + {$ELSE} { DPMI/WIN/NT/OS2 CODE } +{$ifdef fpc} + Dec(Pointer(P), SizeOf(TBuffer)); { Actual buffer pointer } +{$else fpc} + Dec(PtrRec(P).Ofs, SizeOf(TBuffer)); { Actual buffer pointer } +{$endif fpc} + Buffer := BufferList; { Start on first } + PrevBuf := Nil; { Preset prevbuf to nil } + While (Buffer <> Nil) AND (P <> Buffer) Do Begin { Search for buffer } + PrevBuf := Buffer; { Hold last buffer } + Buffer := Buffer^.Next; { Move to next buffer } + End; + If (Buffer <> Nil) Then Begin { Buffer was found } + If (PrevBuf = Nil) Then { We were first on list } + BufferList := Buffer^.Next Else { Set bufferlist entry } + PrevBuf^.Next := Buffer^.Next; { Remove us from chain } + FreeMem(Buffer, Buffer^.Size); { Release buffer } + End; + {$ENDIF} + End; +END; + +{---------------------------------------------------------------------------} +{ NewBuffer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE NewBuffer (Var P: Pointer; Size: Word); +VAR BufSize: Word; Buffer: PBuffer; +BEGIN + {$IFDEF PROC_REAL} { REAL MODE DOS CODE } + BufSize := (Size + 15) SHR 4 + 1; { Paragraphs to alloc } + If (BufHeapPtr+BufSize > BufHeapEnd) Then P := Nil { Exceeeds heap } + Else Begin + Buffer := Ptr(BufHeapPtr, 0); { Current position } + Buffer^.Size := Size; { Set size } + Buffer^.Master := @PtrRec(P).Seg; { Set master } + P := Ptr(BufHeapPtr + 1, 0); { Position ptr } + Inc(BufHeapPtr, BufSize); { Allow space on heap } + End; + {$ELSE} { DPMI/WIN/NT/OS2 CODE } + BufSize := Size + SizeOf(TBuffer); { Size to allocate } + Buffer := MemAlloc(BufSize); { Allocate the memory } + If (Buffer <> Nil) Then Begin + Buffer^.Next := BufferList; { First part of chain } + BufferList := Buffer; { Complete the chain } + Buffer^.Size := BufSize; { Hold the buffer size } +{$ifdef fpc} + Inc(Pointer(Buffer), SizeOf(TBuffer)); { Buffer to data area } +{$else fpc} + Inc(PtrRec(Buffer).Ofs, SizeOf(TBuffer)); { Buffer to data area } +{$endif fpc} + End; + P := Buffer; { Return the buffer ptr } + {$ENDIF} +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ DOS MEMORY CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ InitDosMem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE InitDosMem; +BEGIN + {$IFDEF PROC_REAL} { REAl MODE DOS CODE } + SetMemTop(Ptr(BufHeapEnd, 0)); { Move heap to empty } + {$ENDIF} +END; + +{---------------------------------------------------------------------------} +{ DoneDosMem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 01Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DoneDosMem; +{$IFDEF PROC_REAL} VAR MemTop: Pointer; {$ENDIF} +BEGIN + {$IFDEF PROC_REAL} { REAL MODE DOS CODE } + MemTop := Ptr(BufHeapPtr, 0); { Top of memory } + If (BufHeapPtr = PtrRec(HeapEnd).Seg) Then Begin { Is memory empty } + FreeCacheMem; { Release memory } + MemTop := HeapPtr; { Set pointer } + End; + SetMemTop(MemTop); { Release memory } + {$ENDIF} +END; + +END. diff --git a/packages/fv/src/menus.pas b/packages/fv/src/menus.pas new file mode 100644 index 0000000000..7d8896dc14 --- /dev/null +++ b/packages/fv/src/menus.pas @@ -0,0 +1,1632 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of MENUS.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@starwon.com.au - backup e-mail addr } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} + +UNIT Menus; + +{$CODEPAGE cp437} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Near calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES + {$IFDEF OS_WINDOWS} { WIN/NT CODE } + {$IFNDEF PPC_SPEED} { NON SPEED COMPILER } + {$IFDEF PPC_FPC} { FPC WINDOWS COMPILER } + Windows, { Standard unit } + {$ELSE} { OTHER COMPILERS } + WinTypes,WinProcs, { Standard units } + {$ENDIF} + {$ELSE} { SPEEDSOFT COMPILER } + WinBase, WinDef, { Standard units } + {$ENDIF} + {$ENDIF} + + objects, drivers, views, fvconsts; { GFV standard units } + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ COLOUR PALETTES } +{---------------------------------------------------------------------------} +CONST + CMenuView = #2#3#4#5#6#7; { Menu colours } + CStatusLine = #2#3#4#5#6#7; { Statusline colours } + +{***************************************************************************} +{ RECORD DEFINITIONS } +{***************************************************************************} +TYPE + TMenuStr = String[31]; { Menu string } + + PMenu = ^TMenu; { Pointer to menu } + +{---------------------------------------------------------------------------} +{ TMenuItem RECORD } +{---------------------------------------------------------------------------} + PMenuItem = ^TMenuItem; + TMenuItem = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Next: PMenuItem; { Next menu item } + Name: PString; { Menu item name } + Command: Word; { Menu item command } + Disabled: Boolean; { Menu item state } + KeyCode: Word; { Menu item keycode } + HelpCtx: Word; { Menu item help ctx } + Case Integer Of + 0: (Param: PString); + 1: (SubMenu: PMenu); + END; + +{---------------------------------------------------------------------------} +{ TMenu RECORD } +{---------------------------------------------------------------------------} + TMenu = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Items: PMenuItem; { Menu item list } + Default: PMenuItem; { Default menu } + END; + +{---------------------------------------------------------------------------} +{ TStatusItem RECORD } +{---------------------------------------------------------------------------} +TYPE + PStatusItem = ^TStatusItem; + TStatusItem = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Next: PStatusItem; { Next status item } + Text: PString; { Text of status item } + KeyCode: Word; { Keycode of item } + Command: Word; { Command of item } + END; + +{---------------------------------------------------------------------------} +{ TStatusDef RECORD } +{---------------------------------------------------------------------------} +TYPE + PStatusDef = ^TStatusDef; + TStatusDef = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + Next: PStatusDef; { Next status defined } + Min, Max: Word; { Range of item } + Items: PStatusItem; { Item list } + END; + +{***************************************************************************} +{ OBJECT DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TMenuView OBJECT - MENU VIEW ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + PMenuView = ^TMenuView; + TMenuView = OBJECT (TView) + ParentMenu: PMenuView; { Parent menu } + Menu : PMenu; { Menu item list } + Current : PMenuItem; { Current menu item } + OldItem : PMenuItem; { Old item for draws } + CONSTRUCTOR Init (Var Bounds: TRect); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION Execute: Word; Virtual; + FUNCTION GetHelpCtx: Word; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION FindItem (Ch: Char): PMenuItem; + FUNCTION HotKey (KeyCode: Word): PMenuItem; + FUNCTION NewSubView (Var Bounds: TRect; AMenu: PMenu; + AParentMenu: PMenuView): PMenuView; Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE GetItemRect (Item: PMenuItem; Var R: TRect); Virtual; + private + PROCEDURE GetItemRectX (Item: PMenuItem; Var R: TRect); Virtual; + END; + +{---------------------------------------------------------------------------} +{ TMenuBar OBJECT - MENU BAR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TMenuBar = OBJECT (TMenuView) + CONSTRUCTOR Init (Var Bounds: TRect; AMenu: PMenu); + DESTRUCTOR Done; Virtual; + PROCEDURE Draw; Virtual; + private + PROCEDURE GetItemRectX (Item: PMenuItem; Var R: TRect); Virtual; + END; + PMenuBar = ^TMenuBar; + +{---------------------------------------------------------------------------} +{ TMenuBox OBJECT - BOXED MENU OBJECT } +{---------------------------------------------------------------------------} +TYPE + TMenuBox = OBJECT (TMenuView) + CONSTRUCTOR Init (Var Bounds: TRect; AMenu: PMenu; + AParentMenu: PMenuView); + PROCEDURE Draw; Virtual; + private + PROCEDURE GetItemRectX (Item: PMenuItem; Var R: TRect); Virtual; + END; + PMenuBox = ^TMenuBox; + +{---------------------------------------------------------------------------} +{ TMenuPopUp OBJECT - POPUP MENU OBJECT } +{---------------------------------------------------------------------------} +TYPE + TMenuPopup = OBJECT (TMenuBox) + CONSTRUCTOR Init (Var Bounds: TRect; AMenu: PMenu); + DESTRUCTOR Done; Virtual; + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + END; + PMenuPopup = ^TMenuPopup; + +{---------------------------------------------------------------------------} +{ TStatusLine OBJECT - STATUS LINE OBJECT } +{---------------------------------------------------------------------------} +TYPE + TStatusLine = OBJECT (TView) + Items: PStatusItem; { Status line items } + Defs : PStatusDef; { Status line default } + CONSTRUCTOR Init (Var Bounds: TRect; ADefs: PStatusDef); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION Hint (AHelpCtx: Word): String; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE Update; Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PRIVATE + PROCEDURE FindItems; + PROCEDURE DrawSelect (Selected: PStatusItem); + END; + PStatusLine = ^TStatusLine; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MENU INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-NewMenu------------------------------------------------------------ +Allocates and returns a pointer to a new TMenu record. Sets the Items +and Default fields of the record to the value given by the parameter. +An error creating will return a nil pointer. +14May98 LdB +---------------------------------------------------------------------} +FUNCTION NewMenu (Items: PMenuItem): PMenu; + +{-DisposeMenu-------------------------------------------------------- +Disposes of all the elements of the specified menu (and all submenus). +14May98 LdB +---------------------------------------------------------------------} +PROCEDURE DisposeMenu (Menu: PMenu); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MENU ITEM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-NewLine------------------------------------------------------------ +Allocates and returns a pointer to a new TMenuItem record that +represents a separator line in a menu box. +An error creating will return a nil pointer. +14May98 LdB +---------------------------------------------------------------------} +FUNCTION NewLine (Next: PMenuItem): PMenuItem; + +{-NewItem------------------------------------------------------------ +Allocates and returns a pointer to a new TMenuItem record that +represents a menu item (using NewStr to allocate the Name and Param). +An error creating will return a nil pointer. +14May98 LdB +---------------------------------------------------------------------} +FUNCTION NewItem (Name, Param: TMenuStr; KeyCode: Word; Command: Word; + AHelpCtx: Word; Next: PMenuItem): PMenuItem; + +{-NewSubMenu--------------------------------------------------------- +Allocates and returns a pointer to a new TMenuItem record, which +represents a submenu (using NewStr to allocate the Name). +An error creating will return a nil pointer. +14May98 LdB +---------------------------------------------------------------------} +FUNCTION NewSubMenu (Name: TMenuStr; AHelpCtx: Word; SubMenu: PMenu; + Next: PMenuItem): PMenuItem; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STATUS INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-NewStatusDef------------------------------------------------------- +Allocates and returns a pointer to a new TStatusDef record initialized +with the given parameter values. Calls to NewStatusDef can be nested. +An error creating will return a nil pointer. +15May98 LdB +---------------------------------------------------------------------} +FUNCTION NewStatusDef (AMin, AMax: Word; AItems: PStatusItem; + ANext: PStatusDef): PStatusDef; + +{-NewStatusKey------------------------------------------------------- +Allocates and returns a pointer to a new TStatusItem record initialized +with the given parameter values (using NewStr to allocate the Text). +An error in creating will return a nil pointer. +15May98 LdB +---------------------------------------------------------------------} +FUNCTION NewStatusKey (AText: String; AKeyCode: Word; ACommand: Word; + ANext: PStatusItem): PStatusItem; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{-RegisterMenus------------------------------------------------------- +Calls RegisterType for each of the object types defined in this unit. +15May98 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterMenus; + +{***************************************************************************} +{ OBJECT REGISTRATION } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TMenuBar STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RMenuBar: TStreamRec = ( + ObjType: idMenuBar; { Register id = 40 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TMenuBar)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TMenuBar); + {$ENDIF} + Load: @TMenuBar.Load; { Object load method } + Store: @TMenuBar.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TMenuBox STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RMenuBox: TStreamRec = ( + ObjType: idMenuBox; { Register id = 41 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TMenuBox)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TMenuBox); + {$ENDIF} + Load: @TMenuBox.Load; { Object load method } + Store: @TMenuBox.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TStatusLine STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RStatusLine: TStreamRec = ( + ObjType: 42; { Register id = 42 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TStatusLine)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TStatusLine); + {$ENDIF} + Load: @TStatusLine.Load; { Object load method } + Store: @TStatusLine.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TMenuPopup STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RMenuPopup: TStreamRec = ( + ObjType: 43; { Register id = 43 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TMenuPopup)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TMenuPopup); + {$ENDIF} + Load: @TMenuPopup.Load; { Object load method } + Store: @TMenuPopup.Store { Object store method } + ); + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED PUBLIC VARIABLES } +{---------------------------------------------------------------------------} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} +USES + Video; + +CONST + SubMenuChar : array[boolean] of char = ('>',#16); + { SubMenuChar is the character displayed at right of submenu } + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMenuView OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMenuView----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMenuView.Init (Var Bounds: TRect); +BEGIN + Inherited Init(Bounds); { Call ancestor } + EventMask := EventMask OR evBroadcast; { See broadcast events } +END; + +{--TMenuView----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMenuView.Load (Var S: TStream); + + FUNCTION DoLoadMenu: PMenu; + VAR Tok: Byte; Item: PMenuItem; Last: ^PMenuItem; HMenu: PMenu; + BEGIN + New(HMenu); { Create new menu } + Last := @HMenu^.Items; { Start on first item } + Item := Nil; { Clear pointer } + S.Read(Tok, SizeOf(Tok)); { Read token } + While (Tok <> 0) Do Begin + New(Item); { Create new item } + Last^ := Item; { First part of chain } + If (Item <> Nil) Then Begin { Check item valid } + Last := @Item^.Next; { Complete chain } + With Item^ Do Begin + Name := S.ReadStr; { Read menu name } + S.Read(Command, SizeOf(Command)); { Menu item command } + S.Read(Disabled, SizeOf(Disabled)); { Menu item state } + S.Read(KeyCode, SizeOf(KeyCode)); { Menu item keycode } + S.Read(HelpCtx, SizeOf(HelpCtx)); { Menu item help ctx } + If (Name <> Nil) Then + If Command = 0 Then +{$ifdef PPC_FPC} + SubMenu := DoLoadMenu() { Load submenu } +{$else not PPC_FPC} + SubMenu := DoLoadMenu { Load submenu } +{$endif not PPC_FPC} + Else Param := S.ReadStr; { Read param string } + End; + End; + S.Read(Tok, SizeOf(Tok)); { Read token } + End; + Last^ := Nil; { List complete } + HMenu^.Default := HMenu^.Items; { Set menu default } + DoLoadMenu := HMenu; { Return menu } + End; + +BEGIN + Inherited Load(S); { Call ancestor } + Menu := DoLoadMenu; { Load menu items } +END; + +{--TMenuView----------------------------------------------------------------} +{ Execute -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.Execute: Word; +TYPE MenuAction = (DoNothing, DoSelect, DoReturn); +VAR AutoSelect: Boolean; Action: MenuAction; Ch: Char; Res: Word; R: TRect; + ItemShown, P: PMenuItem; Target: PMenuView; E: TEvent; MouseActive: Boolean; + + PROCEDURE TrackMouse; + VAR Mouse: TPoint; R: TRect; + BEGIN + Mouse.X := E.Where.X - Origin.X; { Local x position } + Mouse.Y := E.Where.Y - oRigin.Y; { Local y position } + Current := Menu^.Items; { Start with current } + While (Current <> Nil) Do Begin + GetItemRectX(Current, R); { Get item rectangle } + If R.Contains(Mouse) Then Begin { Contains mouse } + MouseActive := True; { Return true } + Exit; { Then exit } + End; + Current := Current^.Next; { Try next item } + End; + END; + + PROCEDURE TrackKey (FindNext: Boolean); + + PROCEDURE NextItem; + BEGIN + Current := Current^.Next; { Move to next item } + If (Current = Nil) Then + Current := Menu^.Items; { Return first menu } + END; + + PROCEDURE PrevItem; + VAR P: PMenuItem; + BEGIN + P := Current; { Start on current } + If (P = Menu^.Items) Then P := Nil; { Check if at start } + Repeat NextItem Until Current^.Next = P; { Prev item found } + END; + + BEGIN + If (Current <> Nil) Then { Current view valid } + Repeat + If FindNext Then NextItem Else PrevItem; { Find next/prev item } + Until (Current^.Name <> Nil); { Until we have name } + END; + + FUNCTION MouseInOwner: Boolean; + VAR Mouse: TPoint; R: TRect; + BEGIN + MouseInOwner := False; { Preset false } + If (ParentMenu <> Nil) AND (ParentMenu^.Size.Y = 1) + Then Begin { Valid parent menu } + Mouse.X := E.Where.X - ParentMenu^.Origin.X;{ Local x position } + Mouse.Y := E.Where.Y - ParentMenu^.Origin.Y;{ Local y position } + ParentMenu^.GetItemRectX(ParentMenu^.Current,R);{ Get item rect } + MouseInOwner := R.Contains(Mouse); { Return result } + End; + END; + + FUNCTION MouseInMenus: Boolean; + VAR P: PMenuView; + BEGIN + P := ParentMenu; { Parent menu } + While (P <> Nil) AND NOT P^.MouseInView(E.Where) + Do P := P^.ParentMenu; { Check next menu } + MouseInMenus := (P <> Nil); { Return result } + END; + + FUNCTION TopMenu: PMenuView; + VAR P: PMenuView; + BEGIN + P := @Self; { Start with self } + While (P^.ParentMenu <> Nil) Do + P := P^.ParentMenu; { Check next menu } + TopMenu := P; { Top menu } + END; + +BEGIN + AutoSelect := False; { Clear select flag } + MouseActive := False; { Clear mouse flag } + Res := 0; { Clear result } + ItemShown := Nil; { Clear item pointer } + If (Menu <> Nil) Then Current := Menu^.Default { Set current item } + Else Current := Nil; { No menu = no current } + Repeat + Action := DoNothing; { Clear action flag } + GetEvent(E); { Get next event } + Case E.What Of + evMouseDown: If MouseInView(E.Where) { Mouse in us } + OR MouseInOwner Then Begin { Mouse in owner area } + TrackMouse; { Track the mouse } + If (Size.Y = 1) Then AutoSelect := True; { Set select flag } + End Else Action := DoReturn; { Set return action } + evMouseUp: Begin + TrackMouse; { Track the mouse } + If MouseInOwner Then { Mouse in owner } + Current := Menu^.Default { Set as current } + Else If (Current <> Nil) AND + (Current^.Name <> Nil) Then + Action := DoSelect { Set select action } + Else If MouseActive OR MouseInView(E.Where) + Then Action := DoReturn { Set return action } + Else Begin + Current := Menu^.Default; { Set current item } + If (Current = Nil) Then + Current := Menu^.Items; { Select first item } + Action := DoNothing; { Do nothing action } + End; + End; + evMouseMove: If (E.Buttons <> 0) Then Begin { Mouse moved } + TrackMouse; { Track the mouse } + If NOT (MouseInView(E.Where) OR MouseInOwner) + AND MouseInMenus Then Action := DoReturn; { Set return action } + End; + evKeyDown: + Case CtrlToArrow(E.KeyCode) Of { Check arrow keys } + kbUp, kbDown: If (Size.Y <> 1) Then + TrackKey(CtrlToArrow(E.KeyCode) = kbDown){ Track keyboard } + Else If (E.KeyCode = kbDown) Then { Down arrow } + AutoSelect := True; { Select item } + kbLeft, kbRight: If (ParentMenu = Nil) Then + TrackKey(CtrlToArrow(E.KeyCode)=kbRight) { Track keyboard } + Else Action := DoReturn; { Set return action } + kbHome, kbEnd: If (Size.Y <> 1) Then Begin + Current := Menu^.Items; { Set to first item } + If (E.KeyCode = kbEnd) Then { If the 'end' key } + TrackKey(False); { Move to last item } + End; + kbEnter: Begin + If Size.Y = 1 Then AutoSelect := True; { Select item } + Action := DoSelect; { Return the item } + End; + kbEsc: Begin + Action := DoReturn; { Set return action } + If (ParentMenu = Nil) OR + (ParentMenu^.Size.Y <> 1) Then { Check parent } + ClearEvent(E); { Kill the event } + End; + Else Target := @Self; { Set target as self } + Ch := GetAltChar(E.KeyCode); + If (Ch = #0) Then Ch := E.CharCode Else + Target := TopMenu; { Target is top menu } + P := Target^.FindItem(Ch); { Check for item } + If (P = Nil) Then Begin + P := TopMenu^.HotKey(E.KeyCode); { Check for hot key } + If (P <> Nil) AND { Item valid } + CommandEnabled(P^.Command) Then Begin { Command enabled } + Res := P^.Command; { Set return command } + Action := DoReturn; { Set return action } + End + End Else If Target = @Self Then Begin + If Size.Y = 1 Then AutoSelect := True; { Set auto select } + Action := DoSelect; { Select item } + Current := P; { Set current item } + End Else If (ParentMenu <> Target) OR + (ParentMenu^.Current <> P) Then { Item different } + Action := DoReturn; { Set return action } + End; + evCommand: If (E.Command = cmMenu) Then Begin { Menu command } + AutoSelect := False; { Dont select item } + If (ParentMenu <> Nil) Then + Action := DoReturn; { Set return action } + End Else Action := DoReturn; { Set return action } + End; + If (ItemShown <> Current) Then Begin { New current item } + OldItem := ItemShown; { Hold old item } + ItemShown := Current; { Hold new item } + DrawView; { Redraw the items } + OldItem := Nil; { Clear old item } + End; + If (Action = DoSelect) OR ((Action = DoNothing) + AND AutoSelect) Then { Item is selecting } + If (Current <> Nil) Then With Current^ Do { Current item valid } + If (Name <> Nil) Then { Item has a name } + If (Command = 0) Then Begin { Has no command } + If (E.What AND (evMouseDown+evMouseMove) <> 0) + Then PutEvent(E); { Put event on queue } + GetItemRectX(Current, R); { Get area of item } + R.A.X := R.A.X + Origin.X; { Left start point } + R.A.Y := R.B.Y + Origin.Y;{ Top start point } + R.B.X := Owner^.Size.X; { X screen area left } + R.B.Y := Owner^.Size.Y; { Y screen area left } + Target := TopMenu^.NewSubView(R, SubMenu, + @Self); { Create drop menu } + Res := Owner^.ExecView(Target); { Execute dropped view } + Dispose(Target, Done); { Dispose drop view } + End Else If Action = DoSelect Then + Res := Command; { Return result } + If (Res <> 0) AND CommandEnabled(Res) { Check command } + Then Begin + Action := DoReturn; { Return command } + ClearEvent(E); { Clear the event } + End Else Res := 0; { Clear result } + Until (Action = DoReturn); + If (E.What <> evNothing) Then + If (ParentMenu <> Nil) OR (E.What = evCommand) { Check event type } + Then PutEvent(E); { Put event on queue } + If (Current <> Nil) Then Begin + Menu^.Default := Current; { Set new default } + Current := Nil; { Clear current } + DrawView; { Redraw the view } + End; + Execute := Res; { Return result } +END; + +{--TMenuView----------------------------------------------------------------} +{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.GetHelpCtx: Word; +VAR C: PMenuView; +BEGIN + C := @Self; { Start at self } + While (C <> Nil) AND ((C^.Current = Nil) OR + (C^.Current^.HelpCtx = hcNoContext) OR { Has no context } + (C^.Current^.Name = Nil)) Do C := C^.ParentMenu; { Parent menu context } + If (C<>Nil) Then GetHelpCtx := C^.Current^.HelpCtx { Current context } + Else GetHelpCtx := hcNoContext; { No help context } +END; + +{--TMenuView----------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.GetPalette: PPalette; +{$IFDEF PPC_DELPHI3} { DELPHI3+ COMPILER } +CONST P: String = CMenuView; { Possible huge string } +{$ELSE} { OTHER COMPILERS } +CONST P: String[Length(CMenuView)] = CMenuView; { Always normal string } +{$ENDIF} +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TMenuView----------------------------------------------------------------} +{ FindItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.FindItem (Ch: Char): PMenuItem; +VAR I: Integer; P: PMenuItem; +BEGIN + Ch := UpCase(Ch); { Upper case of char } + P := Menu^.Items; { First menu item } + While (P <> Nil) Do Begin { While item valid } + If (P^.Name <> Nil) AND (NOT P^.Disabled) { Valid enabled cmd } + Then Begin + I := Pos('~', P^.Name^); { Scan for highlight } + If (I <> 0) AND (Ch = UpCase(P^.Name^[I+1])) { Hotkey char found } + Then Begin + FindItem := P; { Return item } + Exit; { Now exit } + End; + End; + P := P^.Next; { Next item } + End; + FindItem := Nil; { No item found } +END; + +{--TMenuView----------------------------------------------------------------} +{ HotKey -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.HotKey (KeyCode: Word): PMenuItem; + + FUNCTION FindHotKey (P: PMenuItem): PMenuItem; + VAR T: PMenuItem; + BEGIN + While (P <> Nil) Do Begin { While item valid } + If (P^.Name <> Nil) Then { If valid name } + If (P^.Command = 0) Then Begin { Valid command } + T := FindHotKey(P^.SubMenu^.Items); { Search for hot key } + If (T <> Nil) Then Begin + FindHotKey := T; { Return hotkey } + Exit; { Now exit } + End; + End Else If NOT P^.Disabled AND { Hotkey is enabled } + (P^.KeyCode <> kbNoKey) AND { Valid keycode } + (P^.KeyCode = KeyCode) Then Begin { Key matches request } + FindHotKey := P; { Return hotkey code } + Exit; { Exit } + End; + P := P^.Next; { Next item } + End; + FindHotKey := Nil; { No item found } + END; + +BEGIN + HotKey := FindHotKey(Menu^.Items); { Hot key function } +END; + +{--TMenuView----------------------------------------------------------------} +{ NewSubView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TMenuView.NewSubView (Var Bounds: TRect; AMenu: PMenu; + AParentMenu: PMenuView): PMenuView; +BEGIN + NewSubView := New(PMenuBox, Init(Bounds, AMenu, + AParentMenu)); { Create a menu box } +END; + +{--TMenuView----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuView.Store (Var S: TStream); + + PROCEDURE DoStoreMenu (AMenu: PMenu); + VAR Item: PMenuItem; Tok: Byte; + BEGIN + Tok := $FF; { Preset max count } + Item := AMenu^.Items; { Start first item } + While (Item <> Nil) Do Begin + With Item^ Do Begin + S.Write(Tok, SizeOf(Tok)); { Write tok value } + S.WriteStr(Name); { Write item name } + S.Write(Command, SizeOf(Command)); { Menu item command } + S.Write(Disabled, SizeOf(Disabled)); { Menu item state } + S.Write(KeyCode, SizeOf(KeyCode)); { Menu item keycode } + S.Write(HelpCtx, SizeOf(HelpCtx)); { Menu item help ctx } + If (Name <> Nil) Then + If Command = 0 Then DoStoreMenu(SubMenu) + Else S.WriteStr(Param); { Write parameter } + End; + Item := Item^.Next; { Next item } + End; + Tok := 0; { Clear tok count } + S.Write(Tok, SizeOf(Tok)); { Write tok value } + END; + +BEGIN + TView.Store(S); { TView.Store called } + DoStoreMenu(Menu); { Store menu items } +END; + +{--TMenuView----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuView.HandleEvent (Var Event: TEvent); +VAR CallDraw: Boolean; P: PMenuItem; + + PROCEDURE UpdateMenu (AMenu: PMenu); + VAR P: PMenuItem; CommandState: Boolean; + BEGIN + P := AMenu^.Items; { Start on first item } + While (P <> Nil) Do Begin + If (P^.Name <> Nil) Then { Valid name } + If (P^.Command = 0) Then UpdateMenu(P^.SubMenu){ Update menu } + Else Begin + CommandState := CommandEnabled(P^.Command); { Menu item state } + If (P^.Disabled = CommandState) Then Begin + P^.Disabled := NOT CommandState; { Disable item } + CallDraw := True; { Must draw } + End; + End; + P := P^.Next; { Next item } + End; + END; + + PROCEDURE DoSelect; + BEGIN + PutEvent(Event); { Put event on queue } + Event.Command := Owner^.ExecView(@Self); { Execute view } + If (Event.Command <> 0) AND + CommandEnabled(Event.Command) Then Begin + Event.What := evCommand; { Command event } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + End; + ClearEvent(Event); { Clear the event } + END; + +BEGIN + If (Menu <> Nil) Then + Case Event.What Of + evMouseDown: DoSelect; { Select menu item } + evKeyDown: + If (FindItem(GetAltChar(Event.KeyCode)) <> Nil) + Then DoSelect Else Begin { Select menu item } + P := HotKey(Event.KeyCode); { Check for hotkey } + If (P <> Nil) AND + (CommandEnabled(P^.Command)) Then Begin + Event.What := evCommand; { Command event } + Event.Command := P^.Command; { Set command event } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + ClearEvent(Event); { Clear the event } + End; + End; + evCommand: + If Event.Command = cmMenu Then DoSelect; { Select menu item } + evBroadcast: + If (Event.Command = cmCommandSetChanged) { Commands changed } + Then Begin + CallDraw := False; { Preset no redraw } + UpdateMenu(Menu); { Update menu } + If CallDraw Then DrawView; { Redraw if needed } + End; + End; +END; + +{--TMenuView----------------------------------------------------------------} +{ GetItemRectX -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuView.GetItemRectX (Item: PMenuItem; Var R: TRect); +BEGIN { Abstract method } +END; + +{--TMenuView----------------------------------------------------------------} +{ GetItemRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuView.GetItemRect (Item: PMenuItem; Var R: TRect); +BEGIN + GetItemRectX(Item,R); +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMenuBar OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMenuBar-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMenuBar.Init (Var Bounds: TRect; AMenu: PMenu); +BEGIN + Inherited Init(Bounds); { Call ancestor } + GrowMode := gfGrowHiX; { Set grow mode } + Menu := AMenu; { Hold menu item } + Options := Options OR ofPreProcess; { Preprocessing view } +END; + +{--TMenuBar-----------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TMenuBar.Done; +BEGIN + If (Menu <> Nil) Then DisposeMenu(Menu); { Dispose menu items } + Inherited Done; { Call ancestor } +END; + +{--TMenuBar-----------------------------------------------------------------} +{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuBar.Draw; +VAR I, J, CNormal, CSelect, CNormDisabled, CSelDisabled, Color: Word; + P: PMenuItem; B: TDrawBuffer; +BEGIN + CNormal := GetColor($0301); { Normal colour } + CSelect := GetColor($0604); { Select colour } + CNormDisabled := GetColor($0202); { Disabled colour } + CSelDisabled := GetColor($0505); { Select disabled } + MoveChar(B, ' ', Byte(CNormal), Size.X); { Empty bar } + If (Menu <> Nil) Then Begin { Valid menu } + I := 0; { Set start position } + P := Menu^.Items; { First item } + While (P <> Nil) Do Begin + If (P^.Name <> Nil) Then Begin { Name valid } + If P^.Disabled Then Begin + If (P = Current) Then Color := CSelDisabled{ Select disabled } + Else Color := CNormDisabled { Normal disabled } + End Else Begin + If (P = Current) Then Color := CSelect { Select colour } + Else Color := CNormal; { Normal colour } + End; + J := CStrLen(P^.Name^); { Length of string } + MoveChar(B[I], ' ', Byte(Color), 1); + MoveCStr(B[I+1], P^.Name^, Color); { Name to buffer } + MoveChar(B[I+1+J], ' ', Byte(Color), 1); + Inc(I, J+2); { Advance position } + End; + P := P^.Next; { Next item } + End; + End; + WriteBuf(0, 0, Size.X, 1, B); { Write the string } +END; + +{--TMenuBar-----------------------------------------------------------------} +{ GetItemRectX -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuBar.GetItemRectX (Item: PMenuItem; Var R: TRect); +VAR I: Integer; P: PMenuItem; +BEGIN + I := 0; { Preset to zero } + R.Assign(0, 0, 0, 1); { Initial rect size } + P := Menu^.Items; { First item } + While (P <> Nil) Do Begin { While valid item } + R.A.X := I; { Move area along } + If (P^.Name <> Nil) Then Begin { Valid name } + R.B.X := R.A.X+CTextWidth(' ' + P^.Name^ + ' ');{ Add text width } + I := I + CStrLen(P^.Name^) + 2; { Add item length } + End Else R.B.X := R.A.X; + If (P = Item) Then break; { Requested item found } + P := P^.Next; { Next item } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMenuBox OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMenuBox-----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMenuBox.Init (Var Bounds: TRect; AMenu: PMenu; + AParentMenu: PMenuView); +VAR W, H, L: Integer; S: String; P: PMenuItem; R: TRect; +BEGIN + W := 0; { Clear initial width } + H := 2; { Set initial height } + If (AMenu <> Nil) Then Begin { Valid menu } + P := AMenu^.Items; { Start on first item } + While (P <> Nil) Do Begin { If item valid } + If (P^.Name <> Nil) Then Begin { Check for name } + S := ' ' + P^.Name^ + ' '; { Transfer string } + If (P^.Command <> 0) AND (P^.Param <> Nil) + Then S := S + ' - ' + P^.Param^; { Add any parameter } + End; + L := CTextWidth(S); { Width of string } + If (L > W) Then W := L; { Hold maximum } + Inc(H); { Inc count of items } + P := P^.Next; { Move to next item } + End; + End; + W := 5 + W; { Longest text width } + R.Copy(Bounds); { Copy the bounds } + If (R.A.X + W < R.B.X) Then R.B.X := R.A.X + W { Shorten if possible } + Else R.A.X := R.B.X - W; { Insufficent space } + R.B.X := R.A.X + W; + If (R.A.Y + H < R.B.Y) Then R.B.Y := R.A.Y + H { Shorten if possible } + Else R.A.Y := R.B.Y - H; { Insufficent height } + Inherited Init(R); { Call ancestor } + State := State OR sfShadow; { Set shadow state } + Options := Options OR ofFramed or ofPreProcess; { View pre processes } + Menu := AMenu; { Hold menu } + ParentMenu := AParentMenu; { Hold parent } +END; + +{--TMenuBox-----------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuBox.Draw; +VAR CNormal, CSelect, CSelectDisabled, CDisabled, Color: Word; Index, Y: Integer; + S: String; P: PMenuItem; B: TDrawBuffer; +Type + FrameLineType = (UpperLine,NormalLine,SeparationLine,LowerLine); + FrameLineChars = Array[0..2] of char; +Const + FrameLines : Array[FrameLineType] of FrameLineChars = + ('ÚÄ¿','³ ³','ÃÄ´','ÀÄÙ'); + Procedure CreateBorder(LineType : FrameLineType); + Begin + MoveChar(B, ' ', CNormal, 1); + MoveChar(B[1], FrameLines[LineType][0], CNormal, 1); + MoveChar(B[2], FrameLines[LineType][1], Color, Size.X-4); + MoveChar(B[Size.X-2], FrameLines[LineType][2], CNormal, 1); + MoveChar(B[Size.X-1], ' ', CNormal, 1); + End; + + +BEGIN + CNormal := GetColor($0301); { Normal colour } + CSelect := GetColor($0604); { Selected colour } + CDisabled := GetColor($0202); { Disabled colour } + CSelectDisabled := GetColor($0505); { Selected, but disabled } + Color := CNormal; { Normal colour } + CreateBorder(UpperLine); + WriteBuf(0, 0, Size.X, 1, B); { Write the line } + Y := 1; + If (Menu <> Nil) Then Begin { We have a menu } + P := Menu^.Items; { Start on first } + While (P <> Nil) Do Begin { Valid menu item } + Color := CNormal; { Normal colour } + If (P^.Name <> Nil) Then Begin { Item has text } + If P^.Disabled Then + begin + if (P = Current) then + Color := CSelectDisabled + else + Color := CDisabled; { Is item disabled } + end + else + If (P = Current) Then Color := CSelect; { Select colour } + CreateBorder(NormalLine); + Index:=2; + S := ' ' + P^.Name^ + ' '; { Menu string } + MoveCStr(B[Index], S, Color); { Transfer string } + if P^.Command = 0 then + MoveChar(B[Size.X - 4],SubMenuChar[LowAscii], + Byte(Color), 1) else + If (P^.Command <> 0) AND(P^.Param <> Nil) Then + Begin + MoveCStr(B[Size.X - 3 - Length(P^.Param^)], P^.Param^, Color); { Add param chars } + S := S + ' - ' + P^.Param^; { Add to string } + End; + If (OldItem = Nil) OR (OldItem = P) OR + (Current = P) Then + Begin { We need to fix draw } + WriteBuf(0, Y, Size.X, 1, B); { Write the whole line } + End; + End Else Begin { no text NewLine } + Color := CNormal; { Normal colour } + CreateBorder(SeparationLine); + WriteBuf(0, Y, Size.X, 1, B); { Write the line } + End; + Inc(Y); { Next line down } + P := P^.Next; { fetch next item } + End; + End; + Color := CNormal; { Normal colour } + CreateBorder(LowerLine); + WriteBuf(0, Size.Y-1, Size.X, 1, B); { Write the line } +END; + + +{--TMenuBox-----------------------------------------------------------------} +{ GetItemRectX -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuBox.GetItemRectX (Item: PMenuItem; Var R: TRect); +VAR X, Y: Integer; P: PMenuItem; +BEGIN + Y := 1; { Initial y position } + P := Menu^.Items; { Initial item } + While (P <> Item) Do Begin { Valid item } + Inc(Y); { Inc position } + P := P^.Next; { Next item } + End; + X := 2; { Left/Right margin } + R.Assign(X, Y, Size.X - X, Y + 1); { Assign area } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TMenuPopUp OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TMenuPopUp---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TMenuPopup.Init (Var Bounds: TRect; AMenu: PMenu); +BEGIN + Inherited Init(Bounds, AMenu, Nil); { Call ancestor } +END; + +{--TMenuPopUp---------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TMenuPopup.Done; +BEGIN + If (Menu <> Nil) Then DisposeMenu(Menu); { Dispose menu items } + Inherited Done; { Call ancestor } +END; + +{--TMenuPopUp---------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TMenuPopup.HandleEvent (Var Event: TEvent); +VAR P: PMenuItem; +BEGIN + Case Event.What Of + evKeyDown: Begin + P := FindItem(GetCtrlChar(Event.KeyCode)); { Find the item } + If (P = Nil) Then P := HotKey(Event.KeyCode);{ Try hot key } + If (P <> Nil) AND (CommandEnabled(P^.Command)) + Then Begin { Command valid } + Event.What := evCommand; { Command event } + Event.Command := P^.Command; { Set command value } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + ClearEvent(Event); { Clear the event } + End Else If (GetAltChar(Event.KeyCode) <> #0) + Then ClearEvent(Event); { Clear the event } + End; + End; + Inherited HandleEvent(Event); { Call ancestor } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStatusLine OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TStatusLine--------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStatusLine.Init (Var Bounds: TRect; ADefs: PStatusDef); +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR ofPreProcess; { Pre processing view } + EventMask := EventMask OR evBroadcast; { See broadcasts } + GrowMode := gfGrowLoY + gfGrowHiX + gfGrowHiY; { Set grow modes } + Defs := ADefs; { Set default items } + FindItems; { Find the items } +END; + +{--TStatusLine--------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStatusLine.Load (Var S: TStream); + + FUNCTION DoLoadStatusItems: PStatusItem; + VAR Count: Integer; Cur, First: PStatusItem; Last: ^PStatusItem; + BEGIN + Cur := Nil; { Preset nil } + Last := @First; { Start on first item } + S.Read(Count, SizeOf(Count)); { Read count } + While (Count > 0) Do Begin + New(Cur); { New status item } + Last^ := Cur; { First chain part } + If (Cur <> Nil) Then Begin { Check pointer valid } + Last := @Cur^.Next; { Chain complete } + Cur^.Text := S.ReadStr; { Read item text } + S.Read(Cur^.KeyCode, SizeOf(Cur^.KeyCode)); { Keycode of item } + S.Read(Cur^.Command, SizeOf(Cur^.Command)); { Command of item } + End; + Dec(Count); { One item loaded } + End; + Last^ := Nil; { Now chain end } + DoLoadStatusItems := First; { Return the list } + END; + + FUNCTION DoLoadStatusDefs: PStatusDef; + VAR Count: Integer; Cur, First: PStatusDef; Last: ^PStatusDef; + BEGIN + Last := @First; { Start on first } + S.Read(Count, SizeOf(Count)); { Read item count } + While (Count > 0) Do Begin + New(Cur); { New status def } + Last^ := Cur; { First part of chain } + If (Cur <> Nil) Then Begin { Check pointer valid } + Last := @Cur^.Next; { Chain complete } + S.Read(Cur^.Min, SizeOf(Cur^.Min)); { Read min data } + S.Read(Cur^.Max, SizeOf(Cur^.Max)); { Read max data } + Cur^.Items := DoLoadStatusItems; { Set pointer } + End; + Dec(Count); { One item loaded } + End; + Last^ := Nil; { Now chain ends } + DoLoadStatusDefs := First; { Return item list } + END; + +BEGIN + Inherited Load(S); { Call ancestor } + Defs := DoLoadStatusDefs; { Retreive items } + FindItems; { Find the items } +END; + +{--TStatusLine--------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TStatusLine.Done; +VAR T: PStatusDef; + + PROCEDURE DisposeItems (Item: PStatusItem); + VAR T: PStatusItem; + BEGIN + While (Item <> Nil) Do Begin { Item to dispose } + T := Item; { Hold pointer } + Item := Item^.Next; { Move down chain } + DisposeStr(T^.Text); { Dispose string } + Dispose(T); { Dispose item } + End; + END; + +BEGIN + While (Defs <> Nil) Do Begin + T := Defs; { Hold pointer } + Defs := Defs^.Next; { Move down chain } + DisposeItems(T^.Items); { Dispose the item } + Dispose(T); { Dispose status item } + End; + Inherited Done; { Call ancestor } +END; + + +{--TStatusLine--------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStatusLine.GetPalette: PPalette; +{$IFDEF PPC_DELPHI3} { DELPHI3+ COMPILER } +CONST P: String = CStatusLine; { Possible huge string } +{$ELSE} { OTHER COMPILERS } +CONST P: String[Length(CStatusLine)] = CStatusLine; { Always normal string } +{$ENDIF} +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TStatusLine--------------------------------------------------------------} +{ Hint -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStatusLine.Hint (AHelpCtx: Word): String; +BEGIN + Hint := ''; { Return nothing } +END; + +{--TStatusLine--------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.Draw; +BEGIN + DrawSelect(Nil); { Call draw select } +END; + +{--TStatusLine--------------------------------------------------------------} +{ Update -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.Update; +VAR H: Word; P: PView; +BEGIN + P := TopView; { Get topmost view } + If (P <> Nil) Then H := P^.GetHelpCtx Else { Top views context } + H := hcNoContext; { No context } + If (HelpCtx <> H) Then Begin { Differs from last } + HelpCtx := H; { Hold new context } + FindItems; { Find the item } + DrawView; { Redraw the view } + End; +END; + +{--TStatusLine--------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.Store (Var S: TStream); + + PROCEDURE DoStoreStatusItems (Cur: PStatusItem); + VAR Count: Integer; T: PStatusItem; + BEGIN + Count := 0; { Clear count } + T := Cur; { Start on current } + While (T <> Nil) Do Begin + Inc(Count); { Count items } + T := T^.Next; { Next item } + End; + S.Write(Count, SizeOf(Count)); { Write item count } + While (Cur <> Nil) Do Begin + S.WriteStr(Cur^.Text); { Store item text } + S.Write(Cur^.KeyCode, SizeOf(Cur^.KeyCode)); { Keycode of item } + S.Write(Cur^.Command, SizeOf(Cur^.Command)); { Command of item } + Cur := Cur^.Next; { Move to next item } + End; + END; + + PROCEDURE DoStoreStatusDefs (Cur: PStatusDef); + VAR Count: Integer; T: PStatusDef; + BEGIN + Count := 0; { Clear count } + T := Cur; { Current status item } + While (T <> Nil) Do Begin + Inc(Count); { Count items } + T := T^.Next { Next item } + End; + S.Write(Count, 2); { Write item count } + While (Cur <> Nil) Do Begin + With Cur^ Do Begin + S.Write(Cur^.Min, 2); { Write min data } + S.Write(Cur^.Max, 2); { Write max data } + DoStoreStatusItems(Items); { Store the items } + End; + Cur := Cur^.Next; { Next status item } + End; + END; + +BEGIN + TView.Store(S); { TView.Store called } + DoStoreStatusDefs(Defs); { Store status items } +END; + +{--TStatusLine--------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.HandleEvent (Var Event: TEvent); +VAR Mouse: TPoint; T, Tt: PStatusItem; + + FUNCTION ItemMouseIsIn: PStatusItem; + VAR X, Xi: Word; T: PStatusItem; + BEGIN + ItemMouseIsIn := Nil; { Preset fail } + If (Mouse.Y < 0) OR (Mouse.Y > 1) { Outside view height } + Then Exit; { Not in view exit } + X := 0; { Zero x position } + T := Items; { Start at first item } + While (T <> Nil) Do Begin { While item valid } + If (T^.Text <> Nil) Then Begin { Check valid text } + Xi := X; { Hold initial x value } + X := Xi + CTextWidth(' ' + T^.Text^ + ' '); { Add text width } + If (Mouse.X >= Xi) AND (Mouse.X < X) + Then Begin + ItemMouseIsIn := T; { Selected item } + Exit; { Now exit } + End; + End; + T := T^.Next; { Next item } + End; + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evMouseDown: Begin + T := Nil; { Preset ptr to nil } + Repeat + Mouse.X := Event.Where.X - Origin.X; { Local x position } + Mouse.Y := Event.Where.Y - Origin.Y; { Local y position } + Tt := ItemMouseIsIn; { Find selected item } + If (T <> Tt) Then { Item has changed } + DrawSelect(Tt); { Draw new item } + T := Tt { Transfer item } + Until NOT MouseEvent(Event, evMouseMove); { Mouse stopped moving } + If (T <> Nil) AND CommandEnabled(T^.Command) { Check cmd enabled } + Then Begin + Event.What := evCommand; { Command event } + Event.Command := T^.Command; { Set command value } + Event.InfoPtr := Nil; { No info ptr } + PutEvent(Event); { Put event on queue } + End; + ClearEvent(Event); { Clear the event } + DrawSelect(Nil); { Clear the highlight } + End; + evKeyDown: Begin { Key down event } + T := Items; { Start on first item } + While (T <> Nil) Do Begin { For each valid item } + If (Event.KeyCode = T^.KeyCode) AND { Check for hot key } + CommandEnabled(T^.Command) Then Begin { Check cmd enabled } + Event.What := evCommand; { Change to command } + Event.Command := T^.Command; { Set command value } + Event.InfoPtr := Nil; { Clear info ptr } + PutEvent(Event); { Put event on queue } + ClearEvent(Event); { Clear the event } + Exit; Exit; { Now exit } + End; + T := T^.Next; { Next item } + End; + End; + evBroadcast: + If (Event.Command = cmCommandSetChanged) Then { Command set change } + DrawView; { Redraw view } + End; +END; + +{***************************************************************************} +{ TStatusLine OBJECT PRIVATE METHODS } +{***************************************************************************} + +{--TStatusLine--------------------------------------------------------------} +{ FindItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.FindItems; +VAR P: PStatusDef; +BEGIN + P := Defs; { First status item } + While (P <> Nil) AND ((HelpCtx < P^.Min) OR + (HelpCtx > P^.Max)) Do P := P^.Next; { Find status item } + If (P = Nil) Then Items := Nil Else + Items := P^.Items; { Return found item } +END; + +{--TStatusLine--------------------------------------------------------------} +{ DrawSelect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStatusLine.DrawSelect (Selected: PStatusItem); +VAR I, L: Integer; Color, CSelect, CNormal, CSelDisabled, CNormDisabled: Word; + HintBuf: String; B: TDrawBuffer; T: PStatusItem; +BEGIN + CNormal := GetColor($0301); { Normal colour } + CSelect := GetColor($0604); { Select colour } + CNormDisabled := GetColor($0202); { Disabled colour } + CSelDisabled := GetColor($0505); { Select disabled } + MoveChar(B, ' ', Byte(CNormal), Size.X); { Clear the buffer } + T := Items; { First item } + I := 0; { Clear the count } + L := 0; + While (T <> Nil) Do Begin { While valid item } + If (T^.Text <> Nil) Then Begin { While valid text } + L := CStrLen(' '+T^.Text^+' '); { Text length } + If CommandEnabled(T^.Command) Then Begin { Command enabled } + If T = Selected Then Color := CSelect { Selected colour } + Else Color := CNormal { Normal colour } + End Else + If T = Selected Then Color := CSelDisabled { Selected disabled } + Else Color := CNormDisabled; { Disabled colour } + MoveCStr(B[I], ' '+T^.Text^+' ', Color); { Move text to buf } + Inc(I, L); { Advance position } + End; + T := T^.Next; { Next item } + End; + HintBuf := Hint(HelpCtx); { Get hint string } + If (HintBuf <> '') Then Begin { Hint present } + {$IFNDEF OS_WINDOWS} + MoveChar(B[I], #179, Byte(CNormal), 1); { '|' char to buffer } + {$ELSE} + MoveChar(B[I], #166, Byte(CNormal), 1); { '|' char to buffer } + {$ENDIF} + Inc(I, 2); { Move along } + MoveStr(B[I], HintBuf, Byte(CNormal)); { Move hint to buffer } + I := I + Length(HintBuf); { Hint length } + End; + WriteLine(0, 0, Size.X, 1, B); { Write the buffer } +END; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MENU INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ NewMenu -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewMenu (Items: PMenuItem): PMenu; +VAR P: PMenu; +BEGIN + New(P); { Create new menu } + FillChar(P^,sizeof(TMenu),0); + If (P <> Nil) Then Begin { Check valid pointer } + P^.Items := Items; { Hold item list } + P^.Default := Items; { Set default item } + End; + NewMenu := P; { Return menu } +END; + +{---------------------------------------------------------------------------} +{ DisposeMenu -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE DisposeMenu (Menu: PMenu); +VAR P, Q: PMenuItem; +BEGIN + If (Menu <> Nil) Then Begin { Valid menu item } + P := Menu^.Items; { First item in list } + While (P <> Nil) Do Begin { Item is valid } + If (P^.Name <> Nil) Then Begin { Valid name pointer } + DisposeStr(P^.Name); { Dispose of name } + If (P^.Command <> 0) Then + DisposeStr(P^.Param) Else { Dispose parameter } + DisposeMenu(P^.SubMenu); { Dispose submenu } + End; + Q := P; { Hold pointer } + P := P^.Next; { Move to next item } + Dispose(Q); { Dispose of item } + End; + Dispose(Menu); { Dispose of menu } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ MENU ITEM ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ NewLine -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewLine (Next: PMenuItem): PMenuItem; +VAR P: PMenuItem; +BEGIN + New(P); { Allocate memory } + FillChar(P^,sizeof(TMenuItem),0); + If (P <> Nil) Then Begin { Check valid pointer } + P^.Next := Next; { Hold next menu item } + End; + NewLine := P; { Return new line } +END; + +{---------------------------------------------------------------------------} +{ NewItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewItem (Name, Param: TMenuStr; KeyCode: Word; Command: Word; + AHelpCtx: Word; Next: PMenuItem): PMenuItem; +VAR P: PMenuItem; R: TRect; T: PView; +BEGIN + If (Name <> '') AND (Command <> 0) Then Begin + New(P); { Allocate memory } + FillChar(P^,sizeof(TMenuItem),0); + If (P <> Nil) Then Begin { Check valid pointer } + P^.Next := Next; { Hold next item } + P^.Name := NewStr(Name); { Hold item name } + P^.Command := Command; { Hold item command } + R.Assign(1, 1, 10, 10); { Random assignment } + T := New(PView, Init(R)); { Create a view } + If (T <> Nil) Then Begin + P^.Disabled := NOT T^.CommandEnabled(Command); + Dispose(T, Done); { Dispose of view } + End Else P^.Disabled := True; + P^.KeyCode := KeyCode; { Hold item keycode } + P^.HelpCtx := AHelpCtx; { Hold help context } + P^.Param := NewStr(Param); { Hold parameter } + End; + NewItem := P; { Return item } + End Else NewItem := Next; { Move forward } +END; + +{---------------------------------------------------------------------------} +{ NewSubMenu -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 14May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewSubMenu (Name: TMenuStr; AHelpCtx: Word; SubMenu: PMenu; + Next: PMenuItem): PMenuItem; +VAR P: PMenuItem; +BEGIN + If (Name <> '') AND (SubMenu <> Nil) Then Begin + New(P); { Allocate memory } + FillChar(P^,sizeof(TMenuItem),0); + If (P <> Nil) Then Begin { Check valid pointer } + P^.Next := Next; { Hold next item } + P^.Name := NewStr(Name); { Hold submenu name } + P^.HelpCtx := AHelpCtx; { Set help context } + P^.SubMenu := SubMenu; { Hold next submenu } + End; + NewSubMenu := P; { Return submenu } + End Else NewSubMenu := Next; { Return next item } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STATUS INTERFACE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ NewStatusDef -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewStatusDef (AMin, AMax: Word; AItems: PStatusItem; +ANext:PStatusDef): PStatusDef; +VAR T: PStatusDef; +BEGIN + New(T); { Allocate memory } + If (T <> Nil) Then Begin { Check valid pointer } + T^.Next := ANext; { Set next item } + T^.Min := AMin; { Hold min value } + T^.Max := AMax; { Hold max value } + T^.Items := AItems; { Hold item list } + End; + NewStatusDef := T; { Return status } +END; + +{---------------------------------------------------------------------------} +{ NewStatusKey -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewStatusKey (AText: String; AKeyCode: Word; ACommand: Word; + ANext: PStatusItem): PStatusItem; +VAR T: PStatusItem; +BEGIN + New(T); { Allocate memory } + If (T <> Nil) Then Begin { Check valid pointer } + T^.Text := NewStr(AText); { Hold text string } + T^.KeyCode := AKeyCode; { Hold keycode } + T^.Command := ACommand; { Hold command } + T^.Next := ANext; { Pointer to next } + End; + NewStatusKey := T; { Return status item } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ RegisterMenus -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterMenus; +BEGIN + RegisterType(RMenuBar); { Register bar menu } + RegisterType(RMenuBox); { Register menu box } + RegisterType(RStatusLine); { Register status line } + RegisterType(RMenuPopup); { Register popup menu } +END; + +END. diff --git a/packages/fv/src/msgbox.pas b/packages/fv/src/msgbox.pas new file mode 100644 index 0000000000..e9b867c530 --- /dev/null +++ b/packages/fv/src/msgbox.pas @@ -0,0 +1,321 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of MSGBOX.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail addr } +{ ldeboer@starwon.com.au - backup e-mail addr } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Fix } +{ ------- --------- --------------------------------- } +{ 1.00 12 Jun 96 Initial DOS/DPMI code released. } +{ 1.10 18 Oct 97 Code converted to GUI & TEXT mode. } +{ 1.20 18 Jul 97 Windows conversion added. } +{ 1.30 29 Aug 97 Platform.inc sort added. } +{ 1.40 22 Oct 97 Delphi3 32 bit code added. } +{ 1.50 05 May 98 Virtual pascal 2.0 code added. } +{ 1.60 30 Sep 99 Complete recheck preformed } +{**********************************************************} + +UNIT MsgBox; + +{2.0 compatibility} +{$ifdef VER2_0} + {$macro on} + {$define resourcestring := const} +{$endif} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Near calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES objects, dialogs; { Standard GFV units } + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ MESSAGE BOX CLASSES } +{---------------------------------------------------------------------------} +CONST + mfWarning = $0000; { Display a Warning box } + mfError = $0001; { Dispaly a Error box } + mfInformation = $0002; { Display an Information Box } + mfConfirmation = $0003; { Display a Confirmation Box } + + mfInsertInApp = $0080; { Insert message box into } + { app instead of the Desktop } +{---------------------------------------------------------------------------} +{ MESSAGE BOX BUTTON FLAGS } +{---------------------------------------------------------------------------} +CONST + mfYesButton = $0100; { Yes button into the dialog } + mfNoButton = $0200; { No button into the dialog } + mfOKButton = $0400; { OK button into the dialog } + mfCancelButton = $0800; { Cancel button into the dialog } + + mfYesNoCancel = mfYesButton + mfNoButton + mfCancelButton; + { Yes, No, Cancel dialog } + mfOKCancel = mfOKButton + mfCancelButton; + { Standard OK, Cancel dialog } + +var + MsgBoxTitles: array[0..3] of string[40]; + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +procedure InitMsgBox; +procedure DoneMsgBox; + { Init initializes the message box display system's text strings. Init is + called by TApplication.Init after a successful call to Resource.Init or + Resource.Load. } + +{-MessageBox--------------------------------------------------------- +MessageBox displays the given string in a standard sized dialog box. +Before the dialog is displayed the Msg and Params are passed to FormatStr. +The resulting string is displayed as a TStaticText view in the dialog. +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION MessageBox (Const Msg: String; Params: Pointer; + AOptions: Word): Word; + +{-MessageBoxRect----------------------------------------------------- +MessageBoxRec allows the specification of a TRect for the message box +to occupy. +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION MessageBoxRect (Var R: TRect; Const Msg: String; Params: Pointer; + AOptions: Word): Word; + +{-MessageBoxRectDlg-------------------------------------------------- +MessageBoxRecDlg allows the specification of a TRect for the message box +to occupy plus the dialog window (to allow different dialog window types). +---------------------------------------------------------------------} +FUNCTION MessageBoxRectDlg (Dlg: PDialog; Var R: TRect; Const Msg: String; + Params: Pointer; AOptions: Word): Word; + +{-InputBox----------------------------------------------------------- +InputBox displays a simple dialog that allows user to type in a string +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION InputBox (Const Title, ALabel: String; Var S: String; + Limit: Byte): Word; + +{-InputBoxRect------------------------------------------------------- +InputBoxRect is like InputBox but allows the specification of a rectangle. +30Sep99 LdB +---------------------------------------------------------------------} +FUNCTION InputBoxRect (Var Bounds: TRect; Const Title, ALabel: String; + Var S: String; Limit: Byte): Word; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +USES Drivers, Views, App{, Resource}; { Standard GFV units } + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +const + Commands: array[0..3] of word = + (cmYes, cmNo, cmOK, cmCancel); +var + ButtonName: array[0..3] of string[40]; + +resourcestring sConfirm='Confirm'; + sError='Error'; + sInformation='Information'; + sWarning='Warning'; + + +{---------------------------------------------------------------------------} +{ MessageBox -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MessageBox(Const Msg: String; Params: Pointer; AOptions: Word): Word; +VAR R: TRect; +BEGIN + R.Assign(0, 0, 40, 9); { Assign area } + If (AOptions AND mfInsertInApp = 0) Then { Non app insert } + R.Move((Desktop^.Size.X - R.B.X) DIV 2, + (Desktop^.Size.Y - R.B.Y) DIV 2) Else { Calculate position } + R.Move((Application^.Size.X - R.B.X) DIV 2, + (Application^.Size.Y - R.B.Y) DIV 2); { Calculate position } + MessageBox := MessageBoxRect(R, Msg, Params, + AOptions); { Create message box } +END; + +FUNCTION MessageBoxRectDlg (Dlg: PDialog; Var R: TRect; Const Msg: String; + Params: Pointer; AOptions: Word): Word; +VAR I, X, ButtonCount: Integer; S: String; Control: PView; + ButtonList: Array[0..4] Of PView; +BEGIN + With Dlg^ Do Begin + FormatStr(S, Msg, Params^); { Format the message } + Control := New(PStaticText, Init(R, S)); { Create static text } + Insert(Control); { Insert the text } + X := -2; { Set initial value } + ButtonCount := 0; { Clear button count } + For I := 0 To 3 Do + If (AOptions AND ($0100 SHL I) <> 0) Then Begin + R.Assign(0, 0, 10, 2); { Assign screen area } + Control := New(PButton, Init(R, ButtonName[I], + Commands[i], bfNormal)); { Create button } + Inc(X, Control^.Size.X + 2); { Adjust position } + ButtonList[ButtonCount] := Control; { Add to button list } + Inc(ButtonCount); { Inc button count } + End; + X := (Size.X - X) SHR 1; { Calc x position } + If (ButtonCount > 0) Then + For I := 0 To ButtonCount - 1 Do Begin { For each button } + Control := ButtonList[I]; { Transfer button } + Insert(Control); { Insert button } + Control^.MoveTo(X, Size.Y - 3); { Position button } + Inc(X, Control^.Size.X + 2); { Adjust position } + End; + SelectNext(False); { Select first button } + End; + If (AOptions AND mfInsertInApp = 0) Then + MessageBoxRectDlg := DeskTop^.ExecView(Dlg) Else { Execute dialog } + MessageBoxRectDlg := Application^.ExecView(Dlg); { Execute dialog } +end; + + +{---------------------------------------------------------------------------} +{ MessageBoxRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION MessageBoxRect(Var R: TRect; Const Msg: String; Params: Pointer; + AOptions: Word): Word; +var + Dialog: PDialog; +BEGIN + Dialog := New (PDialog, Init (R, MsgBoxTitles [AOptions + AND $3])); { Create dialog } + with Dialog^ do + R.Assign(3, 2, Size.X - 2, Size.Y - 3); { Assign area for text } + MessageBoxRect := MessageBoxRectDlg (Dialog, R, Msg, Params, AOptions); + Dispose (Dialog, Done); { Dispose of dialog } +END; + +{---------------------------------------------------------------------------} +{ InputBox -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION InputBox(Const Title, ALabel: String; Var S: String; + Limit: Byte): Word; +VAR R: TRect; +BEGIN + R.Assign(0, 0, 60, 8); { Assign screen area } + R.Move((Desktop^.Size.X - R.B.X) DIV 2, + (Desktop^.Size.Y - R.B.Y) DIV 2); { Position area } + InputBox := InputBoxRect(R, Title, ALabel, S, + Limit); { Create input box } +END; + +{---------------------------------------------------------------------------} +{ InputBoxRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION InputBoxRect(Var Bounds: TRect; Const Title, ALabel: String; + Var S: String; Limit: Byte): Word; +VAR C: Word; R: TRect; Control: PView; Dialog: PDialog; +BEGIN + Dialog := New(PDialog, Init(Bounds, Title)); { Create dialog } + With Dialog^ Do Begin + R.Assign(4 + CStrLen(ALabel), 2, Size.X - 3, 3); { Assign screen area } + Control := New(PInputLine, Init(R, Limit)); { Create input line } + Insert(Control); { Insert input line } + R.Assign(2, 2, 3 + CStrLen(ALabel), 3); { Assign screen area } + Insert(New(PLabel, Init(R, ALabel, Control))); { Insert label } + R.Assign(Size.X - 24, Size.Y - 4, Size.X - 14, + Size.Y - 2); { Assign screen area } + Insert(New(PButton, Init(R, 'O~K~', cmOk, + bfDefault))); { Insert okay button } + Inc(R.A.X, 12); { New start x position } + Inc(R.B.X, 12); { New end x position } + Insert(New(PButton, Init(R, 'Cancel', cmCancel, + bfNormal))); { Insert cancel button } + Inc(R.A.X, 12); { New start x position } + Inc(R.B.X, 12); { New end x position } + SelectNext(False); { Select first button } + End; + Dialog^.SetData(S); { Set data in dialog } + C := DeskTop^.ExecView(Dialog); { Execute the dialog } + If (C <> cmCancel) Then Dialog^.GetData(S); { Get data from dialog } + Dispose(Dialog, Done); { Dispose of dialog } + InputBoxRect := C; { Return execute result } +END; + + +procedure InitMsgBox; +begin + ButtonName[0] := slYes; + ButtonName[1] := slNo; + ButtonName[2] := slOk; + ButtonName[3] := slCancel; + MsgBoxTitles[0] := sWarning; + MsgBoxTitles[1] := sError; + MsgBoxTitles[2] := sInformation; + MsgBoxTitles[3] := sConfirm; +end; + +procedure DoneMsgBox; +begin +end; + +END. diff --git a/packages/fv/src/outline.pas b/packages/fv/src/outline.pas new file mode 100644 index 0000000000..38a9803f4f --- /dev/null +++ b/packages/fv/src/outline.pas @@ -0,0 +1,685 @@ +unit outline; + +{$CODEPAGE cp437} + +{***************************************************************************} + interface +{***************************************************************************} + +uses drivers,objects,views; + +type Pnode=^Tnode; + Tnode=record + next:Pnode; + text:Pstring; + childlist:Pnode; + expanded:boolean; + end; + + Poutlineviewer=^Toutlineviewer; + Toutlineviewer=object(Tscroller) + foc:sw_integer; + constructor init(var bounds:Trect; + AHscrollbar,AVscrollbar:Pscrollbar); + procedure adjust(node:pointer;expand:boolean);virtual; + function creategraph(level:integer;lines:longint; + flags:word;levwidth,endwidth:integer; + const chars:string):string; + procedure draw;virtual; + procedure expandall(node:pointer); + function firstthat(test:pointer):pointer; + procedure focused(i:sw_integer);virtual; + procedure foreach(action:pointer); + function getchild(node:pointer;i:sw_integer):pointer;virtual; + function getgraph(level:integer;lines:longint;flags:word):string; + function getnode(i:sw_integer):pointer;virtual; + function getnumchildren(node:pointer):sw_integer;virtual; + function getpalette:Ppalette;virtual; + function getroot:pointer;virtual; + function gettext(node:pointer):string;virtual; + procedure handleevent(var event:Tevent);virtual; + function haschildren(node:pointer):boolean;virtual; + function isexpanded(node:pointer):boolean;virtual; + function isselected(i:sw_integer):boolean;virtual; + procedure selected(i:sw_integer);virtual; + procedure setstate(Astate:word;enable:boolean);virtual; + procedure update; + private + procedure set_focus(Afocus:sw_integer); + function do_recurse(action,callerframe:pointer; + stop_if_found:boolean):pointer; + end; + + Poutline=^Toutline; + Toutline=object(Toutlineviewer) + root:Pnode; + constructor init(var bounds:Trect; + AHscrollbar,AVscrollbar:Pscrollbar; + Aroot:Pnode); + procedure adjust(node:pointer;expand:boolean);virtual; + function getchild(node:pointer;i:sw_integer):pointer;virtual; + function getnumchildren(node:pointer):sw_integer;virtual; + function getroot:pointer;virtual; + function gettext(node:pointer):string;virtual; + function haschildren(node:pointer):boolean;virtual; + function isexpanded(node:pointer):boolean;virtual; + destructor done;virtual; + end; + +const ovExpanded = $1; + ovChildren = $2; + ovLast = $4; + + Coutlineviewer=Cscroller+#8#8; + +function newnode(const Atext:string;Achildren,Anext:Pnode):Pnode; +procedure disposenode(node:Pnode); + + +{***************************************************************************} + implementation +{***************************************************************************} + +type TMyFunc = function(_EBP: Pointer; Cur: Pointer; + Level, Position: sw_integer; Lines: LongInt; + Flags: Word): Boolean; + + +function newnode(const Atext:string;Achildren,Anext:Pnode):Pnode; + +begin + newnode:=new(Pnode); + with newnode^ do + begin + next:=Anext; + text:=newstr(Atext); + childlist:=Achildren; + expanded:=true; + end; +end; + +procedure disposenode(node:Pnode); + +var next:Pnode; + +begin + while node<>nil do + begin + disposenode(node^.childlist); + disposestr(node^.text); + next:=node^.next; + dispose(node); + node:=next; + end; +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ Toutlineviewer object methods } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +constructor Toutlineviewer.init(var bounds:Trect; + AHscrollbar,AVscrollbar:Pscrollbar); + +begin + inherited init(bounds,AHscrollbar,AVscrollbar); + foc:=0; + growmode:=gfGrowHiX+gfGrowHiY; +end; + +procedure Toutlineviewer.adjust(node:pointer;expand:boolean); + +begin + abstract; +end; + +function TOutlineViewer.CreateGraph(Level: Integer; Lines: LongInt; + Flags: Word; LevWidth, EndWidth: Integer; + const Chars: String): String; +const + FillerOrBar = 0; + YorL = 2; + StraightOrTee= 4; + Retracted = 6; +var + Last, Children, Expanded: Boolean; + I , J : Byte; + Graph : String; + +begin + { Load registers } + graph:=space(Level*LevWidth+EndWidth+1); + + { Write bar characters } + J := 1; + while (Level > 0) do + begin + Inc(J); + if (Lines and 1) <> 0 then + Graph[J] := Chars[FillerOrBar+2] + else + Graph[J] := Chars[FillerOrBar+1]; + for I := 1 to LevWidth - 1 do + Graph[I]:= Chars[FillerOrBar+1]; + J := J + LevWidth - 1; + Dec(Level); + Lines := Lines shr 1; + end; + + { Write end characters } + Dec(EndWidth); + if EndWidth > 0 then + begin + Inc(J); + if Flags and ovLast <> 0 then + Graph[J] := Chars[YorL+2] + else + Graph[J] := Chars[YorL+1]; + Dec(EndWidth); + if EndWidth > 0 then + begin + Dec(EndWidth); + for I := 1 to EndWidth do + Graph[I]:= Chars[StraightOrTee+1]; + J := J + EndWidth; + Inc(J); + if (Flags and ovChildren) <> 0 then + Graph[J] := Chars[StraightOrTee+2] + else + Graph[J] := Chars[StraightOrTee+1]; + end; + Inc(J); + if Flags and ovExpanded <> 0 then + Graph[J] := Chars[Retracted+2] + else + Graph[J] := Chars[Retracted+1]; + end; + Graph[0] := Char(J); + + CreateGraph := Graph; +end; + +function Toutlineviewer.do_recurse(action,callerframe:pointer; + stop_if_found:boolean):pointer; + +var position:sw_integer; + r:pointer; + + function recurse(cur:pointer;level:integer;lines:longint;lastchild:boolean):pointer; + + var i,childcount:sw_integer; + child:pointer; + flags:word; + children,expanded,found:boolean; + + begin + inc(position); + recurse:=nil; + + children:=haschildren(cur); + expanded:=isexpanded(cur); + + {Determine flags.} + flags:=0; + if not children or expanded then + inc(flags,ovExpanded); + if children and expanded then + inc(flags,ovChildren); + if lastchild then + inc(flags,ovLast); + + {Call the function.} + found:=TMyFunc(action)(callerframe,cur,level,position,lines,flags); + + if stop_if_found and found then + recurse:=cur + else if children and expanded then {Recurse children?} + begin + if not lastchild then + lines:=lines or (1 shl level); + {Iterate all childs.} + childcount:=getnumchildren(cur); + for i:=0 to childcount-1 do + begin + child:=getchild(cur,i); + if (child<>nil) and (level<31) then + recurse:=recurse(child,level+1,lines,i=childcount-1); + {Did we find a node?} + if recurse<>nil then + break; + end; + end; + end; + +begin + position:=-1; + r:=getroot; + if r<>nil then + do_recurse:=recurse(r,0,0,true) + else + do_recurse:=nil; +end; + +procedure Toutlineviewer.draw; + +var c_normal,c_normal_x,c_select,c_focus:byte; + maxpos:sw_integer; + b:Tdrawbuffer; + + function draw_item(cur:pointer;level,position:sw_integer; + lines:longint;flags:word):boolean; + + var c,i:byte; + s,t:string; + + begin + draw_item:=position>=delta.y+size.y; + if (position<delta.y) or draw_item then + exit; + + maxpos:=position; + s:=getgraph(level,lines,flags); + t:=gettext(cur); + + {Determine text colour.} + if (foc=position) and (state and sffocused<>0) then + c:=c_focus + else if isselected(position) then + c:=c_select + else if flags and ovexpanded<>0 then + c:=c_normal_x + else + c:=c_normal; + + {Fill drawbuffer with graph and text to draw.} + for i:=0 to size.x-1 do + begin + wordrec(b[i]).hi:=c; + if i+delta.x<length(s) then + wordrec(b[i]).lo:=byte(s[1+i+delta.x]) + else if 1+i+delta.x-length(s)<=length(t) then + wordrec(b[i]).lo:=byte(t[1+i+delta.x-length(s)]) + else + wordrec(b[i]).lo:=byte(' '); + end; + + {Draw!} + writeline(0,position-delta.y,size.x,1,b); + end; + +begin + c_normal:=getcolor(4); + c_normal_x:=getcolor(1); + c_focus:=getcolor(2); + c_select:=getcolor(3); + maxpos:=-1; + foreach(@draw_item); + movechar(b,' ',c_normal,size.x); + writeline(0,maxpos+1,size.x,size.y-(maxpos-delta.y),b); +end; + +procedure Toutlineviewer.expandall(node:pointer); + +var i:sw_integer; + +begin + if haschildren(node) then + begin + for i:=0 to getnumchildren(node)-1 do + expandall(getchild(node,i)); + adjust(node,true); + end; +end; + +function Toutlineviewer.firstthat(test:pointer):pointer; + +begin + firstthat:=do_recurse(test,get_caller_frame(get_frame),true); +end; + +procedure Toutlineviewer.focused(i:sw_integer); + +begin + foc:=i; +end; + +procedure Toutlineviewer.foreach(action:pointer); + +begin + do_recurse(action,get_caller_frame(get_frame),false); +end; + +function Toutlineviewer.getchild(node:pointer;i:sw_integer):pointer; + +begin + abstract; +end; + +function Toutlineviewer.getgraph(level:integer;lines:longint; + flags:word):string; + +begin + getgraph:=creategraph(level,lines,flags,3,3,' ³ÃÀÄÄ+Ä'); +end; + +function Toutlineviewer.getnode(i:sw_integer):pointer; + + function test_position(node:pointer;level,position:sw_integer;lines:longInt; + flags:word):boolean; + + begin + test_position:=position=i; + end; + +begin + getnode:=firstthat(@test_position); +end; + +function Toutlineviewer.getnumchildren(node:pointer):sw_integer; + +begin + abstract; +end; + +function Toutlineviewer.getpalette:Ppalette; + +const p:string[length(Coutlineviewer)]=Coutlineviewer; + +begin + getpalette:=@p; +end; + +function Toutlineviewer.getroot:pointer; + +begin + abstract; +end; + +function Toutlineviewer.gettext(node:pointer):string; + +begin + abstract; +end; + +procedure Toutlineviewer.handleevent(var event:Tevent); + +var mouse:Tpoint; + cur:pointer; + new_focus:sw_integer; + count:byte; + handled,m,mouse_drag:boolean; + graph:string; + + function graph_of_focus(var graph:string):pointer; + + var _level:sw_integer; + _lines:longInt; + _flags:word; + + function find_focused(cur:pointer;level,position:sw_integer; + lines:longint;flags:word):boolean; + + begin + find_focused:=position=foc; + if find_focused then + begin + _level:=level; + _lines:=lines; + _flags:=flags; + end; + end; + + begin + graph_of_focus:=firstthat(@find_focused); + graph:=getgraph(_level,_lines,_flags); + end; + +const skip_mouse_events=3; + +begin + inherited handleevent(event); + case event.what of + evKeyboard: + begin + new_focus:=foc; + handled:=true; + case ctrltoarrow(event.keycode) of + kbUp,kbLeft: + dec(new_focus); + kbDown,kbRight: + inc(new_focus); + kbPgDn: + inc(new_focus,size.y-1); + kbPgUp: + dec(new_focus,size.y-1); + kbCtrlPgUp: + new_focus:=0; + kbCtrlPgDn: + new_focus:=limit.y-1; + kbHome: + new_focus:=delta.y; + kbEnd: + new_focus:=delta.y+size.y-1; + kbCtrlEnter,kbEnter: + selected(new_focus); + else + case event.charcode of + '-','+': + begin + adjust(getnode(new_focus),event.charcode='+'); + update; + end; + '*': + begin + expandall(getnode(new_focus)); + update; + end; + else + handled:=false; + end; + end; + if new_focus<0 then + new_focus:=0; + if new_focus>=limit.y then + new_focus:=limit.y-1; + if foc<>new_focus then + set_focus(new_focus); + if handled then + clearevent(event); + end; + evMouseDown: + begin + count:=1; + mouse_drag:=false; + repeat + makelocal(event.where,mouse); + if mouseinview(event.where) then + new_focus:=delta.y+mouse.y + else + begin + inc(count,byte(event.what=evMouseAuto)); + if count and skip_mouse_events=0 then + begin + if mouse.y<0 then + dec(new_focus); + if mouse.y>=size.y then + inc(new_focus); + end; + end; + if new_focus<0 then + new_focus:=0; + if new_focus>=limit.y then + new_focus:=limit.y-1; + if foc<>new_focus then + set_focus(new_focus); + m:=mouseevent(event,evMouseMove+evMouseAuto); + if m then + mouse_drag:=true; + until not m; + if event.double then + selected(foc) + else if not mouse_drag then + begin + cur:=graph_of_focus(graph); + if mouse.x<length(graph) then + begin + adjust(cur,not isexpanded(cur)); + update; + end; + end; + end; + end; +end; + + +function Toutlineviewer.haschildren(node:pointer):boolean; + +begin + abstract; +end; + +function Toutlineviewer.isexpanded(node:pointer):boolean; + +begin + abstract; +end; + +function Toutlineviewer.isselected(i:sw_integer):boolean; + +begin + isselected:=foc=i; +end; + +procedure Toutlineviewer.selected(i:sw_integer); + +begin + {Does nothing by default.} +end; + +procedure Toutlineviewer.set_focus(Afocus:sw_integer); + +begin + assert((Afocus>=0) and (Afocus<limit.y)); + focused(Afocus); + if Afocus<delta.y then + scrollto(delta.x,Afocus) + else if Afocus-size.y>=delta.y then + scrollto(delta.x,Afocus-size.y+1); + drawview; +end; + +procedure Toutlineviewer.setstate(Astate:word;enable:boolean); + +begin + if Astate and sffocused<>0 then + drawview; + inherited setstate(Astate,enable); +end; + +procedure Toutlineviewer.update; + +var count:sw_integer; + maxwidth:byte; + + procedure check_item(cur:pointer;level,position:sw_integer; + lines:longint;flags:word); + + var width:word; + + begin + inc(count); + width:=length(gettext(cur))+length(getgraph(level,lines,flags)); + if width>maxwidth then + maxwidth:=width; + end; + +begin + count:=0; + maxwidth:=0; + foreach(@check_item); + setlimit(maxwidth,count); + set_focus(foc); +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ Toutline object methods } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +constructor Toutline.init(var bounds:Trect; + AHscrollbar,AVscrollbar:Pscrollbar; + Aroot:Pnode); + +begin + inherited init(bounds,AHscrollbar,AVscrollbar); + root:=Aroot; + update; +end; + +procedure Toutline.adjust(node:pointer;expand:boolean); + +begin + assert(node<>nil); + Pnode(node)^.expanded:=expand; +end; + +function Toutline.getnumchildren(node:pointer):sw_integer; + +var p:Pnode; + +begin + assert(node<>nil); + p:=Pnode(node)^.childlist; + getnumchildren:=0; + while p<>nil do + begin + inc(getnumchildren); + p:=p^.next; + end; +end; + +function Toutline.getchild(node:pointer;i:sw_integer):pointer; + +begin + assert(node<>nil); + getchild:=Pnode(node)^.childlist; + while i<>0 do + begin + dec(i); + getchild:=Pnode(getchild)^.next; + end; +end; + +function Toutline.getroot:pointer; + +begin + getroot:=root; +end; + +function Toutline.gettext(node:pointer):string; + +begin + assert(node<>nil); + gettext:=Pnode(node)^.text^; +end; + +function Toutline.haschildren(node:pointer):boolean; + +begin + assert(node<>nil); + haschildren:=Pnode(node)^.childlist<>nil; +end; + +function Toutline.isexpanded(node:pointer):boolean; + +begin + assert(node<>nil); + isexpanded:=Pnode(node)^.expanded; +end; + +destructor Toutline.done; + +begin + disposenode(root); + inherited done; +end; + +end. diff --git a/packages/fv/src/platform.inc b/packages/fv/src/platform.inc new file mode 100644 index 0000000000..4e35ffa59d --- /dev/null +++ b/packages/fv/src/platform.inc @@ -0,0 +1,415 @@ +{***************[ PLATFORM INCLUDE UNIT ]******************} +{ } +{ System independent INCLUDE file to sort PLATFORMS } +{ } +{ Parts Copyright (c) 1997 by Balazs Scheidler } +{ bazsi@tas.vein.hu } +{ } +{ Parts Copyright (c) 1999, 2000 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@projectent.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ - C'T patch to BP (16 Bit) } +{ LINUX - FPC 0.9912+ (32 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Who Fix } +{ ------- -------- --- ---------------------------- } +{ 0.1 02 Jul 97 Bazsi Initial implementation } +{ 0.2 28 Aug 97 LdB Fixed OS2 platform sort } +{ 0.3 29 Aug 97 LdB Added assembler type changes } +{ 0.4 29 Aug 97 LdB OS_DOS removed from WINDOWS } +{ 0.5 23 Oct 97 LdB Delphi & speed compilers } +{ 0.6 05 May 98 LdB Virtual Pascal 2.0 added } +{ 0.7 19 May 98 LdB Delphi 2/3 definitions added } +{ 0.8 06 Aug 98 CEC FPC only support fixed WIN32 } +{ 0.9 10 Aug 98 LdB BP_VMTLink def/Undef added } +{ 1.0 27 Aug 98 LdB Atari, Mac etc not undef dos } +{ 1.1 25 Oct 98 PfV Delphi 4 definitions added } +{ 1.2 06 Jun 99 LdB Sybil 2.0 support added } +{ 1.3 13 Jun 99 LdB Sybil 2.0 undef BP_VMT link } +{ 1.31 03 Nov 99 LdB FPC windows defines WIN32 } +{ 1.32 04 Nov 99 LdB Delphi 5 definitions added } +{ 1.33 16 Oct 00 LdB WIN32/WIN16 defines added } +{ 1.34 02 May 02 MvdV FreeBSD, NetBSD, OS_UNIX } +{**********************************************************} + +{ **************************************************************************** + + 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 + + **************************************************************************** + + 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 + + DPMI OS_DOS BP/TP7 PPC_BP PROC_Protected BIT_16 ASM_BP + FPC PPC_FPC PROC_Protected BIT_32 ASM_FPC + + LINUX OS_LINUX FPC PPC_FPC PROC_Protected BIT_32 ASM_FPC + OS_UNIX + + FREEBSD OS_FREEBSD FPC PPC_FPC PROC_Protected BIT_32 ASM_FPC + OS_UNIX + + NETBSD OS_NETBSD FPC PPC_FPC PROC_Protected BIT_32 ASM_FPC + OS_UNIX + + WINDOWS OS_WINDOWS BP/TP7 PPC_BP PROC_Protected BIT_16 ASM_BP + DELPHI PPC_DELPHI PROC_Protected BIT_16 ASM_BP + DELPHI2 PPC_DELPHI2 PROC_Protected BIT_16 ASM_BP + + WIN95/NT OS_WINDOWS DELPHI2 PPC_DELPHI2 PROC_Protected BIT_32 ASM_BP + DELPHI3 PPC_DELPHI3 PROC_Protected BIT_32 ASM_BP + DELPHI4 PPC_DELPHI3 PROC_Protected BIT_32 ASM_BP + DELPHI5 PPC_DELPHI3 PROC_Protected BIT_32 ASM_BP + VIRTUAL PPC_VIRTUAL PROC_Protected BIT 32 ASM_BP + SYBIL2 PPC_SPEED PROC_Protected BIT_32 ASM_BP + FPC PPC_FPC PROC_Protected BIT_32 ASM_FPC + + 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 + SYBIL2 PPC_SPEED PROC_Protected BIT_32 ASM_BP + FPC PPC_FPC PROC_Protected BIT_32 ASM_FPC + ****************************************************************************} +{**************************************************************************** + +FOR ALL COMPILERS BP_VMTLink defined but FPC and Delphi3/Delphi4 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,OS_UNIX FPC 32-bit AT&T ---- + FREEBSD OS_NETBSD,OS_UNIX FPC 32-bit AT&T ---- + NETBSD OS_FREEBSD,OS_UNIX 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} +{$DEFINE CPU86} + +{---------------------------------------------------------------------------} +{ FPC 32 BIT COMPILER changes ASM, 32 bits etc - Updated 27Aug98 LdB } +{---------------------------------------------------------------------------} +{$IFDEF FPC} + {$mode 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} + {$DEFINE Use_API} + {$DEFINE NO_WINDOW} +{$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} + {$DEFINE OS_UNIX} +{$ENDIF} + +{$IFDEF FreeBSD} + {$UNDEF OS_DOS} + {$DEFINE OS_FREEBSD} + {$DEFINE OS_UNIX} +{$ENDIF} + +{$IFDEF NETBSD} + {$UNDEF OS_DOS} + {$DEFINE OS_NETBSD} + {$DEFINE OS_UNIX} +{$ENDIF} + + +{$IFDEF Darwin} + {$UNDEF OS_DOS} + {$DEFINE OS_DARWIN} + {$DEFINE OS_UNIX} +{$ENDIF} + + +{$IFDEF SOLARIS} + {$UNDEF OS_DOS} + {$DEFINE OS_SOLARIS} + {$DEFINE OS_UNIX} +{$ENDIF} + +{$IFDEF BEOS} + {$UNDEF OS_DOS} + {$DEFINE OS_BEOS} + {$DEFINE OS_UNIX} +{$ENDIF} + +{------------------------------------------------} +{ FPC Netware COMPILER changes operating system } +{------------------------------------------------} +{$IFDEF Netware} + {$UNDEF OS_DOS} + {$DEFINE OS_NETWARE} + {$IFDEF NETWARE_LIBC} + {$DEFINE OS_NETWARE_LIBC} + {$ELSE} + {$DEFINE OS_NETWARE_CLIB} + {$ENDIF} + {$DEFINE HasSysMsgUnit} +{$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 03Nov99 LdB } +{---------------------------------------------------------------------------} +{$IFDEF WINDOWS} + {$UNDEF OS_DOS} + {$DEFINE OS_WINDOWS} + {$UNDEF PROC_Real} + {$DEFINE PROC_Protected} + {$IFDEF FPC} + {$DEFINE WIN32} + {$ENDIF} +{$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} + +{---------------------------------------------------------------------------} +{ DELPHI5 COMPILER changes compiler type - Updated 04Nov99 pfv } +{---------------------------------------------------------------------------} +{$IFDEF VER130} + {$UNDEF PPC_BP} + {$DEFINE PPC_DELPHI} + {$DEFINE PPC_DELPHI3} + {$DEFINE PPC_DELPHI4} + {$DEFINE PPC_DELPHI5} + {$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} + {$UNDEF BP_VMTLink} +{$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} + +{$IFDEF OS_DOS} + {$DEFINE NO_WINDOW} +{$ENDIF} + +{---------------------------------------------------------------------------} +{ WIN16 AND WIN32 set if in windows - Updated 16Oct2000 LdB } +{---------------------------------------------------------------------------} +{$IFDEF OS_WINDOWS} { WINDOWS SYSTEM } + {$IFDEF BIT_16} + {$DEFINE WIN16} { 16 BIT WINDOWS } + {$ENDIF} + {$IFDEF BIT_32} + {$DEFINE WIN32} { 32 BIT WINDOWS } + {$ENDIF} +{$ENDIF} + + + diff --git a/packages/fv/src/resource.pas b/packages/fv/src/resource.pas new file mode 100644 index 0000000000..fe2a6cbc88 --- /dev/null +++ b/packages/fv/src/resource.pas @@ -0,0 +1,741 @@ + +asjgfsdkjsfld +{ Resource Unit + + Programmer: Brad Williams + BitSoft Development, L.L.C. + Copyright (c) 1996 + Version 1.1 + +Revision History + +1.1 (12/26/97) + - updated to add cdResource directive so that can use standard TStringList + resources created by TVRW and TVDT + +1.0 + - original implementation } + +unit Resource; + +interface + +{ + The Resource unit provides global variables which are used to build and + access resource files. InitRez must always be called before accessing any + variables in the Resource unit. The programmer should also always call + Done to free all file handles allocated to the program. +} + +{$i platform.inc} + +{$ifdef PPC_FPC} + {$H-} +{$else} + {$F+,O+,E+,N+} +{$endif} +{$X+,R-,I-,Q-,V-} +{$ifndef OS_UNIX} + {$S-} +{$endif} + +uses + + FVConsts, Objects, Dos; + +const + + RezExt: ExtStr = '.RES'; + { The file extension used on all resource files. } + RezBufferSize: Word = 4096; + { RezBufferSize is the number of bytes to use for the resource file's + stream's buffer. RezBufferSize is passed to TBufStream.Init. } + + { reXXXX constants are used with resource files to retrieve the standard + Free Vision dialogs. The constant is followed by the Unit in which it + is used and the resource which is stored separated by a period. } + + reChDirDialog = 'ChDirDialog'; { StdDlg.TChDirDialog } + reEditChDirDialog = 'EditChDirDialog'; { StdDlg.TEditChDirDialog } + reFindTextDlg = 'FindTextDlg'; { Editors.CreateFindDialog } + reHints = 'Hints'; { Resource.Hints } + reJumpLineDlg = 'JumpLineDlg'; { Editors.MakeJumpLineDlg } + reLabels = 'Labels'; { Resource.Labels } + reMenuBar = 'MenuBar'; { App.MenuBar } + reOpenDlg = 'OpenDlg'; { StdDlg.TFileDialog - Open } + reReformDocDlg = 'ReformDocDlg'; { Editors.MakeReformDocDlg } + reReplaceDlg = 'ReplaceDlg'; { Editors.CreateReplaceDialog } + reRightMarginDlg = 'RightMarginDlg'; { Editors.MakeRightMarginDlg } + reStatusLine = 'StatusLine'; { App.StatusLine } + reStrings = 'Strings'; { Resource.Strings } + reSaveAsDlg = 'SaveAsDlg'; { StdDlg.TFileDialog - Save As } + reTabStopDlg = 'TabStopDlg'; { Editors.MakeTabStopDlg } + reWindowListDlg = 'WindowListDlg'; { Editors.MakeWindowListDlg } + reAboutDlg = 'About'; { App unit about dialog } + + {$I str.inc} + { STR.INC declares all the string list constants used in the standard + Free Vision library units. They are placed in a separate file as a + template for use by the resource file generator, MakeRez. + + Applications which use resource files and need to add strings of their + own should use STR.INC as the start for the resource file. + + See MakeRez.PAS for more information about generating resource files.} + +type + + + PConstant = ^TConstant; + TConstant = object(TObject) + Value: Word; + { The value assigned to the constant. } + constructor Init (AValue: Word; AText: string); + { Init assigns AValue to Value to AText to Text. AText may be an empty + string. + + If an error occurs Init fails. } + destructor Done; virtual; + { Done disposes of Text then calls the inherited destructor. } + procedure SetText (AText: string); + { SetText changes FText to the word equivalent of AText. } + procedure SetValue (AValue: string); + { SetValue changes Value to the word equivalent of AValue. } + function Text: string; + { Text returns a string equivalent to FText. If FText is nil, an + empty string is returned. } + function ValueAsString: string; + { ValueAsString returns the string equivalent of Value. } + private + FText: PString; + { The text to display for the constant. } + end; { of TConstant } + + + PMemStringList = ^TMemStringList; + TMemStringList = object(TSortedCollection) + { A TMemStringList combines the functions of a TStrListMaker and a + TStringList into one object, allowing generation and use of string + lists in the same application. TMemStringList is fully compatible + with string lists created using TStrListMaker, so legacy applications + will work without problems. + + When using a string list in the same program as it is created, a + resource file is not required. This allows language independant coding + of units without the need for conditional defines and recompiling. } + constructor Init; + { Creates an empty, in-memory string list that is not associated with a + resource file. } + constructor Load (var S: TStream); + { Load creates a TStringList from which it gets its strings upon a call + to Get. The strings on the resource file may be loaded into memory + for editing by calling LoadList. + + If initialized with Load, the stream must remain valid for the life + of this object. } + destructor Done; virtual; + { Done deallocates the memory allocated to the string list. } + function Compare (Key1, Key2: Pointer): Sw_Integer; virtual; + { Compare assumes Key1 and Key2 are Word values and returns: + + -1 if Key1 < Key2 + 0 if Key1 = Key2 + 1 if Key1 > Key2 } + function Get (Key: Word): String; virtual; + { GetKey searches for a string with a key matching Key and returns it. + An empty string is returned if a string with a matching Key is not + found. + + If Count > 0, the in memory collection is searched. If List^.Count + is 0, the inherited Get method is called. } + procedure Insert (Item: Pointer); virtual; + { If Item is not nil, Insert attempts to insert the item into the + collection. If a collection expansion error occurs Insert disposes + of Item by calling FreeItem. + + Item must be a pointer to a TConstant or its descendant. } + function KeyOf (Item: Pointer): Pointer; virtual; + { KeyOf returns a pointer to TConstant.Value. } + function LoadStrings: Sw_Integer; + { LoadStrings reads all strings the associated resource file into + memory, places them in the collection, and returns 0. + + If an error occurs LoadStrings returns the stream status error code + or a DOS error code. Possible DOS error codes include: + + 2: no associated resource file + 8: out of memory } + function NewConstant (Value: Word; S: string): PConstant; virtual; + { NewConstant is called by LoadStrings. } + procedure Put (Key: Word; S: String); virtual; + { Put creates a new PConstant containing Key and Word then calls + Insert to place it in the collection. } + procedure Store (var S: TStream); + { Store creates a TStrListMaker, fills it with the items in List, + writes the TStrListMaker to the stream by calling + TStrListMaker.Store, then disposes of the TStrListMaker. } + private + StringList: PStringList; + end; { of TMemStringList) } + + +var + + {$ifdef cdResource} + Hints: PStringList; + {$else} + Hints: PMemStringList; + {$endif cdResource} + { Hints is a string list for use within the application to provide + context sensitive help on the command line. Hints is always used in + the application. } + + {$ifdef cdResource} + Strings: PStringList; + {$else} + Strings: PMemStringList; + {$endif cdResource} + { Strings holds messages such as errors and general information that are + displayed at run-time, normally with MessageBox. Strings is always + used in the application. } + + {$ifdef cdResource} + Labels: PStringList; + {$else} + Labels: PMemStringList; + {$endif cdResource} + { Labels is a string list for use within the application when a + resource file is not used, or when creating a resource file. Labels + contains all text used in dialog titles, labels, buttons, menus, + statuslines, etc., used in the application which can be burned into + language specific resources. It does not contain any messages + displayed at run-time using MessageBox or the status line hints. + + Using the Labels variable when creating views allows language + independant coding of views such as the MessageBox, StdDlg and Editors + units. } + + RezFile: PResourceFile; + { RezFile is a global variable used when the Free Vision library + is compiled using the cdResource conditional define, or when creating + resource files. + + All standard Free Vision application resources are accessed from the + resource file using the reXXXX constants. Modify the STR.INC under a + new file name to create new language specific resource files. See the + MakeRez program file for more information. } + + + +procedure DoneResource; + { Done destructs all objects initialized in this unit and frees all + allocated heap. } + +{$ifndef cdResource} +function InitResource: Boolean; +{$endif cdResource} + { Init initializes the Hints and Strings for use with in memory strings + lists. Init should be used in applications which do not use a resource + file, or when creating resource files. } + +{$ifdef cdResource} +function InitRezFile (AFile: FNameStr; Mode: Word; + var AResFile: PResourceFile): Sw_Integer; +{$endif cdResource} + { InitRezFile initializes a new PResourceFile using the name passed in + AFile and the stream mode passed in Mode and returns 0. + + If an error occurs InitRezFile returns the DOS error and AResFile is + invalid. Possible DOS error values include: + + 2: file not found or other stream initialization error + 11: invalid format - not a valid resource file } + +{$ifdef cdResource} +function LoadResource (AFile: FNameStr): Boolean; +{$endif cdResource} + { Load is used to open a resource file for use in the application. + + For Load to return True, the resource file must be properly opened and + assigned to RezFile and the Hints string list must be successfully loaded + from the stream. If an error occurs, Load displays an English error + message using PrintStr and returns False. } + +function MergeLists (Source, Dest: PMemStringList): Sw_Integer; + { MergeLists moves all key/string pairs from Source to destination, + deleting them from Source. Duplicate strings are ignored. } + + +const + RMemStringList: TStreamRec = ( + ObjType: idMemStringList; + VmtLink: Ofs(TypeOf(TMemStringList)^); + Load: @TMemStringList.Load; + Store: @TMemStringList.Store); + + +implementation + +{****************************************************************************} +{ Private Declarations } +{****************************************************************************} + +uses + {Memory, }Drivers; + +{****************************************************************************} +{ TConstant object } +{****************************************************************************} +{****************************************************************************} +{ TConstant.Init } +{****************************************************************************} +constructor TConstant.Init (AValue: Word; AText: string); +begin + if not inherited Init then + Fail; + Value := AValue; + FText := NewStr(AText); + if (FText = nil) and (AText <> '') then + begin + inherited Done; + Fail; + end; +end; + +{****************************************************************************} +{ TConstant.Done } +{****************************************************************************} +destructor TConstant.Done; +begin + DisposeStr(FText); + inherited Done; +end; + +{****************************************************************************} +{ TConstant.SetText } +{****************************************************************************} +procedure TConstant.SetText (AText: string); +begin + DisposeStr(FText); + FText := NewStr(AText); +end; + +{****************************************************************************} +{ TConstant.SetValue } +{****************************************************************************} +procedure TConstant.SetValue (AValue: string); +var + N: Word; + ErrorCode: Integer; +begin + Val(AValue,N,ErrorCode); + if ErrorCode = 0 then + Value := N; +end; + +{****************************************************************************} +{ TConstant.Text } +{****************************************************************************} +function TConstant.Text: string; +begin + if (FText = nil) then + Text := '' + else Text := FText^; +end; + +{****************************************************************************} +{ TConstant.ValueAsString } +{****************************************************************************} +function TConstant.ValueAsString: string; +var + S: string[5]; +begin + Str(Value,S); + ValueAsString := S; +end; + +{****************************************************************************} +{ TMemStringList Object } +{****************************************************************************} +{****************************************************************************} +{ TMemStringList.Init } +{****************************************************************************} +constructor TMemStringList.Init; +begin + if not inherited Init(10,10) then + Fail; + StringList := nil; +end; + +{****************************************************************************} +{ TMemStringList.Load } +{****************************************************************************} +constructor TMemStringList.Load (var S: TStream); +begin + if not inherited Init(10,10) then + Fail; + StringList := New(PStringList,Load(S)); +end; + +{****************************************************************************} +{ TMemStringList.Done } +{****************************************************************************} +destructor TMemStringList.Done; +begin + if (StringList <> nil) then + Dispose(StringList,Done); + inherited Done; +end; + +{****************************************************************************} +{ TMemStringList.Compare } +{****************************************************************************} +function TMemStringList.Compare (Key1, Key2: Pointer): Sw_Integer; +begin + if Word(Key1^) < Word(Key2^) then + Compare := -1 + else Compare := Byte(Word(Key1^) > Word(Key2^)); +end; + +{****************************************************************************} +{ TMemStringList.Get } +{****************************************************************************} +function TMemStringList.Get (Key: Word): string; +var + i: Sw_Integer; + S: string; +begin + if (StringList = nil) then + begin { started with Init, use in memory string list } + if Search(@Key,i) then + Get := PConstant(At(i))^.Text + else Get := ''; + end + else begin + S := StringList^.Get(Key); + Get := S; + end; +end; + +{****************************************************************************} +{ TMemStringList.Insert } +{****************************************************************************} +procedure TMemStringList.Insert (Item: Pointer); +var + i: Sw_Integer; +begin + if (Item <> nil) then + begin + i := Count; + inherited Insert(Item); + if (i = Count) then { collection expansion failed } + Dispose(PConstant(Item),Done); + end; +end; + +{****************************************************************************} +{ TMemStringList.KeyOf } +{****************************************************************************} +function TMemStringList.KeyOf (Item: Pointer): Pointer; +begin + KeyOf := @(PConstant(Item)^.Value); +end; + +{****************************************************************************} +{ TMemStringList.LoadStrings } +{****************************************************************************} +function TMemStringList.LoadStrings: Sw_Integer; + procedure MakeEditableString (var Str: string); + const + SpecialChars: array[1..3] of Char = #3#10#13; + var + i, j: Byte; + begin + for i := 1 to 3 do + while (Pos(SpecialChars[i],Str) <> 0) do + begin + j := Pos(SpecialChars[i],Str); + System.Delete(Str,j,1); + case i of + 1: System.Insert('#3',Str,j); + 2: System.Insert('#10',Str,j); + 3: System.Insert('#13',Str,j); + end; + end; + end; +var + Constant: PConstant; + i: Word; + S: string; +begin + LoadStrings := 0; + if (StringList = nil) then + begin + LoadStrings := 2; + Exit; + end; + for i := 0 to 65535 do + begin + S := StringList^.Get(i); + if (S <> '') then + begin + MakeEditableString(S); + Constant := NewConstant(i,S); +(* + if LowMemory then + begin + if (Constant <> nil) then + Dispose(Constant,Done); + LoadStrings := 8; { out of memory } + Exit; + end; +*) + Insert(Constant); + end; + end; +end; + +{****************************************************************************} +{ TMemStringList.NewConstant } +{****************************************************************************} +function TMemStringList.NewConstant (Value: Word; S: string): PConstant; +begin + NewConstant := New(PConstant,Init(Value,S)); +end; + +{****************************************************************************} +{ TMemStringList.Put } +{****************************************************************************} +procedure TMemStringList.Put (Key: Word; S: string); +begin + Insert(New(PConstant,Init(Key,S))); +end; + +{****************************************************************************} +{ TMemStringList.Store } +{****************************************************************************} +procedure TMemStringList.Store (var S: TStream); +var + StrList: PStrListMaker; + Size: Word; + procedure Total (Constant: PConstant);{$ifndef FPC}far;{$endif} + begin + with Constant^ do + Inc(Size,Succ(Length(Text))); + end; + procedure AddString (Constant: PConstant);{$ifndef FPC}far;{$endif} + const + Numbers = ['0'..'9']; + var + i, j: Byte; + N: Byte; + ErrorCode: Integer; + S: string; + begin + with Constant^ do + begin + { convert formatting characters } + S := Text; + while (Pos('#',S) <> 0) do + begin + i := Succ(Pos('#',S)); + j := i; + if (Length(S) > j) then + Inc(j,Byte(S[Succ(j)] in Numbers)); + Val(Copy(S,i,j-i+1),N,ErrorCode); + System.Delete(S,Pred(i),j-i+2); + System.Insert(Char(N),S,Pred(i)); + end; + StrList^.Put(Value,Text) + end; + end; +begin + Size := 0; + ForEach(@Total); + StrList := New(PStrListMaker,Init(Size,Count * 6)); + if (StrList = nil) then + begin + S.Status := 8; { DOS error not enough memory } + Exit; + end; + ForEach(@AddString); + StrList^.Store(S); + Dispose(StrList,Done); +end; + +{****************************************************************************} +{ Public Procedures and Functions } +{****************************************************************************} + +{****************************************************************************} +{ Done } +{****************************************************************************} +procedure DoneResource; +begin + if (RezFile <> nil) then + begin + Dispose(RezFile,Done); + RezFile:=nil; + end; + if (Strings <> nil) then + begin + Dispose(Strings,Done); + Strings:=nil; + end; + if (Hints <> nil) then + begin + Dispose(Hints,Done); + Hints:=nil; + end; + if (Labels <> nil) then + begin + Dispose(Labels,Done); + Labels:=nil; + end; +end; + +{****************************************************************************} +{ Init } +{****************************************************************************} +{$ifndef cdResource} + +{$I strtxt.inc} + { strtxt.inc contains the real strings and procedures InitRes... which + is converted from str.inc } + +function InitResource: Boolean; +begin + InitResource := False; + Hints := New(PMemStringList,Init); + if (Hints = nil) then + begin + PrintStr('Fatal error. Could not create Hints list.'); + Exit; + end; + Strings := New(PMemStringList,Init); + if (Strings = nil) then + begin + DoneResource; + Exit; + end; + Labels := New(PMemStringList,Init); + if (Labels = nil) then + begin + DoneResource; + Exit; + end; +{ now load the defaults } + InitResLabels; + InitResStrings; + InitResource := True; +end; +{$endif cdResource} + +{****************************************************************************} +{ InitRezFile } +{****************************************************************************} +{$ifdef cdResource} +function InitRezFile (AFile: FNameStr; Mode: Word; + var AResFile: PResourceFile): Sw_Integer; +var + Stream: PBufStream; + Result: Sw_Integer; +begin + Stream := New(PBufStream,Init(AFile,Mode,RezBufferSize)); + if (Stream = nil) then + Result := 2 { file not found; could also be out of memory } + else begin + AResFile := New(PResourceFile,Init(Stream)); + if (AResFile = nil) then + begin + Dispose(Stream,Done); + Result := 11; + end + else Result := 0; + end; + InitRezFile := Result; +end; +{$endif cdResource} + +{****************************************************************************} +{ Load } +{****************************************************************************} +{$ifdef cdResource} +function LoadResource (AFile: FNameStr): Boolean; +var + Stream: PBufStream; +begin + Load := False; + Stream := New(PBufStream,Init(AFile,stOpenRead,RezBufferSize)); + if (Stream = nil) or (Stream^.Status <> 0) then + begin + Done; + PrintStr('Fatal error. Could not open resource file: ' + AFile); + Exit; + end; + RezFile := New(PResourceFile,Init(Stream)); + if (RezFile = nil) then + begin + Dispose(Stream,Done); + Done; + PrintStr('Fatal error. Could not initialize resource file.'); + Exit; + end; + Hints := PStringList(RezFile^.Get(reHints)); + if (Hints = nil) then + begin + Done; + PrintStr('Fatal error. Could not load Hints string list.'); + Exit; + end; + Strings := PStringList(RezFile^.Get(reStrings)); + if (Strings = nil) then + begin + Done; + PrintStr('Fatal error. Could not load Strings string list.'); + Exit; + end; + Load := True; +end; +{$endif cdResource} + +{****************************************************************************} +{ MergeLists } +{****************************************************************************} +function MergeLists (Source, Dest: PMemStringList): Sw_Integer; +var + Result: Sw_Integer; + procedure MoveItem (Constant: PConstant);{$ifndef FPC}far;{$endif} + var + j: Sw_Integer; + begin + if (Result = 0) and (not Dest^.Search(Dest^.KeyOf(Constant),j)) then + begin + j := Dest^.Count; + Dest^.Insert(Constant); + if (j = Dest^.Count) then + Result := 8 + else Source^.Delete(Constant); + end; + end; +begin + if (Source = nil) or (Dest = nil) then + begin + MergeLists := 6; + Exit; + end; + Result := 0; + Source^.ForEach(@MoveItem); + MergeLists := Result; +end; + +{****************************************************************************} +{ Unit Initialization } +{****************************************************************************} + +begin + RezFile := nil; + Hints := nil; + Strings := nil; + Labels := nil; +end. diff --git a/packages/fv/src/statuses.pas b/packages/fv/src/statuses.pas new file mode 100644 index 0000000000..143848ba25 --- /dev/null +++ b/packages/fv/src/statuses.pas @@ -0,0 +1,1404 @@ +{$V-} +unit Statuses; + +{$CODEPAGE cp437} + +{#Z+} +{ Free Vision Status Objects Unit + Free VIsion + Written by : Brad Williams, DVM + +Revision History + +1.2.3 (96/04/13) + - moved Pause and Resume to methods of TStatus leaving TStatus Pause and + Resume "aware" + - eliminated many bugs + - moved Pause, Resume and Cancel from TStatusDlg to TStatus + +1.2.1 (95/12/6) + - minor typo corrections in opening unit documentation + - F+ to Z+ around stream registration records + - removed redundant sentence in TAppStatus definition + - updated CBarStatus documentation and constant + - removed TGauge.Init cross-reference from TSpinner.Init + - added THeapMemAvail and RegistertvStatus documentation + - numerous other documentation updates + - changed all calls to Send to Message + +1.2.0 (95/11/24) + - conversion to Bsd format + +1.1.0 (05/01/94) + - initial WVS release + + +Known Bugs + +ScanHelp Errors + - sdXXXX constants help documentation doesn't show TStatusDlg and + TMessageStatusDlg + - ScanHelp produces garbage in evStatus help context + +tvStatus Bugs + - CAppStatus may not be correct } +{#Z-} + +{ The tvStatus unit implements several views for providing information to +the user which needs to be updated during program execution, such as a +progress indicator, clock, heap viewer, gauges, etc. All tvStatus views +respond to a new message event class, evStatus. An individual status view +only processes an event with its associated command. } + +interface + +{$i platform.inc} + +{$ifdef PPC_FPC} + {$H-} +{$else} + {$F+,O+,E+,N+} +{$endif} +{$X+,R-,I-,Q-,V-} +{$ifndef OS_UNIX} + {$S-} +{$endif} + +uses + + FVCommon, FVConsts, Objects, Drivers, Views, Dialogs; +{ Resource;} + +const + + evStatus = $8000; + { evStatus represents the event class all status views know how to + respond to. } + {#X Statuses } + + + CStatus = #1#2#3; +{$ifndef cdPrintDoc} +{#F+} +{ÝTStatus.CStatus palette +ßßßßßßßßßßßßßßßßßßßßßßßßß} +{#F-} +{$endif cdPrintDoc} +{ Status views use the default palette, CStatus, to map onto the first three +entries in the standard window palette. } +{#F+} +{ 1 2 3 + ÉÍÍÍÍÑÍÍÍÍÑÍÍÍÍ» + CStatus º 1 ³ 2 ³ 3 º + ÈÍÍÑÍÏÍÍÑÍÏÍÍÑͼ +Normal TextÄÄÄÙ ³ ³ +OtherÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ³ +Highlighted TextÄÄÄÄÄÄÄÄÙ } +{#F-} +{#X TStatus } + + CAppStatus = #2#5#4; +{$ifndef cdPrintDoc} +{#F+} +{ÝTAppStatus.CAppStatus palette +ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß} +{#F-} +{$endif cdPrintDoc} +{ Status views which are inserted into the application rather than a dialog +or window use the default palette, CAppStatus, to map onto the application +object's palette. } +{#F+} +{ 1 2 3 + ÉÍÍÍÍÑÍÍÍÍÑÍÍÍÍ» + CAppStatus º 2 ³ 5 ³ 4 º + ÈÍÍÑÍÏÍÍÑÍÏÍÍÑͼ +Normal TextÄÄÄÄÄÄÙ ³ ³ +OtherÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ³ +Highlighted TextÄÄÄÄÄÄÄÄÄÄÄÙ } +{#F-} + {#X tvStatus TAppStatus } + + + CBarGauge = CStatus + #16#19; +{$ifndef cdPrintDoc} +{#F+} +{ÝTBarGauge.CBarGauge palette +ßßßßßßßßßßßßßßßßßßßßßßßßßßßßß} +{#F-} +{$endif cdPrintDoc} +{ TBarGauge's use the default palette, CBarGauge, to map onto the dialog or +window owner's palette. } +{#F+} +{ 1 2 3 4 5 + ÉÍÍÍÍÑÍÍÍÍÑÍÍÍÍÑÍÍÍÍÑÍÍÍÍ» + CAppStatus º 2 ³ 5 ³ 4 ³ 16 ³ 19 º + ÈÍÍÑÍÏÍÍÑÍÏÍÍÑÍÏÍÍÑÍÏÍÍÑͼ +Normal TextÄÄÄÄÄÄÙ ³ ³ ³ ÀÄÄÄÄ filled in bar +OtherÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ³ ÀÄÄÄÄÄÄÄÄÄ empty bar +Highlighted TextÄÄÄÄÄÄÄÄÄÄÄÙ } +{#F-} + {#X tvStatus TBarGauge } + + +{#T sdXXXX } +{$ifndef cdPrintDoc} +{#F+} +{ÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜ +Ý sdXXXX constants (STDDLG unit) Þ +ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß} +{#F-} +{$endif cdNoPrintDoc} +{ sdXXXX constants are used to determine the types of buttons displayed in a +#TStatusDlg# or #TStatusMessageDlg#. } +{#F+} +{ Constant ³ Value ³ Meaning +ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍØÍÍÍÍÍÍÍØÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ + sdNone ³ $0000 ³ no buttons + sdCancelButton ³ $0001 ³ show Cancel button + sdPauseButton ³ $0002 ³ show Pause button + sdResumeButton ³ $0004 ³ show Resume button + sdAllButtons ³ $0008 ³ show Cancel, Pause and Resume + ³ ³ buttons } +{#Z+} + sdNone = $0000; + sdCancelButton = $0001; + sdPauseButton = $0002; + sdResumeButton = $0004; + sdAllButtons = sdCancelButton or sdPauseButton or sdResumeButton; +{#Z-} + {#X tvStatus TStatusDlg TStatusMessageDlg } + + SpinChars : String[4] = '³/Ä\'; + { SpinChars are the characters used by a #TSpinnerGauge# when it is drawn. + Only one character is displayed at a time. The string is cycled + through then started over again until the view is disposed. } + {#X tvStatus } + + sfPause = $F000; + { sfPause is an additional state flag used internally by status views to + indicate they are in a paused state and should not respond to their + command. } + +type + {#Z+} + PStatus = ^TStatus; + {#Z-} + TStatus = Object(TParamText) + { TStatus is the base object type from which all status views descend. + Status views are used to display information that will change at + run-time based upon some state or process in the application, such as + printing. + + All status views that are to be inserted into the application should + descend from #TAppStatus# for proper color mapping. } + Command : Word; + { Command is the only command the status view will respond to. When + the status view receives an evStatus event it checks the value of the + Event.Command field against Command before handling the event. } + {#X HandleEvent } + constructor Init (R : TRect; ACommand : Word; AText : String; + AParamCount : Integer); + { Init calls the inherited constructor then sets #Command# to ACommand. + + If an error occurs Init fails. } + {#X Load } + constructor Load (var S : TStream); + { Load calls the inherited constructor then reads #Command# from the + stream. + + If an error occurs Load fails. } + {#X Store Init } + function Cancel : Boolean; virtual; + { Cancel should prompt the user when necessary for validation of + canceling the process which the status view is displaying. If the + user elects to continue the process Cancel must return False, + otherwise Cancel must return True. } + {#X Pause Resume } + function GetPalette : PPalette; virtual; + { GetPalette returns a pointer to the default status view palette, + #CStatus#. } + {#X TAppStatus CAppStatus } + procedure HandleEvent (var Event : TEvent); virtual; + { HandleEvent captures any #evStatus# messages with its command value + equal to #Command#, then calls #Update# with Data set to + Event.InfoPtr. If the State field has its #sfPause# bit set, the + view ignores the event. } + procedure Pause; virtual; + { Pause sends an evStatus message to the application with Event.Command + set to cmStatusPause and Event.InfoPtr set to #Status#^.Command. The + #Status# view's sfPause bit of the State flag is set by calling + SetState. In the paused state, the status view does not respond to + its associated command. } + {#X Resume sdXXXX Cancel } + procedure Reset; virtual; + { Reset causes the status view to be reset to its beginning or default + value, then be redrawn. Reset is used after an event is aborted + which can only be performed in its entirety. } + procedure Resume; virtual; + { Resume is called in response to pressing the Resume button. Resume + sends an evStatus message to the application with Event.Command set + to cmStatusPause and Event.InfoPtr set to #Status#^.Command. The + Status view's sfPause bit is turned off by calling SetState. } + {#X Pause sdXXXX Cancel } + procedure Store (var S : TStream); { store should never be virtual;} + { Store calls the inherited Store method then writes #Command# to the + stream. } + {#X Load } + procedure Update (Data : Pointer); virtual; + { Update changes the status' displayed text as necessary based on + Data. } + {#X Command HandleEvent } + end; { of TStatus } + + + {#Z+} + PStatusDlg = ^TStatusDlg; + {#Z-} + TStatusDlg = Object(TDialog) + { A TStatusDlg displays a status view and optional buttons. It may be + used to display any status message and optionally provide end user + cancelation or pausing of an ongoing operation, such as printing. + + All status views that are to be inserted into a window or dialog should + descend from #TStatus# for proper color mapping. } + Status : PStatus; + { Status is the key status view for the dialog. When a cmStatusPause + command is broadcast in response to pressing the pause button, + Event.InfoPtr is set to point to the command associated with Status. } + {#X TStatus cmXXXX } + constructor Init (ATitle : TTitleStr; AStatus : PStatus; AFlags : Word); + { Init calls the inherited constructor to create the dialog and sets + the EventMask to handle #evStatus# events. AStatus is assigned to + #Status# and inserted into the dialog at position 2,2. + + The dialog is anchored at AStatus^.Origin and its size is at least + AStatus^.Size + 2 in both dimensions. The actual size is determined + by the AFlags byte. The #sdXXXX# constants should be used to signify + which buttons to display. + + If an error occurs Init fails. } + {#X TStatus.Pause TStatus.Resume } + constructor Load (var S : TStream); + { Load calls the inherited constructor then loads #Status#. + + If an error occurs Load fails. } + {#X Store } + procedure Cancel (ACommand : Word); virtual; + { Cancel sends an evStatus message to the Application object with + command set to cmCancel and InfoPtr set to the calling status view's + command, then calls the inherited Cancel method. } + {#X TBSDDialog.Cancel } + procedure HandleEvent (var Event : TEvent); virtual; + { All evStatus events are accepted by the dialog and sent to each + subview in Z-order until cleared. + + If the dialog recieves an evCommand or evBroadcast event with the + Command parameter set to cmCancel, HandleEvent sends an #evStatus# + message to the Application variable with Event.Command set to the + cmStatusCancel and Event.InfoPtr set to the #Status#.Command and + disposes of itself. + + When a pause button is included, a cmStatusPause broadcast event is + associated with the button. When the button is pressed a call to + #TStatus.Pause# results. The status view is inactivated until it + receives an evStatus event with a commond of cmStatusResume and + Event.InfoPtr set to the status view's Command value. When a pause + button is used, the application should respond to the evStatus event + (with Event.Command of cmStatusPause) appropriately, then dispatch a + cmStatusResume evStatus event when ready to resume activity. } + {#X TStatus.Command } + procedure InsertButtons (AFlags : Word); virtual; + { InsertButtons enlarges the dialog to the necessary size and inserts + the buttons specified in AFlags into the last row of the dialog. } + procedure Store (var S : TStream); { store should never be virtual;} + { Store calls the inherited Store method then writes #Status# to the + stream. } + {#X Load } + end; { of TStatusDlg } + + + {#Z+} + PStatusMessageDlg = ^TStatusMessageDlg; + {#Z-} + TStatusMessageDlg = Object(TStatusDlg) + { A TStatusMessageDlg displays a message as static text with a status + view on the line below it. + + All status views that are to be inserted into a window or dialog should + descend from #TStatus# for proper color mapping. } + constructor Init (ATitle : TTitleStr; AStatus : PStatus; AFlags : Word; + AMessage : String); + { Init calls the inherited constructor then inserts a TStaticText view + containing AMessage at the top line of the dialog. + + The size of the dialog is determined by the size of the AStatus. The + dialog is anchored at AStatus^.Origin and is of at least + AStatus^.Size + 2 in heighth and width. The exact width and heighth + are determined by AOptions. + + AFlags contains flags which determine the buttons to be displayed + in the dialog. + + If an error occurs Init fails. } + end; { of TStatusMessageDlg } + + + {#Z+} + PGauge = ^TGauge; + {#Z-} + TGauge = Object(TStatus) + { A gauge is used to represent the current numerical position within a + range of values. When Current equals Max a gauge dispatches an + #evStatus# event with the command set to cmStatusDone to the + Application object. } + Min : LongInt; + { Min is the minimum value which #Current# may be set to. } + {#X Max } + Max : LongInt; + { Max is the maximum value which #Current# may be set to. } + {#X Min } + Current : LongInt; + { Current is the current value represented in the gauge. } + {#X Max Min } + constructor Init (R : TRect; ACommand : Word; AMin, AMax : LongInt); + { Init calls the inherited constructor then sets #Min# and #Max# to + AMin and AMax, respectively. #Current# is set to AMin. + + If an error occurs Init fails. } + {#X Load } + constructor Load (var S : TStream); + { Load calls the inherited constructor then reads #Min#, #Max# and + #Current# from the stream. + + If an error occurs Load fails. } + {#X Init Store } + procedure Draw; virtual; + { Draw writes the following to the screen: } +{#F+} +{ +Min = XXX Max = XXX Current = XXX } +{#F-} + { where XXX are the current values of the corresponding variables. } + procedure GetData (var Rec); virtual; + { GetData assumes Rec is a #TGaugeRec# and returns the current settings + of the gauge. } + {#X SetData } + procedure Reset; virtual; + { Reset sets #Current# to #Min# then redraws the status view. } + {#X TStatus.Reset } + procedure SetData (var Rec); virtual; + { SetData assumes Rec is a #TGaugeRec# and sets the gauge's variables + accordingly. } + {#X GetData } + procedure Store (var S : TStream); { store should never be virtual;} + { Store calls the inherited Store method then writes #Min#, #Max# and + #Current# to the stream. } + {#X Load } + procedure Update (Data : Pointer); virtual; + { Update increments #Current#. } + end; { of TGauge } + + + {#Z+} + PGaugeRec = ^TGaugeRec; + {#Z-} + TGaugeRec = record + { A TGaugeRec is used to set and get a #TGauge#'s variables. } + {#X TGauge.GetData TGauge.SetData } + Min, Max, Current : LongInt; + end; { of TGaugeRec } + + + {#Z+} + PArrowGauge = ^TArrowGauge; + {#Z-} + TArrowGauge = Object(TGauge) + { An arrow gauge draws a progressively larger series of arrows across the + view. If Right is True, the arrows are right facing, '>', and are + drawn from left to right. If Right is False, the arrows are left + facing, '<', and are drawn from right to left. } + Right : Boolean; + { Right determines the direction of arrow used and the direction which + the status view is filled. If Right is True, the arrows are right + facing, '>', and are drawn from left to right. If Right is False, + the arrows are left facing, '<', and are drawn from right to left. } + {#X Draw } + constructor Init (R : TRect; ACommand : Word; AMin, AMax : Word; + RightArrow : Boolean); + { Init calls the inherited constructor then sets #Right# to RightArrow. + + If an error occurs Init fails. } + {#X Load } + constructor Load (var S : TStream); + { Load calls the inherited constructor then reads #Right# from the + stream. + + If an error occurs Load fails. } + {#X Init Store } + procedure Draw; virtual; + { Draw fills the Current / Max percent of the view with arrows. } + {#X Right } + procedure GetData (var Rec); virtual; + { GetData assumes Rec is a #TArrowGaugeRec# and returns the current + settings of the views variables. } + {#X SetData } + procedure SetData (var Rec); virtual; + { SetData assumes Rec is a #TArrowGaugeRec# and sets the view's + variables accordingly. } + {#X GetData } + procedure Store (var S : TStream); { store should never be virtual;} + { Store calls the inherited Store method then writes #Right# to the + stream. } + {#X Load } + end; { of TArrowGauge } + + + {#Z+} + PArrowGaugeRec = ^TArrowGaugeRec; + {#Z-} + TArrowGaugeRec = record + { A TArrowGaugeRec is used to set and get the variables of a + #TArrowGauge#. } + {#X TArrowGauge.GetData TArrowGauge.SetData } + Min, Max, Count : LongInt; + Right : Boolean; + end; { of TGaugeRec } + + + {#Z+} + PPercentGauge = ^TPercentGauge; + {#Z-} + TPercentGauge = Object(TGauge) + { A TPercentGauge displays a numerical percentage as returned by + #Percent# followed by a '%' sign. } + function Percent : Integer; virtual; + { Percent returns the whole number value of (Current / Max) * 100. } + {#X TGauge.Current TGauge.Max } + procedure Draw; virtual; + { Draw writes the current percentage to the screen. } + {#X Percent } + end; { of TPercentGauge } + + + {#Z+} + PBarGauge = ^TBarGauge; + {#Z-} + TBarGauge = Object(TPercentGauge) + { A TBarGauge displays a bar which increases in size from the left to + the right of the view as Current increases. A numeric percentage + representing the value of (Current / Max) * 100 is displayed in the + center of the bar. } + {#x TPercentGauge.Percent } + procedure Draw; virtual; + { Draw draws the bar and percentage to the screen representing the + current status of the view's variables. } + {#X TGauge.Update } + function GetPalette : PPalette; virtual; + { GetPalette returns a pointer to the default status view palette, + #CBarStatus#. } + end; { of TBarGauge } + + + {#Z+} + PSpinnerGauge = ^TSpinnerGauge; + {#Z-} + TSpinnerGauge = Object(TGauge) + { A TSpinnerGauge displays a series of characters in one spot on the + screen giving the illusion of a spinning line. } + constructor Init (X, Y : Integer; ACommand : Word); + { Init calls the inherited constructor with AMin set to 0 and AMax set + to 4. } + procedure Draw; virtual; + { Draw uses the #SpinChars# variable to draw the view's Current + character. } + {#X Update } + procedure HandleEvent (var Event : TEvent); virtual; + { HandleEvent calls TStatus.HandleEvent so that a cmStatusDone event + is not generated when Current equals Max. } + {#X TGauge.Current TGauge.Max } + procedure Update (Data : Pointer); virtual; + { Update increments Current until Current equals Max, when it resets + Current to Min. } + {#X Draw HandleEvent } + end; { of TSpinnerGauge } + + + {#Z+} + PAppStatus = ^TAppStatus; + {#Z-} + TAppStatus = Object(TStatus) + { TAppStatus is a base object which implements color control for status + views that are normally inserted in the Application object. } + {#X TStatus } + function GetPalette : PPalette; virtual; + { GetPalette returns a pointer to the default application status view + palette, #CAppStatus#. } + {#X TStatus CStatus } + end; { of TAppStatus } + + + {#Z+} + PHeapMaxAvail = ^THeapMaxAvail; + {#Z-} + THeapMaxAvail = Object(TAppStatus) + { A THeapMaxAvail displays the largest available contiguous area of heap + memory. It responds to a cmStatusUpdate event by calling MaxAvail and + comparing the result to #Max#, then updating the view if necessary. } + {#X THeapMemAvail } + constructor Init (X, Y : Integer); + { Init creates the view with the following text: + + MaxAvail = xxxx + + where xxxx is the result returned by MaxAvail. } + procedure Update (Data : Pointer); virtual; + { Update changes #Mem# to the current MemAvail and redraws the status + if necessary. } + private + Max : LongInt; + { Max is the last reported value from MaxAvail. } + {#X Update } + end; { of THeapMaxAvail } + + + {#Z+} + PHeapMemAvail = ^THeapMemAvail; + {#Z-} + THeapMemAvail = Object(TAppStatus) + { A THeapMemAvail displays the total amount of heap memory available to + the application. It responds to a cmStatusUpdate event by calling + MemAvail and comparing the result to #Max#, then updating the view if + necessary. } + {#X THeapMaxAvail } + constructor Init (X, Y : Integer); + { Init creates the view with the following text: + + MemAvail = xxxx + + where xxxx is the result returned by MemAvail. } + {#X Load } + procedure Update (Data : Pointer); virtual; + { Update changes #Mem# to the current MemAvail and redraws the status + if necessary. } + private + Mem : LongInt; + { Mem is the last available value reported by MemAvail. } + {#X Update } + end; { of THeapMemAvail } + + +{$ifndef cdPrintDoc} +{#Z+} +{$endif cdPrintDoc} +const + RStatus : TStreamRec = ( + ObjType : idStatus; + VmtLink : Ofs(TypeOf(TStatus)^); + Load : @TStatus.Load; + Store : @TStatus.Store); + + RStatusDlg : TStreamRec = ( + ObjType : idStatusDlg; + VmtLink : Ofs(TypeOf(TStatusDlg)^); + Load : @TStatusDlg.Load; + Store : @TStatusDlg.Store); + + RStatusMessageDlg : TStreamRec = ( + ObjType : idStatusMessageDlg; + VmtLink : Ofs(TypeOf(TStatusMessageDlg)^); + Load : @TStatusMessageDlg.Load; + Store : @TStatusMessageDlg.Store); + + RGauge : TStreamRec = ( + ObjType : idGauge; + VmtLink : Ofs(TypeOf(TGauge)^); + Load : @TGauge.Load; + Store : @TGauge.Store); + + RArrowGauge : TStreamRec = ( + ObjType : idArrowGauge; + VmtLink : Ofs(TypeOf(TArrowGauge)^); + Load : @TArrowGauge.Load; + Store : @TArrowGauge.Store); + + RBarGauge : TStreamRec = ( + ObjType : idBarGauge; + VmtLink : Ofs(TypeOf(TBarGauge)^); + Load : @TBarGauge.Load; + Store : @TBarGauge.Store); + + RPercentGauge : TStreamRec = ( + ObjType : idPercentGauge; + VmtLink : Ofs(TypeOf(TPercentGauge)^); + Load : @TPercentGauge.Load; + Store : @TPercentGauge.Store); + + RSpinnerGauge : TStreamRec = ( + ObjType : idSpinnerGauge; + VmtLink : Ofs(TypeOf(TSpinnerGauge)^); + Load : @TSpinnerGauge.Load; + Store : @TSpinnerGauge.Store); + + RAppStatus : TStreamRec = ( + ObjType : idAppStatus; + VmtLink : Ofs(TypeOf(TAppStatus)^); + Load : @TAppStatus.Load; + Store : @TAppStatus.Store); + + RHeapMinAvail : TStreamRec = ( + ObjType : idHeapMinAvail; + VmtLink : Ofs(TypeOf(THeapMaxAvail)^); + Load : @THeapMaxAvail.Load; + Store : @THeapMaxAvail.Store); + + RHeapMemAvail : TStreamRec = ( + ObjType : idHeapMemAvail; + VmtLink : Ofs(TypeOf(THeapMemAvail)^); + Load : @THeapMemAvail.Load; + Store : @THeapMemAvail.Store); +{$ifndef cdPrintDoc} +{#Z-} +{$endif cdPrintDoc} + +procedure RegisterStatuses; +{$ifndef cdPrintDoc} +{#F+} +{ÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜ +ÝRegisterStatuses procedure (Statuses unit)Þ +ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß} +{#F-} +{$endif cdPrintDoc} + { RegisterStatuses calls RegisterType for each of the status view and + status dialog object types defined in the tvStatus unit. After calling + RegisterStatuses, your application can read or write any of those types + with streams. } + + +implementation + +uses + MsgBox, App; + +{****************************************************************************} +{ Local procedures and functions } +{****************************************************************************} + +{****************************************************************************} +{ TAppStatus Object } +{****************************************************************************} +{****************************************************************************} +{ TAppStatus.GetPalette } +{****************************************************************************} +function TAppStatus.GetPalette : PPalette; +const P : String[Length(CAppStatus)] = CAppStatus; +begin + GetPalette := PPalette(@P); +end; + +{****************************************************************************} +{ TArrowGauge Object } +{****************************************************************************} +{****************************************************************************} +{ TArrowGauge.Init } +{****************************************************************************} +constructor TArrowGauge.Init (R : TRect; ACommand : Word; AMin, AMax : Word; + RightArrow : Boolean); +begin + if not TGauge.Init(R,ACommand,AMin,AMax) then + Fail; + Right := RightArrow; +end; + +{****************************************************************************} +{ TArrowGauge.Load } +{****************************************************************************} +constructor TArrowGauge.Load (var S : TStream); +begin + if not TGauge.Load(S) then + Fail; + S.Read(Right,SizeOf(Right)); + if (S.Status <> stOk) then + begin + TGauge.Done; + Fail; + end; +end; + +{****************************************************************************} +{ TArrowGauge.Draw } +{****************************************************************************} +procedure TArrowGauge.Draw; +const Arrows : array[0..1] of Char = '<>'; +var + B : TDrawBuffer; + C : Word; + Len : Byte; +begin + C := GetColor(1); + Len := Round(Size.X * Current/(Max - Min)); + MoveChar(B,' ',C,Size.X); + if Right then + MoveChar(B,Arrows[Byte(Right)],C,Len) + else MoveChar(B[Size.X - Len],Arrows[Byte(Right)],C,Len); + WriteLine(0,0,Size.X,1,B); +end; + +{****************************************************************************} +{ TArrowGauge.GetData } +{****************************************************************************} +procedure TArrowGauge.GetData (var Rec); +begin + PArrowGaugeRec(Rec)^.Min := Min; + PArrowGaugeRec(Rec)^.Max := Max; + PArrowGaugeRec(Rec)^.Count := Current; + PArrowGaugeRec(Rec)^.Right := Right; +end; + +{****************************************************************************} +{ TArrowGauge.SetData } +{****************************************************************************} +procedure TArrowGauge.SetData (var Rec); +begin + Min := PArrowGaugeRec(Rec)^.Min; + Max := PArrowGaugeRec(Rec)^.Max; + Current := PArrowGaugeRec(Rec)^.Count; + Right := PArrowGaugeRec(Rec)^.Right; +end; + +{****************************************************************************} +{ TArrowGauge.Store } +{****************************************************************************} +procedure TArrowGauge.Store (var S : TStream); +begin + TGauge.Store(S); + S.Write(Right,SizeOf(Right)); +end; + +{****************************************************************************} +{ TBarGauge Object } +{****************************************************************************} +{****************************************************************************} +{ TBarGauge.Draw } +{****************************************************************************} +procedure TBarGauge.Draw; +var + B : TDrawBuffer; + C : Word; + FillSize : Word; + PercentDone : LongInt; + S : String[4]; +begin + { fill entire view } + MoveChar(B,' ',GetColor(4),Size.X); + { make progress bar } + C := GetColor(5); + FillSize := Round(Size.X * (Current / Max)); + MoveChar(B,' ',C,FillSize); + { display percent done } + PercentDone := Percent; + FormatStr(S,'%d%%',PercentDone); + if PercentDone < 50 then + C := GetColor(4); + FillSize := (Size.X - Length(S)) div 2; + MoveStr(B[FillSize],S,C); + WriteLine(0,0,Size.X,Size.Y,B); +end; + +{****************************************************************************} +{ TBarGauge.GetPalette } +{****************************************************************************} +function TBarGauge.GetPalette : PPalette; +const + S : String[Length(CBarGauge)] = CBarGauge; +begin + GetPalette := PPalette(@S); +end; + +{****************************************************************************} +{ TGauge Object } +{****************************************************************************} +{****************************************************************************} +{ TGauge.Init } +{****************************************************************************} +constructor TGauge.Init (R : TRect; ACommand : Word; AMin, AMax : LongInt); +begin + if not TStatus.Init(R,ACommand,'',1) then + Fail; + Min := AMin; + Max := AMax; + Current := Min; +end; + +{****************************************************************************} +{ TGauge.Load } +{****************************************************************************} +constructor TGauge.Load (var S : TStream); +begin + if not TStatus.Load(S) then + Fail; + S.Read(Min,SizeOf(Min)); + S.Read(Max,SizeOf(Max)); + S.Read(Current,SizeOf(Current)); + if S.Status <> stOk then + begin + TStatus.Done; + Fail; + end; +end; + +{****************************************************************************} +{ TGauge.Draw } +{****************************************************************************} +procedure TGauge.Draw; +var + S : String; + B : TDrawBuffer; +begin + { Blank the gauge } + MoveChar(B,' ',GetColor(1),Size.X); + WriteBuf(0,0,Size.X,Size.Y,B); + { write current status } + FormatStr(S,'%d',Current); + MoveStr(B,S,GetColor(1)); + WriteBuf(0,0,Size.X,Size.Y,B); +end; + +{****************************************************************************} +{ TGauge.GetData } +{****************************************************************************} +procedure TGauge.GetData (var Rec); +begin + TGaugeRec(Rec).Min := Min; + TGaugeRec(Rec).Max := Max; + TGaugeRec(Rec).Current := Current; +end; + +{****************************************************************************} +{ TGauge.Reset } +{****************************************************************************} +procedure TGauge.Reset; +begin + Current := Min; + DrawView; +end; + +{****************************************************************************} +{ TGauge.SetData } +{****************************************************************************} +procedure TGauge.SetData (var Rec); +begin + Min := TGaugeRec(Rec).Min; + Max := TGaugeRec(Rec).Max; + Current := TGaugeRec(Rec).Current; +end; + +{****************************************************************************} +{ TGauge.Store } +{****************************************************************************} +procedure TGauge.Store (var S : TStream); +begin + TStatus.Store(S); + S.Write(Min,SizeOf(Min)); + S.Write(Max,SizeOf(Max)); + S.Write(Current,SizeOf(Current)); +end; + +{****************************************************************************} +{ TGauge.Update } +{****************************************************************************} +procedure TGauge.Update (Data : Pointer); +begin + if Current < Max then + begin + Inc(Current); + DrawView; + end + else Message(@Self,evStatus,cmStatusDone,@Self); +end; + +{****************************************************************************} +{ THeapMaxAvail Object } +{****************************************************************************} +{****************************************************************************} +{ THeapMaxAvail.Init } +{****************************************************************************} +constructor THeapMaxAvail.Init (X, Y : Integer); +var + R : TRect; +begin + R.Assign(X,Y,X+20,Y+1); + if not TAppStatus.Init(R,cmStatusUpdate,' MaxAvail = %d',1) then + Fail; + Max := -1; +end; + +{****************************************************************************} +{ THeapMaxAvail.Update } +{****************************************************************************} +procedure THeapMaxAvail.Update (Data : Pointer); +var + M : LongInt; +begin + M := MaxAvail; + if (Max <> M) then + begin + Max := MaxAvail; + SetData(Max); + end; +end; + +{****************************************************************************} +{ THeapMemAvail Object } +{****************************************************************************} +{****************************************************************************} +{ THeapMemAvail.Init } +{****************************************************************************} +constructor THeapMemAvail.Init (X, Y : Integer); +var + R : TRect; +begin + R.Assign(X,Y,X+20,Y+1); + if not TAppStatus.Init(R,cmStatusUpdate,' MemAvail = %d',1) then + Fail; + Mem := -1; +end; + +{****************************************************************************} +{ THeapMemAvail.Update } +{****************************************************************************} +procedure THeapMemAvail.Update (Data : Pointer); + { Total bytes available on the heap. May not be contiguous. } +var + M : LongInt; +begin + M := MemAvail; + if (Mem <> M) then + begin + Mem := M; + SetData(Mem); + end; +end; + +{****************************************************************************} +{ TPercentGauge Object } +{****************************************************************************} +{****************************************************************************} +{ TPercentGauge.Draw } +{****************************************************************************} +procedure TPercentGauge.Draw; +var + B : TDrawBuffer; + C : Word; + S : String; + PercentDone : LongInt; + FillSize : Integer; +begin + C := GetColor(1); + MoveChar(B,' ',C,Size.X); + WriteLine(0,0,Size.X,Size.Y,B); + PercentDone := Percent; + FormatStr(S,'%d%%',PercentDone); + MoveStr(B[(Size.X - Byte(S[0])) div 2],S,C); + WriteLine(0,0,Size.X,Size.Y,B); +end; + +{****************************************************************************} +{ TPercentGauge.Percent } +{****************************************************************************} +function TPercentGauge.Percent : Integer; + { Returns percent as a whole integer Current of Max } +begin + Percent := Round((Current/Max) * 100); +end; + +{****************************************************************************} +{ TSpinnerGauge Object } +{****************************************************************************} + +{****************************************************************************} +{ TSpinnerGauge.Init } +{****************************************************************************} +constructor TSpinnerGauge.Init (X, Y : Integer; ACommand : Word); +var R : TRect; +begin + R.Assign(X,Y,X+1,Y+1); + if not TGauge.Init(R,ACommand,1,4) then + Fail; +end; + +{****************************************************************************} +{ TSpinnerGauge.Draw } +{****************************************************************************} +procedure TSpinnerGauge.Draw; +var + B : TDrawBuffer; + C : Word; +begin + C := GetColor(1); + MoveChar(B,' ',C,Size.X); + WriteLine(0,0,Size.X,Size.Y,B); + MoveChar(B[Size.X div 2],SpinChars[Current],C,1); + WriteLine(0,0,Size.X,Size.Y,B); +end; + +{****************************************************************************} +{ TSpinnerGauge.HandleEvent } +{****************************************************************************} +procedure TSpinnerGauge.HandleEvent (var Event : TEvent); +begin + TStatus.HandleEvent(Event); +end; + +{****************************************************************************} +{ TSpinnerGauge.Update } +{****************************************************************************} +procedure TSpinnerGauge.Update (Data : Pointer); +begin + if Current = Max then + Current := Min + else Inc(Current); + DrawView; +end; + +{****************************************************************************} +{ TStatus Object } +{****************************************************************************} +{****************************************************************************} +{ TStatus.Init } +{****************************************************************************} +constructor TStatus.Init (R : TRect; ACommand : Word; AText : String; + AParamCount : Integer); +begin + if (not TParamText.Init(R,AText,AParamCount)) then + Fail; + EventMask := EventMask or evStatus; + Command := ACommand; +end; + +{****************************************************************************} +{ TStatus.Load } +{****************************************************************************} +constructor TStatus.Load (var S : TStream); +begin + if not TParamText.Load(S) then + Fail; + S.Read(Command,SizeOf(Command)); + if (S.Status <> stOk) then + begin + TParamText.Done; + Fail; + end; +end; + +{****************************************************************************} +{ TStatus.Cancel } +{****************************************************************************} +function TStatus.Cancel : Boolean; +begin + Cancel := True; +end; + +{****************************************************************************} +{ TStatus.GetPalette } +{****************************************************************************} +function TStatus.GetPalette : PPalette; +const + P : String[Length(CStatus)] = CStatus; +begin + GetPalette := PPalette(@P); +end; + +{****************************************************************************} +{ TStatus.HandleEvent } +{****************************************************************************} +procedure TStatus.HandleEvent (var Event : TEvent); +begin + if (Event.What = evCommand) and (Event.Command = cmStatusPause) then + begin + Pause; + ClearEvent(Event); + end; + case Event.What of + evStatus : + case Event.Command of + cmStatusDone : + if (Event.InfoPtr = @Self) then + begin + Message(Owner,evStatus,cmStatusDone,@Self); + ClearEvent(Event); + end; + cmStatusUpdate : + if (Event.InfoWord = Command) and ((State and sfPause) = 0) then + begin + Update(Event.InfoPtr); + { ClearEvent(Event); } { don't clear the event so multiple } + { status views can respond to the same event } + end; + cmStatusResume : + if (Event.InfoWord = Command) and + ((State and sfPause) = sfPause) then + begin + Resume; + ClearEvent(Event); + end; + cmStatusPause : + if (Event.InfoWord = Command) and ((State and sfPause) = 0) then + begin + Pause; + ClearEvent(Event); + end; + end; + end; + TParamText.HandleEvent(Event); +end; + +{****************************************************************************} +{ TStatus.Pause } +{****************************************************************************} +procedure TStatus.Pause; +begin + SetState(sfPause,True); +end; + +{****************************************************************************} +{ TStatus.Reset } +{****************************************************************************} +procedure TStatus.Reset; +begin + DrawView; +end; + +{****************************************************************************} +{ TStatus.Resume } +{****************************************************************************} +procedure TStatus.Resume; +begin + SetState(sfPause,False); +end; + +{****************************************************************************} +{ TStatus.Store } +{****************************************************************************} +procedure TStatus.Store (var S : TStream); +begin + TParamText.Store(S); + S.Write(Command,SizeOf(Command)); +end; + +{****************************************************************************} +{ TStatus.Update } +{****************************************************************************} +procedure TStatus.Update (Data : Pointer); +begin + DisposeStr(Text); + Text := NewStr(String(Data^)); + DrawView; +end; + +{****************************************************************************} +{ TStatusDlg Object } +{****************************************************************************} +{****************************************************************************} +{ TStatusDlg.Init } +{****************************************************************************} +constructor TStatusDlg.Init (ATitle : TTitleStr; AStatus : PStatus; + AFlags : Word); +var + R : TRect; + i : LongInt; + Buttons : Byte; +begin + if (AStatus = nil) then + Fail; + R.A := AStatus^.Origin; + R.B := AStatus^.Size; + Inc(R.B.Y,R.A.Y+4); + Inc(R.B.X,R.A.X+5); + if not TDialog.Init(R,ATitle) then + Fail; + EventMask := EventMask or evStatus; + Status := AStatus; + Status^.MoveTo(2,2); + Insert(Status); + InsertButtons(AFlags); +end; + +{****************************************************************************} +{ TStatusDlg.Load } +{****************************************************************************} +constructor TStatusDlg.Load (var S : TStream); +begin + if not TDialog.Load(S) then + Fail; + GetSubViewPtr(S,Status); + if (S.Status <> stOk) then + begin + if (Status <> nil) then + Dispose(Status,Done); + TDialog.Done; + Fail; + end; +end; + +{****************************************************************************} +{ TStatusDlg.Cancel } +{****************************************************************************} +procedure TStatusDlg.Cancel (ACommand : Word); +begin + if Status^.Cancel then + TDialog.Cancel(ACommand); +end; + +{****************************************************************************} +{ TStatusDlg.HandleEvent } +{****************************************************************************} +procedure TStatusDlg.HandleEvent (var Event : TEvent); +begin + case Event.What of + evStatus : + case Event.Command of + cmStatusDone : + if Event.InfoPtr = Status then + begin + TDialog.Cancel(cmOk); + ClearEvent(Event); + end; + end; + { else let TDialog.HandleEvent send to all subviews for handling } + evBroadcast, evCommand : + case Event.Command of + cmCancel, cmClose : + begin + Cancel(cmCancel); + ClearEvent(Event); + end; + cmStatusPause : + begin + Status^.Pause; + ClearEvent(Event); + end; + cmStatusResume : + begin + Status^.Resume; + ClearEvent(Event); + end; + end; + end; + TDialog.HandleEvent(Event); +end; + +{****************************************************************************} +{ TStatusDlg.InsertButtons } +{****************************************************************************} +procedure TStatusDlg.InsertButtons (AFlags : Word); +var + R : TRect; + P : PButton; + Buttons : Byte; + X, Y, Gap : Integer; + i : Word; +begin + Buttons := Byte(((AFlags and sdCancelButton) = sdCancelButton)); + { do this Inc twice, once for Pause and once for Resume buttons } + Inc(Buttons,2 * Byte(((AFlags and sdPauseButton) = sdPauseButton))); + if Buttons > 0 then + begin + Status^.GrowMode := gfGrowHiX; + { resize dialog to hold all requested buttons } + if Size.X < ((Buttons * 12) + 2) then + GrowTo((Buttons * 12) + 2,Size.Y + 2) + else GrowTo(Size.X,Size.Y + 2); + { find correct starting position for first button } + Gap := Size.X - (Buttons * 10) - 2; + Gap := Gap div Succ(Buttons); + X := Gap; + if X < 2 then + X := 2; + Y := Size.Y - 3; + { insert buttons } + if ((AFlags and sdCancelButton) = sdCancelButton) then + begin + P := NewButton(X,Y,10,2,'Cancel',cmCancel,hcCancel,bfDefault); + P^.GrowMode := gfGrowHiY or gfGrowLoY; + Inc(X,12 + Gap); + end; + if ((AFlags and sdPauseButton) = sdPauseButton) then + begin + P := NewButton(X,Y,10,2,'~P~ause',cmStatusPause,hcStatusPause,bfNormal); + P^.GrowMode := gfGrowHiY or gfGrowLoY; + Inc(X,12 + Gap); + P := NewButton(X,Y,10,2,'~R~esume',cmStatusResume,hcStatusResume, + bfBroadcast); + P^.GrowMode := gfGrowHiY or gfGrowLoY; + end; + end; { of if } + SelectNext(False); +end; + +{****************************************************************************} +{ TStatusDlg.Store } +{****************************************************************************} +procedure TStatusDlg.Store (var S : TStream); +begin + TDialog.Store(S); + PutSubViewPtr(S,Status); +end; + +{****************************************************************************} +{ TStatusMessageDlg Object } +{****************************************************************************} +{****************************************************************************} +{ TStatusMessageDlg.Init } +{****************************************************************************} +constructor TStatusMessageDlg.Init (ATitle : TTitleStr; AStatus : PStatus; + AFlags : Word; AMessage : String); +var + P : PStaticText; + X, Y : Integer; + R : TRect; +begin + if not TStatusDlg.Init(ATitle,AStatus,AFlags) then + Fail; + Status^.GrowMode := gfGrowLoY or gfGrowHiY; + GetExtent(R); + X := R.B.X - R.A.X; + if X < Size.X then + X := Size.X; + Y := R.B.Y - R.A.Y; + if Y < Size.Y then + Y := Size.Y; + GrowTo(X,Y); + R.Assign(2,2,Size.X-2,Size.Y-3); + P := New(PStaticText,Init(R,AMessage)); + if (P = nil) then + begin + TStatusDlg.Done; + Fail; + end; + GrowTo(Size.X,Size.Y + P^.Size.Y + 1); + Insert(P); +end; + +{****************************************************************************} +{ Global procedures and functions } +{****************************************************************************} + +{****************************************************************************} +{ RegisterStatuses } +{****************************************************************************} +procedure RegisterStatuses; +begin +{ RegisterType(RStatus); + RegisterType(RStatusDlg); + RegisterType(RGauge); + RegisterType(RArrowGauge); + RegisterType(RPercentGauge); + RegisterType(RBarGauge); + RegisterType(RSpinnerGauge); } +end; + +{****************************************************************************} +{ Unit Initialization } +{****************************************************************************} +begin +end. diff --git a/packages/fv/src/stddlg.pas b/packages/fv/src/stddlg.pas new file mode 100644 index 0000000000..4b584e4e62 --- /dev/null +++ b/packages/fv/src/stddlg.pas @@ -0,0 +1,2770 @@ +{*******************************************************} +{ Free Vision Runtime Library } +{ StdDlg Unit } +{ Version: 0.1.0 } +{ Release Date: July 23, 1998 } +{ } +{*******************************************************} +{ } +{ This unit is a port of Borland International's } +{ StdDlg.pas unit. It is for distribution with the } +{ Free Pascal (FPK) Compiler as part of the 32-bit } +{ Free Vision library. The unit is still fully } +{ functional under BP7 by using the tp compiler } +{ directive when rebuilding the library. } +{ } +{*******************************************************} + +{ Revision History + +1.1a (97/12/29) + - fixed bug in TFileDialog.HandleEvent that prevented the user from being + able to have an action taken automatically when the FileList was + selected and kbEnter pressed + +1.1 + - modified OpenNewFile to take a history list ID + - implemented OpenNewFile + +1.0 (1992) + - original implementation } + +unit StdDlg; + +{ + This unit has been modified to make some functions global, apply patches + from version 3.1 of the TVBUGS list, added TEditChDirDialog, and added + several new global functions and procedures. +} + +{$i platform.inc} + +{$ifdef PPC_FPC} + {$H-} +{$else} + {$F+,O+,E+,N+} +{$endif} +{$X+,R-,I-,Q-,V-} +{$ifndef OS_UNIX} + {$S-} +{$endif} +{$ifdef OS_DOS} + {$define HAS_DOS_DRIVES} +{$endif} +{$ifdef OS_WINDOWS} + {$define HAS_DOS_DRIVES} +{$endif} +{$ifdef OS_OS2} + {$define HAS_DOS_DRIVES} +{$endif} + +{2.0 compatibility} +{$ifdef VER2_0} + {$macro on} + {$define resourcestring := const} +{$endif} + +interface + +uses + FVConsts, Objects, Drivers, Views, Dialogs, Validate, Dos; + +const + MaxDir = 255; { Maximum length of a DirStr. } + MaxFName = 255; { Maximum length of a FNameStr. } + + DirSeparator : Char = system.DirectorySeparator; + +{$ifdef Unix} + AllFiles = '*'; +{$else} + AllFiles = '*.*'; +{$endif} + +type + { TSearchRec } + + { Record used to store directory information by TFileDialog + This is a part of Dos.Searchrec for Bp !! } + + TSearchRec = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + Attr: Longint; + Time: Longint; + Size: Longint; + Name: string[MaxFName]; + end; + PSearchRec = ^TSearchRec; + +type + + { TFileInputLine is a special input line that is used by } + { TFileDialog that will update its contents in response to a } + { cmFileFocused command from a TFileList. } + + PFileInputLine = ^TFileInputLine; + TFileInputLine = object(TInputLine) + constructor Init(var Bounds: TRect; AMaxLen: Sw_Integer); + procedure HandleEvent(var Event: TEvent); virtual; + end; + + { TFileCollection is a collection of TSearchRec's. } + + PFileCollection = ^TFileCollection; + TFileCollection = object(TSortedCollection) + function Compare(Key1, Key2: Pointer): Sw_Integer; virtual; + procedure FreeItem(Item: Pointer); virtual; + function GetItem(var S: TStream): Pointer; virtual; + procedure PutItem(var S: TStream; Item: Pointer); virtual; + end; + + {#Z+} + PFileValidator = ^TFileValidator; + {#Z-} + TFileValidator = Object(TValidator) + end; { of TFileValidator } + + { TSortedListBox is a TListBox that assumes it has a } + { TStoredCollection instead of just a TCollection. It will } + { perform an incremental search on the contents. } + + PSortedListBox = ^TSortedListBox; + TSortedListBox = object(TListBox) + SearchPos: Byte; + {ShiftState: Byte;} + HandleDir : boolean; + constructor Init(var Bounds: TRect; ANumCols: Sw_Word; + AScrollBar: PScrollBar); + procedure HandleEvent(var Event: TEvent); virtual; + function GetKey(var S: String): Pointer; virtual; + procedure NewList(AList: PCollection); virtual; + end; + + { TFileList is a TSortedList box that assumes it contains } + { a TFileCollection as its collection. It also communicates } + { through broadcast messages to TFileInput and TInfoPane } + { what file is currently selected. } + + PFileList = ^TFileList; + TFileList = object(TSortedListBox) + constructor Init(var Bounds: TRect; AScrollBar: PScrollBar); + destructor Done; virtual; + function DataSize: Sw_Word; virtual; + procedure FocusItem(Item: Sw_Integer); virtual; + procedure GetData(var Rec); virtual; + function GetText(Item,MaxLen: Sw_Integer): String; virtual; + function GetKey(var S: String): Pointer; virtual; + procedure HandleEvent(var Event: TEvent); virtual; + procedure ReadDirectory(AWildCard: PathStr); + procedure SetData(var Rec); virtual; + end; + + { TFileInfoPane is a TView that displays the information } + { about the currently selected file in the TFileList } + { of a TFileDialog. } + + PFileInfoPane = ^TFileInfoPane; + TFileInfoPane = object(TView) + S: TSearchRec; + constructor Init(var Bounds: TRect); + procedure Draw; virtual; + function GetPalette: PPalette; virtual; + procedure HandleEvent(var Event: TEvent); virtual; + end; + + { TFileDialog is a standard file name input dialog } + + TWildStr = PathStr; + +const + fdOkButton = $0001; { Put an OK button in the dialog } + fdOpenButton = $0002; { Put an Open button in the dialog } + fdReplaceButton = $0004; { Put a Replace button in the dialog } + fdClearButton = $0008; { Put a Clear button in the dialog } + fdHelpButton = $0010; { Put a Help button in the dialog } + fdNoLoadDir = $0100; { Do not load the current directory } + { contents into the dialog at Init. } + { This means you intend to change the } + { WildCard by using SetData or store } + { the dialog on a stream. } + +type + + PFileHistory = ^TFileHistory; + TFileHistory = object(THistory) + CurDir : PString; + procedure HandleEvent(var Event: TEvent);virtual; + destructor Done; virtual; + procedure AdaptHistoryToDir(Dir : string); + end; + + PFileDialog = ^TFileDialog; + TFileDialog = object(TDialog) + FileName: PFileInputLine; + FileList: PFileList; + FileHistory: PFileHistory; + WildCard: TWildStr; + Directory: PString; + constructor Init(AWildCard: TWildStr; const ATitle, + InputName: String; AOptions: Word; HistoryId: Byte); + constructor Load(var S: TStream); + destructor Done; virtual; + procedure GetData(var Rec); virtual; + procedure GetFileName(var S: PathStr); + procedure HandleEvent(var Event: TEvent); virtual; + procedure SetData(var Rec); virtual; + procedure Store(var S: TStream); + function Valid(Command: Word): Boolean; virtual; + private + procedure ReadDirectory; + end; + + { TDirEntry } + + PDirEntry = ^TDirEntry; + TDirEntry = record + DisplayText: PString; + Directory: PString; + end; { of TDirEntry } + + { TDirCollection is a collection of TDirEntry's used by } + { TDirListBox. } + + PDirCollection = ^TDirCollection; + TDirCollection = object(TCollection) + function GetItem(var S: TStream): Pointer; virtual; + procedure FreeItem(Item: Pointer); virtual; + procedure PutItem(var S: TStream; Item: Pointer); virtual; + end; + + { TDirListBox displays a tree of directories for use in the } + { TChDirDialog. } + + PDirListBox = ^TDirListBox; + TDirListBox = object(TListBox) + Dir: DirStr; + Cur: Word; + constructor Init(var Bounds: TRect; AScrollBar: PScrollBar); + destructor Done; virtual; + function GetText(Item,MaxLen: Sw_Integer): String; virtual; + procedure HandleEvent(var Event: TEvent); virtual; + function IsSelected(Item: Sw_Integer): Boolean; virtual; + procedure NewDirectory(var ADir: DirStr); + procedure SetState(AState: Word; Enable: Boolean); virtual; + end; + + { TChDirDialog is a standard change directory dialog. } + +const + cdNormal = $0000; { Option to use dialog immediately } + cdNoLoadDir = $0001; { Option to init the dialog to store on a stream } + cdHelpButton = $0002; { Put a help button in the dialog } + +type + + PChDirDialog = ^TChDirDialog; + TChDirDialog = object(TDialog) + DirInput: PInputLine; + DirList: PDirListBox; + OkButton: PButton; + ChDirButton: PButton; + constructor Init(AOptions: Word; HistoryId: Sw_Word); + constructor Load(var S: TStream); + function DataSize: Sw_Word; virtual; + procedure GetData(var Rec); virtual; + procedure HandleEvent(var Event: TEvent); virtual; + procedure SetData(var Rec); virtual; + procedure Store(var S: TStream); + function Valid(Command: Word): Boolean; virtual; + private + procedure SetUpDialog; + end; + + PEditChDirDialog = ^TEditChDirDialog; + TEditChDirDialog = Object(TChDirDialog) + { TEditChDirDialog allows setting/getting the starting directory. The + transfer record is a DirStr. } + function DataSize : Sw_Word; virtual; + procedure GetData (var Rec); virtual; + procedure SetData (var Rec); virtual; + end; { of TEditChDirDialog } + + + {#Z+} + PDirValidator = ^TDirValidator; + {#Z-} + TDirValidator = Object(TFilterValidator) + constructor Init; + function IsValid(const S: string): Boolean; virtual; + function IsValidInput(var S: string; SuppressFill: Boolean): Boolean; + virtual; + end; { of TDirValidator } + + + FileConfirmFunc = function (AFile : FNameStr) : Boolean; + { Functions of type FileConfirmFunc's are used to prompt the end user for + confirmation of an operation. + + FileConfirmFunc's should ask the user whether to perform the desired + action on the file named AFile. If the user elects to perform the + function FileConfirmFunc's return True, otherwise they return False. + + Using FileConfirmFunc's allows routines to be coded independant of the + user interface implemented. OWL and TurboVision are supported through + conditional defines. If you do not use either user interface you must + compile this unit with the conditional define cdNoMessages and set all + FileConfirmFunc variables to a valid function prior to calling any + routines in this unit. } + {#X ReplaceFile DeleteFile } + + +var + + ReplaceFile : FileConfirmFunc; + { ReplaceFile returns True if the end user elects to replace the existing + file with the new file, otherwise it returns False. + + ReplaceFile is only called when #CheckOnReplace# is True. } + {#X DeleteFile } + + DeleteFile : FileConfirmFunc; + { DeleteFile returns True if the end user elects to delete the file, + otherwise it returns False. + + DeleteFile is only called when #CheckOnDelete# is True. } + {#X ReplaceFile } + + +const + + CInfoPane = #30; + + { TStream registration records } + +function Contains(S1, S2: String): Boolean; + { Contains returns true if S1 contains any characters in S2. } + +function DriveValid(Drive: Char): Boolean; + { DriveValid returns True if Drive is a valid DOS drive. Drive valid works + by attempting to change the current directory to Drive, then restoring + the original directory. } + +function ExtractDir(AFile: FNameStr): DirStr; + { ExtractDir returns the path of AFile terminated with a trailing '\'. If + AFile contains no directory information, an empty string is returned. } + +function ExtractFileName(AFile: FNameStr): NameStr; + { ExtractFileName returns the file name without any directory or file + extension information. } + +function Equal(const S1, S2: String; Count: Sw_word): Boolean; + { Equal returns True if S1 equals S2 for up to Count characters. Equal is + case-insensitive. } + +function FileExists (AFile : FNameStr) : Boolean; + { FileExists looks for the file specified in AFile. If AFile is present + FileExists returns true, otherwise FileExists returns False. + + The search is performed relative to the current system directory, but + other directories may be searched by prefacing a file name with a valid + directory path. + + There is no check for a vaild file name or drive. Errrors are handled + internally and not reported in DosError. Critical errors are left to + the system's critical error handler. } + {#X OpenFile } + +function GetCurDir: DirStr; + { GetCurDir returns the current directory. The directory returned always + ends with a trailing backslash '\'. } + +function GetCurDrive: Char; + { GetCurDrive returns the letter of the current drive as reported by the + operating system. } + +function IsWild(const S: String): Boolean; + { IsWild returns True if S contains a question mark (?) or asterix (*). } + +function IsList(const S: String): Boolean; + { IsList returns True if S contains list separator (;) char } + +function IsDir(const S: String): Boolean; + { IsDir returns True if S is a valid DOS directory. } + +{procedure MakeResources;} + { MakeResources places a language specific version of all resources + needed for the StdDlg unit to function on the RezFile using the string + constants and variables in the Resource unit. The Resource unit and the + appropriate string lists must be initialized prior to calling this + procedure. } + +function NoWildChars(S: String): String; + { NoWildChars deletes the wild card characters ? and * from the string S + and returns the result. } + +function OpenFile (var AFile : FNameStr; HistoryID : Byte) : Boolean; + { OpenFile prompts the user to select a file using the file specifications + in AFile as the starting file and path. Wildcards are accepted. If the + user accepts a file OpenFile returns True, otherwise OpenFile returns + False. + + Note: The file returned may or may not exist. } + +function OpenNewFile (var AFile: FNameStr; HistoryID: Byte): Boolean; + { OpenNewFile allows the user to select a directory from disk and enter a + new file name. If the file name entered is an existing file the user is + optionally prompted for confirmation of replacing the file based on the + value in #CheckOnReplace#. If a file name is successfully entered, + OpenNewFile returns True. } + {#X OpenFile } + +function PathValid(var Path: PathStr): Boolean; + { PathValid returns True if Path is a valid DOS path name. Path may be a + file or directory name. Trailing '\'s are removed. } + +procedure RegisterStdDlg; + { RegisterStdDlg registers all objects in the StdDlg unit for stream + usage. } + +function SaveAs (var AFile : FNameStr; HistoryID : Word) : Boolean; + { SaveAs prompts the user for a file name using AFile as a template. If + AFile already exists and CheckOnReplace is True, the user is prompted + to replace the file. + + If a valid file name is entered SaveAs returns True, other SaveAs returns + False. } + +function SelectDir (var ADir : DirStr; HistoryID : Byte) : Boolean; + { SelectDir prompts the user to select a directory using ADir as the + starting directory. If a directory is selected, SelectDir returns True. + The directory returned is gauranteed to exist. } + +function ShrinkPath (AFile : FNameStr; MaxLen : Byte) : FNameStr; + { ShrinkPath returns a file name with a maximu length of MaxLen. + Internal directories are removed and replaced with elipses as needed to + make the file name fit in MaxLen. + + AFile must be a valid path name. } + +function StdDeleteFile (AFile : FNameStr) : Boolean; + { StdDeleteFile returns True if the end user elects to delete the file, + otherwise it returns False. + + DeleteFile is only called when CheckOnDelete is True. } + +function StdReplaceFile (AFile : FNameStr) : Boolean; + { StdReplaceFile returns True if the end user elects to replace the existing + AFile with the new AFile, otherwise it returns False. + + ReplaceFile is only called when CheckOnReplace is True. } + +function ValidFileName(var FileName: PathStr): Boolean; + { ValidFileName returns True if FileName is a valid DOS file name. } + + +const + CheckOnReplace : Boolean = True; + { CheckOnReplace is used by file functions. If a file exists, it is + optionally replaced based on the value of CheckOnReplace. + + If CheckOnReplace is False the file is replaced without asking the + user. If CheckOnReplace is True, the end user is asked to replace the + file using a call to ReplaceFile. + + CheckOnReplace is set to True by default. } + + CheckOnDelete : Boolean = True; + { CheckOnDelete is used by file and directory functions. If a file + exists, it is optionally deleted based on the value of CheckOnDelete. + + If CheckOnDelete is False the file or directory is deleted without + asking the user. If CheckOnDelete is True, the end user is asked to + delete the file/directory using a call to DeleteFile. + + CheckOnDelete is set to True by default. } + + + +const + RFileInputLine: TStreamRec = ( + ObjType: idFileInputLine; + VmtLink: Ofs(TypeOf(TFileInputLine)^); + Load: @TFileInputLine.Load; + Store: @TFileInputLine.Store + ); + + RFileCollection: TStreamRec = ( + ObjType: idFileCollection; + VmtLink: Ofs(TypeOf(TFileCollection)^); + Load: @TFileCollection.Load; + Store: @TFileCollection.Store + ); + + RFileList: TStreamRec = ( + ObjType: idFileList; + VmtLink: Ofs(TypeOf(TFileList)^); + Load: @TFileList.Load; + Store: @TFileList.Store + ); + + RFileInfoPane: TStreamRec = ( + ObjType: idFileInfoPane; + VmtLink: Ofs(TypeOf(TFileInfoPane)^); + Load: @TFileInfoPane.Load; + Store: @TFileInfoPane.Store + ); + + RFileDialog: TStreamRec = ( + ObjType: idFileDialog; + VmtLink: Ofs(TypeOf(TFileDialog)^); + Load: @TFileDialog.Load; + Store: @TFileDialog.Store + ); + + RDirCollection: TStreamRec = ( + ObjType: idDirCollection; + VmtLink: Ofs(TypeOf(TDirCollection)^); + Load: @TDirCollection.Load; + Store: @TDirCollection.Store + ); + + RDirListBox: TStreamRec = ( + ObjType: idDirListBox; + VmtLink: Ofs(TypeOf(TDirListBox)^); + Load: @TDirListBox.Load; + Store: @TDirListBox.Store + ); + + RChDirDialog: TStreamRec = ( + ObjType: idChDirDialog; + VmtLink: Ofs(TypeOf(TChDirDialog)^); + Load: @TChDirDialog.Load; + Store: @TChDirDialog.Store + ); + + RSortedListBox: TStreamRec = ( + ObjType: idSortedListBox; + VmtLink: Ofs(TypeOf(TSortedListBox)^); + Load: @TSortedListBox.Load; + Store: @TSortedListBox.Store + ); + + REditChDirDialog : TStreamRec = ( + ObjType : idEditChDirDialog; + VmtLink : Ofs(TypeOf(TEditChDirDialog)^); + Load : @TEditChDirDialog.Load; + Store : @TEditChDirDialog.Store); + + +implementation + +{****************************************************************************} +{ Local Declarations } +{****************************************************************************} + +uses + App, {Memory,} HistList, MsgBox{, Resource}; + +type + + PStringRec = record + { PStringRec is needed for properly displaying PStrings using + MessageBox. } + AString : PString; + end; + +resourcestring sChangeDirectory='Change Directory'; + sDeleteFile='Delete file?'#13#10#13#3'%s'; + sDirectory='Directory'; + sDrives='Drives'; + sInvalidDirectory='Invalid directory.'; + sInvalidDriveOrDir='Invalid drive or directory.'; + sInvalidFileName='Invalid file name.'; + sOpen='Open'; + sReplaceFile='Replace file?'#13#10#13#3'%s'; + sSaveAs='Save As'; + sTooManyFiles='Too many files.'; + + smApr='Apr'; + smAug='Aug'; + smDec='Dec'; + smFeb='Feb'; + smJan='Jan'; + smJul='Jul'; + smJun='Jun'; + smMar='Mar'; + smMay='May'; + smNov='Nov'; + smOct='Oct'; + smSep='Sep'; + + slChDir='~C~hdir'; + slClear='C~l~ear'; + slDirectoryName='Directory ~n~ame'; + slDirectoryTree='Directory ~t~ree'; + slFiles='~F~iles'; + slReplace='~R~eplace'; + slRevert='~R~evert'; + +{****************************************************************************} +{ PathValid } +{****************************************************************************} +{$ifdef go32v2} +{$define NetDrive} +{$endif go32v2} +{$ifdef win32} +{$define NetDrive} +{$endif win32} + +procedure RemoveDoubleDirSep(var ExpPath : PathStr); +var + p: longint; +{$ifdef NetDrive} + OneDirSepRemoved: boolean; +{$endif NetDrive} +begin + p:=pos(DirSeparator+DirSeparator,ExpPath); +{$ifdef NetDrive} + if p=1 then + begin + ExpPath:=Copy(ExpPath,1,high(ExpPath)); + OneDirSepRemoved:=true; + p:=pos(DirSeparator+DirSeparator,ExpPath); + end + else + OneDirSepRemoved:=false; +{$endif NetDrive} + while p>0 do + begin + ExpPath:=Copy(ExpPath,1,p)+Copy(ExpPath,p+2,high(ExpPath)); + p:=pos(DirSeparator+DirSeparator,ExpPath); + end; +{$ifdef NetDrive} + if OneDirSepRemoved then + ExpPath:=DirSeparator+ExpPath; +{$endif NetDrive} +end; + +function PathValid (var Path: PathStr): Boolean; +var + ExpPath: PathStr; + SR: SearchRec; +begin + RemoveDoubleDirSep(Path); + ExpPath := FExpand(Path); +{$ifdef HAS_DOS_DRIVES} + if (Length(ExpPath) <= 3) then + PathValid := DriveValid(ExpPath[1]) + else +{$endif} + begin + { do not change '/' into '' } + if (Length(ExpPath)>1) and (ExpPath[Length(ExpPath)] = DirSeparator) then + Dec(ExpPath[0]); + FindFirst(ExpPath, Directory, SR); + PathValid := (DosError = 0) and (SR.Attr and Directory <> 0); +{$ifdef NetDrive} + if (DosError<>0) and (length(ExpPath)>2) and + (ExpPath[1]='\') and (ExpPath[2]='\')then + begin + { Checking '\\machine\sharedfolder' directly always fails.. + rather try '\\machine\sharedfolder\*' PM } + {$ifdef fpc} + FindClose(SR); + {$endif} + FindFirst(ExpPath+'\*',AnyFile,SR); + PathValid:=(DosError = 0); + end; +{$endif NetDrive} + {$ifdef fpc} + FindClose(SR); + {$endif} + end; +end; + +{****************************************************************************} +{ TDirValidator Object } +{****************************************************************************} +{****************************************************************************} +{ TDirValidator.Init } +{****************************************************************************} +constructor TDirValidator.Init; +const { What should this list be? The commented one doesn't allow home, + end, right arrow, left arrow, Ctrl+XXXX, etc. } + Chars: TCharSet = ['A'..'Z','a'..'z','.','~',':','_','-']; +{ Chars: TCharSet = [#0..#255]; } +begin + Chars := Chars + [DirSeparator]; + if not inherited Init(Chars) then + Fail; +end; + +{****************************************************************************} +{ TDirValidator.IsValid } +{****************************************************************************} +function TDirValidator.IsValid(const S: string): Boolean; +begin +{ IsValid := False; } + IsValid := True; +end; + +{****************************************************************************} +{ TDirValidator.IsValidInput } +{****************************************************************************} +function TDirValidator.IsValidInput(var S: string; SuppressFill: Boolean): Boolean; +begin +{ IsValid := False; } + IsValidInput := True; +end; + +{****************************************************************************} +{ TFileInputLine Object } +{****************************************************************************} +{****************************************************************************} +{ TFileInputLine.Init } +{****************************************************************************} +constructor TFileInputLine.Init(var Bounds: TRect; AMaxLen: Sw_Integer); +begin + TInputLine.Init(Bounds, AMaxLen); + EventMask := EventMask or evBroadcast; +end; + +{****************************************************************************} +{ TFileInputLine.HandleEvent } +{****************************************************************************} +procedure TFileInputLine.HandleEvent(var Event: TEvent); +begin + TInputLine.HandleEvent(Event); + if (Event.What = evBroadcast) and (Event.Command = cmFileFocused) and + (State and sfSelected = 0) then + begin + if PSearchRec(Event.InfoPtr)^.Attr and Directory <> 0 then + begin + Data^ := PSearchRec(Event.InfoPtr)^.Name + DirSeparator + + PFileDialog(Owner)^.WildCard; + { PFileDialog(Owner)^.FileHistory^.AdaptHistoryToDir( + PSearchRec(Event.InfoPtr)^.Name+DirSeparator);} + end + else Data^ := PSearchRec(Event.InfoPtr)^.Name; + DrawView; + end; +end; + +{****************************************************************************} +{ TFileCollection Object } +{****************************************************************************} +{****************************************************************************} +{ TFileCollection.Compare } +{****************************************************************************} + function uppername(const s : string) : string; + var + i : Sw_integer; + in_name : boolean; + begin + in_name:=true; + for i:=length(s) downto 1 do + if in_name and (s[i] in ['a'..'z']) then + uppername[i]:=char(byte(s[i])-32) + else + begin + uppername[i]:=s[i]; + if s[i] = DirSeparator then + in_name:=false; + end; + uppername[0]:=s[0]; + end; + +function TFileCollection.Compare(Key1, Key2: Pointer): Sw_Integer; +begin + if PSearchRec(Key1)^.Name = PSearchRec(Key2)^.Name then Compare := 0 + else if PSearchRec(Key1)^.Name = '..' then Compare := 1 + else if PSearchRec(Key2)^.Name = '..' then Compare := -1 + else if (PSearchRec(Key1)^.Attr and Directory <> 0) and + (PSearchRec(Key2)^.Attr and Directory = 0) then Compare := 1 + else if (PSearchRec(Key2)^.Attr and Directory <> 0) and + (PSearchRec(Key1)^.Attr and Directory = 0) then Compare := -1 + else if UpperName(PSearchRec(Key1)^.Name) > UpperName(PSearchRec(Key2)^.Name) then + Compare := 1 +{$ifdef unix} + else if UpperName(PSearchRec(Key1)^.Name) < UpperName(PSearchRec(Key2)^.Name) then + Compare := -1 + else if PSearchRec(Key1)^.Name > PSearchRec(Key2)^.Name then + Compare := 1 +{$endif def unix} + else + Compare := -1; +end; + +{****************************************************************************} +{ TFileCollection.FreeItem } +{****************************************************************************} +procedure TFileCollection.FreeItem(Item: Pointer); +begin + Dispose(PSearchRec(Item)); +end; + +{****************************************************************************} +{ TFileCollection.GetItem } +{****************************************************************************} +function TFileCollection.GetItem(var S: TStream): Pointer; +var + Item: PSearchRec; +begin + New(Item); + S.Read(Item^, SizeOf(TSearchRec)); + GetItem := Item; +end; + +{****************************************************************************} +{ TFileCollection.PutItem } +{****************************************************************************} +procedure TFileCollection.PutItem(var S: TStream; Item: Pointer); +begin + S.Write(Item^, SizeOf(TSearchRec)); +end; + + +{***************************************************************************** + TFileList +*****************************************************************************} + +const + ListSeparator=';'; + +function MatchesMask(What, Mask: string): boolean; + + function upper(const s : string) : string; + var + i : Sw_integer; + begin + for i:=1 to length(s) do + if s[i] in ['a'..'z'] then + upper[i]:=char(byte(s[i])-32) + else + upper[i]:=s[i]; + upper[0]:=s[0]; + end; + + Function CmpStr(const hstr1,hstr2:string):boolean; + var + found : boolean; + i1,i2 : Sw_integer; + begin + i1:=0; + i2:=0; + if hstr1='' then + begin + CmpStr:=(hstr2=''); + exit; + end; + found:=true; + repeat + inc(i1); + if (i1>length(hstr1)) then + break; + inc(i2); + if (i2>length(hstr2)) then + break; + case hstr1[i1] of + '?' : + found:=true; + '*' : + begin + found:=true; + if (i1=length(hstr1)) then + i2:=length(hstr2) + else + if (i1<length(hstr1)) and (hstr1[i1+1]<>hstr2[i2]) then + begin + if i2<length(hstr2) then + dec(i1) + end + else + if i2>1 then + dec(i2); + end; + else + found:=(hstr1[i1]=hstr2[i2]) or (hstr2[i2]='?'); + end; + until not found; + if found then + begin + found:=(i2>=length(hstr2)) and + ( + (i1>length(hstr1)) or + ((i1=length(hstr1)) and + (hstr1[i1]='*')) + ); + end; + CmpStr:=found; + end; + +var + D1,D2 : DirStr; + N1,N2 : NameStr; + E1,E2 : Extstr; +begin +{$ifdef Unix} + FSplit(What,D1,N1,E1); + FSplit(Mask,D2,N2,E2); +{$else} + FSplit(Upper(What),D1,N1,E1); + FSplit(Upper(Mask),D2,N2,E2); +{$endif} + MatchesMask:=CmpStr(N2,N1) and CmpStr(E2,E1); +end; + +function MatchesMaskList(What, MaskList: string): boolean; +var P: integer; + Match: boolean; +begin + Match:=false; + if What<>'' then + repeat + P:=Pos(ListSeparator, MaskList); + if P=0 then P:=length(MaskList)+1; + Match:=MatchesMask(What,copy(MaskList,1,P-1)); + Delete(MaskList,1,P); + until Match or (MaskList=''); + MatchesMaskList:=Match; +end; + +constructor TFileList.Init(var Bounds: TRect; AScrollBar: PScrollBar); +begin + TSortedListBox.Init(Bounds, 2, AScrollBar); +end; + +destructor TFileList.Done; +begin + if List <> nil then Dispose(List, Done); + TListBox.Done; +end; + +function TFileList.DataSize: Sw_Word; +begin + DataSize := 0; +end; + +procedure TFileList.FocusItem(Item: Sw_Integer); +begin + TSortedListBox.FocusItem(Item); + if (List^.Count > 0) then + Message(Owner, evBroadcast, cmFileFocused, List^.At(Item)); +end; + +procedure TFileList.GetData(var Rec); +begin +end; + +function TFileList.GetKey(var S: String): Pointer; +const + SR: TSearchRec = (); + +procedure UpStr(var S: String); +var + I: Sw_Integer; +begin + for I := 1 to Length(S) do S[I] := UpCase(S[I]); +end; + +begin + if (HandleDir{ShiftState and $03 <> 0}) or ((S <> '') and (S[1]='.')) then + SR.Attr := Directory + else SR.Attr := 0; + SR.Name := S; +{$ifndef Unix} + UpStr(SR.Name); +{$endif Unix} + GetKey := @SR; +end; + +function TFileList.GetText(Item,MaxLen: Sw_Integer): String; +var + S: String; + SR: PSearchRec; +begin + SR := PSearchRec(List^.At(Item)); + S := SR^.Name; + if SR^.Attr and Directory <> 0 then + begin + S[Length(S)+1] := DirSeparator; + Inc(S[0]); + end; + GetText := S; +end; + +procedure TFileList.HandleEvent(var Event: TEvent); +var + S : String; + K : pointer; + Value : Sw_integer; +begin + if (Event.What = evMouseDown) and (Event.Double) then + begin + Event.What := evCommand; + Event.Command := cmOK; + PutEvent(Event); + ClearEvent(Event); + end + else if (Event.What = evKeyDown) and (Event.CharCode='<') then + begin + { select '..' } + S := '..'; + K := GetKey(S); + If PSortedCollection(List)^.Search(K, Value) then + FocusItem(Value); + end + else TSortedListBox.HandleEvent(Event); +end; + +procedure TFileList.ReadDirectory(AWildCard: PathStr); +const + FindAttr = ReadOnly + Archive; + PrevDir = '..'; +var + S: SearchRec; + P: PSearchRec; + FileList: PFileCollection; + NumFiles: Word; + FindStr, + WildName : string; + Dir: DirStr; + Ext: ExtStr; + Name: NameStr; + Event : TEvent; + Tmp: PathStr; +begin + NumFiles := 0; + FileList := New(PFileCollection, Init(5, 5)); + AWildCard := FExpand(AWildCard); + FSplit(AWildCard, Dir, Name, Ext); + if pos(ListSeparator,AWildCard)>0 then + begin + WildName:=Copy(AWildCard,length(Dir)+1,255); + FindStr:=Dir+AllFiles; + end + else + begin + WildName:=Name+Ext; + FindStr:=AWildCard; + end; + FindFirst(FindStr, FindAttr, S); + P := PSearchRec(@P); + while assigned(P) and (DosError = 0) do + begin + if (S.Attr and Directory = 0) and + MatchesMaskList(S.Name,WildName) then + begin +{ P := MemAlloc(SizeOf(P^)); + if assigned(P) then + begin} + new(P); + P^.Attr:=S.Attr; + P^.Time:=S.Time; + P^.Size:=S.Size; + P^.Name:=S.Name; + FileList^.Insert(P); +{ end;} + end; + FindNext(S); + end; + {$ifdef fpc} + FindClose(S); + {$endif} + + Tmp := Dir + AllFiles; + FindFirst(Tmp, Directory, S); + while (P <> nil) and (DosError = 0) do + begin + if (S.Attr and Directory <> 0) and (S.Name <> '.') and (S.Name <> '..') then + begin +{ P := MemAlloc(SizeOf(P^)); + if P <> nil then + begin} + new(p); + P^.Attr:=S.Attr; + P^.Time:=S.Time; + P^.Size:=S.Size; + P^.Name:=S.Name; + FileList^.Insert(P); +{ end;} + end; + FindNext(S); + end; + {$ifdef fpc} + FindClose(S); + {$endif} + {$ifndef Unix} + if Length(Dir) > 4 then + {$endif not Unix} + begin +{ + P := MemAlloc(SizeOf(P^)); + if P <> nil then + begin} + new(p); + FindFirst(Tmp, Directory, S); + FindNext(S); + if (DosError = 0) and (S.Name = PrevDir) then + begin + P^.Attr:=S.Attr; + P^.Time:=S.Time; + P^.Size:=S.Size; + P^.Name:=S.Name; + end + else + begin + P^.Name := PrevDir; + P^.Size := 0; + P^.Time := $210000; + P^.Attr := Directory; + end; + FileList^.Insert(PSearchRec(P)); + {$ifdef fpc} + FindClose(S); + {$endif} +{ end;} + end; + if P = nil then + MessageBox(sTooManyFiles, nil, mfOkButton + mfWarning); + NewList(FileList); + if List^.Count > 0 then + begin + Event.What := evBroadcast; + Event.Command := cmFileFocused; + Event.InfoPtr := List^.At(0); + Owner^.HandleEvent(Event); + end; +end; + +procedure TFileList.SetData(var Rec); +begin + with PFileDialog(Owner)^ do + Self.ReadDirectory(Directory^ + WildCard); +end; + +{****************************************************************************} +{ TFileInfoPane Object } +{****************************************************************************} +{****************************************************************************} +{ TFileInfoPane.Init } +{****************************************************************************} +constructor TFileInfoPane.Init(var Bounds: TRect); +begin + TView.Init(Bounds); + FillChar(S,SizeOf(S),#0); + EventMask := EventMask or evBroadcast; +end; + +{****************************************************************************} +{ TFileInfoPane.Draw } +{****************************************************************************} +procedure TFileInfoPane.Draw; +var + B: TDrawBuffer; + D: String[9]; + M: String[3]; + PM: Boolean; + Color: Word; + Time: DateTime; + Path: PathStr; + FmtId: String; + Params: array[0..7] of PtruInt; + Str: String[80]; +const + sDirectoryLine = ' %-12s %-9s %3s %2d, %4d %2d:%02d%cm'; + sFileLine = ' %-12s %-9d %3s %2d, %4d %2d:%02d%cm'; + InValidFiles : array[0..2] of string[12] = ('','.','..'); +var + Month: array[1..12] of String[3]; +begin + Month[1] := smJan; + Month[2] := smFeb; + Month[3] := smMar; + Month[4] := smApr; + Month[5] := smMay; + Month[6] := smJun; + Month[7] := smJul; + Month[8] := smAug; + Month[9] := smSep; + Month[10] := smOct; + Month[11] := smNov; + Month[12] := smDec; + { Display path } + if (PFileDialog(Owner)^.Directory <> nil) then + Path := PFileDialog(Owner)^.Directory^ + else Path := ''; + Path := FExpand(Path+PFileDialog(Owner)^.WildCard); + { avoid B Buffer overflow PM } + Path := ShrinkPath(Path, Size.X - 1); + Color := GetColor($01); + MoveChar(B, ' ', Color, Size.X); { fill with empty spaces } + WriteLine(0, 0, Size.X, Size.Y, B); + MoveStr(B[1], Path, Color); + WriteLine(0, 0, Size.X, 1, B); + if (S.Name = InValidFiles[0]) or (S.Name = InValidFiles[1]) or + (S.Name = InValidFiles[2]) then + Exit; + + { Display file } + Params[0] := ptruint(@S.Name); + if S.Attr and Directory <> 0 then + begin + FmtId := sDirectoryLine; + D := sDirectory; + Params[1] := ptruint(@D); + end else + begin + FmtId := sFileLine; + Params[1] := S.Size; + end; + UnpackTime(S.Time, Time); + M := Month[Time.Month]; + Params[2] := ptruint(@M); + Params[3] := Time.Day; + Params[4] := Time.Year; + PM := Time.Hour >= 12; + Time.Hour := Time.Hour mod 12; + if Time.Hour = 0 then Time.Hour := 12; + Params[5] := Time.Hour; + Params[6] := Time.Min; + if PM then + Params[7] := Byte('p') + else Params[7] := Byte('a'); + FormatStr(Str, FmtId, Params); + MoveStr(B, Str, Color); + WriteLine(0, 1, Size.X, 1, B); + + { Fill in rest of rectangle } + MoveChar(B, ' ', Color, Size.X); + WriteLine(0, 2, Size.X, Size.Y-2, B); +end; + +function TFileInfoPane.GetPalette: PPalette; +const + P: String[Length(CInfoPane)] = CInfoPane; +begin + GetPalette := PPalette(@P); +end; + +procedure TFileInfoPane.HandleEvent(var Event: TEvent); +begin + TView.HandleEvent(Event); + if (Event.What = evBroadcast) and (Event.Command = cmFileFocused) then + begin + S := PSearchRec(Event.InfoPtr)^; + DrawView; + end; +end; + +{**************************************************************************** + TFileHistory +****************************************************************************} + + function LTrim(const S: String): String; + var + I: Sw_Integer; + begin + I := 1; + while (I < Length(S)) and (S[I] = ' ') do Inc(I); + LTrim := Copy(S, I, 255); + end; + + function RTrim(const S: String): String; + var + I: Sw_Integer; + begin + I := Length(S); + while S[I] = ' ' do Dec(I); + RTrim := Copy(S, 1, I); + end; + + function RelativePath(var S: PathStr): Boolean; + begin + S := LTrim(RTrim(S)); + RelativePath := not ((S <> '') and ((S[1] = DirSeparator) or (S[2] = ':'))); + end; + +{ try to reduce the length of S+dir as a file path+pattern } + + function Simplify (var S,Dir : string) : string; + var i : sw_integer; + begin + if RelativePath(Dir) then + begin + if (S<>'') and (Copy(Dir,1,3)='..'+DirSeparator) then + begin + i:=Length(S); + for i:=Length(S)-1 downto 1 do + if S[i]=DirSeparator then + break; + if S[i]=DirSeparator then + Simplify:=Copy(S,1,i)+Copy(Dir,4,255) + else + Simplify:=S+Dir; + end + else + Simplify:=S+Dir; + end + else + Simplify:=Dir; + end; + +{****************************************************************************} +{ TFileHistory.HandleEvent } +{****************************************************************************} + +procedure TFileHistory.HandleEvent(var Event: TEvent); +var + HistoryWindow: PHistoryWindow; + R,P: TRect; + C: Word; + Rslt: String; +begin + TView.HandleEvent(Event); + if (Event.What = evMouseDown) or + ((Event.What = evKeyDown) and (CtrlToArrow(Event.KeyCode) = kbDown) and + (Link^.State and sfFocused <> 0)) then + begin + if not Link^.Focus then + begin + ClearEvent(Event); + Exit; + end; + if assigned(CurDir) then + Rslt:=CurDir^ + else + Rslt:=''; + Rslt:=Simplify(Rslt,Link^.Data^); + RemoveDoubleDirSep(Rslt); + If IsWild(Rslt) then + RecordHistory(Rslt); + Link^.GetBounds(R); + Dec(R.A.X); Inc(R.B.X); Inc(R.B.Y,7); Dec(R.A.Y,1); + Owner^.GetExtent(P); + R.Intersect(P); + Dec(R.B.Y,1); + HistoryWindow := InitHistoryWindow(R); + if HistoryWindow <> nil then + begin + C := Owner^.ExecView(HistoryWindow); + if C = cmOk then + begin + Rslt := HistoryWindow^.GetSelection; + if Length(Rslt) > Link^.MaxLen then Rslt[0] := Char(Link^.MaxLen); + Link^.Data^ := Rslt; + Link^.SelectAll(True); + Link^.DrawView; + end; + Dispose(HistoryWindow, Done); + end; + ClearEvent(Event); + end + else if (Event.What = evBroadcast) then + if ((Event.Command = cmReleasedFocus) and (Event.InfoPtr = Link)) + or (Event.Command = cmRecordHistory) then + begin + if assigned(CurDir) then + Rslt:=CurDir^ + else + Rslt:=''; + Rslt:=Simplify(Rslt,Link^.Data^); + RemoveDoubleDirSep(Rslt); + If IsWild(Rslt) then + RecordHistory(Rslt); + end; +end; + +procedure TFileHistory.AdaptHistoryToDir(Dir : string); + var S,S2 : String; + i,Count : Sw_word; +begin + if assigned(CurDir) then + begin + S:=CurDir^; + if S=Dir then + exit; + DisposeStr(CurDir); + end + else + S:=''; + CurDir:=NewStr(Simplify(S,Dir)); + + Count:=HistoryCount(HistoryId); + for i:=1 to count do + begin + S2:=HistoryStr(HistoryId,1); + HistoryRemove(HistoryId,1); + if RelativePath(S2) then + if S<>'' then + S2:=S+S2 + else + S2:=FExpand(S2); + { simply full path + we should simplify relative to Dir ! } + HistoryAdd(HistoryId,S2); + end; + +end; + +destructor TFileHistory.Done; +begin + If assigned(CurDir) then + DisposeStr(CurDir); + Inherited Done; +end; + +{**************************************************************************** + TFileDialog +****************************************************************************} + +constructor TFileDialog.Init(AWildCard: TWildStr; const ATitle, + InputName: String; AOptions: Word; HistoryId: Byte); +var + Control: PView; + R: TRect; + Opt: Word; +begin + R.Assign(15,1,64,20); + TDialog.Init(R, ATitle); + Options := Options or ofCentered; + WildCard := AWildCard; + + R.Assign(3,3,31,4); + FileName := New(PFileInputLine, Init(R, 79)); + FileName^.Data^ := WildCard; + Insert(FileName); + R.Assign(2,2,3+CStrLen(InputName),3); + Control := New(PLabel, Init(R, InputName, FileName)); + Insert(Control); + R.Assign(31,3,34,4); + FileHistory := New(PFileHistory, Init(R, FileName, HistoryId)); + Insert(FileHistory); + + R.Assign(3,14,34,15); + Control := New(PScrollBar, Init(R)); + Insert(Control); + R.Assign(3,6,34,14); + FileList := New(PFileList, Init(R, PScrollBar(Control))); + Insert(FileList); + R.Assign(2,5,8,6); + Control := New(PLabel, Init(R, slFiles, FileList)); + Insert(Control); + + R.Assign(35,3,46,5); + Opt := bfDefault; + if AOptions and fdOpenButton <> 0 then + begin + Insert(New(PButton, Init(R,slOpen, cmFileOpen, Opt))); + Opt := bfNormal; + Inc(R.A.Y,3); Inc(R.B.Y,3); + end; + if AOptions and fdOkButton <> 0 then + begin + Insert(New(PButton, Init(R,slOk, cmFileOpen, Opt))); + Opt := bfNormal; + Inc(R.A.Y,3); Inc(R.B.Y,3); + end; + if AOptions and fdReplaceButton <> 0 then + begin + Insert(New(PButton, Init(R, slReplace,cmFileReplace, Opt))); + Opt := bfNormal; + Inc(R.A.Y,3); Inc(R.B.Y,3); + end; + if AOptions and fdClearButton <> 0 then + begin + Insert(New(PButton, Init(R, slClear,cmFileClear, Opt))); + Opt := bfNormal; + Inc(R.A.Y,3); Inc(R.B.Y,3); + end; + Insert(New(PButton, Init(R, slCancel, cmCancel, bfNormal))); + Inc(R.A.Y,3); Inc(R.B.Y,3); + if AOptions and fdHelpButton <> 0 then + begin + Insert(New(PButton, Init(R,slHelp,cmHelp, bfNormal))); + Inc(R.A.Y,3); Inc(R.B.Y,3); + end; + + R.Assign(1,16,48,18); + Control := New(PFileInfoPane, Init(R)); + Insert(Control); + + SelectNext(False); + + if AOptions and fdNoLoadDir = 0 then ReadDirectory; +end; + +constructor TFileDialog.Load(var S: TStream); +begin + if not TDialog.Load(S) then + Fail; + S.Read(WildCard, SizeOf(WildCard)); + if (S.Status <> stOk) then + begin + TDialog.Done; + Fail; + end; + GetSubViewPtr(S, FileName); + GetSubViewPtr(S, FileList); + GetSubViewPtr(S, FileHistory); + ReadDirectory; + if (DosError <> 0) then + begin + TDialog.Done; + Fail; + end; +end; + +destructor TFileDialog.Done; +begin + DisposeStr(Directory); + TDialog.Done; +end; + +procedure TFileDialog.GetData(var Rec); +begin + GetFilename(PathStr(Rec)); +end; + +procedure TFileDialog.GetFileName(var S: PathStr); + +var + Path: PathStr; + Name: NameStr; + Ext: ExtStr; + TWild : string; + TPath: PathStr; + TName: NameStr; + TExt: NameStr; + i : Sw_integer; +begin + S := FileName^.Data^; + if RelativePath(S) then + begin + if (Directory <> nil) then + S := FExpand(Directory^ + S); + end + else + S := FExpand(S); + if Pos(ListSeparator,S)=0 then + begin + If FileExists(S) then + exit; + FSplit(S, Path, Name, Ext); + if ((Name = '') or (Ext = '')) and not IsDir(S) then + begin + TWild:=WildCard; + repeat + i:=Pos(ListSeparator,TWild); + if i=0 then + i:=length(TWild)+1; + FSplit(Copy(TWild,1,i-1), TPath, TName, TExt); + if ((Name = '') and (Ext = '')) then + S := Path + TName + TExt + else + if Name = '' then + S := Path + TName + Ext + else + if Ext = '' then + begin + if IsWild(Name) then + S := Path + Name + TExt + else + S := Path + Name + NoWildChars(TExt); + end; + if FileExists(S) then + break; + System.Delete(TWild,1,i); + until TWild=''; + if TWild='' then + S := Path + Name + Ext; + end; + end; +end; + +procedure TFileDialog.HandleEvent(var Event: TEvent); +begin + if (Event.What and evBroadcast <> 0) and + (Event.Command = cmListItemSelected) then + begin + EndModal(cmFileOpen); + ClearEvent(Event); + end; + TDialog.HandleEvent(Event); + if Event.What = evCommand then + case Event.Command of + cmFileOpen, cmFileReplace, cmFileClear: + begin + EndModal(Event.Command); + ClearEvent(Event); + end; + end; +end; + +procedure TFileDialog.SetData(var Rec); +begin + TDialog.SetData(Rec); + if (PathStr(Rec) <> '') and (IsWild(TWildStr(Rec))) then + begin + Valid(cmFileInit); + FileName^.Select; + end; +end; + +procedure TFileDialog.ReadDirectory; +begin + FileList^.ReadDirectory(WildCard); + FileHistory^.AdaptHistoryToDir(GetCurDir); + Directory := NewStr(GetCurDir); +end; + +procedure TFileDialog.Store(var S: TStream); +begin + TDialog.Store(S); + S.Write(WildCard, SizeOf(WildCard)); + PutSubViewPtr(S, FileName); + PutSubViewPtr(S, FileList); + PutSubViewPtr(S, FileHistory); +end; + +function TFileDialog.Valid(Command: Word): Boolean; +var + FName: PathStr; + Dir: DirStr; + Name: NameStr; + Ext: ExtStr; + + function CheckDirectory(var S: PathStr): Boolean; + begin + if not PathValid(S) then + begin + MessageBox(sInvalidDriveOrDir, nil, mfError + mfOkButton); + FileName^.Select; + CheckDirectory := False; + end else CheckDirectory := True; + end; + + function CompleteDir(const Path: string): string; + begin + { keep c: untouched PM } + if (Path<>'') and (Path[Length(Path)]<>DirSeparator) and + (Path[Length(Path)]<>':') then + CompleteDir:=Path+DirSeparator + else + CompleteDir:=Path; + end; + + function NormalizeDir(const Path: string): string; + var Root: boolean; + begin + Root:=false; + {$ifdef Unix} + if Path=DirSeparator then Root:=true; + {$else} + if (length(Path)=3) and (Upcase(Path[1]) in['A'..'Z']) and + (Path[2]=':') and (Path[3]=DirSeparator) then + Root:=true; + {$endif} + if (Root=false) and (copy(Path,length(Path),1)=DirSeparator) then + NormalizeDir:=copy(Path,1,length(Path)-1) + else + NormalizeDir:=Path; + end; +function NormalizeDirF(var S: openstring): boolean; +begin + S:=NormalizeDir(S); + NormalizeDirF:=true; +end; + +begin + if Command = 0 then + begin + Valid := True; + Exit; + end + else Valid := False; + if TDialog.Valid(Command) then + begin + GetFileName(FName); + if (Command <> cmCancel) and (Command <> cmFileClear) then + begin + if IsWild(FName) or IsList(FName) then + begin + FSplit(FName, Dir, Name, Ext); + if CheckDirectory(Dir) then + begin + FileHistory^.AdaptHistoryToDir(Dir); + DisposeStr(Directory); + Directory := NewStr(Dir); + if Pos(ListSeparator,FName)>0 then + WildCard:=Copy(FName,length(Dir)+1,255) + else + WildCard := Name+Ext; + if Command <> cmFileInit then + FileList^.Select; + FileList^.ReadDirectory(Directory^+WildCard); + end; + end + else + if NormalizeDirF(FName) then + { ^^ this is just a dummy if construct (the func always returns true, + it's just there, 'coz I don't want to rearrange the following "if"s... } + if IsDir(FName) then + begin + if CheckDirectory(FName) then + begin + FileHistory^.AdaptHistoryToDir(CompleteDir(FName)); + DisposeStr(Directory); + Directory := NewSTr(CompleteDir(FName)); + if Command <> cmFileInit then FileList^.Select; + FileList^.ReadDirectory(Directory^+WildCard); + end + end + else + if ValidFileName(FName) then + Valid := True + else + begin + MessageBox(^C + sInvalidFileName, nil, mfError + mfOkButton); + Valid := False; + end; + end + else Valid := True; + end; +end; + +{ TDirCollection } + +function TDirCollection.GetItem(var S: TStream): Pointer; +var + DirItem: PDirEntry; +begin + New(DirItem); + DirItem^.DisplayText := S.ReadStr; + DirItem^.Directory := S.ReadStr; + GetItem := DirItem; +end; + +procedure TDirCollection.FreeItem(Item: Pointer); +var + DirItem: PDirEntry absolute Item; +begin + DisposeStr(DirItem^.DisplayText); + DisposeStr(DirItem^.Directory); + Dispose(DirItem); +end; + +procedure TDirCollection.PutItem(var S: TStream; Item: Pointer); +var + DirItem: PDirEntry absolute Item; +begin + S.WriteStr(DirItem^.DisplayText); + S.WriteStr(DirItem^.Directory); +end; + +{ TDirListBox } + +const + DrivesS: String = ''; + Drives: PString = @DrivesS; + +constructor TDirListBox.Init(var Bounds: TRect; AScrollBar: + PScrollBar); +begin + DrivesS := sDrives; + TListBox.Init(Bounds, 1, AScrollBar); + Dir := ''; +end; + +destructor TDirListBox.Done; +begin + if (List <> nil) then + Dispose(List,Done); + TListBox.Done; +end; + +function TDirListBox.GetText(Item,MaxLen: Sw_Integer): String; +begin + GetText := PDirEntry(List^.At(Item))^.DisplayText^; +end; + +procedure TDirListBox.HandleEvent(var Event: TEvent); +begin + case Event.What of + evMouseDown: + if Event.Double then + begin + Event.What := evCommand; + Event.Command := cmChangeDir; + PutEvent(Event); + ClearEvent(Event); + end; + evKeyboard: + if (Event.CharCode = ' ') and + (PSearchRec(List^.At(Focused))^.Name = '..') then + NewDirectory(PSearchRec(List^.At(Focused))^.Name); + end; + TListBox.HandleEvent(Event); +end; + +function TDirListBox.IsSelected(Item: Sw_Integer): Boolean; +begin +{ IsSelected := Item = Cur; } + IsSelected := Inherited IsSelected(Item); +end; + +procedure TDirListBox.NewDirectory(var ADir: DirStr); +const + PathDir = 'ÀÄÂ'; + FirstDir = 'ÀÂÄ'; + MiddleDir = ' ÃÄ'; + LastDir = ' ÀÄ'; + IndentSize = ' '; +var + AList: PCollection; + NewDir, Dirct: DirStr; + C, OldC: Char; + S, Indent: String[80]; + P: PString; + NewCur: Word; + isFirst: Boolean; + SR: SearchRec; + I: Sw_Integer; + + function NewDirEntry(const DisplayText, Directory: String): PDirEntry;{$ifdef PPC_BP}near;{$endif} + var + DirEntry: PDirEntry; + begin + New(DirEntry); + DirEntry^.DisplayText := NewStr(DisplayText); + If Directory='' then + DirEntry^.Directory := NewStr(DirSeparator) + else + DirEntry^.Directory := NewStr(Directory); + NewDirEntry := DirEntry; + end; + +begin + Dir := ADir; + AList := New(PDirCollection, Init(5,5)); +{$ifdef HAS_DOS_DRIVES} + AList^.Insert(NewDirEntry(Drives^,Drives^)); + if Dir = Drives^ then + begin + isFirst := True; + OldC := ' '; + for C := 'A' to 'Z' do + begin + if (C < 'C') or DriveValid(C) then + begin + if OldC <> ' ' then + begin + if isFirst then + begin + S := FirstDir + OldC; + isFirst := False; + end + else S := MiddleDir + OldC; + AList^.Insert(NewDirEntry(S, OldC + ':' + DirSeparator)); + end; + if C = GetCurDrive then NewCur := AList^.Count; + OldC := C; + end; + end; + if OldC <> ' ' then + AList^.Insert(NewDirEntry(LastDir + OldC, OldC + ':' + DirSeparator)); + end + else +{$endif HAS_DOS_DRIVES} + begin + Indent := IndentSize; + NewDir := Dir; +{$ifdef HAS_DOS_DRIVES} + Dirct := Copy(NewDir,1,3); + AList^.Insert(NewDirEntry(PathDir + Dirct, Dirct)); + NewDir := Copy(NewDir,4,255); +{$else HAS_DOS_DRIVES} + Dirct := ''; +{$endif HAS_DOS_DRIVES} + while NewDir <> '' do + begin + I := Pos(DirSeparator,NewDir); + if I <> 0 then + begin + S := Copy(NewDir,1,I-1); + Dirct := Dirct + S; + AList^.Insert(NewDirEntry(Indent + PathDir + S, Dirct)); + NewDir := Copy(NewDir,I+1,255); + end + else + begin + Dirct := Dirct + NewDir; + AList^.Insert(NewDirEntry(Indent + PathDir + NewDir, Dirct)); + NewDir := ''; + end; + Indent := Indent + IndentSize; + Dirct := Dirct + DirSeparator; + end; + NewCur := AList^.Count-1; + isFirst := True; + NewDir := Dirct + AllFiles; + FindFirst(NewDir, Directory, SR); + while DosError = 0 do + begin + if (SR.Attr and Directory <> 0) and + (SR.Name <> '.') and (SR.Name <> '..') then + begin + if isFirst then + begin + S := FirstDir; + isFirst := False; + end else S := MiddleDir; + AList^.Insert(NewDirEntry(Indent + S + SR.Name, Dirct + SR.Name)); + end; + FindNext(SR); + end; + FindClose(SR); + P := PDirEntry(AList^.At(AList^.Count-1))^.DisplayText; + I := Pos('À',P^); + if I = 0 then + begin + I := Pos('Ã',P^); + if I <> 0 then P^[I] := 'À'; + end else + begin + P^[I+1] := 'Ä'; + P^[I+2] := 'Ä'; + end; + end; + NewList(AList); + FocusItem(NewCur); + Cur:=NewCur; +end; + +procedure TDirListBox.SetState(AState: Word; Enable: Boolean); +begin + TListBox.SetState(AState, Enable); + if AState and sfFocused <> 0 then + PChDirDialog(Owner)^.ChDirButton^.MakeDefault(Enable); +end; + +{****************************************************************************} +{ TChDirDialog Object } +{****************************************************************************} +{****************************************************************************} +{ TChDirDialog.Init } +{****************************************************************************} +constructor TChDirDialog.Init(AOptions: Word; HistoryId: Sw_Word); +var + R: TRect; + Control: PView; +begin + R.Assign(16, 2, 64, 20); + TDialog.Init(R,sChangeDirectory); + + Options := Options or ofCentered; + + R.Assign(3, 3, 30, 4); + DirInput := New(PInputLine, Init(R, FileNameLen+4)); + Insert(DirInput); + R.Assign(2, 2, 17, 3); + Control := New(PLabel, Init(R,slDirectoryName, DirInput)); + Insert(Control); + R.Assign(30, 3, 33, 4); + Control := New(PHistory, Init(R, DirInput, HistoryId)); + Insert(Control); + + R.Assign(32, 6, 33, 16); + Control := New(PScrollBar, Init(R)); + Insert(Control); + R.Assign(3, 6, 32, 16); + DirList := New(PDirListBox, Init(R, PScrollBar(Control))); + Insert(DirList); + R.Assign(2, 5, 17, 6); + Control := New(PLabel, Init(R, slDirectoryTree, DirList)); + Insert(Control); + + R.Assign(35, 6, 45, 8); + OkButton := New(PButton, Init(R, slOk, cmOK, bfDefault)); + Insert(OkButton); + Inc(R.A.Y,3); Inc(R.B.Y,3); + ChDirButton := New(PButton,Init(R,slChDir,cmChangeDir, + bfNormal)); + Insert(ChDirButton); + Inc(R.A.Y,3); Inc(R.B.Y,3); + Insert(New(PButton, Init(R,slRevert, cmRevert, bfNormal))); + if AOptions and cdHelpButton <> 0 then + begin + Inc(R.A.Y,3); Inc(R.B.Y,3); + Insert(New(PButton, Init(R,slHelp, cmHelp, bfNormal))); + end; + + if AOptions and cdNoLoadDir = 0 then SetUpDialog; + + SelectNext(False); +end; + +{****************************************************************************} +{ TChDirDialog.Load } +{****************************************************************************} +constructor TChDirDialog.Load(var S: TStream); +begin + TDialog.Load(S); + GetSubViewPtr(S, DirList); + GetSubViewPtr(S, DirInput); + GetSubViewPtr(S, OkButton); + GetSubViewPtr(S, ChDirbutton); + SetUpDialog; +end; + +{****************************************************************************} +{ TChDirDialog.DataSize } +{****************************************************************************} +function TChDirDialog.DataSize: Sw_Word; +begin + DataSize := 0; +end; + +{****************************************************************************} +{ TChDirDialog.GetData } +{****************************************************************************} +procedure TChDirDialog.GetData(var Rec); +begin +end; + +{****************************************************************************} +{ TChDirDialog.HandleEvent } +{****************************************************************************} +procedure TChDirDialog.HandleEvent(var Event: TEvent); +var + CurDir: DirStr; + P: PDirEntry; +begin + TDialog.HandleEvent(Event); + case Event.What of + evCommand: + begin + case Event.Command of + cmRevert: GetDir(0,CurDir); + cmChangeDir: + begin + P := DirList^.List^.At(DirList^.Focused); + if (P^.Directory^ = Drives^) + or DriveValid(P^.Directory^[1]) then + CurDir := P^.Directory^ + else Exit; + end; + else + Exit; + end; + if (Length(CurDir) > 3) and + (CurDir[Length(CurDir)] = DirSeparator) then + CurDir := Copy(CurDir,1,Length(CurDir)-1); + DirList^.NewDirectory(CurDir); + DirInput^.Data^ := CurDir; + DirInput^.DrawView; + DirList^.Select; + ClearEvent(Event); + end; + end; +end; + +{****************************************************************************} +{ TChDirDialog.SetData } +{****************************************************************************} +procedure TChDirDialog.SetData(var Rec); +begin +end; + +{****************************************************************************} +{ TChDirDialog.SetUpDialog } +{****************************************************************************} +procedure TChDirDialog.SetUpDialog; +var + CurDir: DirStr; +begin + if DirList <> nil then + begin + CurDir := GetCurDir; + DirList^.NewDirectory(CurDir); + if (Length(CurDir) > 3) and (CurDir[Length(CurDir)] = DirSeparator) then + CurDir := Copy(CurDir,1,Length(CurDir)-1); + if DirInput <> nil then + begin + DirInput^.Data^ := CurDir; + DirInput^.DrawView; + end; + end; +end; + +{****************************************************************************} +{ TChDirDialog.Store } +{****************************************************************************} +procedure TChDirDialog.Store(var S: TStream); +begin + TDialog.Store(S); + PutSubViewPtr(S, DirList); + PutSubViewPtr(S, DirInput); + PutSubViewPtr(S, OkButton); + PutSubViewPtr(S, ChDirButton); +end; + +{****************************************************************************} +{ TChDirDialog.Valid } +{****************************************************************************} +function TChDirDialog.Valid(Command: Word): Boolean; +var + P: PathStr; +begin + Valid := True; + if Command = cmOk then + begin + P := FExpand(DirInput^.Data^); + if (Length(P) > 3) and (P[Length(P)] = DirSeparator) then + Dec(P[0]); + {$I-} + ChDir(P); + if (IOResult <> 0) then + begin + MessageBox(sInvalidDirectory, nil, mfError + mfOkButton); + Valid := False; + end; + {$I+} + end; +end; + +{****************************************************************************} +{ TEditChDirDialog Object } +{****************************************************************************} +{****************************************************************************} +{ TEditChDirDialog.DataSize } +{****************************************************************************} +function TEditChDirDialog.DataSize : Sw_Word; +begin + DataSize := SizeOf(DirStr); +end; + +{****************************************************************************} +{ TEditChDirDialog.GetData } +{****************************************************************************} +procedure TEditChDirDialog.GetData (var Rec); +var + CurDir : DirStr absolute Rec; +begin + if (DirInput = nil) then + CurDir := '' + else begin + CurDir := DirInput^.Data^; + if (CurDir[Length(CurDir)] <> DirSeparator) then + CurDir := CurDir + DirSeparator; + end; +end; + +{****************************************************************************} +{ TEditChDirDialog.SetData } +{****************************************************************************} +procedure TEditChDirDialog.SetData (var Rec); +var + CurDir : DirStr absolute Rec; +begin + if DirList <> nil then + begin + DirList^.NewDirectory(CurDir); + if DirInput <> nil then + begin + if (Length(CurDir) > 3) and (CurDir[Length(CurDir)] = DirSeparator) then + DirInput^.Data^ := Copy(CurDir,1,Length(CurDir)-1) + else DirInput^.Data^ := CurDir; + DirInput^.DrawView; + end; + end; +end; + +{****************************************************************************} +{ TSortedListBox Object } +{****************************************************************************} +{****************************************************************************} +{ TSortedListBox.Init } +{****************************************************************************} +constructor TSortedListBox.Init(var Bounds: TRect; ANumCols: Sw_Word; + AScrollBar: PScrollBar); +begin + TListBox.Init(Bounds, ANumCols, AScrollBar); + SearchPos := 0; + ShowCursor; + SetCursor(1,0); +end; + +{****************************************************************************} +{ TSortedListBox.HandleEvent } +{****************************************************************************} +procedure TSortedListBox.HandleEvent(var Event: TEvent); +const + SpecialChars: set of Char = [#0,#9,#27]; +var + CurString, NewString: String; + K: Pointer; + Value : Sw_integer; + OldPos, OldValue: Sw_Integer; + T: Boolean; +begin + OldValue := Focused; + TListBox.HandleEvent(Event); + if (OldValue <> Focused) or + ((Event.What = evBroadcast) and (Event.InfoPtr = @Self) and + (Event.Command = cmReleasedFocus)) then + SearchPos := 0; + if Event.What = evKeyDown then + begin + { patched to prevent error when no or empty list or Escape pressed } + if (not (Event.CharCode in SpecialChars)) and + (List <> nil) and (List^.Count > 0) then + begin + Value := Focused; + if Value < Range then + CurString := GetText(Value, 255) + else + CurString := ''; + OldPos := SearchPos; + if Event.KeyCode = kbBack then + begin + if SearchPos = 0 then Exit; + Dec(SearchPos); + if SearchPos = 0 then + HandleDir:= ((GetShiftState and $3) <> 0) or (Event.CharCode in ['A'..'Z']); + CurString[0] := Char(SearchPos); + end + else if (Event.CharCode = '.') then + SearchPos := Pos('.',CurString) + else + begin + Inc(SearchPos); + if SearchPos = 1 then + HandleDir := ((GetShiftState and 3) <> 0) or (Event.CharCode in ['A'..'Z']); + CurString[0] := Char(SearchPos); + CurString[SearchPos] := Event.CharCode; + end; + K := GetKey(CurString); + T := PSortedCollection(List)^.Search(K, Value); + if Value < Range then + begin + if Value < Range then + NewString := GetText(Value, 255) + else + NewString := ''; + if Equal(NewString, CurString, SearchPos) then + begin + if Value <> OldValue then + begin + FocusItem(Value); + { Assumes ListControl will set the cursor to the first character } + { of the sfFocused item } + SetCursor(Cursor.X+SearchPos, Cursor.Y); + end + else + SetCursor(Cursor.X+(SearchPos-OldPos), Cursor.Y); + end + else + SearchPos := OldPos; + end + else SearchPos := OldPos; + if (SearchPos <> OldPos) or (Event.CharCode in ['A'..'Z','a'..'z']) then + ClearEvent(Event); + end; + end; +end; + +function TSortedListBox.GetKey(var S: String): Pointer; +begin + GetKey := @S; +end; + +procedure TSortedListBox.NewList(AList: PCollection); +begin + TListBox.NewList(AList); + SearchPos := 0; +end; + +{****************************************************************************} +{ Global Procedures and Functions } +{****************************************************************************} + +{****************************************************************************} +{ Contains } +{****************************************************************************} +function Contains(S1, S2: String): Boolean; + { Contains returns true if S1 contains any characters in S2. } +var + i : Byte; +begin + Contains := True; + i := 1; + while ((i < Length(S2)) and (i < Length(S1))) do + if (Upcase(S1[i]) = Upcase(S2[i])) then + Exit + else Inc(i); + Contains := False; +end; + +{****************************************************************************} +{ StdDeleteFile } +{****************************************************************************} +function StdDeleteFile (AFile : FNameStr) : Boolean; +var + Rec : PStringRec; +begin + if CheckOnDelete then + begin + AFile := ShrinkPath(AFile,33); + Rec.AString := PString(@AFile); + StdDeleteFile := (MessageBox(^C + sDeleteFile, + @Rec,mfConfirmation or mfOkCancel) = cmOk); + end + else StdDeleteFile := False; +end; + +{****************************************************************************} +{ DriveValid } +{****************************************************************************} +function DriveValid(Drive: Char): Boolean; +{$ifdef HAS_DOS_DRIVES} +var + D: Char; +begin + D := GetCurDrive; + {$I-} + ChDir(Drive+':'); + if (IOResult = 0) then + begin + DriveValid := True; + ChDir(D+':') + end + else DriveValid := False; + {$I+} +end; +{$else HAS_DOS_DRIVES} +begin + DriveValid:=true; +end; +{$endif HAS_DOS_DRIVES} + +{****************************************************************************} +{ Equal } +{****************************************************************************} +function Equal(const S1, S2: String; Count: Sw_word): Boolean; +var + i: Sw_Word; +begin + Equal := False; + if (Length(S1) < Count) or (Length(S2) < Count) then + Exit; + for i := 1 to Count do + if UpCase(S1[I]) <> UpCase(S2[I]) then + Exit; + Equal := True; +end; + +{****************************************************************************} +{ ExtractDir } +{****************************************************************************} +function ExtractDir(AFile: FNameStr): DirStr; + { ExtractDir returns the path of AFile terminated with a trailing '\'. If + AFile contains no directory information, an empty string is returned. } +var + D: DirStr; + N: NameStr; + E: ExtStr; +begin + FSplit(AFile,D,N,E); + if D = '' then + begin + ExtractDir := ''; + Exit; + end; + if D[Byte(D[0])] <> DirSeparator then + D := D + DirSeparator; + ExtractDir := D; +end; + +{****************************************************************************} +{ ExtractFileName } +{****************************************************************************} +function ExtractFileName(AFile: FNameStr): NameStr; +var + D: DirStr; + N: NameStr; + E: ExtStr; +begin + FSplit(AFile,D,N,E); + ExtractFileName := N; +end; + +{****************************************************************************} +{ FileExists } +{****************************************************************************} +function FileExists (AFile : FNameStr) : Boolean; +begin + FileExists := (FSearch(AFile,'') <> ''); +end; + +{****************************************************************************} +{ GetCurDir } +{****************************************************************************} +function GetCurDir: DirStr; +var + CurDir: DirStr; +begin + GetDir(0, CurDir); + if (Length(CurDir) > 3) then + begin + Inc(CurDir[0]); + CurDir[Length(CurDir)] := DirSeparator; + end; + GetCurDir := CurDir; +end; + +{****************************************************************************} +{ GetCurDrive } +{****************************************************************************} +function GetCurDrive: Char; +{$ifdef go32v2} +var + Regs : Registers; +begin + Regs.AH := $19; + Intr($21,Regs); + GetCurDrive := Char(Regs.AL + Byte('A')); +end; +{$else not go32v2} +var + D : DirStr; +begin + D:=GetCurDir; + if (Length(D)>1) and (D[2]=':') then + begin + if (D[1]>='a') and (D[1]<='z') then + GetCurDrive:=Char(Byte(D[1])+Byte('A')-Byte('a')) + else + GetCurDrive:=D[1]; + end + else + GetCurDrive:='C'; +end; +{$endif not go32v2} + +{****************************************************************************} +{ IsDir } +{****************************************************************************} +function IsDir(const S: String): Boolean; +var + SR: SearchRec; + Is: boolean; +begin + Is:=false; +{$ifdef Unix} + Is:=(S=DirSeparator); { handle root } +{$else} + Is:=(length(S)=3) and (Upcase(S[1]) in['A'..'Z']) and (S[2]=':') and (S[3]=DirSeparator); + { handle root dirs } +{$endif} + if Is=false then + begin + FindFirst(S, Directory, SR); + if DosError = 0 then + Is := (SR.Attr and Directory) <> 0 + else + Is := False; + {$ifdef fpc} + FindClose(SR); + {$endif} + end; + IsDir:=Is; +end; + +{****************************************************************************} +{ IsWild } +{****************************************************************************} +function IsWild(const S: String): Boolean; +begin + IsWild := (Pos('?',S) > 0) or (Pos('*',S) > 0); +end; + +{****************************************************************************} +{ IsList } +{****************************************************************************} +function IsList(const S: String): Boolean; +begin + IsList := (Pos(ListSeparator,S) > 0); +end; + +{****************************************************************************} +{ MakeResources } +{****************************************************************************} +(* +procedure MakeResources; +var + Dlg : PDialog; + Key : String; + i : Word; +begin + for i := 0 to 1 do + begin + case i of + 0 : begin + Key := reOpenDlg; + Dlg := New(PFileDialog,Init('*.*',sOpen,slName, + fdOkButton or fdHelpButton or fdNoLoadDir,0)); + end; + 1 : begin + Key := reSaveAsDlg; + Dlg := New(PFileDialog,Init('*.*',sSaveAs,slName, + fdOkButton or fdHelpButton or fdNoLoadDir,0)); + end; + 2 : begin + Key := reEditChDirDialog; + Dlg := New(PEditChDirDialog,Init(cdHelpButton, + hiCurrentDirectories)); + end; + end; + if Dlg = nil then + begin + PrintStr('Error initializing dialog ' + Key); + Halt; + end + else begin + RezFile^.Put(Dlg,Key); + if (RezFile^.Stream^.Status <> stOk) then + begin + PrintStr('Error writing dialog ' + Key + ' to the resource file.'); + Halt; + end; + end; + end; +end; +*) +{****************************************************************************} +{ NoWildChars } +{****************************************************************************} +function NoWildChars(S: String): String; +const + WildChars : array[0..1] of Char = ('?','*'); +var + i : Sw_Word; +begin + repeat + i := Pos('?',S); + if (i > 0) then + System.Delete(S,i,1); + until (i = 0); + repeat + i := Pos('*',S); + if (i > 0) then + System.Delete(S,i,1); + until (i = 0); + NoWildChars:=S; +end; + +{****************************************************************************} +{ OpenFile } +{****************************************************************************} +function OpenFile (var AFile : FNameStr; HistoryID : Byte) : Boolean; +var + Dlg : PFileDialog; +begin + {$ifdef cdResource} + Dlg := PFileDialog(RezFile^.Get(reOpenDlg)); + {$else} + Dlg := New(PFileDialog,Init('*.*',sOpen,slName, + fdOkButton or fdHelpButton,0)); + {$endif cdResource} + { this might not work } + PHistory(Dlg^.FileName^.Next^.Next)^.HistoryID := HistoryID; + OpenFile := (Application^.ExecuteDialog(Dlg,@AFile) = cmFileOpen); +end; + +{****************************************************************************} +{ OpenNewFile } +{****************************************************************************} +function OpenNewFile (var AFile: FNameStr; HistoryID: Byte): Boolean; + { OpenNewFile allows the user to select a directory from disk and enter a + new file name. If the file name entered is an existing file the user is + optionally prompted for confirmation of replacing the file based on the + value in #CheckOnReplace#. If a file name is successfully entered, + OpenNewFile returns True. } + {#X OpenFile } +begin + OpenNewFile := False; + if OpenFile(AFile,HistoryID) then + begin + if not ValidFileName(AFile) then + Exit; + if FileExists(AFile) then + if (not CheckOnReplace) or (not ReplaceFile(AFile)) then + Exit; + OpenNewFile := True; + end; +end; + +{****************************************************************************} +{ RegisterStdDlg } +{****************************************************************************} +procedure RegisterStdDlg; +begin + RegisterType(RFileInputLine); + RegisterType(RFileCollection); + RegisterType(RFileList); + RegisterType(RFileInfoPane); + RegisterType(RFileDialog); + RegisterType(RDirCollection); + RegisterType(RDirListBox); + RegisterType(RSortedListBox); + RegisterType(RChDirDialog); +end; + +{****************************************************************************} +{ StdReplaceFile } +{****************************************************************************} +function StdReplaceFile (AFile : FNameStr) : Boolean; +var + Rec : PStringRec; +begin + if CheckOnReplace then + begin + AFile := ShrinkPath(AFile,33); + Rec.AString := PString(@AFile); + StdReplaceFile := + (MessageBox(^C + sReplaceFile, + @Rec,mfConfirmation or mfOkCancel) = cmOk); + end + else StdReplaceFile := True; +end; + +{****************************************************************************} +{ SaveAs } +{****************************************************************************} +function SaveAs (var AFile : FNameStr; HistoryID : Word) : Boolean; +var + Dlg : PFileDialog; +begin + SaveAs := False; + Dlg := New(PFileDialog,Init('*.*',sSaveAs,slSaveAs, + fdOkButton or fdHelpButton,0)); + { this might not work } + PHistory(Dlg^.FileName^.Next^.Next)^.HistoryID := HistoryID; + Dlg^.HelpCtx := hcSaveAs; + if (Application^.ExecuteDialog(Dlg,@AFile) = cmFileOpen) and + ((not FileExists(AFile)) or ReplaceFile(AFile)) then + SaveAs := True; +end; + +{****************************************************************************} +{ SelectDir } +{****************************************************************************} +function SelectDir (var ADir : DirStr; HistoryID : Byte) : Boolean; +var + Dir: DirStr; + Dlg : PEditChDirDialog; + Rec : DirStr; +begin + {$I-} + GetDir(0,Dir); + {$I+} + Rec := FExpand(ADir); + Dlg := New(PEditChDirDialog,Init(cdHelpButton,HistoryID)); + if (Application^.ExecuteDialog(Dlg,@Rec) = cmOk) then + begin + SelectDir := True; + ADir := Rec; + end + else SelectDir := False; + {$I-} + ChDir(Dir); + {$I+} +end; + +{****************************************************************************} +{ ShrinkPath } +{****************************************************************************} +function ShrinkPath (AFile : FNameStr; MaxLen : Byte) : FNameStr; +var + Filler: string; + D1 : DirStr; + N1 : NameStr; + E1 : ExtStr; + i : Sw_Word; + +begin + if Length(AFile) > MaxLen then + begin + FSplit(FExpand(AFile),D1,N1,E1); + AFile := Copy(D1,1,3) + '..' + DirSeparator; + i := Pred(Length(D1)); + while (i > 0) and (D1[i] <> DirSeparator) do + Dec(i); + if (i = 0) then + AFile := AFile + D1 + else AFile := AFile + Copy(D1,Succ(i),Length(D1)-i); + if AFile[Length(AFile)] <> DirSeparator then + AFile := AFile + DirSeparator; + if Length(AFile)+Length(N1)+Length(E1) <= MaxLen then + AFile := AFile + N1 + E1 + else + begin + Filler := '...' + DirSeparator; + AFile:=Copy(Afile,1,MaxLen-Length(Filler)-Length(N1)-Length(E1)) + +Filler+N1+E1; + end; + end; + ShrinkPath := AFile; +end; + +{****************************************************************************} +{ ValidFileName } +{****************************************************************************} +function ValidFileName(var FileName: PathStr): Boolean; +var + IllegalChars: string[12]; + Dir: DirStr; + Name: NameStr; + Ext: ExtStr; +begin +{$ifdef PPC_FPC} +{$ifdef go32v2} + { spaces are allowed if LFN is supported } + if LFNSupport then + IllegalChars := ';,=+<>|"[]'+DirSeparator + else + IllegalChars := ';,=+<>|"[] '+DirSeparator; +{$else not go32v2} +{$ifdef win32} + IllegalChars := ';,=+<>|"[]'+DirSeparator; +{$else not go32v2 and not win32 } + IllegalChars := ';,=+<>|"[] '+DirSeparator; +{$endif not win32} +{$endif not go32v2} +{$else not PPC_FPC} + IllegalChars := ';,=+<>|"[] '+DirSeparator; +{$endif PPC_FPC} + ValidFileName := True; + FSplit(FileName, Dir, Name, Ext); + if not ((Dir = '') or PathValid(Dir)) or + Contains(Name, IllegalChars) or + Contains(Dir, IllegalChars) then + ValidFileName := False; +end; + +{****************************************************************************} +{ Unit Initialization Section } +{****************************************************************************} +begin +{$ifdef PPC_BP} + ReplaceFile := StdReplaceFile; + DeleteFile := StdDeleteFile; +{$else} + ReplaceFile := @StdReplaceFile; + DeleteFile := @StdDeleteFile; +{$endif PPC_BP} +end. diff --git a/packages/fv/src/str.inc b/packages/fv/src/str.inc new file mode 100644 index 0000000000..c833c69155 --- /dev/null +++ b/packages/fv/src/str.inc @@ -0,0 +1,190 @@ +{ Strings } +sVideoFailed = 0; {Video initialization failed.} +sButtonDefault = 1; { Button default } +sButtonDisabled = 2; { Button disabled } +sButtonNormal = 3; { Button normal } +sButtonSelected = 4; { Button selected } +sButtonShadow = 5; { Button shadow } +sButtonShortcut = 6; { Button shortcut } +sChangeDirectory = 7; { Change Directory } +sClipboard = 8; { Clipboard } +sClusterNormal = 9; { Cluster normal } +sClusterSelected = 10; { Cluster selected } +sClusterShortcut = 11; { Cluster shortcut } +sColor = 12; { Color } +sColors = 13; { Colors } +sConfirm = 14; { Confirm } +sDeleteFile = 15; { Delete file?#13#10#13#3%s } +sDirectory = 16; { Directory } +sDisabled = 17; { Disabled } +sDrives = 18; { Drives } +sError = 19; { Error } +sFileAlreadyOpen = 20; { #3%s#13#10#13#3is already open in window %d. } +sFileCreateError = 21; { Error creating file %s } +sFileReadError = 22; { Error reading file %s } +sFileUntitled = 23; { Save untitled file? } +sFileWriteError = 24; { Error writing to file %s } +sFind = 25; { Find } +sFrameActive = 26; { Frame active } +sFrameBackground = 27; { Frame/background } +sFrameIcons = 28; { Frame icons } +sFramePassive = 29; { Frame passive } +sHighlight = 30; { Highlight } +sHistoryBarIcons = 31; { History bar icons } +sHistoryBarPage = 32; { History bar page } +sHistoryButton = 33; { History button } +sHistorySides = 34; { History sides } +sInformation = 35; { Information } +sInformationPane = 36; { Information pane } +sInputArrow = 37; { Input arrow } +sInputNormal = 38; { Input normal } +sInputSelected = 39; { Input selected } +sInvalidCharacter = 40; { Invalid character in input } +sInvalidDirectory = 41; { Invalid directory. } +sInvalidDriveOrDir = 42; { Invalid drive or directory. } +sInvalidFileName = 43; { Invalid file name. } +sInvalidPicture = 44; { Input does not conform to picture: %s } +sInvalidValue = 45; { Value not in the range %d to %d } +sInverse = 46; { Inverse } +sJumpTo = 47; { Jump To } +sLabelNormal = 48; { Label normal } +sLabelSelected = 49; { Label selected } +sLabelShortcut = 50; { Label shortcut } +sListDivider = 51; { List divider } +sListFocused = 52; { List focused } +sListNormal = 53; { List normal } +sListSelected = 54; { List selected } +sModified = 55; { #3%s#13#10#13#3has been modified. Save? } +sNoName = 56; { NONAME } +sNormal = 57; { Normal } +sNormalText = 58; { Normal text } +sNotInList = 59; { Input not in valid-list } +sOpen = 60; { Open } +sOutOfMemory = 61; { Not enough memory for this operation. } +sOutOfUnNamedWindows = 62; { Out of unnamed window numbers. Save or discard some unnamed files and try again. } +sPasteNotPossible = 63; { Wordwrap on: Paste not possible in current margins when at end of line. } +sReformatDocument = 64; { Reformat Document } +sReformatNotPossible = 65; { Paragraph reformat not possible while trying to wrap current line with current margins. } +sReformattingTheDocument = 66; { Reformatting the document: } +sReplace = 67; { Replace } +sReplaceFile = 68; { Replace file?#13#10#13#3%s } +sReplaceNotPossible = 69; { Wordwrap on: Replace not possible in current margins when at end of line. } +sReplaceThisOccurence = 70; { Replace this occurence? } +sRightMargin = 71; { Right Margin } +sSaveAs = 72; { Save As } +sScrollbarIcons = 73; { Scroll bar icons } +sScrollbarPage = 74; { Scroll bar page } +sSearchStringNotFound = 75; { Search string not found. } +sSelectFormatStart = 76; { Select Format Start } +sSelectWhereToBegin = 77; { Please select where to begin. } +sSelected = 78; { Selected } +sSelectedDisabled = 79; { Selected disabled } +sSetting = 80; { Setting: } +sShortcut = 81; { Shortcut } +sShortcutSelected = 82; { ShortcutSelected } +sStaticText = 83; { Static text } +sTabSettings = 84; { Tab Settings } +sText = 85; { Text } +sTooManyFiles = 86; { Too many files. } +sTypeExitOnReturn = 87; { Type EXIT to return... } +sUnderline = 88; { Underline } +sUnknownDialog = 89; { Unknown dialog requested! } +sUntitled = 90; { Untitled } +sWarning = 91; { Warning } +sWindowList = 92; { Window List } +sWordWrapNotPossible = 93; { Wordwrap on: Wordwrap not possible in current margins with continuous line. } +sWordWrapOff = 94; { You must turn on wordwrap before you can reformat. } +smApr = 95; { Apr } +smAug = 96; { Aug } +smDec = 97; { Dec } +smFeb = 98; { Feb } +smJan = 99; { Jan } +smJul = 100; { Jul } +smJun = 101; { Jun } +smMar = 102; { Mar } +smMay = 103; { May } +smNov = 104; { Nov } +smOct = 105; { Oct } +smSep = 106; { Sep } +{ Labels } +slAbout = 107; { ~A~bout } +slAltF1 = 108; { Alt+F1 } +slAltF3Close = 109; { ~Alt+F3~ Close } +slAltXExit = 110; { ~Alt-X~ Exit } +slBackground = 111; { ~B~ackground } +slCancel = 112; { Cancel } +slCascade = 113; { C~a~scade } +slCaseSensitive = 114; { ~C~ase sensitive } +slChDir = 115; { ~C~hdir } +slChangeDir = 116; { ~C~hange dir... } +slClear = 117; { C~l~ear } +slClose = 118; { ~C~lose } +slCloseAll = 119; { Cl~o~se all } +slColor = 120; { ~C~olor } +slContents = 121; { ~C~ontents } +slCopy = 122; { ~C~opy } +slCtrlF1 = 123; { Ctrl+F1 } +slCurrentLine = 124; { ~C~urrent line } +slCut = 125; { Cu~t~ } +slDOSShell = 126; { ~D~OS shell } +slDelete = 127; { ~D~elete } +slDirectoryName = 128; { Directory ~n~ame } +slDirectoryTree = 129; { Directory ~t~ree } +slEdit = 130; { ~E~dit } +slEntireDocument = 131; { ~E~ntire document } +slExit = 132; { E~x~it } +slF10Menu = 133; { ~F10~ Menu } +slF1Help = 134; { ~F1~ Help } +slF3Open = 135; { ~F3~ Open } +slFile = 136; { ~F~ile } +slFiles = 137; { ~F~iles } +slForeground = 138; { ~F~oreground } +slGroup = 139; { ~G~roup } +slHelp = 140; { ~H~elp } +slIndex = 141; { ~I~ndex } +slItem = 142; { ~I~tem } +slLineNumber = 143; { ~L~ine number } +slName = 144; { ~N~ame } +slNew = 145; { ~N~ew } +slNewText = 146; { ~N~ew text } +slNext = 147; { ~N~ext } +slNo = 148; { ~N~o } +slOk = 149; { O~k~ } +slOpen = 150; { ~O~pen } +slOpenDots = 151; { ~O~pen... } +slPaste = 152; { ~P~aste } +slPrevious = 153; { ~P~revious } +slPreviousTopic = 154; { ~P~revious topic } +slPromptOnReplace = 155; { ~P~rompt on replace } +slReformatDocument = 156; { ~R~eformat document } +slReplace = 157; { ~R~eplace } +slReplaceAll = 158; { ~R~eplace all } +slRevert = 159; { ~R~evert } +slSave = 160; { ~S~ave } +slSaveAll = 161; { Save a~l~l } +slSaveAs = 162; { S~a~ve as... } +slSaveFileAs = 163; { ~S~ave file as } +slShiftF1 = 164; { Shift+F1 } +slSizeMove = 165; { ~S~ize/Move } +slTextToFind = 166; { ~T~ext to find } +slTile = 167; { ~T~ile } +slTopicSearch = 168; { ~T~opic search } +slUndo = 169; { ~U~ndo } +slUsingHelp = 170; { ~U~sing help } +slWholeWordsOnly = 171; { ~W~hole words only } +slWindow = 172; { ~W~indow } +slWindows = 173; { ~W~indows } +slYes = 174; { ~Y~es } +slZoom = 175; { ~Z~oom } +slAltF3 = 176; { Alt+F3 } +slAltX = 177; { Alt+X } +slF2 = 178; { F2 } +slF3 = 179; { F3 } +slF5 = 180; { F5 } +slF6 = 181; { F6 } +slCtrlDel = 182; { Ctrl+Del } +slCtrlF5 = 183; { Ctrl+F5 } +slCtrlIns = 184; { Ctrl+Ins } +slShiftDel = 185; { Shift+Del } +slShiftF6 = 186; { Shift+F6 } +slShiftIns = 187; { Shift+Ins } diff --git a/packages/fv/src/strtxt.inc b/packages/fv/src/strtxt.inc new file mode 100644 index 0000000000..361b1b98b7 --- /dev/null +++ b/packages/fv/src/strtxt.inc @@ -0,0 +1,216 @@ +type standard_string=record + nr:word; + text:Pchar; + end; + +const standard_string_count=107; + standard_strings:array[0..standard_string_count-1] of standard_string=( + (nr:sVideoFailed;text:'Video initialization failed.'), + (nr:sButtonDefault;text:'Button default'), + (nr:sButtonDisabled;text:'Button disabled'), + (nr:sButtonNormal;text:'Button normal'), + (nr:sButtonSelected;text:'Button selected'), + (nr:sButtonShadow;text:'Button shadow'), + (nr:sButtonShortcut;text:'Button shortcut'), + (nr:sChangeDirectory;text:'Change Directory'), + (nr:sClipboard;text:'Clipboard'), + (nr:sClusterNormal;text:'Cluster normal'), + (nr:sClusterSelected;text:'Cluster selected'), + (nr:sClusterShortcut;text:'Cluster shortcut'), + (nr:sColor;text:'Color'), + (nr:sColors;text:'Colors'), + (nr:sConfirm;text:'Confirm'), + (nr:sDeleteFile;text:'Delete file?'#13#10#13#3'%s'), + (nr:sDirectory;text:'Directory'), + (nr:sDisabled;text:'Disabled'), + (nr:sDrives;text:'Drives'), + (nr:sError;text:'Error'), + (nr:sFileAlreadyOpen;text:''#3'%s'#13#10#13#3'is already open in window %d.'), + (nr:sFileCreateError;text:'Error creating file %s'), + (nr:sFileReadError;text:'Error reading file %s'), + (nr:sFileUntitled;text:'Save untitled file?'), + (nr:sFileWriteError;text:'Error writing to file %s'), + (nr:sFind;text:'Find'), + (nr:sFrameActive;text:'Frame active'), + (nr:sFrameBackground;text:'Frame/background'), + (nr:sFrameIcons;text:'Frame icons'), + (nr:sFramePassive;text:'Frame passive'), + (nr:sHighlight;text:'Highlight'), + (nr:sHistoryBarIcons;text:'History bar icons'), + (nr:sHistoryBarPage;text:'History bar page'), + (nr:sHistoryButton;text:'History button'), + (nr:sHistorySides;text:'History sides'), + (nr:sInformation;text:'Information'), + (nr:sInformationPane;text:'Information pane'), + (nr:sInputArrow;text:'Input arrow'), + (nr:sInputNormal;text:'Input normal'), + (nr:sInputSelected;text:'Input selected'), + (nr:sInvalidCharacter;text:'Invalid character in input'), + (nr:sInvalidDirectory;text:'Invalid directory.'), + (nr:sInvalidDriveOrDir;text:'Invalid drive or directory.'), + (nr:sInvalidFileName;text:'Invalid file name.'), + (nr:sInvalidPicture;text:'Input does not conform to picture: %s'), + (nr:sInvalidValue;text:'Value not in the range %d to %d'), + (nr:sInverse;text:'Inverse'), + (nr:sJumpTo;text:'Jump To'), + (nr:sLabelNormal;text:'Label normal'), + (nr:sLabelSelected;text:'Label selected'), + (nr:sLabelShortcut;text:'Label shortcut'), + (nr:sListDivider;text:'List divider'), + (nr:sListFocused;text:'List focused'), + (nr:sListNormal;text:'List normal'), + (nr:sListSelected;text:'List selected'), + (nr:sModified;text:''#3'%s'#13#10#13#3'has been modified. Save?'), + (nr:sNoName;text:'NONAME'), + (nr:sNormal;text:'Normal'), + (nr:sNormalText;text:'Normal text'), + (nr:sNotInList;text:'Input not in valid-list'), + (nr:sOpen;text:'Open'), + (nr:sOutOfMemory;text:'Not enough memory for this operation.'), + (nr:sOutOfUnNamedWindows;text:'Out of unnamed window numbers. Save or discard some unnamed files and try again.'), + (nr:sPasteNotPossible;text:'Wordwrap on: Paste not possible in current margins when at end of line.'), + (nr:sReformatDocument;text:'Reformat Document'), + (nr:sReformatNotPossible;text:'Paragraph reformat not possible while trying to wrap current line with current margins.'), + (nr:sReformattingTheDocument;text:'Reformatting the document:'), + (nr:sReplace;text:'Replace'), + (nr:sReplaceFile;text:'Replace file?'#13#10#13#3'%s'), + (nr:sReplaceNotPossible;text:'Wordwrap on: Replace not possible in current margins when at end of line.'), + (nr:sReplaceThisOccurence;text:'Replace this occurence?'), + (nr:sRightMargin;text:'Right Margin'), + (nr:sSaveAs;text:'Save As'), + (nr:sScrollbarIcons;text:'Scroll bar icons'), + (nr:sScrollbarPage;text:'Scroll bar page'), + (nr:sSearchStringNotFound;text:'Search string not found.'), + (nr:sSelectFormatStart;text:'Select Format Start'), + (nr:sSelectWhereToBegin;text:'Please select where to begin.'), + (nr:sSelected;text:'Selected'), + (nr:sSelectedDisabled;text:'Selected disabled'), + (nr:sSetting;text:'Setting:'), + (nr:sShortcut;text:'Shortcut'), + (nr:sShortcutSelected;text:'ShortcutSelected'), + (nr:sStaticText;text:'Static text'), + (nr:sTabSettings;text:'Tab Settings'), + (nr:sText;text:'Text'), + (nr:sTooManyFiles;text:'Too many files.'), + (nr:sTypeExitOnReturn;text:'Type EXIT to return...'), + (nr:sUnderline;text:'Underline'), + (nr:sUnknownDialog;text:'Unknown dialog requested!'), + (nr:sUntitled;text:'Untitled'), + (nr:sWarning;text:'Warning'), + (nr:sWindowList;text:'Window List'), + (nr:sWordWrapNotPossible;text:'Wordwrap on: Wordwrap not possible in current margins with continuous line.'), + (nr:sWordWrapOff;text:'You must turn on wordwrap before you can reformat.'), + (nr:smApr;text:'Apr'), + (nr:smAug;text:'Aug'), + (nr:smDec;text:'Dec'), + (nr:smFeb;text:'Feb'), + (nr:smJan;text:'Jan'), + (nr:smJul;text:'Jul'), + (nr:smJun;text:'Jun'), + (nr:smMar;text:'Mar'), + (nr:smMay;text:'May'), + (nr:smNov;text:'Nov'), + (nr:smOct;text:'Oct'), + (nr:smSep;text:'Sep')); + +procedure InitResStrings; + +var i:word; + +begin + for i:=0 to standard_string_count-1 do + strings^.put(standard_strings[i].nr,strpas(standard_strings[i].text)); +end; + +const standard_label_count=81; + standard_labels:array[0..standard_label_count-1] of standard_string=( + (nr:slAbout;text:'~A~bout'), + (nr:slAltF1;text:'Alt+F1'), + (nr:slAltF3Close;text:'~Alt+F3~ Close'), + (nr:slAltXExit;text:'~Alt-X~ Exit'), + (nr:slBackground;text:'~B~ackground'), + (nr:slCancel;text:'Cancel'), + (nr:slCascade;text:'C~a~scade'), + (nr:slCaseSensitive;text:'~C~ase sensitive'), + (nr:slChDir;text:'~C~hdir'), + (nr:slChangeDir;text:'~C~hange dir...'), + (nr:slClear;text:'C~l~ear'), + (nr:slClose;text:'~C~lose'), + (nr:slCloseAll;text:'Cl~o~se all'), + (nr:slColor;text:'~C~olor'), + (nr:slContents;text:'~C~ontents'), + (nr:slCopy;text:'~C~opy'), + (nr:slCtrlF1;text:'Ctrl+F1'), + (nr:slCurrentLine;text:'~C~urrent line'), + (nr:slCut;text:'Cu~t~'), + (nr:slDOSShell;text:'~D~OS shell'), + (nr:slDelete;text:'~D~elete'), + (nr:slDirectoryName;text:'Directory ~n~ame'), + (nr:slDirectoryTree;text:'Directory ~t~ree'), + (nr:slEdit;text:'~E~dit'), + (nr:slEntireDocument;text:'~E~ntire document'), + (nr:slExit;text:'E~x~it'), + (nr:slF10Menu;text:'~F10~ Menu'), + (nr:slF1Help;text:'~F1~ Help'), + (nr:slF3Open;text:'~F3~ Open'), + (nr:slFile;text:'~F~ile'), + (nr:slFiles;text:'~F~iles'), + (nr:slForeground;text:'~F~oreground'), + (nr:slGroup;text:'~G~roup'), + (nr:slHelp;text:'~H~elp'), + (nr:slIndex;text:'~I~ndex'), + (nr:slItem;text:'~I~tem'), + (nr:slLineNumber;text:'~L~ine number'), + (nr:slName;text:'~N~ame'), + (nr:slNew;text:'~N~ew'), + (nr:slNewText;text:'~N~ew text'), + (nr:slNext;text:'~N~ext'), + (nr:slNo;text:'~N~o'), + (nr:slOk;text:'O~k~'), + (nr:slOpen;text:'~O~pen'), + (nr:slOpenDots;text:'~O~pen...'), + (nr:slPaste;text:'~P~aste'), + (nr:slPrevious;text:'~P~revious'), + (nr:slPreviousTopic;text:'~P~revious topic'), + (nr:slPromptOnReplace;text:'~P~rompt on replace'), + (nr:slReformatDocument;text:'~R~eformat document'), + (nr:slReplace;text:'~R~eplace'), + (nr:slReplaceAll;text:'~R~eplace all'), + (nr:slRevert;text:'~R~evert'), + (nr:slSave;text:'~S~ave'), + (nr:slSaveAll;text:'Save a~l~l'), + (nr:slSaveAs;text:'S~a~ve as...'), + (nr:slSaveFileAs;text:'~S~ave file as'), + (nr:slShiftF1;text:'Shift+F1'), + (nr:slSizeMove;text:'~S~ize/Move'), + (nr:slTextToFind;text:'~T~ext to find'), + (nr:slTile;text:'~T~ile'), + (nr:slTopicSearch;text:'~T~opic search'), + (nr:slUndo;text:'~U~ndo'), + (nr:slUsingHelp;text:'~U~sing help'), + (nr:slWholeWordsOnly;text:'~W~hole words only'), + (nr:slWindow;text:'~W~indow'), + (nr:slWindows;text:'~W~indows'), + (nr:slYes;text:'~Y~es'), + (nr:slZoom;text:'~Z~oom'), + (nr:slAltF3;text:'Alt+F3'), + (nr:slAltX;text:'Alt+X'), + (nr:slF2;text:'F2'), + (nr:slF3;text:'F3'), + (nr:slF5;text:'F5'), + (nr:slF6;text:'F6'), + (nr:slCtrlDel;text:'Ctrl+Del'), + (nr:slCtrlF5;text:'Ctrl+F5'), + (nr:slCtrlIns;text:'Ctrl+Ins'), + (nr:slShiftDel;text:'Shift+Del'), + (nr:slShiftF6;text:'Shift+F6'), + (nr:slShiftIns;text:'Shift+Ins')); + +procedure InitResLabels; + +var i:word; + +begin + for i:=0 to standard_label_count-1 do + labels^.put(standard_labels[i].nr,strpas(standard_labels[i].text)); +end; diff --git a/packages/fv/src/sysmsg.pas b/packages/fv/src/sysmsg.pas new file mode 100644 index 0000000000..c702dca377 --- /dev/null +++ b/packages/fv/src/sysmsg.pas @@ -0,0 +1,127 @@ +{ + + Unit to handle system events + + Copyright 2000 by Pierre Muller <muller@ics.u-strasbg.fr> + + 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 sysmsg; + +interface + +type + TSystemMessage = ( + SysNothing, + SysSetFocus, + SysReleaseFocus, + SysClose, + SysResize ); + + TSystemEvent = Record + case typ : TSystemMessage of + SysClose : ( CloseTyp : Longint); + SysResize : (X,Y : Longint); + end; + + PSystemEvent = ^TSystemEvent; + +const + SystemEventBufSize = 16; + +var + PendingSystemEvent : array[0..SystemEventBufSize-1] of TSystemEvent; + PendingSystemHead, + PendingSystemTail : PSystemEvent; + PendingSystemEvents : byte; + + LastSystemEvent : TSystemEvent; + + +procedure InitSystemMsg; + +procedure DoneSystemMsg; + +procedure GetSystemEvent(var SystemEvent:TSystemEvent); +{ Returns the last SystemEvent, and waits for one if not available } + +procedure PutSystemEvent(const SystemEvent: TSystemEvent); +{ Adds the given SystemEvent to the input queue. } + +function PollSystemEvent(var SystemEvent: TSystemEvent):boolean; +{ Checks if a SystemEvent is available, and returns it if one is found. If no + event is pending, it returns 0 } + +implementation + +{$undef HAS_SYSMSG} + +{$ifdef go32v2} +{$i go32smsg.inc} +{$define HAS_SYSMSG} +{$endif go32v2} +{$ifdef win32} +{$i w32smsg.inc} +{$define HAS_SYSMSG} +{$endif win32} +{$ifdef unix} +{$i unixsmsg.inc} +{$define HAS_SYSMSG} +{$endif unix} + +{$ifdef HAS_SYSMSG} + +procedure PutSystemEvent(const SystemEvent: TSystemEvent); +begin + if PendingSystemEvents<SystemEventBufSize then + begin + PendingSystemTail^:=SystemEvent; + inc(PendingSystemTail); + if longint(PendingSystemTail)=longint(@PendingSystemEvent)+sizeof(PendingSystemEvent) then + PendingSystemTail:=@PendingSystemEvent; + inc(PendingSystemEvents); + end; +end; + +{$else HAS_SYSMSG} + +procedure InitSystemMsg; +begin +end; + +procedure DoneSystemMsg; +begin +end; + +procedure GetSystemEvent(var SystemEvent:TSystemEvent); +begin + FillChar(SystemEvent,SizeOf(SystemEvent),#0); +end; + +function PollSystemEvent(var SystemEvent: TSystemEvent):boolean; +begin + FillChar(SystemEvent,SizeOf(SystemEvent),#0); + PollSystemEvent:=false; +end; + +procedure PutSystemEvent(const SystemEvent: TSystemEvent); +begin +end; + +{$endif not HAS_SYSMSG} + +end. diff --git a/packages/fv/src/tabs.pas b/packages/fv/src/tabs.pas new file mode 100644 index 0000000000..d2860b3e8d --- /dev/null +++ b/packages/fv/src/tabs.pas @@ -0,0 +1,774 @@ +{ + + Tabbed group for TV/FV dialogs + + Copyright 2000-4 by Free Pascal core 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. + + ****************************************************************************} +unit tabs; + +{$I platform.inc} (* Multi-platform support defines *) +{$CODEPAGE cp437} + +interface + +uses + objects, + drivers, + views, + fvconsts; + + +type + PTabItem = ^TTabItem; + TTabItem = record + Next : PTabItem; + View : PView; + Dis : boolean; + end; + + PTabDef = ^TTabDef; + TTabDef = record + Next : PTabDef; + Name : PString; + Items : PTabItem; + DefItem : PView; + ShortCut : char; + end; + + PTab = ^TTab; + TTab = object(TGroup) + TabDefs : PTabDef; + ActiveDef : integer; + DefCount : word; + constructor Init(var Bounds: TRect; ATabDef: PTabDef); + constructor Load (var S: TStream); + function AtTab(Index: integer): PTabDef; virtual; + procedure SelectTab(Index: integer); virtual; + procedure Store (var S: TStream); + function TabCount: integer; + function Valid(Command: Word): Boolean; virtual; + procedure ChangeBounds(var Bounds: TRect); virtual; + procedure HandleEvent(var Event: TEvent); virtual; + function GetPalette: PPalette; virtual; + procedure Draw; virtual; + function DataSize: sw_word;virtual; + procedure SetData(var Rec);virtual; + procedure GetData(var Rec);virtual; + procedure SetState(AState: Word; Enable: Boolean); virtual; + destructor Done; virtual; + private + InDraw: boolean; + function FirstSelectable: PView; + function LastSelectable: PView; + end; + +function NewTabItem(AView: PView; ANext: PTabItem): PTabItem; +procedure DisposeTabItem(P: PTabItem); +function NewTabDef(AName: string; ADefItem: PView; AItems: PTabItem; ANext: PTabDef): PTabDef; +procedure DisposeTabDef(P: PTabDef); + +procedure RegisterTab; + +const + RTab: TStreamRec = ( + ObjType: idTab; +{$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs (TypeOf (TTab)^); +{$ELSE BP_VMTLink} { Alt style VMT link } + VmtLink: TypeOf (TTab); +{$ENDIF BP_VMTLink} + Load: @TTab.Load; + Store: @TTab.Store + ); + + +implementation + +uses + FvCommon, + dialogs; + +constructor TTab.Init(var Bounds: TRect; ATabDef: PTabDef); +begin + inherited Init(Bounds); + Options:=Options or ofSelectable or ofFirstClick or ofPreProcess or ofPostProcess; + GrowMode:=gfGrowHiX+gfGrowHiY+gfGrowRel; + TabDefs:=ATabDef; + ActiveDef:=-1; + SelectTab(0); + ReDraw; +end; + +constructor TTab.Load (var S: TStream); + + function DoLoadTabItems (var XDefItem: PView; ActItem: longint): PTabItem; + var + Count: longint; + Cur, First: PTabItem; + Last: ^PTabItem; + begin + Cur := nil; { Preset nil } + Last := @First; { Start on first item } + S.Read (Count, SizeOf(Count)); { Read item count } + while (Count > 0) do + begin + New (Cur); { New status item } + Last^ := Cur; { First chain part } + if (Cur <> nil) then { Check pointer valid } + begin + Last := @Cur^.Next; { Chain complete } + S.Read (Cur^.Dis, SizeOf (Cur^.Dis)); + Cur^.View := PView (S.Get); + if ActItem = 0 then + XDefItem := Cur^.View; { Find default view } + end; + Dec (Count); { One item loaded } + Dec (ActItem); + end; + Last^ := nil; { Now chain end } + DoLoadTabItems := First; { Return the list } + end; + + function DoLoadTabDefs: PTabDef; + var + Count: longint; + Cur, First: PTabDef; + Last: ^PTabDef; + ActItem: longint; + begin + Last := @First; { Start on first } + Count := DefCount; + while (Count > 0) do + begin + New (Cur); { New status def } + Last^ := Cur; { First part of chain } + if (Cur <> nil) then { Check pointer valid } + begin + Last := @Cur^.Next; { Chain complete } + Cur^.Name := S.ReadStr; { Read name } + S.Read (Cur^.ShortCut, SizeOf (Cur^.ShortCut)); + S.Read (ActItem, SizeOf (ActItem)); + Cur^.Items := DoLoadTabItems (Cur^.DefItem, ActItem); { Set pointer } + end; + Dec (Count); { One item loaded } + end; + Last^ := nil; { Now chain ends } + DoLoadTabDefs := First; { Return item list } + end; + +begin + inherited Load (S); + S.Read (DefCount, SizeOf (DefCount)); + S.Read (ActiveDef, SizeOf (ActiveDef)); + TabDefs := DoLoadTabDefs; +end; + +procedure TTab.Store (var S: TStream); + + procedure DoStoreTabItems (Cur: PTabItem; XDefItem: PView); + var + Count: longint; + T: PTabItem; + ActItem: longint; + begin + Count := 0; { Clear count } + T := Cur; { Start on current } + while (T <> nil) do + begin + if T^.View = XDefItem then { Current = active? } + ActItem := Count; { => set order } + Inc (Count); { Count items } + T := T^.Next; { Next item } + end; + S.Write (ActItem, SizeOf (ActItem)); + S.Write (Count, SizeOf (Count)); { Write item count } + while (Cur <> nil) do + begin + S.Write (Cur^.Dis, SizeOf (Cur^.Dis)); + S.Put (Cur^.View); + end; + end; + + procedure DoStoreTabDefs (Cur: PTabDef); + begin + while (Cur <> nil) do + begin + with Cur^ do + begin + S.WriteStr (Cur^.Name); { Write name } + S.Write (Cur^.ShortCut, SizeOf (Cur^.ShortCut)); + DoStoreTabItems (Items, DefItem); { Store the items } + end; + Cur := Cur^.Next; { Next status item } + end; + end; + +begin + inherited Store (S); + S.Write (DefCount, SizeOf (DefCount)); + S.Write (ActiveDef, SizeOf (ActiveDef)); + DoStoreTabDefs (TabDefs); +end; + +function TTab.TabCount: integer; +var i: integer; + P: PTabDef; +begin + I:=0; P:=TabDefs; + while (P<>nil) do + begin + Inc(I); + P:=P^.Next; + end; + TabCount:=I; +end; + + +function TTab.AtTab(Index: integer): PTabDef; +var i: integer; + P: PTabDef; +begin + i:=0; P:=TabDefs; + while (I<Index) do + begin + if P=nil then RunError($AA); + P:=P^.Next; + Inc(i); + end; + AtTab:=P; +end; + +procedure TTab.SelectTab(Index: integer); +var P: PTabItem; + V: PView; +begin + if ActiveDef<>Index then + begin + if Owner<>nil then Owner^.Lock; + Lock; + { --- Update --- } + if TabDefs<>nil then + begin + DefCount:=1; + while AtTab(DefCount-1)^.Next<>nil do Inc(DefCount); + end + else DefCount:=0; + if ActiveDef<>-1 then + begin + P:=AtTab(ActiveDef)^.Items; + while P<>nil do + begin + if P^.View<>nil then Delete(P^.View); + P:=P^.Next; + end; + end; + ActiveDef:=Index; + P:=AtTab(ActiveDef)^.Items; + while P<>nil do + begin + if P^.View<>nil then Insert(P^.View); + P:=P^.Next; + end; + V:=AtTab(ActiveDef)^.DefItem; + if V<>nil then V^.Select; + ReDraw; + { --- Update --- } + UnLock; + if Owner<>nil then Owner^.UnLock; + DrawView; + end; +end; + +procedure TTab.ChangeBounds(var Bounds: TRect); +var D: TPoint; +procedure DoCalcChange(P: PView); {$ifndef FPC}far;{$endif} +var + R: TRect; +begin + if P^.Owner=nil then Exit; { it think this is a bug in TV } + P^.CalcBounds(R, D); + P^.ChangeBounds(R); +end; +var + P: PTabItem; + I: integer; +begin + D.X := Bounds.B.X - Bounds.A.X - Size.X; + D.Y := Bounds.B.Y - Bounds.A.Y - Size.Y; + inherited ChangeBounds(Bounds); + for I:=0 to TabCount-1 do + if I<>ActiveDef then + begin + P:=AtTab(I)^.Items; + while P<>nil do + begin + if P^.View<>nil then DoCalcChange(P^.View); + P:=P^.Next; + end; + end; +end; + + +function TTab.FirstSelectable: PView; +var + FV : PView; +begin + FV := First; + while (FV<>nil) and ((FV^.Options and ofSelectable)=0) and (FV<>Last) do + FV:=FV^.Next; + if FV<>nil then + if (FV^.Options and ofSelectable)=0 then FV:=nil; + FirstSelectable:=FV; +end; + + +function TTab.LastSelectable: PView; +var + LV : PView; +begin + LV := Last; + while (LV<>nil) and ((LV^.Options and ofSelectable)=0) and (LV<>First) do + LV:=LV^.Prev; + if LV<>nil then + if (LV^.Options and ofSelectable)=0 then LV:=nil; + LastSelectable:=LV; +end; + +procedure TTab.HandleEvent(var Event: TEvent); +var Index : integer; + I : integer; + X : integer; + Len : byte; + P : TPoint; + V : PView; + CallOrig: boolean; + LastV : PView; + FirstV: PView; +begin + if (Event.What and evMouseDown)<>0 then + begin + MakeLocal(Event.Where,P); + if P.Y<3 then + begin + Index:=-1; X:=1; + for i:=0 to DefCount-1 do + begin + Len:=CStrLen(AtTab(i)^.Name^); + if (P.X>=X) and (P.X<=X+Len+1) then Index:=i; + X:=X+Len+3; + end; + if Index<>-1 then + SelectTab(Index); + end; + end; + if Event.What=evKeyDown then + begin + Index:=-1; + case Event.KeyCode of + kbTab,kbShiftTab : + if GetState(sfSelected) then + begin + if Current<>nil then + begin + LastV:=LastSelectable; FirstV:=FirstSelectable; + if ((Current=LastV) or (Current=PLabel(LastV)^.Link)) and (Event.KeyCode=kbShiftTab) then + begin + if Owner<>nil then Owner^.SelectNext(true); + end else + if ((Current=FirstV) or (Current=PLabel(FirstV)^.Link)) and (Event.KeyCode=kbTab) then + begin + Lock; + if Owner<>nil then Owner^.SelectNext(false); + UnLock; + end else + SelectNext(Event.KeyCode=kbShiftTab); + ClearEvent(Event); + end; + end; + else + for I:=0 to DefCount-1 do + begin + if Upcase(GetAltChar(Event.KeyCode))=AtTab(I)^.ShortCut + then begin + Index:=I; + ClearEvent(Event); + Break; + end; + end; + end; + if Index<>-1 then + begin + Select; + SelectTab(Index); + V:=AtTab(ActiveDef)^.DefItem; + if V<>nil then V^.Focus; + end; + end; + CallOrig:=true; + if Event.What=evKeyDown then + begin + if ((Owner<>nil) and (Owner^.Phase=phPostProcess) + and (GetAltChar(Event.KeyCode)<>#0)) or GetState(sfFocused) + then + else CallOrig:=false; + end; + if CallOrig then inherited HandleEvent(Event); +end; + +function TTab.GetPalette: PPalette; +begin + GetPalette:=nil; +end; + +{$define AVOIDTHREELINES} + +procedure TTab.Draw; +const +{$ifdef AVOIDTHREELINES} + UDL='¿'; + LUR='Ä'; + URD='Ú'; +{$else not AVOIDTHREELINES} + UDL='´'; + LUR='Á'; + URD='Ã'; +{$endif not AVOIDTHREELINES} + + +var B : TDrawBuffer; + i : integer; + C1,C2,C3,C : word; + HeaderLen : integer; + X,X2 : integer; + Name : PString; + ActiveKPos : integer; + ActiveVPos : integer; + FC : char; +procedure SWriteBuf(X,Y,W,H: integer; var Buf); +var i: integer; +begin + if Y+H>Size.Y then H:=Size.Y-Y; + if X+W>Size.X then W:=Size.X-X; + if Buffer=nil then WriteBuf(X,Y,W,H,Buf) + else for i:=1 to H do + Move(Buf,Buffer^[X+(Y+i-1)*Size.X],W*2); +end; +procedure ClearBuf; +begin + MoveChar(B,' ',C1,Size.X); +end; +begin + if InDraw then Exit; + InDraw:=true; + { - Start of TGroup.Draw - } +{ if Buffer = nil then + begin + GetBuffer; + end; } + { - Start of TGroup.Draw - } + + C1:=GetColor(1); + C2:=(GetColor(7) and $f0 or $08)+GetColor(9)*256; + C3:=GetColor(8)+GetColor({9}8)*256; + + { Calculate the size of the headers } + HeaderLen:=0; + for i:=0 to DefCount-1 do + HeaderLen:=HeaderLen+CStrLen(AtTab(i)^.Name^)+3; + Dec(HeaderLen); + if HeaderLen>Size.X-2 then HeaderLen:=Size.X-2; + + { --- 1. sor --- } + ClearBuf; + MoveChar(B[0],'³',C1,1); + MoveChar(B[HeaderLen+1],'³',C1,1); + X:=1; + for i:=0 to DefCount-1 do + begin + Name:=AtTab(i)^.Name; X2:=CStrLen(Name^); + if i=ActiveDef + then begin + ActiveKPos:=X-1; + ActiveVPos:=X+X2+2; + if GetState(sfFocused) then C:=C3 else C:=C2; + end + else C:=C2; + MoveCStr(B[X],' '+Name^+' ',C); + X:=X+X2+3; + MoveChar(B[X-1],'³',C1,1); + end; + SWriteBuf(0,1,Size.X,1,B); + + { --- 0. sor --- } + ClearBuf; MoveChar(B[0],'Ú',C1,1); + X:=1; + for i:=0 to DefCount-1 do + begin +{$ifdef AVOIDTHREELINES} + if I<ActiveDef then + FC:='Ú' + else + FC:='¿'; +{$else not AVOIDTHREELINES} + FC:='Â'; +{$endif not AVOIDTHREELINES} + X2:=CStrLen(AtTab(i)^.Name^)+2; + MoveChar(B[X+X2],FC,C1,1); + if i=DefCount-1 then X2:=X2+1; + if X2>0 then + MoveChar(B[X],'Ä',C1,X2); + X:=X+X2+1; + end; + MoveChar(B[HeaderLen+1],'¿',C1,1); + MoveChar(B[ActiveKPos],'Ú',C1,1); + MoveChar(B[ActiveVPos],'¿',C1,1); + SWriteBuf(0,0,Size.X,1,B); + + { --- 2. sor --- } + MoveChar(B[1],'Ä',C1,Max(HeaderLen,0)); + MoveChar(B[HeaderLen+2],'Ä',C1,Max(Size.X-HeaderLen-3,0)); + MoveChar(B[HeaderLen+1],LUR,C1,1); + MoveChar(B[ActiveKPos],'Ù',C1,1); + if ActiveDef=0 then + MoveChar(B[0],'³',C1,1) + else + MoveChar(B[0],URD,C1,1); + MoveChar(B[ActiveKPos+1],' ',C1,Max(ActiveVPos-ActiveKPos-1,0)); + MoveChar(B[ActiveVPos],'À',C1,1); + if HeaderLen+1<Size.X-1 then + MoveChar(B[Size.X-1],'¿',C1,1) + else if (ActiveDef=DefCount-1) then + MoveChar(B[Size.X-1],'³',C1,1) + else + MoveChar(B[Size.X-1],UDL,C1,1); + SWriteBuf(0,2,Size.X,1,B); + + { --- marad‚k sor --- } + ClearBuf; MoveChar(B[0],'³',C1,1); + MoveChar(B[Size.X-1],'³',C1,1); + {SWriteBuf(0,3,Size.X,Size.Y-4,B);} + for i:=3 to Size.Y-1 do + SWriteBuf(0,i,Size.X,1,B); + + { --- Size.X . sor --- } + MoveChar(B[0],'À',C1,1); + MoveChar(B[1],'Ä',C1,Max(Size.X-2,0)); + MoveChar(B[Size.X-1],'Ù',C1,1); + SWriteBuf(0,Size.Y-1,Size.X,1,B); + + { - End of TGroup.Draw - } + if Buffer <> nil then + begin + Lock; + Redraw; + UnLock; + end; + if Buffer <> nil then + WriteBuf(0, 0, Size.X, Size.Y, Buffer^) + else + Redraw; + { - End of TGroup.Draw - } + InDraw:=false; +end; + +function TTab.Valid(Command: Word): Boolean; +var PT : PTabDef; + PI : PTabItem; + OK : boolean; +begin + OK:=true; + PT:=TabDefs; + while (PT<>nil) and (OK=true) do + begin + PI:=PT^.Items; + while (PI<>nil) and (OK=true) do + begin + if PI^.View<>nil then OK:=OK and PI^.View^.Valid(Command); + PI:=PI^.Next; + end; + PT:=PT^.Next; + end; + Valid:=OK; +end; + + +procedure TTab.SetData(var Rec); +type + Bytes = array[0..65534] of Byte; +var + I: Sw_Word; + PT : PTabDef; + PI : PTabItem; +begin + I := 0; + PT:=TabDefs; + while (PT<>nil) do + begin + PI:=PT^.Items; + while (PI<>nil) do + begin + if PI^.View<>nil then + begin + PI^.View^.SetData(Bytes(Rec)[I]); + Inc(I, PI^.View^.DataSize); + end; + PI:=PI^.Next; + end; + PT:=PT^.Next; + end; +end; + + +function TTab.DataSize: sw_word; +var + I: Sw_Word; + PT : PTabDef; + PI : PTabItem; +begin + I := 0; + PT:=TabDefs; + while (PT<>nil) do + begin + PI:=PT^.Items; + while (PI<>nil) do + begin + if PI^.View<>nil then + begin + Inc(I, PI^.View^.DataSize); + end; + PI:=PI^.Next; + end; + PT:=PT^.Next; + end; + DataSize:=i; +end; + + +procedure TTab.GetData(var Rec); +type + Bytes = array[0..65534] of Byte; +var + I: Sw_Word; + PT : PTabDef; + PI : PTabItem; +begin + I := 0; + PT:=TabDefs; + while (PT<>nil) do + begin + PI:=PT^.Items; + while (PI<>nil) do + begin + if PI^.View<>nil then + begin + PI^.View^.GetData(Bytes(Rec)[I]); + Inc(I, PI^.View^.DataSize); + end; + PI:=PI^.Next; + end; + PT:=PT^.Next; + end; +end; + + +procedure TTab.SetState(AState: Word; Enable: Boolean); +var + LastV : PView; +begin + inherited SetState(AState,Enable); + { Select first item } + if (AState and sfSelected)<>0 then + begin + LastV:=LastSelectable; + if LastV<>nil then + LastV^.Select; + end; +end; + +destructor TTab.Done; +var P,X: PTabDef; +procedure DeleteViews(P: PView); {$ifndef FPC}far;{$endif} +begin + if P<>nil then Delete(P); +end; +begin + ForEach(@DeleteViews); + inherited Done; + P:=TabDefs; + while P<>nil do + begin + X:=P^.Next; + DisposeTabDef(P); + P:=X; + end; +end; + + +function NewTabItem(AView: PView; ANext: PTabItem): PTabItem; +var P: PTabItem; +begin + New(P); FillChar(P^,SizeOf(P^),0); + P^.Next:=ANext; P^.View:=AView; + NewTabItem:=P; +end; + +procedure DisposeTabItem(P: PTabItem); +begin + if P<>nil then + begin + if P^.View<>nil then Dispose(P^.View, Done); + Dispose(P); + end; +end; + +function NewTabDef(AName: string; ADefItem: PView; AItems: PTabItem; ANext: PTabDef): PTabDef; +var P: PTabDef; + x: byte; +begin + New(P); + P^.Next:=ANext; P^.Name:=NewStr(AName); P^.Items:=AItems; + x:=pos('~',AName); + if (x<>0) and (x<length(AName)) then P^.ShortCut:=Upcase(AName[x+1]) + else P^.ShortCut:=#0; + P^.DefItem:=ADefItem; + NewTabDef:=P; +end; + +procedure DisposeTabDef(P: PTabDef); +var PI,X: PTabItem; +begin + DisposeStr(P^.Name); + PI:=P^.Items; + while PI<>nil do + begin + X:=PI^.Next; + DisposeTabItem(PI); + PI:=X; + end; + Dispose(P); +end; + +procedure RegisterTab; +begin + RegisterType (RTab); +end; + + +begin + RegisterTab; +end. diff --git a/packages/fv/src/time.pas b/packages/fv/src/time.pas new file mode 100644 index 0000000000..8d685be458 --- /dev/null +++ b/packages/fv/src/time.pas @@ -0,0 +1,465 @@ +{*********************[ TIME UNIT ]************************} +{ } +{ System independent TIME unit } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@starwon.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ - Speed Pascal 1.0+ (32 Bit) } +{ - C'T patch to BP (16 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Fix } +{ ------- --------- --------------------------------- } +{ 1.00 06 Dec 96 First multi platform release. } +{ 1.10 06 Jul 97 New functiions added. } +{ 1.20 22 Jul 97 FPC pascal compiler added. } +{ 1.30 29 Aug 97 Platform.inc sort added. } +{ 1.40 13 Oct 97 Delphi 2/3 32 bit code added. } +{ 1.50 06 Nov 97 Speed pascal code added. } +{ 1.60 05 May 98 Virtual pascal 2.0 compiler added. } +{ 1.61 07 Jul 99 Speedsoft SYBIL 2.0 code added. } +{**********************************************************} + +UNIT Time; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC} { FPC doesn't support these switches } + {$F-} { Short calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$E+} { Emulation is on } + {$N-} { No 80x87 code generation } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{-CurrentMinuteOfDay------------------------------------------------- +Returns the number of minutes since midnight of a current system time. +19Jun97 LdB (Range: 0 - 1439) +---------------------------------------------------------------------} +FUNCTION CurrentMinuteOfDay: Word; + +{-CurrentSecondOfDay------------------------------------------------- +Returns the number of seconds since midnight of current system time. +24Jun97 LdB (Range: 0 - 86399) +---------------------------------------------------------------------} +FUNCTION CurrentSecondOfDay: LongInt; + +{-CurrentSec100OfDay------------------------------------------------- +Returns the 1/100ths of a second since midnight of current system time. +24Jun97 LdB (Range: 0 - 8639999) +---------------------------------------------------------------------} +FUNCTION CurrentSec100OfDay: LongInt; + +{-MinuteOfDay-------------------------------------------------------- +Returns the number of minutes since midnight of a valid given time. +19Jun97 LdB (Range: 0 - 1439) +---------------------------------------------------------------------} +FUNCTION MinuteOfDay (Hour24, Minute: Word): Word; + +{-SecondOfDay-------------------------------------------------------- +Returns the number of seconds since midnight of a valid given time. +19Jun97 LdB (Range: 0 - 86399) +---------------------------------------------------------------------} +FUNCTION SecondOfDay (Hour24, Minute, Second: Word): LongInt; + +{-SetTime------------------------------------------------------------ +Set the operating systems time clock to the given values. If values +are invalid this function will fail without notification. +06Nov97 LdB +---------------------------------------------------------------------} +PROCEDURE SetTime (Hour, Minute, Second, Sec100: Word); + +{-GetTime------------------------------------------------------------ +Returns the current time settings of the operating system. +06Nov97 LdB +---------------------------------------------------------------------} +PROCEDURE GetTime (Var Hour, Minute, Second, Sec100: Word); + +{-MinutesToTime------------------------------------------------------ +Returns the time in hours and minutes of a given number of minutes. +19Jun97 LdB +---------------------------------------------------------------------} +PROCEDURE MinutesToTime (Md: LongInt; Var Hour24, Minute: Word); + +{-SecondsToTime------------------------------------------------------ +Returns the time in hours, mins and secs of a given number of seconds. +19Jun97 LdB +---------------------------------------------------------------------} +PROCEDURE SecondsToTime (Sd: LongInt; Var Hour24, Minute, Second: Word); + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} +{$IFDEF OS_WINDOWS} { WIN/NT CODE } + + {$IFNDEF PPC_SPEED} { NON SPEED COMPILER } + {$IFDEF PPC_FPC} { FPC WINDOWS COMPILER } + USEs Windows; { Standard unit } + {$ELSE} { OTHER COMPILERS } + USES WinTypes, WinProcs; { Standard units } + {$ENDIF} + {$ELSE} { SPEEDSOFT COMPILER } + USES WinBase; { Standard unit } + TYPE TSystemTime = SystemTime; { Type fix up } + {$ENDIF} + +{$ENDIF} + +{$IFDEF OS_OS2} { OS2 COMPILERS } + + {$IFDEF PPC_VIRTUAL} { VIRTUAL PASCAL } + USES OS2Base; { Standard unit } + {$ENDIF} + + {$IFDEF PPC_SPEED} { SPEED PASCAL } + USES BseDos, Os2Def; { Standard unit } + {$ENDIF} + + {$IFDEF PPC_FPC} { FPC } + USES Dos, DosCalls; { Standard unit } + + TYPE DateTime = TDateTime; { Type correction } + {$ENDIF} + + {$IFDEF PPC_BPOS2} { C'T PATCH TO BP CODE } + USES DosTypes, DosProcs; { Standard unit } + + TYPE DateTime = TDateTime; { Type correction } + {$ENDIF} + +{$ENDIF} + +{$ifdef OS_UNIX} + USES Dos; +{$endif OS_UNIX} + +{$ifdef OS_GO32} + USES Dos; +{$endif OS_GO32} + +{$ifdef OS_NETWARE} + USES Dos; +{$endif OS_GO32} + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ CurrentMinuteOfDay -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Jun97 LdB} +{---------------------------------------------------------------------------} +FUNCTION CurrentMinuteOfDay: Word; +VAR Hour, Minute, Second, Sec100: Word; +BEGIN + GetTime(Hour, Minute, Second, Sec100); { Get current time } + CurrentMinuteOfDay := (Hour * 60) + Minute; { Minute from midnight } +END; + +{---------------------------------------------------------------------------} +{ CurrentSecondOfDay -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Jun97 LdB} +{---------------------------------------------------------------------------} +FUNCTION CurrentSecondOfDay: LongInt; +VAR Hour, Minute, Second, Sec100: Word; +BEGIN + GetTime(Hour, Minute, Second, Sec100); { Get current time } + CurrentSecondOfDay := (LongInt(Hour) * 3600) + + (Minute * 60) + Second; { Second from midnight } +END; + +{---------------------------------------------------------------------------} +{ CurrentSec100OfDay -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Jun97 LdB} +{---------------------------------------------------------------------------} +FUNCTION CurrentSec100OfDay: LongInt; +VAR Hour, Minute, Second, Sec100: Word; +BEGIN + GetTime(Hour, Minute, Second, Sec100); { Get current time } + CurrentSec100OfDay := (LongInt(Hour) * 360000) + + (LongInt(Minute) * 6000) + (Second*100)+ Sec100; { Sec100 from midnight } +END; + +{---------------------------------------------------------------------------} +{ MinuteOfDay -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Jun97 LdB } +{---------------------------------------------------------------------------} +FUNCTION MinuteOfDay (Hour24, Minute: Word): Word; +BEGIN + MinuteOfDay := (Hour24 * 60) + Minute; { Minute from midnight } +END; + +{---------------------------------------------------------------------------} +{ SecondOfDay -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Jun97 LdB } +{---------------------------------------------------------------------------} +FUNCTION SecondOfDay (Hour24, Minute, Second: Word): LongInt; +BEGIN + SecondOfDay := (LongInt(Hour24) * 3600) + + (Minute * 60) + Second; { Second from midnight } +END; + +{---------------------------------------------------------------------------} +{ SetTime -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Nov97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE SetTime (Hour, Minute, Second, Sec100: Word); +{$IFDEF OS_DOS} { DOS/DPMI CODE } + {$IFDEF ASM_BP} { BP COMPATABLE ASM } + ASSEMBLER; + ASM + MOV CH, BYTE PTR Hour; { Fetch hour } + MOV CL, BYTE PTR Minute; { Fetch minute } + MOV DH, BYTE PTR Second; { Fetch second } + MOV DL, BYTE PTR Sec100; { Fetch hundredths } + MOV AX, $2D00; { Set function id } + PUSH BP; { Safety save register } + INT $21; { Set the time } + POP BP; { Restore register } + END; + {$ENDIF} + {$IFDEF ASM_FPC} { FPC COMPATABLE ASM } + BEGIN + ASM + MOVB Hour, %CH; { Fetch hour } + MOVB Minute, %CL; { Fetch minute } + MOVB Second, %DH; { Fetch second } + MOVB Sec100, %DL; { Fetch hundredths } + MOVW $0x2D00, %AX; { Set function id } + PUSHL %EBP; { Save register } + INT $0x21; { BIOS set time } + POPL %EBP; { Restore register } + END; + END; + {$ENDIF} +{$ENDIF} +{$IFDEF OS_WINDOWS} { WIN/NT CODE } + {$IFDEF BIT_16} { 16 BIT WINDOWS CODE } + ASSEMBLER; + ASM + MOV CH, BYTE PTR Hour; { Fetch hour } + MOV CL, BYTE PTR Minute; { Fetch minute } + MOV DH, BYTE PTR Second; { Fetch second } + MOV DL, BYTE PTR Sec100; { Fetch hundredths } + MOV AX, $2D00; { Set function id } + PUSH BP; { Safety save register } + INT $21; { Set the time } + POP BP; { Restore register } + END; + {$ENDIF} + {$IFDEF BIT_32} { 32 BIT WINDOWS CODE } + VAR DT: TSystemTime; + BEGIN + {$IFDEF PPC_FPC} { FPC WINDOWS COMPILER } + GetLocalTime(@DT); { Get the date/time } + {$ELSE} { OTHER COMPILERS } + GetLocalTime(DT); { Get the date/time } + {$ENDIF} + DT.wHour := Hour; { Transfer hour } + DT.wMinute := Minute; { Transfer minute } + DT.wSecond := Second; { Transfer seconds } + DT.wMilliseconds := Sec100 * 10; { Transfer millisecs } + SetLocalTime(DT); { Set the date/time } + END; + {$ENDIF} +{$ENDIF} +{$IFDEF OS_OS2} { OS2 CODE } +VAR DT: DateTime; +BEGIN + DosGetDateTime(DT); { Get the date/time } + DT.Hours := Hour; { Transfer hour } + DT.Minutes := Minute; { Transfer minute } + DT.Seconds := Second; { Transfer seconds } + DT.Hundredths := Sec100; { Transfer hundredths } + DosSetDateTime(DT); { Set the time } +END; +{$ENDIF} +{$ifdef OS_UNIX} +BEGIN + {settime is dummy in Linux} +END; +{$endif OS_UNIX} +{$IFDEF OS_NETWARE} +BEGIN + {settime is dummy in Netware (Libc and Clib) } +END; +{$ENDIF OS_NETWARE} + +{---------------------------------------------------------------------------} +{ GetTime -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Nov97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE GetTime (Var Hour, Minute, Second, Sec100: Word); +{$IFDEF OS_DOS} { DOS/DPMI CODE } + {$IFDEF ASM_BP} { BP COMPATABLE ASM } + ASSEMBLER; + ASM + MOV AX, $2C00; { Set function id } + PUSH BP; { Safety save register } + INT $21; { System get time } + POP BP; { Restore register } + XOR AH, AH; { Clear register } + CLD; { Strings go forward } + MOV AL, DL; { Transfer register } + LES DI, Sec100; { ES:DI -> hundredths } + STOSW; { Return hundredths } + MOV AL, DH; { Transfer register } + LES DI, Second; { ES:DI -> seconds } + STOSW; { Return seconds } + MOV AL, CL; { Transfer register } + LES DI, Minute; { ES:DI -> minutes } + STOSW; { Return minutes } + MOV AL, CH; { Transfer register } + LES DI, Hour; { ES:DI -> hours } + STOSW; { Return hours } + END; + {$ENDIF} + {$IFDEF OS_GO32} { FPC COMPATABLE ASM } + BEGIN + (* ASM + MOVW $0x2C00, %AX; { Set function id } + PUSHL %EBP; { Save register } + INT $0x21; { System get time } + POPL %EBP; { Restore register } + XORB %AH, %AH; { Clear register } + MOVB %DL, %AL; { Transfer register } + MOVL Sec100, %EDI; { EDI -> Sec100 } + MOVW %AX, (%EDI); { Return Sec100 } + MOVB %DH, %AL; { Transfer register } + MOVL Second, %EDI; { EDI -> Second } + MOVW %AX, (%EDI); { Return Second } + MOVB %CL, %AL; { Transfer register } + MOVL Minute, %EDI; { EDI -> Minute } + MOVW %AX, (%EDI); { Return minute } + MOVB %CH, %AL; { Transfer register } + MOVL Hour, %EDI; { EDI -> Hour } + MOVW %AX, (%EDI); { Return hour } + END; *) + { direct call of real interrupt seems to render the system + unstable on Win2000 because some registers are not properly + restored if a mouse interrupt is generated while the Dos + interrupt is called... PM } + Dos.GetTime(Hour,Minute,Second,Sec100); + END; + {$ENDIF} +{$ENDIF} +{$IFDEF OS_WINDOWS} { WIN/NT CODE } + {$IFDEF BIT_16} { 16 BIT WINDOWS CODE } + ASSEMBLER; + ASM + MOV AX, $2C00; { Set function id } + PUSH BP; { Safety save register } + INT $21; { System get time } + POP BP; { Restore register } + XOR AH, AH; { Clear register } + CLD; { Strings go forward } + MOV AL, DL; { Transfer register } + LES DI, Sec100; { ES:DI -> hundredths } + STOSW; { Return hundredths } + MOV AL, DH; { Transfer register } + LES DI, Second; { ES:DI -> seconds } + STOSW; { Return seconds } + MOV AL, CL; { Transfer register } + LES DI, Minute; { ES:DI -> minutes } + STOSW; { Return minutes } + MOV AL, CH; { Transfer register } + LES DI, Hour; { ES:DI -> hours } + STOSW; { Return hours } + END; + {$ENDIF} + {$IFDEF BIT_32} { 32 BIT WINDOWS CODE } + VAR DT: TSystemTime; + BEGIN + {$IFDEF PPC_FPC} { FPC WINDOWS COMPILER } + GetLocalTime(@DT); { Get the date/time } + {$ELSE} { OTHER COMPILERS } + GetLocalTime(DT); { Get the date/time } + {$ENDIF} + Hour := DT.wHour; { Transfer hour } + Minute := DT.wMinute; { Transfer minute } + Second := DT.wSecond; { Transfer seconds } + Sec100 := DT.wMilliseconds DIV 10; { Transfer hundredths } + END; + {$ENDIF} +{$ENDIF} +{$IFDEF OS_OS2} { OS2 CODE } +VAR DT: DateTime; +BEGIN + DosGetDateTime(DT); { Get the date/time } + Hour := DT.Hours; { Transfer hour } + Minute := DT.Minutes; { Transfer minute } + Second := DT.Seconds; { Transfer seconds } + Sec100 := DT.Hundredths; { Transfer hundredths } +END; +{$ENDIF} +{$ifdef OS_UNIX} +BEGIN + Dos.GetTime(Hour,Minute,Second,Sec100); +END; +{$endif OS_UNIX} +{$IFDEF OS_NETWARE} +BEGIN + Dos.GetTime(Hour,Minute,Second,Sec100); +END; +{$ENDIF OS_NETWARE} + +{---------------------------------------------------------------------------} +{ MinutesToTime -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Jun97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE MinutesToTime (Md: LongInt; Var Hour24, Minute: Word); +BEGIN + Hour24 := Md DIV 60; { Hours of time } + Minute := Md MOD 60; { Minutes of time } +END; + +{---------------------------------------------------------------------------} +{ SecondsToTime -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Jun97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE SecondsToTime (Sd: LongInt; Var Hour24, Minute, Second: Word); +BEGIN + Hour24 := Sd DIV 3600; { Hours of time } + Minute := Sd MOD 3600 DIV 60; { Minutes of time } + Second := Sd MOD 60; { Seconds of time } +END; + +END. diff --git a/packages/fv/src/timeddlg.pas b/packages/fv/src/timeddlg.pas new file mode 100644 index 0000000000..9a24ee9cd9 --- /dev/null +++ b/packages/fv/src/timeddlg.pas @@ -0,0 +1,254 @@ +{ + + Timed dialogs for Free Vision + + Copyright (c) 2004 by Free Pascal core 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. + + ****************************************************************************} +UNIT timeddlg; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Near calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES objects, dialogs, fvconsts, drivers, views; { Standard GFV unit } + +type + TTimedDialog = object (TDialog) + Secs: longint; + constructor Init (var Bounds: TRect; ATitle: TTitleStr; ASecs: word); + constructor Load (var S: TStream); + procedure GetEvent (var Event: TEvent); virtual; + procedure Store (var S: TStream); virtual; + private + Secs0: longint; + Secs2: longint; + DayWrap: boolean; + end; + PTimedDialog = ^TTimedDialog; + +(* Must be always included in TTimeDialog! *) + TTimedDialogText = object (TStaticText) + constructor Init (var Bounds: TRect); + procedure GetText (var S: string); virtual; + end; + PTimedDialogText = ^TTimedDialogText; + +const + RTimedDialog: TStreamRec = ( + ObjType: idTimedDialog; +{$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs (TypeOf (TTimedDialog)^); +{$ELSE} { Alt style VMT link } + VmtLink: TypeOf (TTimedDialog); +{$ENDIF BP_VMTLink} + Load: @TTimedDialog.Load; + Store: @TTimedDialog.Store + ); + + RTimedDialogText: TStreamRec = ( + ObjType: idTimedDialogText; +{$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs (TypeOf (TTimedDialogText)^); +{$ELSE} { Alt style VMT link } + VmtLink: TypeOf (TTimedDialogText); +{$ENDIF BP_VMTLink} + Load: @TTimedDialogText.Load; + Store: @TTimedDialogText.Store + ); + +procedure RegisterTimedDialog; + +FUNCTION TimedMessageBox (Const Msg: String; Params: Pointer; + AOptions: Word; ASecs: Word): Word; + +{-TimedMessageBoxRect------------------------------------------------ +TimedMessageBoxRect allows the specification of a TRect for the message box +to occupy. +---------------------------------------------------------------------} +FUNCTION TimedMessageBoxRect (Var R: TRect; Const Msg: String; Params: Pointer; + AOptions: Word; ASecs: Word): Word; + + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +USES + dos, + app, {resource,} msgbox; { Standard GFV units } + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +constructor TTimedDialogText.Init (var Bounds: TRect); +begin + inherited Init (Bounds, ''); +end; + + +procedure TTimedDialogText.GetText (var S: string); +begin + if Owner <> nil +(* and (TypeOf (Owner^) = TypeOf (TTimedDialog)) *) + then + begin + Str (PTimedDialog (Owner)^.Secs, S); + S := #3 + S; + end + else + S := ''; +end; + + + +constructor TTimedDialog.Init (var Bounds: TRect; ATitle: TTitleStr; + ASecs: word); +var + H, M, S, S100: word; +begin + inherited Init (Bounds, ATitle); + GetTime (H, M, S, S100); + Secs0 := H * 3600 + M * 60 + S; + Secs2 := Secs0 + ASecs; + Secs := ASecs; + DayWrap := Secs2 > 24 * 3600; +end; + + +procedure TTimedDialog.GetEvent (var Event: TEvent); +var + H, M, S, S100: word; + Secs1: longint; +begin + inherited GetEvent (Event); + GetTime (H, M, S, S100); + Secs1 := H * 3600 + M * 60 + S; + if DayWrap then Inc (Secs1, 24 * 3600); + if Secs2 - Secs1 <> Secs then + begin + Secs := Secs2 - Secs1; + if Secs < 0 then + Secs := 0; +(* If remaining seconds are displayed in one of included views, update them. *) + Redraw; + end; + with Event do + if (Secs = 0) and (What = evNothing) then + begin + What := evCommand; + Command := cmCancel; + end; +end; + + +constructor TTimedDialog.Load (var S: TStream); +begin + inherited Load (S); + S.Read (Secs, SizeOf (Secs)); + S.Read (Secs0, SizeOf (Secs0)); + S.Read (Secs2, SizeOf (Secs2)); + S.Read (DayWrap, SizeOf (DayWrap)); +end; + + +procedure TTimedDialog.Store (var S: TStream); +begin + inherited Store (S); + S.Write (Secs, SizeOf (Secs)); + S.Write (Secs0, SizeOf (Secs0)); + S.Write (Secs2, SizeOf (Secs2)); + S.Write (DayWrap, SizeOf (DayWrap)); +end; + + + +function TimedMessageBox (const Msg: string; Params: pointer; + AOptions: word; ASecs: word): word; +var + R: TRect; +begin + R.Assign(0, 0, 40, 10); { Assign area } + if (AOptions AND mfInsertInApp = 0) then { Non app insert } + R.Move((Desktop^.Size.X - R.B.X) div 2, + (Desktop^.Size.Y - R.B.Y) div 2) { Calculate position } + else + R.Move((Application^.Size.X - R.B.X) div 2, + (Application^.Size.Y - R.B.Y) div 2); { Calculate position } + TimedMessageBox := TimedMessageBoxRect (R, Msg, Params, + AOptions, ASecs); { Create message box } +end; + + +function TimedMessageBoxRect (var R: TRect; const Msg: string; Params: pointer; + AOptions: word; ASecs: word): word; +var + Dlg: PTimedDialog; + TimedText: PTimedDialogText; +begin + Dlg := New (PTimedDialog, Init (R, MsgBoxTitles [AOptions + and $3], ASecs)); { Create dialog } + with Dlg^ do + begin + R.Assign (3, Size.Y - 5, Size.X - 2, Size.Y - 4); + New (TimedText, Init (R)); + Insert (TimedText); + R.Assign (3, 2, Size.X - 2, Size.Y - 5); { Assign area for text } + end; + TimedMessageBoxRect := MessageBoxRectDlg (Dlg, R, Msg, Params, AOptions); + Dispose (Dlg, Done); { Dispose of dialog } +end; + + + +procedure RegisterTimedDialog; +begin + RegisterType (RTimedDialog); + RegisterType (RTimedDialogText); +end; + + +begin + RegisterTimedDialog; +end. diff --git a/packages/fv/src/unixsmsg.inc b/packages/fv/src/unixsmsg.inc new file mode 100644 index 0000000000..7872ebafe8 --- /dev/null +++ b/packages/fv/src/unixsmsg.inc @@ -0,0 +1,126 @@ +{ + System dependent system messages for unix + + Copyright (c) 2002 by Pierre Muller + + 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 file is still a dummy, + it should use ioctl to get information about resizing of windows } + +uses +{$ifdef VER1_0} + linux; +{$else} + BaseUnix,termio; +{$endif} + +Const + SystemEventActive : Boolean = false; + +var + lastxsize,lastysize : longint; + +procedure InitSystemMsg; +var + WinSize : TWinSize; +begin + If SystemEventActive then + exit; + { Code to enable size tracking should go here } + PendingSystemHead:=@PendingSystemEvent; + PendingSystemTail:=@PendingSystemEvent; + PendingSystemEvents:=0; + FillChar(LastSystemEvent,sizeof(TSystemEvent),0); + FillChar(WinSize,sizeof(WinSize),0); +{$ifdef VER1_0} + ioctl(stdinputhandle,TIOCGWINSZ,@winsize); +{$else} + fpioctl(stdinputhandle,TIOCGWINSZ,@winsize); +{$endif} + LastXSize:=WinSize.ws_row; + LastYSize:=WinSize.ws_col; + If LastXSize=0 then + LastXSize:=80; + If LastYSize=0 then + LastYSize:=25; + + SystemEventActive:=true; +end; + + +procedure DoneSystemMsg; +begin + if not SystemEventActive then + exit; + { Code to disable size tracking should go here } + SystemEventActive:=false; +end; + +procedure GetSystemEvent(var SystemEvent: TSystemEvent); +begin + if PendingSystemEvents=0 then + PollSystemEvent(SystemEvent); + if PendingSystemEvents=0 then + exit; + SystemEvent:=PendingSystemHead^; + inc(PendingSystemHead); + if longint(PendingSystemHead)=longint(@PendingSystemEvent)+sizeof(PendingSystemEvent) then + PendingSystemHead:=@PendingSystemEvent; + dec(PendingSystemEvents); + LastSystemEvent:=SystemEvent; +end; + + +function PollSystemEvent(var SystemEvent: TSystemEvent):boolean; +var + CloseState : word; + WinSize : TWinSize; +begin + SystemEvent.typ:=SysNothing; + if not SystemEventActive then + exit(false); + if PendingSystemEvents>0 then + begin + SystemEvent:=PendingSystemHead^; + PollSystemEvent:=true; + end + else + begin + FillChar(WinSize,sizeof(WinSize),0); +{$ifdef VER1_0} + ioctl(stdinputhandle,TIOCGWINSZ,@winsize); +{$else} + fpioctl(stdinputhandle,TIOCGWINSZ,@winsize); +{$endif} + if (winsize.ws_col<>0) and (winsize.ws_row<>0) and + ((winsize.ws_row<>lastxsize) or (winsize.ws_col<>lastysize)) then + begin + SystemEvent.typ:=SysResize; + SystemEvent.x:=WinSize.ws_col; + SystemEvent.y:=WinSize.ws_row; + PutSystemEvent(SystemEvent); + LastXSize:=WinSize.ws_row; + LastYSize:=WinSize.ws_col; + PollSystemEvent:=true; + end + else + PollSystemEvent:=false; + end; +end; + diff --git a/packages/fv/src/validate.pas b/packages/fv/src/validate.pas new file mode 100644 index 0000000000..e4ed9a5be3 --- /dev/null +++ b/packages/fv/src/validate.pas @@ -0,0 +1,1048 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of VALIDATE.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@ibm.net } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ 16 and 32 Bit compilers } +{ DOS - Turbo Pascal 7.0 + (16 Bit) } +{ DPMI - Turbo Pascal 7.0 + (16 Bit) } +{ - FPC 0.9912+ (GO32V2) (32 Bit) } +{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) } +{ - Delphi 1.0+ (16 Bit) } +{ WIN95/NT - Delphi 2.0+ (32 Bit) } +{ - Virtual Pascal 2.0+ (32 Bit) } +{ - Speedsoft Sybil 2.0+ (32 Bit) } +{ - FPC 0.9912+ (32 Bit) } +{ OS2 - Virtual Pascal 1.0+ (32 Bit) } +{ } +{******************[ REVISION HISTORY ]********************} +{ Version Date Fix } +{ ------- --------- --------------------------------- } +{ 1.00 12 Jun 96 Initial DOS/DPMI code released. } +{ 1.10 29 Aug 97 Platform.inc sort added. } +{ 1.20 13 Oct 97 Delphi3 32 bit code added. } +{ 1.30 11 May 98 Virtual pascal 2.0 code added. } +{ 1.40 10 Jul 99 Sybil 2.0 code added } +{ 1.41 03 Nov 99 FPC windows code added } +{**********************************************************} + +UNIT Validate; + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$IFNDEF PPC_FPC}{ FPC doesn't support these switches } + {$F-} { Short calls are okay } + {$A+} { Word Align Data } + {$B-} { Allow short circuit boolean evaluations } + {$O+} { This unit may be overlaid } + {$G+} { 286 Code optimization - if you're on an 8088 get a real computer } + {$P-} { Normal string variables } + {$N-} { No 80x87 code generation } + {$E+} { Emulation is on } +{$ENDIF} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES FVCommon, Objects, fvconsts; { GFV standard units } + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ VALIDATOR STATUS CONSTANTS } +{---------------------------------------------------------------------------} +CONST + vsOk = 0; { Validator ok } + vsSyntax = 1; { Validator sytax err } + +{---------------------------------------------------------------------------} +{ VALIDATOR OPTION MASKS } +{---------------------------------------------------------------------------} +CONST + voFill = $0001; { Validator fill } + voTransfer = $0002; { Validator transfer } + voOnAppend = $0004; { Validator append } + voReserved = $00F8; { Clear above flags } + +{***************************************************************************} +{ RECORD DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ VALIDATOR TRANSFER CONSTANTS } +{---------------------------------------------------------------------------} +TYPE + TVTransfer = (vtDataSize, vtSetData, vtGetData); { Transfer states } + +{---------------------------------------------------------------------------} +{ PICTURE VALIDATOR RESULT CONSTANTS } +{---------------------------------------------------------------------------} +TYPE + TPicResult = (prComplete, prIncomplete, prEmpty, prError, prSyntax, + prAmbiguous, prIncompNoFill); + +{***************************************************************************} +{ OBJECT DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TValidator OBJECT - VALIDATOR ANCESTOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TValidator = OBJECT (TObject) + Status : Word; { Validator status } + Options: Word; { Validator options } + CONSTRUCTOR Load (Var S: TStream); + FUNCTION Valid(CONST S: String): Boolean; + FUNCTION IsValid (CONST S: String): Boolean; Virtual; + FUNCTION IsValidInput (Var S: String; + SuppressFill: Boolean): Boolean; Virtual; + FUNCTION Transfer (Var S: String; Buffer: Pointer; + Flag: TVTransfer): Word; Virtual; + PROCEDURE Error; Virtual; + PROCEDURE Store (Var S: TStream); + END; + PValidator = ^TValidator; + +{---------------------------------------------------------------------------} +{ TPictureValidator OBJECT - PICTURE VALIDATOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TPXPictureValidator = OBJECT (TValidator) + Pic: PString; { Picture filename } + CONSTRUCTOR Init (Const APic: String; AutoFill: Boolean); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION IsValid (Const S: String): Boolean; Virtual; + FUNCTION IsValidInput (Var S: String; + SuppressFill: Boolean): Boolean; Virtual; + FUNCTION Picture (Var Input: String; + AutoFill: Boolean): TPicResult; Virtual; + PROCEDURE Error; Virtual; + PROCEDURE Store (Var S: TStream); + END; + PPXPictureValidator = ^TPXPictureValidator; + +TYPE CharSet = TCharSet; + +{---------------------------------------------------------------------------} +{ TFilterValidator OBJECT - FILTER VALIDATOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TFilterValidator = OBJECT (TValidator) + ValidChars: CharSet; { Valid char set } + CONSTRUCTOR Init (AValidChars: CharSet); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION IsValid (CONST S: String): Boolean; Virtual; + FUNCTION IsValidInput (Var S: String; + SuppressFill: Boolean): Boolean; Virtual; + PROCEDURE Error; Virtual; + PROCEDURE Store (Var S: TStream); + END; + PFilterValidator = ^TFilterValidator; + +{---------------------------------------------------------------------------} +{ TRangeValidator OBJECT - RANGE VALIDATOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TRangeValidator = OBJECT (TFilterValidator) + Min: LongInt; { Min valid value } + Max: LongInt; { Max valid value } + CONSTRUCTOR Init(AMin, AMax: LongInt); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION IsValid (Const S: String): Boolean; Virtual; + FUNCTION Transfer (Var S: String; Buffer: Pointer; + Flag: TVTransfer): Word; Virtual; + PROCEDURE Error; Virtual; + PROCEDURE Store (Var S: TStream); + END; + PRangeValidator = ^TRangeValidator; + +{---------------------------------------------------------------------------} +{ TLookUpValidator OBJECT - LOOKUP VALIDATOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TLookupValidator = OBJECT (TValidator) + FUNCTION IsValid (Const S: String): Boolean; Virtual; + FUNCTION Lookup (Const S: String): Boolean; Virtual; + END; + PLookupValidator = ^TLookupValidator; + +{---------------------------------------------------------------------------} +{ TStringLookUpValidator OBJECT - STRING LOOKUP VALIDATOR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TStringLookupValidator = OBJECT (TLookupValidator) + Strings: PStringCollection; + CONSTRUCTOR Init (AStrings: PStringCollection); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION Lookup (Const S: String): Boolean; Virtual; + PROCEDURE Error; Virtual; + PROCEDURE NewStringList (AStrings: PStringCollection); + PROCEDURE Store (Var S: TStream); + END; + PStringLookupValidator = ^TStringLookupValidator; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{-RegisterValidate--------------------------------------------------- +Calls RegisterType for each of the object types defined in this unit. +18May98 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterValidate; + +{***************************************************************************} +{ OBJECT REGISTRATION } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TPXPictureValidator STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RPXPictureValidator: TStreamRec = ( + ObjType: idPXPictureValidator; { Register id = 80 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TPXPictureValidator)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TPXPictureValidator); + {$ENDIF} + Load: @TPXPictureValidator.Load; { Object load method } + Store: @TPXPictureValidator.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TFilterValidator STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RFilterValidator: TStreamRec = ( + ObjType: idFilterValidator; { Register id = 81 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TFilterValidator)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TFilterValidator); + {$ENDIF} + Load: @TFilterValidator.Load; { Object load method } + Store: @TFilterValidator.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TRangeValidator STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RRangeValidator: TStreamRec = ( + ObjType: idRangeValidator; { Register id = 82 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TRangeValidator)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TRangeValidator); + {$ENDIF} + Load: @TRangeValidator.Load; { Object load method } + Store: @TRangeValidator.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TStringLookupValidator STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RStringLookupValidator: TStreamRec = ( + ObjType: idStringLookupValidator; { Register id = 83 } + {$IFDEF BP_VMTLink} { BP style VMT link } + VmtLink: Ofs(TypeOf(TStringLookupValidator)^); + {$ELSE} { Alt style VMT link } + VmtLink: TypeOf(TStringLookupValidator); + {$ENDIF} + Load: @TStringLookupValidator.Load; { Object load method } + Store: @TStringLookupValidator.Store { Object store method } + ); + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +USES MsgBox; { GFV standard unit } + +{***************************************************************************} +{ PRIVATE ROUTINES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ IsLetter -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION IsLetter (Chr: Char): Boolean; +BEGIN + Chr := Char(Ord(Chr) AND $DF); { Lower to upper case } + If (Chr >= 'A') AND (Chr <='Z') Then { Check if A..Z } + IsLetter := True Else IsLetter := False; { Return result } +END; + +{---------------------------------------------------------------------------} +{ IsComplete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION IsComplete (Rslt: TPicResult): Boolean; +BEGIN + IsComplete := Rslt IN [prComplete, prAmbiguous]; { Return if complete } +END; + +{---------------------------------------------------------------------------} +{ IsInComplete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION IsIncomplete (Rslt: TPicResult): Boolean; +BEGIN + IsIncomplete := Rslt IN + [prIncomplete, prIncompNoFill]; { Return if incomplete } +END; + +{---------------------------------------------------------------------------} +{ NumChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION NumChar (Chr: Char; Const S: String): Byte; +VAR I, Total: Byte; +BEGIN + Total := 0; { Zero total } + For I := 1 To Length(S) Do { For entire string } + If (S[I] = Chr) Then Inc(Total); { Count matches of Chr } + NumChar := Total; { Return char count } +END; + +{---------------------------------------------------------------------------} +{ IsSpecial -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION IsSpecial (Chr: Char; Const Special: String): Boolean; +VAR Rslt: Boolean; I: Byte; +BEGIN + Rslt := False; { Preset false result } + For I := 1 To Length(Special) Do + If (Special[I] = Chr) Then Rslt := True; { Character found } + IsSpecial := Rslt; { Return result } +END; + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TValidator---------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TValidator.Load (Var S:TStream); +BEGIN + Inherited Init; { Call ancestor } + S.Read(Options, SizeOf(Options)); { Read option masks } +END; + +{--TValidator---------------------------------------------------------------} +{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TValidator.Valid (Const S: String): Boolean; +BEGIN + Valid := False; { Preset false result } + If Not IsValid(S) Then Error { Check for error } + Else Valid := True; { Return valid result } +END; + +{--TValidator---------------------------------------------------------------} +{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TValidator.IsValid (Const S: String): Boolean; +BEGIN + IsValid := True; { Default return valid } +END; + +{--TValidator---------------------------------------------------------------} +{ IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TValidator.IsValidInput (Var S: String; SuppressFill: Boolean): Boolean; +BEGIN + IsValidInput := True; { Default return true } +END; + +{--TValidator---------------------------------------------------------------} +{ Transfer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TValidator.Transfer (Var S: String; Buffer: Pointer; + Flag: TVTransfer): Word; +BEGIN + Transfer := 0; { Default return zero } +END; + +{--TValidator---------------------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TValidator.Error; +BEGIN { Abstract method } +END; + +{--TValidator---------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TValidator.Store (Var S: TStream); +BEGIN + S.Write(Options, SizeOf(Options)); { Write options } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TPXPictureValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TPXPictureValidator------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TPXPictureValidator.Init (Const APic: String; AutoFill: Boolean); +VAR S: String; +BEGIN + Inherited Init; { Call ancestor } + Pic := NewStr(APic); { Hold filename } + Options := voOnAppend; { Preset option mask } + If AutoFill Then Options := Options OR voFill; { Check/set fill mask } + S := ''; { Create empty string } + If (Picture(S, False) <> prEmpty) Then { Check for empty } + Status := vsSyntax; { Set error mask } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TPXPictureValidator.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + Pic := S.ReadStr; { Read filename } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TPXPictureValidator.Done; +BEGIN + If (Pic <> Nil) Then DisposeStr(Pic); { Dispose of filename } + Inherited Done; { Call ancestor } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TPXPictureValidator.IsValid (Const S: String): Boolean; +VAR Str: String; Rslt: TPicResult; +BEGIN + Str := S; { Transfer string } + Rslt := Picture(Str, False); { Check for picture } + IsValid := (Pic = nil) OR (Rslt = prComplete) OR + (Rslt = prEmpty); { Return result } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TPXPictureValidator.IsValidInput (Var S: String; + SuppressFill: Boolean): Boolean; +BEGIN + IsValidInput := (Pic = Nil) OR (Picture(S, + (Options AND voFill <> 0) AND NOT SuppressFill) + <> prError); { Return input result } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ Picture -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TPXPictureValidator.Picture (Var Input: String; AutoFill: Boolean): TPicResult; +VAR I, J: Byte; Rslt: TPicResult; Reprocess: Boolean; + + FUNCTION Process (TermCh: Byte): TPicResult; + VAR Rslt: TPicResult; Incomp: Boolean; OldI, OldJ, IncompJ, IncompI: Byte; + + PROCEDURE Consume (Ch: Char); + BEGIN + Input[J] := Ch; { Return character } + Inc(J); { Inc count J } + Inc(I); { Inc count I } + END; + + PROCEDURE ToGroupEnd (Var I: Byte); + VAR BrkLevel, BrcLevel: Integer; + BEGIN + BrkLevel := 0; { Zero bracket level } + BrcLevel := 0; { Zero bracket level } + Repeat + If (I <> TermCh) Then Begin { Not end } + Case Pic^[I] Of + '[': Inc(BrkLevel); { Inc bracket level } + ']': Dec(BrkLevel); { Dec bracket level } + '{': Inc(BrcLevel); { Inc bracket level } + '}': Dec(BrcLevel); { Dec bracket level } + ';': Inc(I); { Next character } + '*': Begin + Inc(I); { Next character } + While Pic^[I] in ['0'..'9'] Do Inc(I); { Search for text } + ToGroupEnd(I); { Move to group end } + Continue; { Now continue } + End; + End; + Inc(I); { Next character } + End; + Until ((BrkLevel = 0) AND (BrcLevel = 0)) OR { Both levels must be 0 } + (I = TermCh); { Terminal character } + END; + + FUNCTION SkipToComma: Boolean; + BEGIN + Repeat + ToGroupEnd(I); { Find group end } + Until (I = TermCh) OR (Pic^[I] = ','); { Terminator found } + If (Pic^[I] = ',') Then Inc(I); { Comma so continue } + SkipToComma := (I < TermCh); { Return result } + END; + + FUNCTION CalcTerm: Byte; + VAR K: Byte; + BEGIN + K := I; { Hold count } + ToGroupEnd(K); { Find group end } + CalcTerm := K; { Return count } + END; + + FUNCTION Iteration: TPicResult; + VAR Itr, K, L: Byte; Rslt: TPicResult; NewTermCh: Byte; + BEGIN + Itr := 0; { Zero iteration } + Iteration := prError; { Preset error result } + Inc(I); { Skip '*' character } + While Pic^[I] in ['0'..'9'] Do Begin { Entry is a number } + Itr := Itr * 10 + Byte(Pic^[I]) - Byte('0'); { Convert to number } + Inc(I); { Next character } + End; + If (I <= TermCh) Then Begin { Not end of name } + K := I; { Hold count } + NewTermCh := CalcTerm; { Calc next terminator } + If (Itr <> 0) Then Begin + For L := 1 To Itr Do Begin { For each character } + I := K; { Reset count } + Rslt := Process(NewTermCh); { Process new entry } + If (NOT IsComplete(Rslt)) Then Begin { Not empty } + If (Rslt = prEmpty) Then { Check result } + Rslt := prIncomplete; { Return incomplete } + Iteration := Rslt; { Return result } + Exit; { Now exit } + End; + End; + End Else Begin + Repeat + I := K; { Hold count } + Rslt := Process(NewTermCh); { Process new entry } + Until (NOT IsComplete(Rslt)); { Until complete } + If (Rslt = prEmpty) OR (Rslt = prError) { Check for any error } + Then Begin + Inc(I); { Next character } + Rslt := prAmbiguous; { Return result } + End; + End; + I := NewTermCh; { Find next name } + End Else Rslt := prSyntax; { Completed } + Iteration := Rslt; { Return result } + END; + + FUNCTION Group: TPicResult; + VAR Rslt: TPicResult; TermCh: Byte; + BEGIN + TermCh := CalcTerm; { Calc new term } + Inc(I); { Next character } + Rslt := Process(TermCh - 1); { Process the name } + If (NOT IsIncomplete(Rslt)) Then I := TermCh; { Did not complete } + Group := Rslt; { Return result } + END; + + FUNCTION CheckComplete (Rslt: TPicResult): TPicResult; + VAR J: Byte; + BEGIN + J := I; { Hold count } + If IsIncomplete(Rslt) Then Begin { Check if complete } + While True Do + Case Pic^[J] Of + '[': ToGroupEnd(J); { Find name end } + '*': If not(Pic^[J + 1] in ['0'..'9']) + Then Begin + Inc(J); { Next name } + ToGroupEnd(J); { Find name end } + End Else Break; + Else Break; + End; + If (J = TermCh) Then Rslt := prAmbiguous; { End of name } + End; + CheckComplete := Rslt; { Return result } + END; + + FUNCTION Scan: TPicResult; + VAR Ch: Char; Rslt: TPicResult; + BEGIN + Scan := prError; { Preset return error } + Rslt := prEmpty; { Preset empty result } + While (I <> TermCh) AND (Pic^[I] <> ',') { For each entry } + Do Begin + If (J > Length(Input)) Then Begin { Move beyond length } + Scan := CheckComplete(Rslt); { Return result } + Exit; { Now exit } + End; + Ch := Input[J]; { Fetch character } + Case Pic^[I] of + '#': If NOT (Ch in ['0'..'9']) Then Exit { Check is a number } + Else Consume(Ch); { Transfer number } + '?': If (NOT IsLetter(Ch)) Then Exit { Check is a letter } + Else Consume(Ch); { Transfer character } + '&': If (NOT IsLetter(Ch)) Then Exit { Check is a letter } + Else Consume(UpCase(Ch)); { Transfer character } + '!': Consume(UpCase(Ch)); { Transfer character } + '@': Consume(Ch); { Transfer character } + '*': Begin + Rslt := Iteration; { Now re-iterate } + If (NOT IsComplete(Rslt)) Then Begin { Check not complete } + Scan := Rslt; { Return result } + Exit; { Now exit } + End; + If (Rslt = prError) Then { Check for error } + Rslt := prAmbiguous; { Return ambiguous } + End; + '{': Begin + Rslt := Group; { Return group } + If (NOT IsComplete(Rslt)) Then Begin { Not incomplete check } + Scan := Rslt; { Return result } + Exit; { Now exit } + End; + End; + '[': Begin + Rslt := Group; { Return group } + If IsIncomplete(Rslt) Then Begin { Incomplete check } + Scan := Rslt; { Return result } + Exit; { Now exit } + End; + If (Rslt = prError) Then { Check for error } + Rslt := prAmbiguous; { Return ambiguous } + End; + Else If Pic^[I] = ';' Then Inc(I); { Move fwd for follow } + If (UpCase(Pic^[I]) <> UpCase(Ch)) Then { Characters differ } + If (Ch = ' ') Then Ch := Pic^[I] { Ignore space } + Else Exit; + Consume(Pic^[I]); { Consume character } + End; { Case } + If (Rslt = prAmbiguous) Then { If ambiguous result } + Rslt := prIncompNoFill { Set incomplete fill } + Else Rslt := prIncomplete; { Set incomplete } + End;{ While} + If (Rslt = prIncompNoFill) Then { Check incomp fill } + Scan := prAmbiguous Else { Return ambiguous } + Scan := prComplete; { Return completed } + END; + + BEGIN + Incomp := False; { Clear incomplete } + InCompJ:=0; { set to avoid a warning } + OldI := I; { Hold I count } + OldJ := J; { Hold J count } + Repeat + Rslt := Scan; { Scan names } + If (Rslt IN [prComplete, prAmbiguous]) AND + Incomp AND (J < IncompJ) Then Begin { Check if complete } + Rslt := prIncomplete; { Return result } + J := IncompJ; { Return position } + End; + If ((Rslt = prError) OR (Rslt = prIncomplete)) { Check no errors } + Then Begin + Process := Rslt; { Hold result } + If ((NOT Incomp) AND (Rslt = prIncomplete)) { Check complete } + Then Begin + Incomp := True; { Set incomplete } + IncompI := I; { Set current position } + IncompJ := J; { Set current position } + End; + I := OldI; { Restore held value } + J := OldJ; { Restore held value } + If (NOT SkipToComma) Then Begin { Check not comma } + If Incomp Then Begin { Check incomplete } + Process := prIncomplete; { Set incomplete mask } + I := IncompI; { Hold incomp position } + J := IncompJ; { Hold incomp position } + End; + Exit; { Now exit } + End; + OldI := I; { Hold position } + End; + Until (Rslt <> prError) AND { Check for error } + (Rslt <> prIncomplete); { Incomplete load } + If (Rslt = prComplete) AND Incomp Then { Complete load } + Process := prAmbiguous Else { Return completed } + Process := Rslt; { Return result } + END; + + FUNCTION SyntaxCheck: Boolean; + VAR I, BrkLevel, BrcLevel: Integer; + Begin + SyntaxCheck := False; { Preset false result } + If (Pic^ <> '') AND (Pic^[Length(Pic^)] <> ';') { Name is valid } + AND ((Pic^[Length(Pic^)] = '*') AND + (Pic^[Length(Pic^) - 1] <> ';') = False) { Not wildcard list } + Then Begin + I := 1; { Set count to 1 } + BrkLevel := 0; { Zero bracket level } + BrcLevel := 0; { Zero bracket level } + While (I <= Length(Pic^)) Do Begin { For each character } + Case Pic^[I] Of + '[': Inc(BrkLevel); { Inc bracket level } + ']': Dec(BrkLevel); { Dec bracket level } + '{': Inc(BrcLevel); { Inc bracket level } + '}': Dec(BrcLevel); { Dec bracket level } + ';': Inc(I); { Next character } + End; + Inc(I); { Next character } + End; + If (BrkLevel = 0) AND (BrcLevel = 0) Then { Check both levels 0 } + SyntaxCheck := True; { Return true syntax } + End; + End; + +BEGIN + Picture := prSyntax; { Preset error default } + If SyntaxCheck Then Begin { Check syntax } + Picture := prEmpty; { Preset picture empty } + If (Input <> '') Then Begin { We have an input } + J := 1; { Set J count to 1 } + I := 1; { Set I count to 1 } + Rslt := Process(Length(Pic^) + 1); { Set end of name } + If (Rslt <> prError) AND (Rslt <> prSyntax) AND + (J <= Length(Input)) Then Rslt := prError; { Check for any error } + If (Rslt = prIncomplete) AND AutoFill { Check autofill flags } + Then Begin + Reprocess := False; { Set reprocess false } + while (I <= Length(Pic^)) AND (NOT { Not at end of name } + IsSpecial(Pic^[I], '#?&!@*{}[],'#0)) { No special chars } + DO Begin + If Pic^[I] = ';' Then Inc(I); { Check for next mark } + Input := Input + Pic^[I]; { Move to that name } + Inc(I); { Inc count } + Reprocess := True; { Set reprocess flag } + End; + J := 1; { Set J count to 1 } + I := 1; { Set I count to 1 } + If Reprocess Then { Check for reprocess } + Rslt := Process(Length(Pic^) + 1); { Move to next name } + End; + If (Rslt = prAmbiguous) Then { Result ambiguous } + Picture := prComplete Else { Return completed } + If (Rslt = prInCompNoFill) Then { Result incomplete } + Picture := prIncomplete Else { Return incomplete } + Picture := Rslt; { Return result } + End; + End; +END; + +{--TPXPictureValidator------------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TPXPictureValidator.Error; +CONST PXErrMsg = 'Input does not conform to picture:'; +VAR S: String; +BEGIN + If (Pic <> Nil) Then S := Pic^ Else S := 'No name';{ Transfer filename } + MessageBox(PxErrMsg + #13' %s', @S, mfError OR + mfOKButton); { Message box } +END; + +{--TPXPictureValidator------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TPXPictureValidator.Store (Var S: TStream); +BEGIN + TValidator.Store(S); { TValidator.store call } + S.WriteStr(Pic); { Write filename } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TFilterValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TFilterValidator---------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TFilterValidator.Init (AValidChars: CharSet); +BEGIN + Inherited Init; { Call ancestor } + ValidChars := AValidChars; { Hold valid char set } +END; + +{--TFilterValidator---------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TFilterValidator.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(ValidChars, SizeOf(ValidChars)); { Read valid char set } +END; + +{--TFilterValidator---------------------------------------------------------} +{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TFilterValidator.IsValid (Const S: String): Boolean; +VAR I: Integer; +BEGIN + I := 1; { Start at position 1 } + While S[I] In ValidChars Do Inc(I); { Check each char } + If (I > Length(S)) Then IsValid := True Else { All characters valid } + IsValid := False; { Invalid characters } +END; + +{--TFilterValidator---------------------------------------------------------} +{ IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TFilterValidator.IsValidInput (Var S: String; SuppressFill: Boolean): Boolean; +VAR I: Integer; +BEGIN + I := 1; { Start at position 1 } + While S[I] In ValidChars Do Inc(I); { Check each char } + If (I > Length(S)) Then IsValidInput := True { All characters valid } + Else IsValidInput := False; { Invalid characters } +END; + +{--TFilterValidator---------------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TFilterValidator.Error; +CONST PXErrMsg = 'Invalid character in input'; +BEGIN + MessageBox(PXErrMsg, Nil, mfError OR mfOKButton); { Show error message } +END; + +{--TFilterValidator---------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TFilterValidator.Store (Var S: TStream); +BEGIN + TValidator.Store(S); { TValidator.Store call } + S.Write(ValidChars, SizeOf(ValidChars)); { Write valid char set } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TRangeValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TRangeValidator----------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TRangeValidator.Init (AMin, AMax: LongInt); +BEGIN + Inherited Init(['0'..'9','+','-']); { Call ancestor } + If (AMin >= 0) Then { Check min value > 0 } + ValidChars := ValidChars - ['-']; { Is so no negatives } + Min := AMin; { Hold min value } + Max := AMax; { Hold max value } +END; + +{--TRangeValidator----------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TRangeValidator.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(Min, SizeOf(Min)); { Read min value } + S.Read(Max, SizeOf(Max)); { Read max value } +END; + +{--TRangeValidator----------------------------------------------------------} +{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRangeValidator.IsValid (Const S: String): Boolean; +VAR Value: LongInt; Code: Sw_Integer; +BEGIN + IsValid := False; { Preset false result } + If Inherited IsValid(S) Then Begin { Call ancestor } + Val(S, Value, Code); { Convert to number } + If (Value >= Min) AND (Value <= Max) { With valid range } + AND (Code = 0) Then IsValid := True; { No illegal chars } + End; +END; + +{--TRangeValidator----------------------------------------------------------} +{ Transfer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TRangeValidator.Transfer (Var S: String; Buffer: Pointer; Flag: TVTransfer): Word; +VAR Value: LongInt; Code: Sw_Integer; +BEGIN + If (Options AND voTransfer <> 0) Then Begin { Tranfer mask set } + Transfer := SizeOf(Value); { Transfer a longint } + Case Flag Of + vtGetData: Begin + Val(S, Value, Code); { Convert s to number } + LongInt(Buffer^) := Value; { Transfer result } + End; + vtSetData: Str(LongInt(Buffer^), S); { Convert to string s } + End; + End Else Transfer := 0; { No transfer = zero } +END; + +{--TRangeValidator----------------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRangeValidator.Error; +CONST PXErrMsg = 'Value not in the range'; +VAR Params: Array[0..1] Of Longint; +BEGIN + Params[0] := Min; { Transfer min value } + Params[1] := Max; { Transfer max value } + MessageBox(PXErrMsg+' %d to %d', @Params, + mfError OR mfOKButton); { Display message } +END; + +{--TRangeValidator----------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TRangeValidator.Store (Var S: TStream); +BEGIN + TFilterValidator.Store(S); { TFilterValidator.Store } + S.Write(Min, SizeOf(Min)); { Write min value } + S.Write(Max, SizeOf(Max)); { Write max value } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TLookUpValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TLookUpValidator---------------------------------------------------------} +{ IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TLookUpValidator.IsValid (Const S: String): Boolean; +BEGIN + IsValid := LookUp(S); { Check for string } +END; + +{--TLookUpValidator---------------------------------------------------------} +{ LookUp -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TLookupValidator.Lookup (Const S: String): Boolean; +BEGIN + Lookup := True; { Default return true } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TStringLookUpValidator OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TStringLookUpValidator---------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStringLookUpValidator.Init (AStrings: PStringCollection); +BEGIN + Inherited Init; { Call ancestor } + Strings := AStrings; { Hold string list } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TStringLookUpValidator.Load (Var S: TStream); +BEGIN + Inherited Load(S); { Call ancestor } + Strings := PStringCollection(S.Get); { Fecth string list } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TStringLookUpValidator.Done; +BEGIN + NewStringList(Nil); { Dispsoe string list } + Inherited Done; { Call ancestor } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ Lookup -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TStringLookUpValidator.Lookup (Const S: String): Boolean; +{$IFDEF PPC_VIRTUAL} VAR Index: LongInt; {$ELSE} VAR Index: sw_Integer; {$ENDIF} +BEGIN + Lookup := False; { Preset false return } + If (Strings <> Nil) Then + Lookup := Strings^.Search(@S, Index); { Search for string } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStringLookUpValidator.Error; +CONST PXErrMsg = 'Input not in valid-list'; +BEGIN + MessageBox(PXErrMsg, Nil, mfError OR mfOKButton); { Display message } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ NewStringList -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStringLookUpValidator.NewStringList (AStrings: PStringCollection); +BEGIN + If (Strings <> Nil) Then Dispose(Strings, Done); { Free old string list } + Strings := AStrings; { Hold new string list } +END; + +{--TStringLookUpValidator---------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TStringLookUpValidator.Store (Var S: TStream); +BEGIN + TLookupValidator.Store(S); { TlookupValidator call } + S.Put(Strings); { Now store strings } +END; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTER ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ RegisterValidate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterValidate; +BEGIN + RegisterType(RPXPictureValidator); { Register viewer } + RegisterType(RFilterValidator); { Register filter } + RegisterType(RRangeValidator); { Register validator } + RegisterType(RStringLookupValidator); { Register str lookup } +END; + +END. diff --git a/packages/fv/src/views.pas b/packages/fv/src/views.pas new file mode 100644 index 0000000000..f29b31e7fc --- /dev/null +++ b/packages/fv/src/views.pas @@ -0,0 +1,4673 @@ +{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********} +{ } +{ System independent GRAPHICAL clone of VIEWS.PAS } +{ } +{ Interface Copyright (c) 1992 Borland International } +{ } +{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer } +{ ldeboer@attglobal.net - primary e-mail address } +{ ldeboer@starwon.com.au - backup e-mail address } +{ } +{****************[ THIS CODE IS FREEWARE ]*****************} +{ } +{ This sourcecode is released for the purpose to } +{ promote the pascal language on all platforms. You may } +{ redistribute it and/or modify with the following } +{ DISCLAIMER. } +{ } +{ This SOURCE CODE is distributed "AS IS" WITHOUT } +{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR } +{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. } +{ } +{*****************[ SUPPORTED PLATFORMS ]******************} +{ } +{ Only Free Pascal Compiler supported } +{ } +{**********************************************************} + +UNIT Views; + +{$CODEPAGE cp437} + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + INTERFACE +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +{====Include file to sort compiler platform out =====================} +{$I Platform.inc} +{====================================================================} + +{==== Compiler directives ===========================================} + +{$X+} { Extended syntax is ok } +{$R-} { Disable range checking } +{$S-} { Disable Stack Checking } +{$I-} { Disable IO Checking } +{$Q-} { Disable Overflow Checking } +{$V-} { Turn off strict VAR strings } +{====================================================================} + +USES + {$IFDEF OS_WINDOWS} { WIN/NT CODE } + Windows, { Standard unit } + {$ENDIF} + + {$IFDEF OS_OS2} { OS2 CODE } + Os2Def, DosCalls, PmWin, + {$ENDIF} + + Objects, FVCommon, Drivers, fvconsts; { GFV standard units } + +{***************************************************************************} +{ PUBLIC CONSTANTS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TView STATE MASKS } +{---------------------------------------------------------------------------} +CONST + sfVisible = $0001; { View visible mask } + sfCursorVis = $0002; { Cursor visible } + sfCursorIns = $0004; { Cursor insert mode } + sfShadow = $0008; { View has shadow } + sfActive = $0010; { View is active } + sfSelected = $0020; { View is selected } + sfFocused = $0040; { View is focused } + sfDragging = $0080; { View is dragging } + sfDisabled = $0100; { View is disabled } + sfModal = $0200; { View is modal } + sfDefault = $0400; { View is default } + sfExposed = $0800; { View is exposed } + sfIconised = $1000; { View is iconised } + +{---------------------------------------------------------------------------} +{ TView OPTION MASKS } +{---------------------------------------------------------------------------} +CONST + ofSelectable = $0001; { View selectable } + ofTopSelect = $0002; { Top selectable } + ofFirstClick = $0004; { First click react } + ofFramed = $0008; { View is framed } + ofPreProcess = $0010; { Pre processes } + ofPostProcess = $0020; { Post processes } + ofBuffered = $0040; { View is buffered } + ofTileable = $0080; { View is tileable } + ofCenterX = $0100; { View centred on x } + ofCenterY = $0200; { View centred on y } + ofCentered = $0300; { View x,y centred } + ofValidate = $0400; { View validates } + ofVersion = $3000; { View TV version } + ofVersion10 = $0000; { TV version 1 view } + ofVersion20 = $1000; { TV version 2 view } + +{---------------------------------------------------------------------------} +{ TView GROW MODE MASKS } +{---------------------------------------------------------------------------} +CONST + gfGrowLoX = $01; { Left side grow } + gfGrowLoY = $02; { Top side grow } + gfGrowHiX = $04; { Right side grow } + gfGrowHiY = $08; { Bottom side grow } + gfGrowAll = $0F; { Grow on all sides } + gfGrowRel = $10; { Grow relative } + +{---------------------------------------------------------------------------} +{ TView DRAG MODE MASKS } +{---------------------------------------------------------------------------} +CONST + dmDragMove = $01; { Move view } + dmDragGrow = $02; { Grow view } + dmLimitLoX = $10; { Limit left side } + dmLimitLoY = $20; { Limit top side } + dmLimitHiX = $40; { Limit right side } + dmLimitHiY = $80; { Limit bottom side } + dmLimitAll = $F0; { Limit all sides } + +{---------------------------------------------------------------------------} +{ >> NEW << TAB OPTION MASKS } +{---------------------------------------------------------------------------} +CONST + tmTab = $01; { Tab move mask } + tmShiftTab = $02; { Shift+tab move mask } + tmEnter = $04; { Enter move mask } + tmLeft = $08; { Left arrow move mask } + tmRight = $10; { Right arrow move mask } + tmUp = $20; { Up arrow move mask } + tmDown = $40; { Down arrow move mask } + +{---------------------------------------------------------------------------} +{ >> NEW << VIEW DRAW MASKS } +{---------------------------------------------------------------------------} +CONST + vdBackGnd = $01; { Draw backgound } + vdInner = $02; { Draw inner detail } + vdCursor = $04; { Draw cursor } + vdBorder = $08; { Draw view border } + vdFocus = $10; { Draw focus state } + vdNoChild = $20; { Draw no children } + vdShadow = $40; + vdAll = vdBackGnd + vdInner + vdCursor + vdBorder + vdFocus + vdShadow; + +{---------------------------------------------------------------------------} +{ TView HELP CONTEXTS } +{---------------------------------------------------------------------------} +CONST + hcNoContext = 0; { No view context } + hcDragging = 1; { No drag context } + +{---------------------------------------------------------------------------} +{ TWindow FLAG MASKS } +{---------------------------------------------------------------------------} +CONST + wfMove = $01; { Window can move } + wfGrow = $02; { Window can grow } + wfClose = $04; { Window can close } + wfZoom = $08; { Window can zoom } + +{---------------------------------------------------------------------------} +{ TWindow PALETTES } +{---------------------------------------------------------------------------} +CONST + wpBlueWindow = 0; { Blue palette } + wpCyanWindow = 1; { Cyan palette } + wpGrayWindow = 2; { Gray palette } + +{---------------------------------------------------------------------------} +{ COLOUR PALETTES } +{---------------------------------------------------------------------------} +CONST + CFrame = #1#1#2#2#3; { Frame palette } + CScrollBar = #4#5#5; { Scrollbar palette } + CScroller = #6#7; { Scroller palette } + CListViewer = #26#26#27#28#29; { Listviewer palette } + + CBlueWindow = #8#9#10#11#12#13#14#15; { Blue window palette } + CCyanWindow = #16#17#18#19#20#21#22#23; { Cyan window palette } + CGrayWindow = #24#25#26#27#28#29#30#31; { Grey window palette } + +{---------------------------------------------------------------------------} +{ TScrollBar PART CODES } +{---------------------------------------------------------------------------} +CONST + sbLeftArrow = 0; { Left arrow part } + sbRightArrow = 1; { Right arrow part } + sbPageLeft = 2; { Page left part } + sbPageRight = 3; { Page right part } + sbUpArrow = 4; { Up arrow part } + sbDownArrow = 5; { Down arrow part } + sbPageUp = 6; { Page up part } + sbPageDown = 7; { Page down part } + sbIndicator = 8; { Indicator part } + +{---------------------------------------------------------------------------} +{ TScrollBar OPTIONS FOR TWindow.StandardScrollBar } +{---------------------------------------------------------------------------} +CONST + sbHorizontal = $0000; { Horz scrollbar } + sbVertical = $0001; { Vert scrollbar } + sbHandleKeyboard = $0002; { Handle keyboard } + +{---------------------------------------------------------------------------} +{ STANDARD COMMAND CODES } +{---------------------------------------------------------------------------} +CONST + cmValid = 0; { Valid command } + cmQuit = 1; { Quit command } + cmError = 2; { Error command } + cmMenu = 3; { Menu command } + cmClose = 4; { Close command } + cmZoom = 5; { Zoom command } + cmResize = 6; { Resize command } + cmNext = 7; { Next view command } + cmPrev = 8; { Prev view command } + cmHelp = 9; { Help command } + cmOK = 10; { Okay command } + cmCancel = 11; { Cancel command } + cmYes = 12; { Yes command } + cmNo = 13; { No command } + cmDefault = 14; { Default command } + cmCut = 20; { Clipboard cut cmd } + cmCopy = 21; { Clipboard copy cmd } + cmPaste = 22; { Clipboard paste cmd } + cmUndo = 23; { Clipboard undo cmd } + cmClear = 24; { Clipboard clear cmd } + cmTile = 25; { Tile subviews cmd } + cmCascade = 26; { Cascade subviews cmd } + cmReceivedFocus = 50; { Received focus } + cmReleasedFocus = 51; { Released focus } + cmCommandSetChanged = 52; { Commands changed } + cmScrollBarChanged = 53; { Scrollbar changed } + cmScrollBarClicked = 54; { Scrollbar clicked on } + cmSelectWindowNum = 55; { Select window } + cmListItemSelected = 56; { Listview item select } + + cmNotify = 27; + cmIdCommunicate = 28; { Communicate via id } + cmIdSelect = 29; { Select via id } + +{---------------------------------------------------------------------------} +{ TWindow NUMBER CONSTANTS } +{---------------------------------------------------------------------------} +CONST + wnNoNumber = 0; { Window has no num } + MaxViewWidth = 255; { Max view width } + + +{***************************************************************************} +{ PUBLIC TYPE DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TWindow Title string } +{---------------------------------------------------------------------------} +TYPE + TTitleStr = String[80]; { Window title string } + +{---------------------------------------------------------------------------} +{ COMMAND SET RECORD } +{---------------------------------------------------------------------------} +TYPE + TCommandSet = SET OF Byte; { Command set record } + PCommandSet = ^TCommandSet; { Ptr to command set } + +{---------------------------------------------------------------------------} +{ PALETTE RECORD } +{---------------------------------------------------------------------------} +TYPE + TPalette = String; { Palette record } + PPalette = ^TPalette; { Pointer to palette } + +{---------------------------------------------------------------------------} +{ TDrawBuffer RECORD } +{---------------------------------------------------------------------------} +TYPE + TDrawBuffer = Array [0..MaxViewWidth - 1] Of Word; { Draw buffer record } + PDrawBuffer = ^TDrawBuffer; { Ptr to draw buffer } + +{---------------------------------------------------------------------------} +{ TVideoBuffer RECORD } +{---------------------------------------------------------------------------} +TYPE + TVideoBuf = ARRAY [0..3999] of Word; { Video buffer } + PVideoBuf = ^TVideoBuf; { Pointer to buffer } + +{---------------------------------------------------------------------------} +{ TComplexArea RECORD } +{---------------------------------------------------------------------------} +TYPE + PComplexArea = ^TComplexArea; { Complex area } + TComplexArea = +{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + PACKED +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + RECORD + X1, Y1 : Sw_Integer; { Top left corner } + X2, Y2 : Sw_Integer; { Lower right corner } + NextArea: PComplexArea; { Next area pointer } + END; + +{***************************************************************************} +{ PUBLIC OBJECT DEFINITIONS } +{***************************************************************************} + +TYPE + PGroup = ^TGroup; { Pointer to group } + +{---------------------------------------------------------------------------} +{ TView OBJECT - ANCESTOR VIEW OBJECT } +{---------------------------------------------------------------------------} + PView = ^TView; + TView = OBJECT (TObject) + GrowMode : Byte; { View grow mode } + DragMode : Byte; { View drag mode } + TabMask : Byte; { Tab move masks } + ColourOfs: Sw_Integer; { View palette offset } + HelpCtx : Word; { View help context } + State : Word; { View state masks } + Options : Word; { View options masks } + EventMask: Word; { View event masks } + Origin : TPoint; { View origin } + Size : TPoint; { View size } + Cursor : TPoint; { Cursor position } + Next : PView; { Next peerview } + Owner : PGroup; { Owner group } + HoldLimit: PComplexArea; { Hold limit values } + + RevCol : Boolean; + BackgroundChar : Char; + + CONSTRUCTOR Init (Var Bounds: TRect); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION Prev: PView; + FUNCTION Execute: Word; Virtual; + FUNCTION Focus: Boolean; + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION TopView: PView; + FUNCTION PrevView: PView; + FUNCTION NextView: PView; + FUNCTION GetHelpCtx: Word; Virtual; + FUNCTION EventAvail: Boolean; + FUNCTION GetPalette: PPalette; Virtual; + function MapColor (color:byte):byte; + FUNCTION GetColor (Color: Word): Word; + FUNCTION Valid (Command: Word): Boolean; Virtual; + FUNCTION GetState (AState: Word): Boolean; + FUNCTION TextWidth (const Txt: String): Sw_Integer; + FUNCTION CTextWidth (const Txt: String): Sw_Integer; + FUNCTION MouseInView (Point: TPoint): Boolean; + FUNCTION CommandEnabled (Command: Word): Boolean; + FUNCTION OverLapsArea (X1, Y1, X2, Y2: Sw_Integer): Boolean; + FUNCTION MouseEvent (Var Event: TEvent; Mask: Word): Boolean; + PROCEDURE Hide; + PROCEDURE Show; + PROCEDURE Draw; Virtual; + PROCEDURE ResetCursor; Virtual; + PROCEDURE Select; + PROCEDURE Awaken; Virtual; + PROCEDURE DrawView; + PROCEDURE MakeFirst; + PROCEDURE DrawCursor; Virtual; + PROCEDURE HideCursor; + PROCEDURE ShowCursor; + PROCEDURE BlockCursor; + PROCEDURE NormalCursor; + PROCEDURE FocusFromTop; Virtual; + PROCEDURE MoveTo (X, Y: Sw_Integer); + PROCEDURE GrowTo (X, Y: Sw_Integer); + PROCEDURE EndModal (Command: Word); Virtual; + PROCEDURE SetCursor (X, Y: Sw_Integer); + PROCEDURE PutInFrontOf (Target: PView); + PROCEDURE SetCommands (Commands: TCommandSet); + PROCEDURE EnableCommands (Commands: TCommandSet); + PROCEDURE DisableCommands (Commands: TCommandSet); + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE SetCmdState (Commands: TCommandSet; Enable: Boolean); + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE Locate (Var Bounds: TRect); + PROCEDURE KeyEvent (Var Event: TEvent); + PROCEDURE GetEvent (Var Event: TEvent); Virtual; + PROCEDURE PutEvent (Var Event: TEvent); Virtual; + PROCEDURE GetExtent (Var Extent: TRect); + PROCEDURE GetBounds (Var Bounds: TRect); + PROCEDURE SetBounds (Var Bounds: TRect); + PROCEDURE GetClipRect (Var Clip: TRect); + PROCEDURE ClearEvent (Var Event: TEvent); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; + PROCEDURE SizeLimits (Var Min, Max: TPoint); Virtual; + PROCEDURE GetCommands (Var Commands: TCommandSet); + PROCEDURE GetPeerViewPtr (Var S: TStream; Var P); + PROCEDURE PutPeerViewPtr (Var S: TStream; P: PView); + PROCEDURE CalcBounds (Var Bounds: TRect; Delta: TPoint); Virtual; + + FUNCTION Exposed: Boolean; { This needs help!!!!! } + PROCEDURE WriteBuf (X, Y, W, H: Sw_Integer; Var Buf); + PROCEDURE WriteLine (X, Y, W, H: Sw_Integer; Var Buf); + PROCEDURE MakeLocal (Source: TPoint; Var Dest: TPoint); + PROCEDURE MakeGlobal (Source: TPoint; Var Dest: TPoint); + PROCEDURE WriteStr (X, Y: Sw_Integer; Str: String; Color: Byte); + PROCEDURE WriteChar (X, Y: Sw_Integer; C: Char; Color: Byte; + Count: Sw_Integer); + PROCEDURE DragView (Event: TEvent; Mode: Byte; Var Limits: TRect; + MinSize, MaxSize: TPoint); + private + procedure CursorChanged; + procedure DrawHide(LastView: PView); + procedure DrawShow(LastView: PView); + procedure DrawUnderRect(var R: TRect; LastView: PView); + procedure DrawUnderView(DoShadow: Boolean; LastView: PView); + procedure do_WriteView(x1,x2,y:Sw_Integer; var Buf); + procedure do_WriteViewRec1(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); + procedure do_WriteViewRec2(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); + function do_ExposedRec1(x1,x2:Sw_integer; p:PView):boolean; + function do_ExposedRec2(x1,x2:Sw_integer; p:PView):boolean; + END; + + SelectMode = (NormalSelect, EnterSelect, LeaveSelect); + +{---------------------------------------------------------------------------} +{ TGroup OBJECT - GROUP OBJECT ANCESTOR } +{---------------------------------------------------------------------------} + TGroup = OBJECT (TView) + Phase : (phFocused, phPreProcess, phPostProcess); + EndState: Word; { Modal result } + Current : PView; { Selected subview } + Last : PView; { 1st view inserted } + Buffer : PVideoBuf; { Speed up buffer } + CONSTRUCTOR Init (Var Bounds: TRect); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION First: PView; + FUNCTION Execute: Word; Virtual; + FUNCTION GetHelpCtx: Word; Virtual; + FUNCTION DataSize: Sw_Word; Virtual; + FUNCTION ExecView (P: PView): Word; Virtual; + FUNCTION FirstThat (P: Pointer): PView; + FUNCTION Valid (Command: Word): Boolean; Virtual; + FUNCTION FocusNext (Forwards: Boolean): Boolean; + PROCEDURE Draw; Virtual; + PROCEDURE Lock; + PROCEDURE UnLock; + PROCEDURE ResetCursor; Virtual; + PROCEDURE Awaken; Virtual; + PROCEDURE ReDraw; + PROCEDURE SelectDefaultView; + PROCEDURE Insert (P: PView); + PROCEDURE Delete (P: PView); + PROCEDURE ForEach (P: Pointer); + { ForEach can't be virtual because it generates SIGSEGV } + PROCEDURE EndModal (Command: Word); Virtual; + PROCEDURE SelectNext (Forwards: Boolean); + PROCEDURE InsertBefore (P, Target: PView); + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE GetData (Var Rec); Virtual; + PROCEDURE SetData (Var Rec); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE EventError (Var Event: TEvent); Virtual; + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; + PROCEDURE GetSubViewPtr (Var S: TStream; Var P); + PROCEDURE PutSubViewPtr (Var S: TStream; P: PView); + function ClipChilds: boolean; virtual; + procedure BeforeInsert(P: PView); virtual; + procedure AfterInsert(P: PView); virtual; + procedure BeforeDelete(P: PView); virtual; + procedure AfterDelete(P: PView); virtual; + + PRIVATE + LockFlag: Byte; + Clip : TRect; + FUNCTION IndexOf (P: PView): Sw_Integer; + FUNCTION FindNext (Forwards: Boolean): PView; + FUNCTION FirstMatch (AState: Word; AOptions: Word): PView; + PROCEDURE ResetCurrent; + PROCEDURE RemoveView (P: PView); + PROCEDURE InsertView (P, Target: PView); + PROCEDURE SetCurrent (P: PView; Mode: SelectMode); + procedure DrawSubViews(P, Bottom: PView); + END; + +{---------------------------------------------------------------------------} +{ TFrame OBJECT - FRAME VIEW OBJECT } +{---------------------------------------------------------------------------} +TYPE + TFrame = OBJECT (TView) + CONSTRUCTOR Init (Var Bounds: TRect); + FUNCTION GetPalette: PPalette; Virtual; + procedure Draw; virtual; + procedure HandleEvent(var Event: TEvent); virtual; + procedure SetState(AState: Word; Enable: Boolean); virtual; + private + FrameMode: Word; + procedure FrameLine(var FrameBuf; Y, N: Sw_Integer; Color: Byte); + END; + PFrame = ^TFrame; + +{---------------------------------------------------------------------------} +{ TScrollBar OBJECT - SCROLL BAR OBJECT } +{---------------------------------------------------------------------------} +TYPE + TScrollChars = Array [0..4] of Char; + + TScrollBar = OBJECT (TView) + Value : Sw_Integer; { Scrollbar value } + Min : Sw_Integer; { Scrollbar minimum } + Max : Sw_Integer; { Scrollbar maximum } + PgStep: Sw_Integer; { One page step } + ArStep: Sw_Integer; { One range step } + Id : Sw_Integer; { Scrollbar ID } + CONSTRUCTOR Init (Var Bounds: TRect); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION ScrollStep (Part: Sw_Integer): Sw_Integer; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE ScrollDraw; Virtual; + PROCEDURE SetValue (AValue: Sw_Integer); + PROCEDURE SetRange (AMin, AMax: Sw_Integer); + PROCEDURE SetStep (APgStep, AArStep: Sw_Integer); + PROCEDURE SetParams (AValue, AMin, AMax, APgStep, AArStep: Sw_Integer); + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PRIVATE + Chars: TScrollChars; { Scrollbar chars } + FUNCTION GetPos: Sw_Integer; + FUNCTION GetSize: Sw_Integer; + PROCEDURE DrawPos (Pos: Sw_Integer); + END; + PScrollBar = ^TScrollBar; + +{---------------------------------------------------------------------------} +{ TScroller OBJECT - SCROLLING VIEW ANCESTOR } +{---------------------------------------------------------------------------} +TYPE + TScroller = OBJECT (TView) + Delta : TPoint; + Limit : TPoint; + HScrollBar: PScrollBar; { Horz scroll bar } + VScrollBar: PScrollBar; { Vert scroll bar } + CONSTRUCTOR Init (Var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + PROCEDURE ScrollDraw; Virtual; + PROCEDURE SetLimit (X, Y: Sw_Integer); + PROCEDURE ScrollTo (X, Y: Sw_Integer); + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; + PRIVATE + DrawFlag: Boolean; + DrawLock: Byte; + PROCEDURE CheckDraw; + END; + PScroller = ^TScroller; + +{---------------------------------------------------------------------------} +{ TListViewer OBJECT - LIST VIEWER OBJECT } +{---------------------------------------------------------------------------} +TYPE + TListViewer = OBJECT (TView) + NumCols : Sw_Integer; { Number of columns } + TopItem : Sw_Integer; { Top most item } + Focused : Sw_Integer; { Focused item } + Range : Sw_Integer; { Range of listview } + HScrollBar: PScrollBar; { Horz scrollbar } + VScrollBar: PScrollBar; { Vert scrollbar } + CONSTRUCTOR Init (Var Bounds: TRect; ANumCols: Sw_Word; AHScrollBar, + AVScrollBar: PScrollBar); + CONSTRUCTOR Load (Var S: TStream); + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION IsSelected (Item: Sw_Integer): Boolean; Virtual; + FUNCTION GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; Virtual; + PROCEDURE Draw; Virtual; + PROCEDURE FocusItem (Item: Sw_Integer); Virtual; + PROCEDURE SetTopItem (Item: Sw_Integer); + PROCEDURE SetRange (ARange: Sw_Integer); + PROCEDURE SelectItem (Item: Sw_Integer); Virtual; + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE ChangeBounds (Var Bounds: TRect); Virtual; + PROCEDURE FocusItemNum (Item: Sw_Integer); Virtual; + END; + PListViewer = ^TListViewer; + +{---------------------------------------------------------------------------} +{ TWindow OBJECT - WINDOW OBJECT ANCESTOR } +{---------------------------------------------------------------------------} +TYPE + TWindow = OBJECT (TGroup) + Flags : Byte; { Window flags } + Number : Sw_Integer; { Window number } + Palette : Sw_Integer; { Window palette } + ZoomRect: TRect; { Zoom rectangle } + Frame : PFrame; { Frame view object } + Title : PString; { Title string } + CONSTRUCTOR Init (Var Bounds: TRect; ATitle: TTitleStr; ANumber: Sw_Integer); + CONSTRUCTOR Load (Var S: TStream); + DESTRUCTOR Done; Virtual; + FUNCTION GetPalette: PPalette; Virtual; + FUNCTION GetTitle (MaxSize: Sw_Integer): TTitleStr; Virtual; + FUNCTION StandardScrollBar (AOptions: Word): PScrollBar; + PROCEDURE Zoom; Virtual; + PROCEDURE Close; Virtual; + PROCEDURE InitFrame; Virtual; + PROCEDURE SetState (AState: Word; Enable: Boolean); Virtual; + PROCEDURE Store (Var S: TStream); + PROCEDURE HandleEvent (Var Event: TEvent); Virtual; + PROCEDURE SizeLimits (Var Min, Max: TPoint); Virtual; + END; + PWindow = ^TWindow; + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ WINDOW MESSAGE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-Message------------------------------------------------------------ +Message sets up an event record and calls Receiver^.HandleEvent to +handle the event. Message returns nil if Receiver is nil, or if +the event is not handled successfully. +12Sep97 LdB +---------------------------------------------------------------------} +FUNCTION Message (Receiver: PView; What, Command: Word; + InfoPtr: Pointer): Pointer; + +{-NewMessage--------------------------------------------------------- +NewMessage sets up an event record including the new fields and calls +Receiver^.HandleEvent to handle the event. Message returns nil if +Receiver is nil, or if the event is not handled successfully. +19Sep97 LdB +---------------------------------------------------------------------} +FUNCTION NewMessage (P: PView; What, Command: Word; Id: Sw_Integer; Data: Real; + InfoPtr: Pointer): Pointer; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ VIEW OBJECT REGISTRATION ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{-RegisterViews------------------------------------------------------ +This registers all the view type objects used in this unit. +11Aug99 LdB +---------------------------------------------------------------------} +PROCEDURE RegisterViews; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ NEW VIEW ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{-CreateIdScrollBar-------------------------------------------------- +Creates and scrollbar object of the given size and direction and sets +the scrollbar id number. +22Sep97 LdB +---------------------------------------------------------------------} +FUNCTION CreateIdScrollBar (X, Y, Size, Id: Sw_Integer; Horz: Boolean): PScrollBar; + +{***************************************************************************} +{ INITIALIZED PUBLIC VARIABLES } +{***************************************************************************} + + +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES } +{---------------------------------------------------------------------------} +CONST + UseNativeClasses: Boolean = True; { Native class modes } + CommandSetChanged: Boolean = False; { Command change flag } + ShowMarkers: Boolean = False; { Show marker state } + ErrorAttr: Byte = $CF; { Error colours } + PositionalEvents: Word = evMouse; { Positional defined } + FocusedEvents: Word = evKeyboard + evCommand; { Focus defined } + MinWinSize: TPoint = (X: 16; Y: 6); { Minimum window size } + ShadowSize: TPoint = (X: 2; Y: 1); { Shadow sizes } + ShadowAttr: Byte = $08; { Shadow attribute } + +{ Characters used for drawing selected and default items in } +{ monochrome color sets } + SpecialChars: Array [0..5] Of Char = (#175, #174, #26, #27, ' ', ' '); + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ STREAM REGISTRATION RECORDS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ TView STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RView: TStreamRec = ( + ObjType: idView; { Register id = 1 } + VmtLink: TypeOf(TView); { Alt style VMT link } + Load: @TView.Load; { Object load method } + Store: @TView.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TFrame STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RFrame: TStreamRec = ( + ObjType: idFrame; { Register id = 2 } + VmtLink: TypeOf(TFrame); { Alt style VMT link } + Load: @TFrame.Load; { Frame load method } + Store: @TFrame.Store { Frame store method } + ); + +{---------------------------------------------------------------------------} +{ TScrollBar STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RScrollBar: TStreamRec = ( + ObjType: idScrollBar; { Register id = 3 } + VmtLink: TypeOf(TScrollBar); { Alt style VMT link } + Load: @TScrollBar.Load; { Object load method } + Store: @TScrollBar.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TScroller STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RScroller: TStreamRec = ( + ObjType: idScroller; { Register id = 4 } + VmtLink: TypeOf(TScroller); { Alt style VMT link } + Load: @TScroller.Load; { Object load method } + Store: @TScroller.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TListViewer STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RListViewer: TStreamRec = ( + ObjType: idListViewer; { Register id = 5 } + VmtLink: TypeOf(TListViewer); { Alt style VMT link } + Load: @TListViewer.Load; { Object load method } + Store: @TLIstViewer.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TGroup STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RGroup: TStreamRec = ( + ObjType: idGroup; { Register id = 6 } + VmtLink: TypeOf(TGroup); { Alt style VMT link } + Load: @TGroup.Load; { Object load method } + Store: @TGroup.Store { Object store method } + ); + +{---------------------------------------------------------------------------} +{ TWindow STREAM REGISTRATION } +{---------------------------------------------------------------------------} +CONST + RWindow: TStreamRec = ( + ObjType: idWindow; { Register id = 7 } + VmtLink: TypeOf(TWindow); { Alt style VMT link } + Load: @TWindow.Load; { Object load method } + Store: @TWindow.Store { Object store method } + ); + + +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + IMPLEMENTATION +{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>} + +USES + Video; + +{***************************************************************************} +{ PRIVATE TYPE DEFINITIONS } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ TFixupList DEFINITION } +{---------------------------------------------------------------------------} +TYPE + TFixupList = ARRAY [1..4096] Of Pointer; { Fix up ptr array } + PFixupList = ^TFixupList; { Ptr to fix up list } + +{***************************************************************************} +{ PRIVATE INITIALIZED VARIABLES } +{***************************************************************************} + +{---------------------------------------------------------------------------} +{ INITIALIZED DOS/DPMI/WIN/NT/OS2 PRIVATE VARIABLES } +{---------------------------------------------------------------------------} +CONST + TheTopView : PView = Nil; { Top focused view } + LimitsLocked: PView = Nil; { View locking limits } + OwnerGroup : PGroup = Nil; { Used for loading } + FixupList : PFixupList = Nil; { Used for loading } + CurCommandSet: TCommandSet = ([0..255] - + [cmZoom, cmClose, cmResize, cmNext, cmPrev]); { All active but these } + + vdInSetCursor = $80; { AVOID RECURSION IN SetCursor } + + { Flags for TFrame } + fmCloseClicked = $01; + fmZoomClicked = $02; + + +type + TstatVar2 = record + target : PView; + offset,y : integer; + end; + +var + staticVar1 : PDrawBuffer; + staticVar2 : TstatVar2; + + +{***************************************************************************} +{ PRIVATE INTERNAL ROUTINES } +{***************************************************************************} + + function posidx(const substr,s : string;idx:sw_integer):sw_integer; + var + i,j : sw_integer; + e : boolean; + begin + i:=idx; + j:=0; + e:=(length(SubStr)>0); + while e and (i<=Length(s)-Length(SubStr)) do + begin + if (SubStr[1]=s[i]) and (Substr=Copy(s,i,Length(SubStr))) then + begin + j:=i; + e:=false; + end; + inc(i); + end; + PosIdx:=j; + end; + + +{$ifdef UNIX} +const + MouseUsesVideoBuf = true; +{$else not UNIX} +const + MouseUsesVideoBuf = false; +{$endif not UNIX} + +procedure DrawScreenBuf(force:boolean); +begin + if (GetLockScreenCount=0) then + begin +{ If MouseUsesVideoBuf then + begin + LockScreenUpdate; + HideMouse; + ShowMouse; + UnlockScreenUpdate; + end + else + HideMouse;} + UpdateScreen(force); +{ If not MouseUsesVideoBuf then + ShowMouse;} + end; +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ VIEW PORT CONTROL ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +TYPE + ViewPortType = RECORD + X1, Y1, X2, Y2: Integer; { Corners of viewport } + Clip : Boolean; { Clip status } + END; + +var + ViewPort : ViewPortType; + +{---------------------------------------------------------------------------} +{ GetViewSettings -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB } +{---------------------------------------------------------------------------} +PROCEDURE GetViewSettings (Var CurrentViewPort: ViewPortType); +BEGIN + CurrentViewPort := ViewPort; { Textmode viewport } +END; + +{---------------------------------------------------------------------------} +{ SetViewPort -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB } +{---------------------------------------------------------------------------} +PROCEDURE SetViewPort (X1, Y1, X2, Y2: Integer; Clip: Boolean); +BEGIN + If (X1 < 0) Then X1 := 0; { X1 negative fix } + If (X1 >ScreenWidth) Then + X1 := ScreenWidth; { X1 off screen fix } + If (Y1 < 0) Then Y1 := 0; { Y1 negative fix } + If (Y1 > ScreenHeight) Then + Y1 := ScreenHeight; { Y1 off screen fix } + If (X2 < 0) Then X2 := 0; { X2 negative fix } + If (X2 > ScreenWidth) Then + X2 := ScreenWidth; { X2 off screen fix } + If (Y2 < 0) Then Y2 := 0; { Y2 negative fix } + If (Y2 > ScreenHeight) Then + Y2 := ScreenHeight; { Y2 off screen fix } + ViewPort.X1 := X1; { Set X1 port value } + ViewPort.Y1 := Y1; { Set Y1 port value } + ViewPort.X2 := X2; { Set X2 port value } + ViewPort.Y2 := Y2; { Set Y2 port value } + ViewPort.Clip := Clip; { Set port clip value } +{ $ifdef DEBUG + If WriteDebugInfo then + Writeln(stderr,'New ViewPort(',X1,',',Y1,',',X2,',',Y2,')'); + $endif DEBUG} +END; + +{***************************************************************************} +{ OBJECT METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TView OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TView--------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20Jun96 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TView.Init (Var Bounds: TRect); +BEGIN + Inherited Init; { Call ancestor } + DragMode := dmLimitLoY; { Default drag mode } + HelpCtx := hcNoContext; { Clear help context } + State := sfVisible; { Default state } + EventMask := evMouseDown + evKeyDown + evCommand; { Default event masks } + BackgroundChar := ' '; + SetBounds(Bounds); { Set view bounds } +END; + +{--TView--------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06May98 LdB } +{---------------------------------------------------------------------------} +{ This load method will read old original TV data from a stream but the } +{ new options and tabmasks are not set so some NEW functionality is not } +{ supported but it should work as per original TV code. } +{---------------------------------------------------------------------------} +CONSTRUCTOR TView.Load (Var S: TStream); +VAR i: Integer; +BEGIN + Inherited Init; { Call ancestor } + S.Read(i, SizeOf(i)); Origin.X:=i; { Read origin x value } + S.Read(i, SizeOf(i)); Origin.Y:=i; { Read origin y value } + S.Read(i, SizeOf(i)); Size.X:=i; { Read view x size } + S.Read(i, SizeOf(i)); Size.Y:=i; { Read view y size } + S.Read(i, SizeOf(i)); Cursor.X:=i; { Read cursor x size } + S.Read(i, SizeOf(i)); Cursor.Y:=i; { Read cursor y size } + S.Read(GrowMode, SizeOf(GrowMode)); { Read growmode flags } + S.Read(DragMode, SizeOf(DragMode)); { Read dragmode flags } + S.Read(HelpCtx, SizeOf(HelpCtx)); { Read help context } + S.Read(State, SizeOf(State)); { Read state masks } + S.Read(Options, SizeOf(Options)); { Read options masks } + S.Read(Eventmask, SizeOf(Eventmask)); { Read event masks } +END; + +{--TView--------------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Nov99 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TView.Done; +VAR P: PComplexArea; +BEGIN + Hide; { Hide the view } + If (Owner <> Nil) Then Owner^.Delete(@Self); { Delete from owner } + While (HoldLimit <> Nil) Do Begin { Free limit memory } + P := HoldLimit^.NextArea; { Hold next pointer } + FreeMem(HoldLimit, SizeOf(TComplexArea)); { Release memory } + HoldLimit := P; { Shuffle to next } + End; +END; + +{--TView--------------------------------------------------------------------} +{ Prev -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.Prev: PView; +VAR NP : PView; +BEGIN + Prev := @Self; + NP := Next; + While (NP <> Nil) AND (NP <> @Self) Do + Begin + Prev := NP; { Locate next view } + NP := NP^.Next; + End; +END; + +{--TView--------------------------------------------------------------------} +{ Execute -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.Execute: Word; +BEGIN + Execute := cmCancel; { Return cancel } +END; + +{--TView--------------------------------------------------------------------} +{ Focus -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.Focus: Boolean; +VAR Res: Boolean; +BEGIN + Res := True; { Preset result } + If (State AND (sfSelected + sfModal)=0) Then Begin { Not modal/selected } + If (Owner <> Nil) Then Begin { View has an owner } + Res := Owner^.Focus; { Return focus state } + If Res Then { Owner has focus } + If ((Owner^.Current = Nil) OR { No current view } + (Owner^.Current^.Options AND ofValidate = 0) { Non validating view } + OR (Owner^.Current^.Valid(cmReleasedFocus))) { Okay to drop focus } + Then Select Else Res := False; { Then select us } + End; + End; + Focus := Res; { Return focus result } +END; + +{--TView--------------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.DataSize: Sw_Word; +BEGIN + DataSize := 0; { Transfer size } +END; + +{--TView--------------------------------------------------------------------} +{ TopView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.TopView: PView; +VAR P: PView; +BEGIN + If (TheTopView = Nil) Then Begin { Check topmost view } + P := @Self; { Start with us } + While (P <> Nil) AND (P^.State AND sfModal = 0) { Check if modal } + Do P := P^.Owner; { Search each owner } + TopView := P; { Return result } + End Else TopView := TheTopView; { Return topview } +END; + +{--TView--------------------------------------------------------------------} +{ PrevView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.PrevView: PView; +BEGIN + If (@Self = Owner^.First) Then PrevView := Nil { We are first view } + Else PrevView := Prev; { Return our prior } +END; + +{--TView--------------------------------------------------------------------} +{ NextView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.NextView: PView; +BEGIN + If (@Self = Owner^.Last) Then NextView := Nil { This is last view } + Else NextView := Next; { Return our next } +END; + +{--TView--------------------------------------------------------------------} +{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.GetHelpCtx: Word; +BEGIN + If (State AND sfDragging <> 0) Then { Dragging state check } + GetHelpCtx := hcDragging Else { Return dragging } + GetHelpCtx := HelpCtx; { Return help context } +END; + +{--TView--------------------------------------------------------------------} +{ EventAvail -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.EventAvail: Boolean; +VAR Event: TEvent; +BEGIN + GetEvent(Event); { Get next event } + If (Event.What <> evNothing) Then PutEvent(Event); { Put it back } + EventAvail := (Event.What <> evNothing); { Return result } +END; + +{--TView--------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.GetPalette: PPalette; +BEGIN + GetPalette := Nil; { Return nil ptr } +END; + +{--TView--------------------------------------------------------------------} +{ MapColor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } +{---------------------------------------------------------------------------} +function TView.MapColor(color:byte):byte; +var + cur : PView; + p : PPalette; +begin + if color=0 then + MapColor:=errorAttr + else + begin + cur:=@Self; + repeat + p:=cur^.GetPalette; + if (p<>Nil) then + if ord(p^[0])<>0 then + begin + if color>ord(p^[0]) then + begin + MapColor:=errorAttr; + Exit; + end; + color:=ord(p^[color]); + if color=0 then + begin + MapColor:=errorAttr; + Exit; + end; + end; + cur:=cur^.Owner; + until (cur=Nil); + MapColor:=color; + end; +end; + + +{--TView--------------------------------------------------------------------} +{ GetColor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.GetColor (Color: Word): Word; +VAR Col: Byte; W: Word; P: PPalette; Q: PView; +BEGIN + W := 0; { Clear colour Sw_Word } + If (Hi(Color) > 0) Then Begin { High colour req } + Col := Hi(Color) + ColourOfs; { Initial offset } + Q := @Self; { Pointer to self } + Repeat + P := Q^.GetPalette; { Get our palette } + If (P <> Nil) Then Begin { Palette is valid } + If (Col <= Length(P^)) Then + Col := Ord(P^[Col]) Else { Return colour } + Col := ErrorAttr; { Error attribute } + End; + Q := Q^.Owner; { Move up to owner } + Until (Q = Nil); { Until no owner } + W := Col SHL 8; { Translate colour } + End; + If (Lo(Color) > 0) Then Begin + Col := Lo(Color) + ColourOfs; { Initial offset } + Q := @Self; { Pointer to self } + Repeat + P := Q^.GetPalette; { Get our palette } + If (P <> Nil) Then Begin { Palette is valid } + If (Col <= Length(P^)) Then + Col := Ord(P^[Col]) Else { Return colour } + Col := ErrorAttr; { Error attribute } + End; + Q := Q^.Owner; { Move up to owner } + Until (Q = Nil); { Until no owner } + End Else Col := ErrorAttr; { No colour found } + GetColor := W OR Col; { Return color } +END; + +{--TView--------------------------------------------------------------------} +{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.Valid (Command: Word): Boolean; +BEGIN + Valid := True; { Simply return true } +END; + +{--TView--------------------------------------------------------------------} +{ GetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.GetState (AState: Word): Boolean; +BEGIN + GetState := State AND AState = AState; { Check states equal } +END; + +{--TView--------------------------------------------------------------------} +{ TextWidth -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Nov99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.TextWidth (const Txt: String): Sw_Integer; +BEGIN + TextWidth := Length(Txt); { Calc text length } +END; + +FUNCTION TView.CTextWidth (const Txt: String): Sw_Integer; +VAR I: Sw_Integer; S: String; +BEGIN + S := Txt; { Transfer text } + Repeat + I := Pos('~', S); { Check for tilde } + If (I <> 0) Then System.Delete(S, I, 1); { Remove the tilde } + Until (I = 0); { Remove all tildes } + CTextWidth := Length(S); { Calc text length } +END; + +{--TView--------------------------------------------------------------------} +{ MouseInView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.MouseInView (Point: TPoint): Boolean; +BEGIN + MakeLocal(Point,Point); + MouseInView := (Point.X >= 0) and + (Point.Y >= 0) and + (Point.X < Size.X) and + (Point.Y < Size.Y); +END; + +{--TView--------------------------------------------------------------------} +{ CommandEnabled -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.CommandEnabled(Command: Word): Boolean; +BEGIN + CommandEnabled := (Command > 255) OR + (Command IN CurCommandSet); { Check command } +END; + +{--TView--------------------------------------------------------------------} +{ OverLapsArea -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.OverlapsArea (X1, Y1, X2, Y2: Sw_Integer): Boolean; +BEGIN + OverLapsArea := False; { Preset false } + If (Origin.X > X2) Then Exit; { Area to the left } + If ((Origin.X + Size.X) < X1) Then Exit; { Area to the right } + If (Origin.Y > Y2) Then Exit; { Area is above } + If ((Origin.Y + Size.Y) < Y1) Then Exit; { Area is below } + OverLapsArea := True; { Return true } +END; + +{--TView--------------------------------------------------------------------} +{ MouseEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TView.MouseEvent (Var Event: TEvent; Mask: Word): Boolean; +BEGIN + Repeat + GetEvent(Event); { Get next event } + Until (Event.What AND (Mask OR evMouseUp) <> 0); { Wait till valid } + MouseEvent := Event.What <> evMouseUp; { Return result } +END; + +{--TView--------------------------------------------------------------------} +{ Hide -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Hide; +BEGIN + If (State AND sfVisible <> 0) Then { View is visible } + SetState(sfVisible, False); { Hide the view } +END; + +{--TView--------------------------------------------------------------------} +{ Show -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Show; +BEGIN + If (State AND sfVisible = 0) Then { View not visible } + SetState(sfVisible, True); { Show the view } +END; + +{--TView--------------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Draw; +VAR B : TDrawBuffer; +BEGIN + MoveChar(B, ' ', GetColor(1), Size.X); + WriteLine(0, 0, Size.X, Size.Y, B); +END; + + +procedure TView.ResetCursor; +const + sfV_CV_F:word = sfVisible + sfCursorVis + sfFocused; +var + p,p2 : PView; + G : PGroup; + cur : TPoint; + + function Check0:boolean; + var + res : byte; + begin + res:=0; + while res=0 do + begin + p:=p^.next; + if p=p2 then + begin + p:=P^.owner; + res:=1 + end + else + if ((p^.state and sfVisible)<>0) and + (cur.x>=p^.origin.x) and + (cur.x<p^.size.x+p^.origin.x) and + (cur.y>=p^.origin.y) and + (cur.y<p^.size.y+p^.origin.y) then + res:=2; + end; + Check0:=res=2; + end; + +begin + if ((state and sfV_CV_F) = sfV_CV_F) then + begin + p:=@Self; + cur:=cursor; + while true do + begin + if (cur.x<0) or (cur.x>=p^.size.x) or + (cur.y<0) or (cur.y>=p^.size.y) then + break; + inc(cur.X,p^.origin.X); + inc(cur.Y,p^.origin.Y); + p2:=p; + G:=p^.owner; + if G=Nil then { top view } + begin + Video.SetCursorPos(cur.x,cur.y); + if (state and sfCursorIns)<>0 then + Video.SetCursorType(crBlock) + else + Video.SetCursorType(crUnderline); + exit; + end; + if (G^.state and sfVisible)=0 then + break; + p:=G^.Last; + if Check0 then + break; + end; { while } + end; { if } + Video.SetCursorType(crHidden); +end; + + +{--TView--------------------------------------------------------------------} +{ Select -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Select; +BEGIN + If (Options AND ofSelectable <> 0) Then { View is selectable } + If (Options AND ofTopSelect <> 0) Then MakeFirst { Top selectable } + Else If (Owner <> Nil) Then { Valid owner } + Owner^.SetCurrent(@Self, NormalSelect); { Make owners current } +END; + +{--TView--------------------------------------------------------------------} +{ Awaken -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Awaken; +BEGIN { Abstract method } +END; + + +{--TView--------------------------------------------------------------------} +{ MakeFirst -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.MakeFirst; +BEGIN + If (Owner <> Nil) Then Begin { Must have owner } + PutInFrontOf(Owner^.First); { Float to the top } + End; +END; + +{--TView--------------------------------------------------------------------} +{ DrawCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.DrawCursor; +BEGIN { Abstract method } + if State and sfFocused <> 0 then + ResetCursor; +END; + + +procedure TView.DrawHide(LastView: PView); +begin + TView.DrawCursor; + DrawUnderView(State and sfShadow <> 0, LastView); +end; + + +procedure TView.DrawShow(LastView: PView); +begin + DrawView; + if State and sfShadow <> 0 then + DrawUnderView(True, LastView); +end; + + +procedure TView.DrawUnderRect(var R: TRect; LastView: PView); +begin + Owner^.Clip.Intersect(R); + Owner^.DrawSubViews(NextView, LastView); + Owner^.GetExtent(Owner^.Clip); +end; + + +procedure TView.DrawUnderView(DoShadow: Boolean; LastView: PView); +var + R: TRect; +begin + GetBounds(R); + if DoShadow then + begin + inc(R.B.X,ShadowSize.X); + inc(R.B.Y,ShadowSize.Y); + end; + DrawUnderRect(R, LastView); +end; + + +procedure TView.DrawView; +begin + if Exposed then + begin + LockScreenUpdate; { don't update the screen yet } + Draw; + UnLockScreenUpdate; + DrawScreenBuf(false); + TView.DrawCursor; + end; +end; + + +{--TView--------------------------------------------------------------------} +{ HideCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.HideCursor; +BEGIN + SetState(sfCursorVis , False); { Hide the cursor } +END; + +{--TView--------------------------------------------------------------------} +{ ShowCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.ShowCursor; +BEGIN + SetState(sfCursorVis , True); { Show the cursor } +END; + +{--TView--------------------------------------------------------------------} +{ BlockCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.BlockCursor; +BEGIN + SetState(sfCursorIns, True); { Set insert mode } +END; + +{--TView--------------------------------------------------------------------} +{ NormalCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.NormalCursor; +BEGIN + SetState(sfCursorIns, False); { Clear insert mode } +END; + +{--TView--------------------------------------------------------------------} +{ FocusFromTop -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11Aug99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.FocusFromTop; +BEGIN + If (Owner <> Nil) AND + (Owner^.State AND sfSelected = 0) + Then Owner^.Select; + If (State AND sfFocused = 0) Then Focus; + If (State AND sfSelected = 0) Then Select; +END; + +{--TView--------------------------------------------------------------------} +{ MoveTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.MoveTo (X, Y: Sw_Integer); +VAR R: TRect; +BEGIN + R.Assign(X, Y, X + Size.X, Y + Size.Y); { Assign area } + Locate(R); { Locate the view } +END; + +{--TView--------------------------------------------------------------------} +{ GrowTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GrowTo (X, Y: Sw_Integer); +VAR R: TRect; +BEGIN + R.Assign(Origin.X, Origin.Y, Origin.X + X, + Origin.Y + Y); { Assign area } + Locate(R); { Locate the view } +END; + +{--TView--------------------------------------------------------------------} +{ EndModal -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.EndModal (Command: Word); +VAR P: PView; +BEGIN + P := TopView; { Get top view } + If (P <> Nil) Then P^.EndModal(Command); { End modal operation } +END; + +{--TView--------------------------------------------------------------------} +{ SetCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SetCursor (X, Y: Sw_Integer); +BEGIN + if (Cursor.X<>X) or (Cursor.Y<>Y) then + begin + Cursor.X := X; + Cursor.Y := Y; + CursorChanged; + end; + TView.DrawCursor; +END; + + +procedure TView.CursorChanged; +begin + Message(Owner,evBroadcast,cmCursorChanged,@Self); +end; + + +{--TView--------------------------------------------------------------------} +{ PutInFrontOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.PutInFrontOf (Target: PView); +VAR P, LastView: PView; +BEGIN + If (Owner <> Nil) AND (Target <> @Self) AND + (Target <> NextView) AND ((Target = Nil) OR + (Target^.Owner = Owner)) Then { Check validity } + If (State AND sfVisible = 0) Then Begin { View not visible } + Owner^.RemoveView(@Self); { Remove from list } + Owner^.InsertView(@Self, Target); { Insert into list } + End Else Begin + LastView := NextView; { Hold next view } + If (LastView <> Nil) Then Begin { Lastview is valid } + P := Target; { P is target } + While (P <> Nil) AND (P <> LastView) + Do P := P^.NextView; { Find our next view } + If (P = Nil) Then LastView := Target; { Lastview is target } + End; + State := State AND NOT sfVisible; { Temp stop drawing } + If (LastView = Target) Then + DrawHide(LastView); + Owner^.Lock; + Owner^.RemoveView(@Self); { Remove from list } + Owner^.InsertView(@Self, Target); { Insert into list } + State := State OR sfVisible; { Allow drawing again } + If (LastView <> Target) Then + DrawShow(LastView); + If (Options AND ofSelectable <> 0) Then { View is selectable } + begin + Owner^.ResetCurrent; { Reset current } + Owner^.ResetCursor; + end; + Owner^.Unlock; + End; +END; + +{--TView--------------------------------------------------------------------} +{ SetCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SetCommands (Commands: TCommandSet); +BEGIN + CommandSetChanged := CommandSetChanged OR + (CurCommandSet <> Commands); { Set change flag } + CurCommandSet := Commands; { Set command set } +END; + +{--TView--------------------------------------------------------------------} +{ EnableCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.EnableCommands (Commands: TCommandSet); +BEGIN + CommandSetChanged := CommandSetChanged OR + (CurCommandSet * Commands <> Commands); { Set changed flag } + CurCommandSet := CurCommandSet + Commands; { Update command set } +END; + +{--TView--------------------------------------------------------------------} +{ DisableCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.DisableCommands (Commands: TCommandSet); +BEGIN + CommandSetChanged := CommandSetChanged OR + (CurCommandSet * Commands <> []); { Set changed flag } + CurCommandSet := CurCommandSet - Commands; { Update command set } +END; + +{--TView--------------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SetState (AState: Word; Enable: Boolean); +var + Command: Word; + OState : Word; +begin + OState:=State; + if Enable then + State := State or AState + else + State := State and not AState; + if Owner <> nil then + case AState of + sfVisible: + begin + if Owner^.State and sfExposed <> 0 then + SetState(sfExposed, Enable); + if Enable then + DrawShow(nil) + else + DrawHide(nil); + if Options and ofSelectable <> 0 then + Owner^.ResetCurrent; + end; + sfCursorVis, + sfCursorIns: + TView.DrawCursor; + sfShadow: + DrawUnderView(True, nil); + sfFocused: + begin + ResetCursor; + if Enable then + Command := cmReceivedFocus + else + Command := cmReleasedFocus; + Message(Owner, evBroadcast, Command, @Self); + end; + end; + if ((OState xor State) and (sfCursorVis+sfCursorIns+sfFocused))<>0 then + CursorChanged; +end; + + +{--TView--------------------------------------------------------------------} +{ SetCmdState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SetCmdState (Commands: TCommandSet; Enable: Boolean); +BEGIN + If Enable Then EnableCommands(Commands) { Enable commands } + Else DisableCommands(Commands); { Disable commands } +END; + +{--TView--------------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetData (Var Rec); +BEGIN { Abstract method } +END; + +{--TView--------------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SetData (Var Rec); +BEGIN { Abstract method } +END; + +{--TView--------------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Store (Var S: TStream); +VAR SaveState: Word; + i: integer; +BEGIN + SaveState := State; { Hold current state } + State := State AND NOT (sfActive OR sfSelected OR + sfFocused OR sfExposed); { Clear flags } + i:=Origin.X;S.Write(i, SizeOf(i)); { Write view x origin } + i:=Origin.Y;S.Write(i, SizeOf(i)); { Write view y origin } + i:=Size.X;S.Write(i, SizeOf(i)); { Write view x size } + i:=Size.Y;S.Write(i, SizeOf(i)); { Write view y size } + i:=Cursor.X;S.Write(i, SizeOf(i)); { Write cursor x size } + i:=Cursor.Y;S.Write(i, SizeOf(i)); { Write cursor y size } + S.Write(GrowMode, SizeOf(GrowMode)); { Write growmode flags } + S.Write(DragMode, SizeOf(DragMode)); { Write dragmode flags } + S.Write(HelpCtx, SizeOf(HelpCtx)); { Write help context } + S.Write(State, SizeOf(State)); { Write state masks } + S.Write(Options, SizeOf(Options)); { Write options masks } + S.Write(Eventmask, SizeOf(Eventmask)); { Write event masks } + State := SaveState; { Reset state masks } +END; + +{--TView--------------------------------------------------------------------} +{ Locate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.Locate (Var Bounds: TRect); +VAR + Min, Max: TPoint; R: TRect; + + FUNCTION Range(Val, Min, Max: Sw_Integer): Sw_Integer; + BEGIN + If (Val < Min) Then Range := Min Else { Value to small } + If (Val > Max) Then Range := Max Else { Value to large } + Range := Val; { Value is okay } + END; + +BEGIN + SizeLimits(Min, Max); { Get size limits } + Bounds.B.X := Bounds.A.X + Range(Bounds.B.X - + Bounds.A.X, Min.X, Max.X); { X bound limit } + Bounds.B.Y := Bounds.A.Y + Range(Bounds.B.Y + - Bounds.A.Y, Min.Y, Max.Y); { Y bound limit } + GetBounds(R); { Current bounds } + If NOT Bounds.Equals(R) Then Begin { Size has changed } + ChangeBounds(Bounds); { Change bounds } + If (State AND sfVisible <> 0) AND { View is visible } + (State AND sfExposed <> 0) AND (Owner <> Nil) { Check view exposed } + Then + begin + if State and sfShadow <> 0 then + begin + R.Union(Bounds); + Inc(R.B.X, ShadowSize.X); + Inc(R.B.Y, ShadowSize.Y); + end; + DrawUnderRect(R, nil); + end; + End; +END; + +{--TView--------------------------------------------------------------------} +{ KeyEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.KeyEvent (Var Event: TEvent); +BEGIN + Repeat + GetEvent(Event); { Get next event } + Until (Event.What = evKeyDown); { Wait till keydown } +END; + +{--TView--------------------------------------------------------------------} +{ GetEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetEvent (Var Event: TEvent); +BEGIN + If (Owner <> Nil) Then Owner^.GetEvent(Event); { Event from owner } +END; + +{--TView--------------------------------------------------------------------} +{ PutEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.PutEvent (Var Event: TEvent); +BEGIN + If (Owner <> Nil) Then Owner^.PutEvent(Event); { Put in owner } +END; + +{--TView--------------------------------------------------------------------} +{ GetExtent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetExtent (Var Extent: TRect); +BEGIN + Extent.A.X := 0; { Zero x field } + Extent.A.Y := 0; { Zero y field } + Extent.B.X := Size.X; { Return x size } + Extent.B.Y := Size.Y; { Return y size } +END; + +{--TView--------------------------------------------------------------------} +{ GetBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetBounds (Var Bounds: TRect); +BEGIN + Bounds.A := Origin; { Get first corner } + Bounds.B.X := Origin.X + Size.X; { Calc corner x value } + Bounds.B.Y := Origin.Y + Size.Y; { Calc corner y value } +END; + +{--TView--------------------------------------------------------------------} +{ SetBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 24Sep99 LdB } +{---------------------------------------------------------------------------} +procedure TView.SetBounds(var Bounds: TRect); +begin + Origin := Bounds.A; { Get first corner } + Size := Bounds.B; { Get second corner } + Dec(Size.X,Origin.X); + Dec(Size.Y,Origin.Y); +end; + +{--TView--------------------------------------------------------------------} +{ GetClipRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetClipRect (Var Clip: TRect); +BEGIN + GetBounds(Clip); { Get current bounds } + If (Owner <> Nil) Then Clip.Intersect(Owner^.Clip);{ Intersect with owner } + Clip.Move(-Origin.X, -Origin.Y); { Sub owner origin } +END; + +{--TView--------------------------------------------------------------------} +{ ClearEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.ClearEvent (Var Event: TEvent); +BEGIN + Event.What := evNothing; { Clear the event } + Event.InfoPtr := @Self; { Set us as handler } +END; + +{--TView--------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.HandleEvent (Var Event: TEvent); +BEGIN + If (Event.What = evMouseDown) Then { Mouse down event } + If (State AND (sfSelected OR sfDisabled) = 0) { Not selected/disabled } + AND (Options AND ofSelectable <> 0) Then { View is selectable } + If (Focus = False) OR { Not view with focus } + (Options AND ofFirstClick = 0) { Not 1st click select } + Then ClearEvent(Event); { Handle the event } +END; + +{--TView--------------------------------------------------------------------} +{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.ChangeBounds (Var Bounds: TRect); +BEGIN + SetBounds(Bounds); { Set new bounds } + DrawView; { Draw the view } +END; + +{--TView--------------------------------------------------------------------} +{ SizeLimits -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.SizeLimits (Var Min, Max: TPoint); +BEGIN + Min.X := 0; { Zero x minimum } + Min.Y := 0; { Zero y minimum } + If (Owner <> Nil) and(Owner^.ClipChilds) Then + Max := Owner^.Size + else { Max owner size } + Begin + Max.X := high(sw_integer); { Max possible x size } + Max.Y := high(sw_integer); { Max possible y size } + End; +END; + +{--TView--------------------------------------------------------------------} +{ GetCommands -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetCommands (Var Commands: TCommandSet); +BEGIN + Commands := CurCommandSet; { Return command set } +END; + +{--TView--------------------------------------------------------------------} +{ GetPeerViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.GetPeerViewPtr (Var S: TStream; Var P); +VAR Index: Integer; +BEGIN + Index := 0; { Zero index value } + S.Read(Index, SizeOf(Index)); { Read view index } + If (Index = 0) OR (OwnerGroup = Nil) Then { Check for peer views } + Pointer(P) := Nil Else Begin { Return nil } + Pointer(P) := FixupList^[Index]; { New view ptr } + FixupList^[Index] := @P; { Patch this pointer } + End; +END; + +{--TView--------------------------------------------------------------------} +{ PutPeerViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.PutPeerViewPtr (Var S: TStream; P: PView); +VAR Index: Integer; +BEGIN + If (P = Nil) OR (OwnerGroup = Nil) Then Index := 0 { Return zero index } + Else Index := OwnerGroup^.IndexOf(P); { Return view index } + S.Write(Index, SizeOf(Index)); { Write the index } +END; + +{--TView--------------------------------------------------------------------} +{ CalcBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.CalcBounds (Var Bounds: Objects.TRect; Delta: TPoint); +VAR S, D: Sw_Integer; Min, Max: TPoint; + + FUNCTION Range (Val, Min, Max: Sw_Integer): Sw_Integer; + BEGIN + If (Val < Min) Then Range := Min Else { Value below min } + If (Val > Max) Then Range := Max Else { Value above max } + Range := Val; { Accept value } + END; + + PROCEDURE GrowI (Var I: Sw_Integer); + BEGIN + If (GrowMode AND gfGrowRel = 0) Then Inc(I, D) + Else I := (I * S + (S - D) SHR 1) DIV (S - D); { Calc grow value } + END; + +BEGIN + GetBounds(Bounds); { Get bounds } + If (GrowMode = 0) Then Exit; { No grow flags exits } + S := Owner^.Size.X; { Set initial size } + D := Delta.X; { Set initial delta } + If (GrowMode AND gfGrowLoX <> 0) Then + GrowI(Bounds.A.X); { Grow left side } + If (GrowMode AND gfGrowHiX <> 0) Then + GrowI(Bounds.B.X); { Grow right side } + If (Bounds.B.X - Bounds.A.X > MaxViewWidth) Then + Bounds.B.X := Bounds.A.X + MaxViewWidth; { Check values } + S := Owner^.Size.Y; D := Delta.Y; { set initial values } + If (GrowMode AND gfGrowLoY <> 0) Then + GrowI(Bounds.A.Y); { Grow top side } + If (GrowMode AND gfGrowHiY <> 0) Then + GrowI(Bounds.B.Y); { grow lower side } + SizeLimits(Min, Max); { Check sizes } + Bounds.B.X := Bounds.A.X + Range(Bounds.B.X - + Bounds.A.X, Min.X, Max.X); { Set right side } + Bounds.B.Y := Bounds.A.Y + Range(Bounds.B.Y - + Bounds.A.Y, Min.Y, Max.Y); { Set lower side } +END; + +{***************************************************************************} +{ TView OBJECT PRIVATE METHODS } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TGroup OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TGroup-------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Jul99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TGroup.Init (Var Bounds: TRect); +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR (ofSelectable + ofBuffered); { Set options } + GetExtent(Clip); { Get clip extents } + EventMask := $FFFF; { See all events } +END; + +{--TGroup-------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TGroup.Load (Var S: TStream); +VAR I: Sw_Word; + Count: Word; + P, Q: ^Pointer; V: PView; OwnerSave: PGroup; + FixupSave: PFixupList; +BEGIN + Inherited Load(S); { Call ancestor } + GetExtent(Clip); { Get view extents } + OwnerSave := OwnerGroup; { Save current group } + OwnerGroup := @Self; { We are current group } + FixupSave := FixupList; { Save current list } + Count := 0; { Zero count value } + S.Read(Count, SizeOf(Count)); { Read entry count } + If (MaxAvail >= Count*SizeOf(Pointer)) Then Begin { Memory available } + GetMem(FixupList, Count*SizeOf(Pointer)); { List size needed } + FillChar(FixUpList^, Count*SizeOf(Pointer), #0); { Zero all entries } + For I := 1 To Count Do Begin + V := PView(S.Get); { Get view off stream } + If (V <> Nil) Then InsertView(V, Nil); { Insert valid views } + End; + V := Last; { Start on last view } + For I := 1 To Count Do Begin + V := V^.Next; { Fetch next view } + P := FixupList^[I]; { Transfer pointer } + While (P <> Nil) Do Begin { If valid view } + Q := P; { Copy pointer } + P := P^; { Fetch pointer } + Q^ := V; { Transfer view ptr } + End; + End; + FreeMem(FixupList, Count*SizeOf(Pointer)); { Release fixup list } + End; + OwnerGroup := OwnerSave; { Reload current group } + FixupList := FixupSave; { Reload current list } + GetSubViewPtr(S, V); { Load any subviews } + SetCurrent(V, NormalSelect); { Select current view } + If (OwnerGroup = Nil) Then Awaken; { If topview activate } +END; + +{--TGroup-------------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TGroup.Done; +VAR P, T: PView; +BEGIN + Hide; { Hide the view } + P := Last; { Start on last } + If (P <> Nil) Then Begin { Subviews exist } + Repeat + P^.Hide; { Hide each view } + P := P^.Prev; { Prior view } + Until (P = Last); { Loop complete } + Repeat + T := P^.Prev; { Hold prior pointer } + Dispose(P, Done); { Dispose subview } + P := T; { Transfer pointer } + Until (Last = Nil); { Loop complete } + End; + Inherited Done; { Call ancestor } +END; + +{--TGroup-------------------------------------------------------------------} +{ First -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.First: PView; +BEGIN + If (Last = Nil) Then First := Nil { No first view } + Else First := Last^.Next; { Return first view } +END; + +{--TGroup-------------------------------------------------------------------} +{ Execute -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.Execute: Word; +VAR Event: TEvent; +BEGIN + Repeat + EndState := 0; { Clear end state } + Repeat + GetEvent(Event); { Get next event } + HandleEvent(Event); { Handle the event } + If (Event.What <> evNothing) Then + EventError(Event); { Event not handled } + Until (EndState <> 0); { Until command set } + Until Valid(EndState); { Repeat until valid } + Execute := EndState; { Return result } + EndState := 0; { Clear end state } +END; + +{--TGroup-------------------------------------------------------------------} +{ GetHelpCtx -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.GetHelpCtx: Word; +VAR H: Word; +BEGIN + H := hcNoContext; { Preset no context } + If (Current <> Nil) Then H := Current^.GetHelpCtx; { Current context } + If (H=hcNoContext) Then H := Inherited GetHelpCtx; { Call ancestor } + GetHelpCtx := H; { Return result } +END; + +{--TGroup-------------------------------------------------------------------} +{ DataSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Jul98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.DataSize: Sw_Word; +VAR Total: Word; P: PView; +BEGIN + Total := 0; { Zero totals count } + P := Last; { Start on last view } + If (P <> Nil) Then Begin { Subviews exist } + Repeat + P := P^.Next; { Move to next view } + Total := Total + P^.DataSize; { Add view size } + Until (P = Last); { Until last view } + End; + DataSize := Total; { Return data size } +END; + +{--TGroup-------------------------------------------------------------------} +{ ExecView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Jul99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.ExecView (P: PView): Word; +VAR SaveOptions: Word; SaveTopView, SaveCurrent: PView; SaveOwner: PGroup; + SaveCommands: TCommandSet; +BEGIN + If (P<>Nil) Then Begin + SaveOptions := P^.Options; { Hold options } + SaveOwner := P^.Owner; { Hold owner } + SaveTopView := TheTopView; { Save topmost view } + SaveCurrent := Current; { Save current view } + GetCommands(SaveCommands); { Save commands } + TheTopView := P; { Set top view } + P^.Options := P^.Options AND NOT ofSelectable; { Not selectable } + P^.SetState(sfModal, True); { Make modal } + SetCurrent(P, EnterSelect); { Select next } + If (SaveOwner = Nil) Then Insert(P); { Insert view } + ExecView := P^.Execute; { Execute view } + If (SaveOwner = Nil) Then Delete(P); { Remove view } + SetCurrent(SaveCurrent, LeaveSelect); { Unselect current } + P^.SetState(sfModal, False); { Clear modal state } + P^.Options := SaveOptions; { Restore options } + TheTopView := SaveTopView; { Restore topview } + SetCommands(SaveCommands); { Restore commands } + End Else ExecView := cmCancel; { Return cancel } +END; + +{ ********************************* REMARK ******************************** } +{ This call really is very COMPILER SPECIFIC and really can't be done } +{ effectively any other way but assembler code as SELF & FRAMES need } +{ to be put down in exact order and OPTIMIZERS make a mess of it. } +{ ******************************** END REMARK *** Leon de Boer, 17Jul99 *** } + +{--TGroup-------------------------------------------------------------------} +{ FirstThat -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.FirstThat (P: Pointer): PView; +VAR + Tp : PView; +BEGIN + If (Last<>Nil) Then + Begin + Tp := Last; { Set temporary ptr } + Repeat + Tp := Tp^.Next; { Get next view } + IF Byte(Longint(CallPointerMethodLocal(P,get_caller_frame(get_frame),@self,Tp)))<>0 THEN + Begin { Test each view } + FirstThat := Tp; { View returned true } + Exit; { Now exit } + End; + Until (Tp=Last); { Until last } + FirstThat := Nil; { None passed test } + End + Else + FirstThat := Nil; { Return nil } +END; + +{--TGroup-------------------------------------------------------------------} +{ Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.Valid (Command: Word): Boolean; + + FUNCTION IsInvalid (P: PView): Boolean; + BEGIN + IsInvalid := NOT P^.Valid(Command); { Check if valid } + END; + +BEGIN + Valid := True; { Preset valid } + If (Command = cmReleasedFocus) Then Begin { Release focus cmd } + If (Current <> Nil) AND { Current view exists } + (Current^.Options AND ofValidate <> 0) Then { Validating view } + Valid := Current^.Valid(Command); { Validate command } + End Else Valid := FirstThat(@IsInvalid) = Nil; { Check first valid } +END; + +{--TGroup-------------------------------------------------------------------} +{ FocusNext -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.FocusNext (Forwards: Boolean): Boolean; +VAR P: PView; +BEGIN + P := FindNext(Forwards); { Find next view } + FocusNext := True; { Preset true } + If (P <> Nil) Then FocusNext := P^.Focus; { Check next focus } +END; + + +procedure TGroup.DrawSubViews(P, Bottom: PView); +begin + if P <> nil then + while P <> Bottom do + begin + P^.DrawView; + P := P^.NextView; + end; +end; + + +{--TGroup-------------------------------------------------------------------} +{ ReDraw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 2Jun06 DM } +{---------------------------------------------------------------------------} +procedure TGroup.Redraw; +begin + {Lock to prevent screen update.} + lockscreenupdate; + DrawSubViews(First, nil); + unlockscreenupdate; + {Draw all views at once, forced update.} + drawscreenbuf(true); +end; + + +PROCEDURE TGroup.ResetCursor; +BEGIN + if (Current<>nil) then + Current^.ResetCursor; +END; + + +{--TGroup-------------------------------------------------------------------} +{ Awaken -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Awaken; + + PROCEDURE DoAwaken (P: PView); + BEGIN + If (P <> Nil) Then P^.Awaken; { Awaken view } + END; + +BEGIN + ForEach(@DoAwaken); { Awaken each view } +END; + +{--TGroup-------------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Draw; +BEGIN + If Buffer=Nil then + DrawSubViews(First, nil) + else + WriteBuf(0,0,Size.X,Size.Y,Buffer); +END; + + +{--TGroup-------------------------------------------------------------------} +{ SelectDefaultView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.SelectDefaultView; +VAR P: PView; +BEGIN + P := Last; { Start at last } + While (P <> Nil) Do Begin + If P^.GetState(sfDefault) Then Begin { Search 1st default } + P^.Select; { Select default view } + P := Nil; { Force kick out } + End Else P := P^.PrevView; { Prior subview } + End; +END; + + +function TGroup.ClipChilds: boolean; +begin + ClipChilds:=true; +end; + + +procedure TGroup.BeforeInsert(P: PView); +begin + { abstract } +end; + +procedure TGroup.AfterInsert(P: PView); +begin + { abstract } +end; + +procedure TGroup.BeforeDelete(P: PView); +begin + { abstract } +end; + +procedure TGroup.AfterDelete(P: PView); +begin + { abstract } +end; + +{--TGroup-------------------------------------------------------------------} +{ Insert -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Insert (P: PView); +BEGIN + BeforeInsert(P); + InsertBefore(P, First); + AfterInsert(P); +END; + +{--TGroup-------------------------------------------------------------------} +{ Delete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Delete (P: PView); +VAR SaveState: Word; +BEGIN + BeforeDelete(P); + SaveState := P^.State; { Save state } + P^.Hide; { Hide the view } + RemoveView(P); { Remove the view } + P^.Owner := Nil; { Clear owner ptr } + P^.Next := Nil; { Clear next ptr } + if SaveState and sfVisible <> 0 then + P^.Show; + AfterDelete(P); +END; + +{ ********************************* REMARK ******************************** } +{ This call really is very COMPILER SPECIFIC and really can't be done } +{ effectively any other way but assembler code as SELF & FRAMES need } +{ to be put down in exact order and OPTIMIZERS make a mess of it. } +{ ******************************** END REMARK *** Leon de Boer, 17Jul99 *** } + +{--TGroup-------------------------------------------------------------------} +{ ForEach -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.ForEach (P: Pointer); +VAR + Tp,Hp,L0 : PView; +{ Vars Hp and L0 are necessary to hold original pointers in case } +{ when some view closes himself as a result of broadcast message ! } +BEGIN + If (Last<>Nil) Then + Begin + Tp:=Last; + Hp:=Tp^.Next; + L0:=Last; { Set temporary ptr } + Repeat + Tp:=Hp; + if tp=nil then + exit; + Hp:=Tp^.Next; { Get next view } + CallPointerMethodLocal(P,get_caller_frame(get_frame),@self,Tp); + Until (Tp=L0); { Until last } + End; +END; + + + +{--TGroup-------------------------------------------------------------------} +{ EndModal -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.EndModal (Command: Word); +BEGIN + If (State AND sfModal <> 0) Then { This view is modal } + EndState := Command Else { Set endstate } + Inherited EndModal(Command); { Call ancestor } +END; + +{--TGroup-------------------------------------------------------------------} +{ SelectNext -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.SelectNext (Forwards: Boolean); +VAR P: PView; +BEGIN + P := FindNext(Forwards); { Find next view } + If (P <> Nil) Then P^.Select; { Select view } +END; + +{--TGroup-------------------------------------------------------------------} +{ InsertBefore -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.InsertBefore (P, Target: PView); +VAR SaveState : Word; +BEGIN + If (P <> Nil) AND (P^.Owner = Nil) AND { View valid } + ((Target = Nil) OR (Target^.Owner = @Self)) { Target valid } + Then Begin + If (P^.Options AND ofCenterX <> 0) Then { Centre on x axis } + P^.Origin.X := (Size.X - P^.Size.X) div 2; + If (P^.Options AND ofCenterY <> 0) Then { Centre on y axis } + P^.Origin.Y := (Size.Y - P^.Size.Y) div 2; + SaveState := P^.State; { Save view state } + P^.Hide; { Make sure hidden } + InsertView(P, Target); { Insert into list } + If (SaveState AND sfVisible <> 0) Then P^.Show; { Show the view } + If (State AND sfActive <> 0) Then { Was active before } + P^.SetState(sfActive , True); { Make active again } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.SetState (AState: Word; Enable: Boolean); + + PROCEDURE DoSetState (P: PView); + BEGIN + If (P <> Nil) Then P^.SetState(AState, Enable); { Set subview state } + END; + + PROCEDURE DoExpose (P: PView); + BEGIN + If (P <> Nil) Then Begin + If (P^.State AND sfVisible <> 0) Then { Check view visible } + P^.SetState(sfExposed, Enable); { Set exposed flag } + End; + END; + +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + Case AState Of + sfActive, sfDragging: Begin + Lock; { Lock the view } + ForEach(@DoSetState); { Set each subview } + UnLock; { Unlock the view } + End; + sfFocused: Begin + If (Current <> Nil) Then + Current^.SetState(sfFocused, Enable); { Focus current view } + End; + sfExposed: Begin + ForEach(@DoExpose); { Expose each subview } + End; + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ GetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Mar98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.GetData (Var Rec); +VAR Total: Sw_Word; P: PView; +BEGIN + Total := 0; { Clear total } + P := Last; { Start at last } + While (P <> Nil) Do Begin { Subviews exist } + P^.GetData(TByteArray(Rec)[Total]); { Get data } + Inc(Total, P^.DataSize); { Increase total } + P := P^.PrevView; { Previous view } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ SetData -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 29Mar98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.SetData (Var Rec); +VAR Total: Sw_Word; P: PView; +BEGIN + Total := 0; { Clear total } + P := Last; { Start at last } + While (P <> Nil) Do Begin { Subviews exist } + P^.SetData(TByteArray(Rec)[Total]); { Get data } + Inc(Total, P^.DataSize); { Increase total } + P := P^.PrevView; { Previous view } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Mar98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Store (Var S: TStream); +VAR Count: Word; OwnerSave: PGroup; + + PROCEDURE DoPut (P: PView); + BEGIN + S.Put(P); { Put view on stream } + END; + +BEGIN + TView.Store(S); { Call view store } + OwnerSave := OwnerGroup; { Save ownergroup } + OwnerGroup := @Self; { Set as owner group } + Count := IndexOf(Last); { Subview count } + S.Write(Count, SizeOf(Count)); { Write the count } + ForEach(@DoPut); { Put each in stream } + PutSubViewPtr(S, Current); { Current on stream } + OwnerGroup := OwnerSave; { Restore ownergroup } +END; + +{--TGroup-------------------------------------------------------------------} +{ EventError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.EventError (Var Event: TEvent); +BEGIN + If (Owner <> Nil) Then Owner^.EventError(Event); { Event error } +END; + +{--TGroup-------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.HandleEvent (Var Event: TEvent); + + FUNCTION ContainsMouse (P: PView): Boolean; + BEGIN + ContainsMouse := (P^.State AND sfVisible <> 0) { Is view visible } + AND P^.MouseInView(Event.Where); { Is point in view } + END; + + PROCEDURE DoHandleEvent (P: PView); + BEGIN + If (P = Nil) OR ((P^.State AND sfDisabled <> 0) AND + (Event.What AND(PositionalEvents OR FocusedEvents) <>0 )) + Then Exit; { Invalid/disabled } + Case Phase Of + phPreProcess: If (P^.Options AND ofPreProcess = 0) + Then Exit; { Not pre processing } + phPostProcess: If (P^.Options AND ofPostProcess = 0) + Then Exit; { Not post processing } + End; + If (Event.What AND P^.EventMask <> 0) Then { View handles event } + P^.HandleEvent(Event); { Pass to view } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evNothing) Then Exit; { No valid event exit } + If (Event.What AND FocusedEvents <> 0) Then Begin { Focused event } + Phase := phPreProcess; { Set pre process } + ForEach(@DoHandleEvent); { Pass to each view } + Phase := phFocused; { Set focused } + DoHandleEvent(Current); { Pass to current } + Phase := phPostProcess; { Set post process } + ForEach(@DoHandleEvent); { Pass to each } + End Else Begin + Phase := phFocused; { Set focused } + If (Event.What AND PositionalEvents <> 0) Then { Positional event } + DoHandleEvent(FirstThat(@ContainsMouse)) { Pass to first } + Else ForEach(@DoHandleEvent); { Pass to all } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.ChangeBounds (Var Bounds: TRect); +VAR D: TPoint; + + PROCEDURE DoCalcChange (P: PView); + VAR R: TRect; + BEGIN + P^.CalcBounds(R, D); { Calc view bounds } + P^.ChangeBounds(R); { Change view bounds } + END; + +BEGIN + D.X := Bounds.B.X - Bounds.A.X - Size.X; { Delta x value } + D.Y := Bounds.B.Y - Bounds.A.Y - Size.Y; { Delta y value } + If ((D.X=0) AND (D.Y=0)) Then Begin + SetBounds(Bounds); { Set new bounds } + { Force redraw } + ReDraw; { Draw the view } + End Else Begin + SetBounds(Bounds); { Set new bounds } + GetExtent(Clip); { Get new clip extents } + Lock; { Lock drawing } + ForEach(@DoCalcChange); { Change each view } + UnLock; { Unlock drawing } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ GetSubViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.GetSubViewPtr (Var S: TStream; Var P); +VAR Index, I: Sw_Word; Q: PView; +BEGIN + Index := 0; { Zero index value } + S.Read(Index, SizeOf(Index)); { Read view index } + If (Index > 0) Then Begin { Valid index } + Q := Last; { Start on last } + For I := 1 To Index Do Q := Q^.Next; { Loop for count } + Pointer(P) := Q; { Return the view } + End Else Pointer(P) := Nil; { Return nil } +END; + +{--TGroup-------------------------------------------------------------------} +{ PutSubViewPtr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.PutSubViewPtr (Var S: TStream; P: PView); +VAR Index: Sw_Word; +BEGIN + If (P = Nil) Then Index := 0 Else { Nil view, Index = 0 } + Index := IndexOf(P); { Calc view index } + S.Write(Index, SizeOf(Index)); { Write the index } +END; + + +{***************************************************************************} +{ TGroup OBJECT PRIVATE METHODS } +{***************************************************************************} + +{--TGroup-------------------------------------------------------------------} +{ IndexOf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.IndexOf (P: PView): Sw_Integer; +VAR I: Sw_Integer; Q: PView; +BEGIN + Q := Last; { Start on last view } + If (Q <> Nil) Then Begin { Subviews exist } + I := 1; { Preset value } + While (Q <> P) AND (Q^.Next <> Last) Do Begin + Q := Q^.Next; { Load next view } + Inc(I); { Increment count } + End; + If (Q <> P) Then IndexOf := 0 Else IndexOf := I; { Return index } + End Else IndexOf := 0; { Return zero } +END; + +{--TGroup-------------------------------------------------------------------} +{ FindNext -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.FindNext (Forwards: Boolean): PView; +VAR P: PView; +BEGIN + FindNext := Nil; { Preset nil return } + If (Current <> Nil) Then Begin { Has current view } + P := Current; { Start on current } + Repeat + If Forwards Then P := P^.Next { Get next view } + Else P := P^.Prev; { Get prev view } + Until ((P^.State AND (sfVisible+sfDisabled) = sfVisible) AND + (P^.Options AND ofSelectable <> 0)) OR { Tab selectable } + (P = Current); { Not singular select } + If (P <> Current) Then FindNext := P; { Return result } + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ FirstMatch -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TGroup.FirstMatch (AState: Word; AOptions: Word): PView; + + FUNCTION Matches (P: PView): Boolean; + BEGIN + Matches := (P^.State AND AState = AState) AND + (P^.Options AND AOptions = AOptions); { Return match state } + END; + +BEGIN + FirstMatch := FirstThat(@Matches); { Return first match } +END; + +{--TGroup-------------------------------------------------------------------} +{ ResetCurrent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.ResetCurrent; +BEGIN + SetCurrent(FirstMatch(sfVisible, ofSelectable), + NormalSelect); { Reset current view } +END; + +{--TGroup-------------------------------------------------------------------} +{ RemoveView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.RemoveView (P: PView); +VAR Q: PView; +BEGIN + If (P <> Nil) AND (Last <> Nil) Then Begin { Check view is valid } + Q := Last; { Start on last view } + While (Q^.Next <> P) AND (Q^.Next <> Last) Do + Q := Q^.Next; { Find prior view } + If (Q^.Next = P) Then Begin { View found } + If (Q^.Next <> Q) Then Begin { Not only view } + Q^.Next := P^.Next; { Rechain views } + If (P = Last) Then Last := P^.Next; { Fix if last removed } + End Else Last := Nil; { Only view } + End; + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ InsertView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.InsertView (P, Target: PView); +BEGIN + If (P <> Nil) Then Begin { Check view is valid } + P^.Owner := @Self; { Views owner is us } + If (Target <> Nil) Then Begin { Valid target } + Target := Target^.Prev; { 1st part of chain } + P^.Next := Target^.Next; { 2nd part of chain } + Target^.Next := P; { Chain completed } + End Else Begin + If (Last <> Nil) Then Begin { Not first view } + P^.Next := Last^.Next; { 1st part of chain } + Last^.Next := P; { Completed chain } + End Else P^.Next := P; { 1st chain to self } + Last := P; { P is now last } + End; + End; +END; + +{--TGroup-------------------------------------------------------------------} +{ SetCurrent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.SetCurrent (P: PView; Mode: SelectMode); + + PROCEDURE SelectView (P: PView; Enable: Boolean); + BEGIN + If (P <> Nil) Then { View is valid } + P^.SetState(sfSelected, Enable); { Select the view } + END; + + PROCEDURE FocusView (P: PView; Enable: Boolean); + BEGIN + If (State AND sfFocused <> 0) AND (P <> Nil) { Check not focused } + Then P^.SetState(sfFocused, Enable); { Focus the view } + END; + +BEGIN + If (Current<>P) Then Begin { Not already current } + Lock; { Stop drawing } + FocusView(Current, False); { Defocus current } + If (Mode <> EnterSelect) Then + SelectView(Current, False); { Deselect current } + If (Mode<>LeaveSelect) Then SelectView(P, True); { Select view P } + FocusView(P, True); { Focus view P } + Current := P; { Set as current view } + UnLock; { Redraw now } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TFrame OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TFrame-------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TFrame.Init (Var Bounds: TRect); +BEGIN + Inherited Init(Bounds); { Call ancestor } + GrowMode := gfGrowHiX + gfGrowHiY; { Set grow modes } + EventMask := EventMask OR evBroadcast; { See broadcasts } +END; + +procedure TFrame.FrameLine(var FrameBuf; Y, N: Sw_Integer; Color: Byte); +const + InitFrame: array[0..17] of Byte = + ($06, $0A, $0C, $05, $00, $05, $03, $0A, $09, + $16, $1A, $1C, $15, $00, $15, $13, $1A, $19); + FrameChars_437: array[0..31] of Char = + ' À ³Úà ÙÄÁ¿´ÂÅ È ºÉÇ ¼ÍÏ»¶ÑÎ'; + FrameChars_850: array[0..31] of Char = + ' À ³Úà ÙÄÁ¿´ÂÅ È ºÉº ¼ÍÍ»ºÍÎ'; +var + FrameMask : array[0..MaxViewWidth-1] of Byte; + ColorMask : word; + i,j,k : {Sw_ lo and hi are used !! }integer; + CurrView : PView; + p : Pchar; +begin + FrameMask[0]:=InitFrame[n]; + FillChar(FrameMask[1],Size.X-2,InitFrame[n+1]); + FrameMask[Size.X-1]:=InitFrame[n+2]; + CurrView:=Owner^.Last^.Next; + while (CurrView<>PView(@Self)) do + begin + if ((CurrView^.Options and ofFramed)<>0) and + ((CurrView^.State and sfVisible)<>0) then + begin + i:=Y-CurrView^.Origin.Y; + if (i<0) then + begin + inc(i); + if i=0 then + i:=$0a06 + else + i:=0; + end + else + begin + if i<CurrView^.Size.Y then + i:=$0005 + else + if i=CurrView^.Size.Y then + i:=$0a03 + else + i:=0; + end; + if (i<>0) then + begin + j:=CurrView^.Origin.X; + k:=CurrView^.Size.X+j; + if j<1 then + j:=1; + if k>Size.X then + k:=Size.X; + if (k>j) then + begin + FrameMask[j-1]:=FrameMask[j-1] or lo(i); + i:=(lo(i) xor hi(i)) or (i and $ff00); + FrameMask[k]:=FrameMask[k] or lo(i); + if hi(i)<>0 then + begin + dec(k,j); + repeat + FrameMask[j]:=FrameMask[j] or hi(i); + inc(j); + dec(k); + until k=0; + end; + end; + end; + end; + CurrView:=CurrView^.Next; + end; + ColorMask:=Color shl 8; + p:=framechars_437; + {$ifdef unix} + {Codepage variables are currently Unix only.} + if internal_codepage<>cp437 then + p:=framechars_850; + {$endif} + for i:=0 to Size.X-1 do + TVideoBuf(FrameBuf)[i]:=ord(p[FrameMask[i]]) or ColorMask; +end; + + +procedure TFrame.Draw; +const + LargeC:array[boolean] of char=('^',#24); + RestoreC:array[boolean] of char=('|',#18); + ClickC:array[boolean] of char=('*',#15); +var + CFrame, CTitle: Word; + F, I, L, Width: Sw_Integer; + B: TDrawBuffer; + Title: TTitleStr; + Min, Max: TPoint; +begin + if State and sfDragging <> 0 then + begin + CFrame := $0505; + CTitle := $0005; + F := 0; + end + else if State and sfActive = 0 then + begin + CFrame := $0101; + CTitle := $0002; + F := 0; + end + else + begin + CFrame := $0503; + CTitle := $0004; + F := 9; + end; + CFrame := GetColor(CFrame); + CTitle := GetColor(CTitle); + Width := Size.X; + L := Width - 10; + if PWindow(Owner)^.Flags and (wfClose+wfZoom) <> 0 then + Dec(L,6); + FrameLine(B, 0, F, Byte(CFrame)); + if (PWindow(Owner)^.Number <> wnNoNumber) and + (PWindow(Owner)^.Number < 10) then + begin + Dec(L,4); + if PWindow(Owner)^.Flags and wfZoom <> 0 then + I := 7 + else + I := 3; + WordRec(B[Width - I]).Lo := PWindow(Owner)^.Number + $30; + end; + if Owner <> nil then + Title := PWindow(Owner)^.GetTitle(L) + else + Title := ''; + if Title <> '' then + begin + L := Length(Title); + if L > Width - 10 then + L := Width - 10; + if L < 0 then + L := 0; + I := (Width - L) shr 1; + MoveChar(B[I - 1], ' ', CTitle, 1); + MoveBuf(B[I], Title[1], CTitle, L); + MoveChar(B[I + L], ' ', CTitle, 1); + end; + if State and sfActive <> 0 then + begin + if PWindow(Owner)^.Flags and wfClose <> 0 then + if FrameMode and fmCloseClicked = 0 then + MoveCStr(B[2], '[~þ~]', CFrame) + else + MoveCStr(B[2], '[~'+ClickC[LowAscii]+'~]', CFrame); + if PWindow(Owner)^.Flags and wfZoom <> 0 then + begin + MoveCStr(B[Width - 5], '[~'+LargeC[LowAscii]+'~]', CFrame); + Owner^.SizeLimits(Min, Max); + if FrameMode and fmZoomClicked <> 0 then + WordRec(B[Width - 4]).Lo := ord(ClickC[LowAscii]) + else + if (Owner^.Size.X=Max.X) and (Owner^.Size.Y=Max.Y) then + WordRec(B[Width - 4]).Lo := ord(RestoreC[LowAscii]); + end; + end; + WriteLine(0, 0, Size.X, 1, B); + for I := 1 to Size.Y - 2 do + begin + FrameLine(B, I, F + 3, Byte(CFrame)); + WriteLine(0, I, Size.X, 1, B); + end; + FrameLine(B, Size.Y - 1, F + 6, Byte(CFrame)); + if State and sfActive <> 0 then + if PWindow(Owner)^.Flags and wfGrow <> 0 then + MoveCStr(B[Width - 2], '~ÄÙ~', CFrame); + WriteLine(0, Size.Y - 1, Size.X, 1, B); +end; + +{--TFrame-------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TFrame.GetPalette: PPalette; +CONST P: String[Length(CFrame)] = CFrame; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +procedure TFrame.HandleEvent(var Event: TEvent); +var + Mouse: TPoint; + + procedure DragWindow(Mode: Byte); + var + Limits: TRect; + Min, Max: TPoint; + begin + Owner^.Owner^.GetExtent(Limits); + Owner^.SizeLimits(Min, Max); + Owner^.DragView(Event, Owner^.DragMode or Mode, Limits, Min, Max); + ClearEvent(Event); + end; + +begin + TView.HandleEvent(Event); + if Event.What = evMouseDown then + begin + MakeLocal(Event.Where, Mouse); + if Mouse.Y = 0 then + begin + if (PWindow(Owner)^.Flags and wfClose <> 0) and + (State and sfActive <> 0) and (Mouse.X >= 2) and (Mouse.X <= 4) then + begin + {Close button clicked.} + repeat + MakeLocal(Event.Where, Mouse); + if (Mouse.X >= 2) and (Mouse.X <= 4) and (Mouse.Y = 0) then + FrameMode := fmCloseClicked + else FrameMode := 0; + DrawView; + until not MouseEvent(Event, evMouseMove + evMouseAuto); + FrameMode := 0; + if (Mouse.X >= 2) and (Mouse.X <= 4) and (Mouse.Y = 0) then + begin + Event.What := evCommand; + Event.Command := cmClose; + Event.InfoPtr := Owner; + PutEvent(Event); + end; + ClearEvent(Event); + DrawView; + end else + if (PWindow(Owner)^.Flags and wfZoom <> 0) and + (State and sfActive <> 0) and (Event.Double or + (Mouse.X >= Size.X - 5) and + (Mouse.X <= Size.X - 3)) then + begin + {Zoom button clicked.} + if not Event.Double then + repeat + MakeLocal(Event.Where, Mouse); + if (Mouse.X >= Size.X - 5) and (Mouse.X <= Size.X - 3) and + (Mouse.Y = 0) then + FrameMode := fmZoomClicked + else FrameMode := 0; + DrawView; + until not MouseEvent(Event, evMouseMove + evMouseAuto); + FrameMode := 0; + if ((Mouse.X >= Size.X - 5) and (Mouse.X <= Size.X - 3) and + (Mouse.Y = 0)) or Event.Double then + begin + Event.What := evCommand; + Event.Command := cmZoom; + Event.InfoPtr := Owner; + PutEvent(Event); + end; + ClearEvent(Event); + DrawView; + end else + if PWindow(Owner)^.Flags and wfMove <> 0 then + DragWindow(dmDragMove); + end else + if (State and sfActive <> 0) and (Mouse.X >= Size.X - 2) and + (Mouse.Y >= Size.Y - 1) then + if PWindow(Owner)^.Flags and wfGrow <> 0 then + DragWindow(dmDragGrow); + end; +end; + + +procedure TFrame.SetState(AState: Word; Enable: Boolean); +begin + TView.SetState(AState, Enable); + if AState and (sfActive + sfDragging) <> 0 then + DrawView; +end; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TScrollBar OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + + +{--TScrollBar---------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TScrollBar.Init (Var Bounds: TRect); +const + VChars: array[boolean] of TScrollChars = + (('^','V', #177, #254, #178),(#30, #31, #177, #254, #178)); + HChars: array[boolean] of TScrollChars = + (('<','>', #177, #254, #178),(#17, #16, #177, #254, #178)); +BEGIN + Inherited Init(Bounds); { Call ancestor } + PgStep := 1; { Page step size = 1 } + ArStep := 1; { Arrow step sizes = 1 } + If (Size.X = 1) Then Begin { Vertical scrollbar } + GrowMode := gfGrowLoX + gfGrowHiX + gfGrowHiY; { Grow vertically } + Chars := VChars[LowAscii]; { Vertical chars } + End Else Begin { Horizontal scrollbar } + GrowMode := gfGrowLoY + gfGrowHiX + gfGrowHiY; { Grow horizontal } + Chars := HChars[LowAscii]; { Horizontal chars } + End; +END; + +{--TScrollBar---------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +{ This load method will read old original TV data from a stream with the } +{ scrollbar id set to zero. } +{---------------------------------------------------------------------------} +CONSTRUCTOR TScrollBar.Load (Var S: TStream); +VAR i: Integer; +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(i, SizeOf(i)); Value:=i; { Read current value } + S.Read(i, SizeOf(i)); Min:=i; { Read min value } + S.Read(i, SizeOf(i)); Max:=i; { Read max value } + S.Read(i, SizeOf(i)); PgStep:=i; { Read page step size } + S.Read(i, SizeOf(i)); ArStep:=i; { Read arrow step size } + S.Read(Chars, SizeOf(Chars)); { Read scroll chars } +END; + +{--TScrollBar---------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TScrollBar.GetPalette: PPalette; +CONST P: String[Length(CScrollBar)] = CScrollBar; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TScrollBar---------------------------------------------------------------} +{ ScrollStep -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TScrollBar.ScrollStep (Part: Sw_Integer): Sw_Integer; +VAR Step: Sw_Integer; +BEGIN + If (Part AND $0002 = 0) Then Step := ArStep { Range step size } + Else Step := PgStep; { Page step size } + If (Part AND $0001 = 0) Then ScrollStep := -Step { Upwards move } + Else ScrollStep := Step; { Downwards move } +END; + +{--TScrollBar---------------------------------------------------------------} +{ ScrollDraw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.ScrollDraw; +VAR P: PView; +BEGIN + If (Id <> 0) Then Begin + P := TopView; { Get topmost view } + NewMessage(P, evCommand, cmIdCommunicate, Id, + Value, @Self); { New Id style message } + End; + NewMessage(Owner, evBroadcast, cmScrollBarChanged, + Id, Value, @Self); { Old TV style message } +END; + + +{--TScrollBar---------------------------------------------------------------} +{ SetValue -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.SetValue (AValue: Sw_Integer); +BEGIN + SetParams(AValue, Min, Max, PgStep, ArStep); { Set value } +END; + +{--TScrollBar---------------------------------------------------------------} +{ SetRange -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.SetRange (AMin, AMax: Sw_Integer); +BEGIN + SetParams(Value, AMin, AMax, PgStep, ArStep); { Set range } +END; + +{--TScrollBar---------------------------------------------------------------} +{ SetStep -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.SetStep (APgStep, AArStep: Sw_Integer); +BEGIN + SetParams(Value, Min, Max, APgStep, AArStep); { Set step sizes } +END; + +{--TScrollBar---------------------------------------------------------------} +{ SetParams -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 21Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.SetParams (AValue, AMin, AMax, APgStep, AArStep: Sw_Integer); +var + OldValue : Sw_Integer; +BEGIN + If (AMax < AMin) Then AMax := AMin; { Max below min fix up } + If (AValue < AMin) Then AValue := AMin; { Value below min fix } + If (AValue > AMax) Then AValue := AMax; { Value above max fix } + OldValue:=Value; + If (Value <> AValue) OR (Min <> AMin) OR + (Max <> AMax) Then Begin { Something changed } + Min := AMin; { Set new minimum } + Max := AMax; { Set new maximum } + Value := AValue; { Set new value } + DrawView; + if OldValue <> AValue then + ScrollDraw; + End; + PgStep := APgStep; { Hold page step } + ArStep := AArStep; { Hold arrow step } +END; + +{--TScrollBar---------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +{ You can save data to the stream compatable with the old original TV by } +{ temporarily turning off the ofGrafVersion making the call to this store } +{ routine and resetting the ofGrafVersion flag after the call. } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.Store (Var S: TStream); +VAR i: Integer; +BEGIN + TView.Store(S); { TView.Store called } + i:=Value;S.Write(i, SizeOf(i)); { Write current value } + i:=Min;S.Write(i, SizeOf(i)); { Write min value } + i:=Max;S.Write(i, SizeOf(i)); { Write max value } + i:=PgStep;S.Write(i, SizeOf(i)); { Write page step size } + i:=ArStep;S.Write(i, SizeOf(i)); { Write arrow step size } + S.Write(Chars, SizeOf(Chars)); { Write scroll chars } +END; + +{--TScrollBar---------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22May98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.HandleEvent (Var Event: TEvent); +VAR Tracking: Boolean; I, P, S, ClickPart, Iv: Sw_Integer; + Mouse: TPoint; Extent: TRect; + + FUNCTION GetPartCode: Sw_Integer; + VAR Mark, Part : Sw_Integer; + BEGIN + Part := -1; { Preset failure } + If Extent.Contains(Mouse) Then Begin { Contains mouse } + If (Size.X = 1) Then Begin { Vertical scrollbar } + Mark := Mouse.Y - 1; { Calc position } + End Else Begin { Horizontal bar } + Mark := Mouse.X - 1; { Calc position } + End; + If (Mark >= P) AND (Mark < P+1) Then { Within thumbnail } + Part := sbIndicator; { Indicator part } + If (Part <> sbIndicator) Then Begin { Not indicator part } + If (Mark < 1) Then Part := sbLeftArrow Else { Left arrow part } + If (Mark < P) Then Part := sbPageLeft Else { Page left part } + If (Mark < S) Then Part := sbPageRight Else { Page right part } + Part := sbRightArrow; { Right arrow part } + If (Size.X = 1) Then Inc(Part, 4); { Correct for vertical } + End; + End; + GetPartCode := Part; { Return part code } + END; + + PROCEDURE Clicked; + BEGIN + NewMessage(Owner, evBroadcast, cmScrollBarClicked, + Id, Value, @Self); { Old TV style message } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evCommand: Begin { Command event } + If (Event.Command = cmIdCommunicate) AND { Id communication } + (Event.Id = Id) AND (Event.InfoPtr <> @Self) { Targeted to us } + Then Begin + SetValue(Round(Event.Data)); { Set scrollbar value } + ClearEvent(Event); { Event was handled } + End; + End; + evKeyDown: + If (State AND sfVisible <> 0) Then Begin { Scrollbar visible } + ClickPart := sbIndicator; { Preset result } + If (Size.Y = 1) Then { Horizontal bar } + Case CtrlToArrow(Event.KeyCode) Of + kbLeft: ClickPart := sbLeftArrow; { Left one item } + kbRight: ClickPart := sbRightArrow; { Right one item } + kbCtrlLeft: ClickPart := sbPageLeft; { One page left } + kbCtrlRight: ClickPart := sbPageRight; { One page right } + kbHome: I := Min; { Move to start } + kbEnd: I := Max; { Move to end } + Else Exit; { Not a valid key } + End + Else { Vertical bar } + Case CtrlToArrow(Event.KeyCode) Of + kbUp: ClickPart := sbUpArrow; { One item up } + kbDown: ClickPart := sbDownArrow; { On item down } + kbPgUp: ClickPart := sbPageUp; { One page up } + kbPgDn: ClickPart := sbPageDown; { One page down } + kbCtrlPgUp: I := Min; { Move to top } + kbCtrlPgDn: I := Max; { Move to bottom } + Else Exit; { Not a valid key } + End; + Clicked; { Send out message } + If (ClickPart <> sbIndicator) Then + I := Value + ScrollStep(ClickPart); { Calculate position } + SetValue(I); { Set new item } + ClearEvent(Event); { Event now handled } + End; + evMouseDown: Begin { Mouse press event } + Clicked; { Scrollbar clicked } + MakeLocal(Event.Where, Mouse); { Localize mouse } + Extent.A.X := 0; { Zero x extent value } + Extent.A.Y := 0; { Zero y extent value } + Extent.B.X := Size.X; { Set extent x value } + Extent.B.Y := Size.Y; { set extent y value } + P := GetPos; { Current position } + S := GetSize; { Initial size } + ClickPart := GetPartCode; { Get part code } + If (ClickPart <> sbIndicator) Then Begin { Not thumb nail } + Repeat + MakeLocal(Event.Where, Mouse); { Localize mouse } + If GetPartCode = ClickPart Then + SetValue(Value+ScrollStep(ClickPart)); { Same part repeat } + Until NOT MouseEvent(Event, evMouseAuto); { Until auto done } + Clicked; { Scrollbar clicked } + End Else Begin { Thumb nail move } + Iv := Value; { Initial value } + Repeat + MakeLocal(Event.Where, Mouse); { Localize mouse } + Tracking := Extent.Contains(Mouse); { Check contains } + If Tracking Then Begin { Tracking mouse } + If (Size.X=1) Then + I := Mouse.Y-1 Else { Calc vert position } + I := Mouse.X-1; { Calc horz position } + If (I < 0) Then I := 0; { Check underflow } + If (I > S) Then I := S; { Check overflow } + End Else I := GetPos; { Get position } + If (I <> P) Then Begin + SetValue(LongInt((LongInt(I)*(Max-Min)) + +(S SHR 1)) DIV S + Min); { Set new value } + P := I; { Hold new position } + End; + Until NOT MouseEvent(Event, evMouseMove); { Until not moving } + If Tracking AND (S > 0) Then { Tracking mouse } + SetValue(LongInt((LongInt(P)*(Max-Min))+ + (S SHR 1)) DIV S + Min); { Set new value } + If (Iv <> Value) Then Clicked; { Scroll has moved } + End; + ClearEvent(Event); { Clear the event } + End; + End; +END; + +{***************************************************************************} +{ TScrollBar OBJECT PRIVATE METHODS } +{***************************************************************************} + +{--TScrollBar---------------------------------------------------------------} +{ GetPos -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TScrollBar.GetPos: Sw_Integer; +VAR R: Sw_Integer; +BEGIN + R := Max - Min; { Get full range } + If (R = 0) Then GetPos := 1 Else { Return zero } + GetPos := LongInt((LongInt(Value-Min) * (GetSize -3)) + + (R SHR 1)) DIV R + 1; { Calc position } +END; + +{--TScrollBar---------------------------------------------------------------} +{ GetSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TScrollBar.GetSize: Sw_Integer; +VAR S: Sw_Integer; +BEGIN + If Size.X = 1 Then + S:= Size.Y + else + S:= Size.X; + If (S < 3) Then S := 3; { Fix minimum size } + GetSize := S; { Return size } +END; + + +{--TScrollBar---------------------------------------------------------------} +{ Draw -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScrollBar.Draw; +BEGIN + DrawPos(GetPos); { Draw position } +END; + + +procedure TScrollBar.DrawPos(Pos: Sw_Integer); +var + S: Sw_Integer; + B: TDrawBuffer; +begin + S := GetSize - 1; + MoveChar(B[0], Chars[0], GetColor(2), 1); + if Max = Min then + MoveChar(B[1], Chars[4], GetColor(1), S - 1) + else + begin + MoveChar(B[1], Chars[2], GetColor(1), S - 1); + MoveChar(B[Pos], Chars[3], GetColor(3), 1); + end; + MoveChar(B[S], Chars[1], GetColor(2), 1); + WriteBuf(0, 0, Size.X, Size.Y, B); +end; + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TScroller OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TScroller----------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TScroller.Init (Var Bounds: TRect; AHScrollBar, AVScrollBar: PScrollBar); +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR ofSelectable; { View is selectable } + EventMask := EventMask OR evBroadcast; { See broadcasts } + HScrollBar := AHScrollBar; { Hold horz scrollbar } + VScrollBar := AVScrollBar; { Hold vert scrollbar } +END; + +{--TScroller----------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +{ This load method will read old original TV data from a stream as well } +{ as the new graphical scroller views. } +{---------------------------------------------------------------------------} +CONSTRUCTOR TScroller.Load (Var S: TStream); +VAR i: Integer; +BEGIN + Inherited Load(S); { Call ancestor } + GetPeerViewPtr(S, HScrollBar); { Load horz scrollbar } + GetPeerViewPtr(S, VScrollBar); { Load vert scrollbar } + S.Read(i, SizeOf(i)); Delta.X:=i; { Read delta x value } + S.Read(i, SizeOf(i)); Delta.Y:=i; { Read delta y value } + S.Read(i, SizeOf(i)); Limit.X:=i; { Read limit x value } + S.Read(i, SizeOf(i)); Limit.Y:=i; { Read limit y value } +END; + +{--TScroller----------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +FUNCTION TScroller.GetPalette: PPalette; +CONST P: String[Length(CScroller)] = CScroller; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Scroller palette } +END; + +{--TScroller----------------------------------------------------------------} +{ ScrollTo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScroller.ScrollTo (X, Y: Sw_Integer); +BEGIN + Inc(DrawLock); { Set draw lock } + If (HScrollBar<>Nil) Then HScrollBar^.SetValue(X); { Set horz scrollbar } + If (VScrollBar<>Nil) Then VScrollBar^.SetValue(Y); { Set vert scrollbar } + Dec(DrawLock); { Release draw lock } + CheckDraw; { Check need to draw } +END; + +{--TScroller----------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScroller.SetState (AState: Word; Enable: Boolean); + + PROCEDURE ShowSBar (SBar: PScrollBar); + BEGIN + If (SBar <> Nil) Then { Scroll bar valid } + If GetState(sfActive + sfSelected) Then { Check state masks } + SBar^.Show Else SBar^.Hide; { Draw appropriately } + END; + +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState AND (sfActive + sfSelected) <> 0) { Active/select change } + Then Begin + ShowSBar(HScrollBar); { Redraw horz scrollbar } + ShowSBar(VScrollBar); { Redraw vert scrollbar } + End; +END; + +{--TScroller----------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +{ The scroller is saved to the stream compatable with the old TV object. } +{---------------------------------------------------------------------------} +PROCEDURE TScroller.Store (Var S: TStream); +VAR i: Integer; +BEGIN + TView.Store(S); { Call TView explicitly } + PutPeerViewPtr(S, HScrollBar); { Store horz bar } + PutPeerViewPtr(S, VScrollBar); { Store vert bar } + i:=Delta.X;S.Write(i, SizeOf(i)); { Write delta x value } + i:=Delta.Y;S.Write(i, SizeOf(i)); { Write delta y value } + i:=Limit.X;S.Write(i, SizeOf(i)); { Write limit x value } + i:=Limit.Y;S.Write(i, SizeOf(i)); { Write limit y value } +END; + +{--TScroller----------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScroller.HandleEvent (Var Event: TEvent); +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + If (Event.What = evBroadcast) AND + (Event.Command = cmScrollBarChanged) AND { Scroll bar change } + ((Event.InfoPtr = HScrollBar) OR { Our scrollbar? } + (Event.InfoPtr = VScrollBar)) Then ScrollDraw; { Redraw scroller } +END; + +{--TScroller----------------------------------------------------------------} +{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TScroller.ChangeBounds (Var Bounds: TRect); +BEGIN + SetBounds(Bounds); { Set new bounds } + Inc(DrawLock); { Set draw lock } + SetLimit(Limit.X, Limit.Y); { Adjust limits } + Dec(DrawLock); { Release draw lock } + DrawFlag := False; { Clear draw flag } + DrawView; { Redraw now } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TListViewer OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +CONST TvListViewerName = 'LISTBOX'; { Native name } + +{--TListViewer--------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TListViewer.Init (Var Bounds: TRect; ANumCols: Sw_Word; AHScrollBar, + AVScrollBar: PScrollBar); +VAR ArStep, PgStep: Sw_Integer; +BEGIN + Inherited Init(Bounds); { Call ancestor } + Options := Options OR (ofFirstClick+ofSelectable); { Set options } + EventMask := EventMask OR evBroadcast; { Set event mask } + NumCols := ANumCols; { Hold column number } + If (AVScrollBar <> Nil) Then Begin { Chk vert scrollbar } + If (NumCols = 1) Then Begin { Only one column } + PgStep := Size.Y -1; { Set page size } + ArStep := 1; { Set step size } + End Else Begin { Multiple columns } + PgStep := Size.Y * NumCols; { Set page size } + ArStep := Size.Y; { Set step size } + End; + AVScrollBar^.SetStep(PgStep, ArStep); { Set scroll values } + End; + If (AHScrollBar <> Nil) Then + AHScrollBar^.SetStep(Size.X DIV NumCols, 1); { Set step size } + HScrollBar := AHScrollBar; { Horz scrollbar held } + VScrollBar := AVScrollBar; { Vert scrollbar held } +END; + +{--TListViewer--------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TListViewer.Load (Var S: TStream); +VAR w: Word; +BEGIN + Inherited Load(S); { Call ancestor } + GetPeerViewPtr(S, HScrollBar); { Get horz scrollbar } + GetPeerViewPtr(S, VScrollBar); { Get vert scrollbar } + S.Read(w, SizeOf(w)); NumCols:=w; { Read column number } + S.Read(w, SizeOf(w)); TopItem:=w; { Read top most item } + S.Read(w, SizeOf(w)); Focused:=w; { Read focused item } + S.Read(w, SizeOf(w)); Range:=w; { Read listview range } +END; + +{--TListViewer--------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TListViewer.GetPalette: PPalette; +CONST P: String[Length(CListViewer)] = CListViewer; { Always normal string } +BEGIN + GetPalette := PPalette(@P); { Return palette } +END; + +{--TListViewer--------------------------------------------------------------} +{ IsSelected -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TListViewer.IsSelected (Item: Sw_Integer): Boolean; +BEGIN + If (Item = Focused) Then IsSelected := True Else + IsSelected := False; { Selected item } +END; + +{--TListViewer--------------------------------------------------------------} +{ GetText -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May98 LdB } +{---------------------------------------------------------------------------} +FUNCTION TListViewer.GetText (Item: Sw_Integer; MaxLen: Sw_Integer): String; +BEGIN { Abstract method } + GetText := ''; { Return empty } +END; + +{--TListViewer--------------------------------------------------------------} +{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.Draw; +VAR I, J, ColWidth, Item, Indent, CurCol: Sw_Integer; + Color: Word; SCOff: Byte; + Text: String; B: TDrawBuffer; +BEGIN + ColWidth := Size.X DIV NumCols + 1; { Calc column width } + If (HScrollBar = Nil) Then Indent := 0 Else { Set indent to zero } + Indent := HScrollBar^.Value; { Fetch any indent } + For I := 0 To Size.Y - 1 Do Begin { For each line } + For J := 0 To NumCols-1 Do Begin { For each column } + Item := J*Size.Y + I + TopItem; { Process this item } + CurCol := J*ColWidth; { Current column } + If (State AND (sfSelected + sfActive) = + (sfSelected + sfActive)) AND (Focused = Item) { Focused item } + AND (Range > 0) Then Begin + Color := GetColor(3); { Focused colour } + SetCursor(CurCol+1,I); { Set the cursor } + SCOff := 0; { Zero colour offset } + End Else If (Item < Range) AND IsSelected(Item){ Selected item } + Then Begin + Color := GetColor(4); { Selected color } + SCOff := 2; { Colour offset=2 } + End Else Begin + Color := GetColor(2); { Normal Color } + SCOff := 4; { Colour offset=4 } + End; + MoveChar(B[CurCol], ' ', Color, ColWidth); { Clear buffer } + If (Item < Range) Then Begin { Within text range } + Text := GetText(Item, ColWidth + Indent); { Fetch text } + Text := Copy(Text, Indent, ColWidth); { Select right bit } + MoveStr(B[CurCol+1], Text, Color); { Transfer to buffer } + If ShowMarkers Then Begin + WordRec(B[CurCol]).Lo := Byte( + SpecialChars[SCOff]); { Set marker character } + WordRec(B[CurCol+ColWidth-2]).Lo := Byte( + SpecialChars[SCOff+1]); { Set marker character } + End; + End; + MoveChar(B[CurCol+ColWidth-1], #179, + GetColor(5), 1); { Put centre line marker } + End; + WriteLine(0, I, Size.X, 1, B); { Write line to screen } + End; +END; + + +{--TListViewer--------------------------------------------------------------} +{ FocusItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.FocusItem (Item: Sw_Integer); +BEGIN + Focused := Item; { Set focus to item } + If (VScrollBar <> Nil) Then + VScrollBar^.SetValue(Item); { Scrollbar to value } + If (Item < TopItem) Then { Item above top item } + If (NumCols = 1) Then TopItem := Item { Set top item } + Else TopItem := Item - Item MOD Size.Y { Set top item } + Else If (Item >= TopItem + (Size.Y*NumCols)) Then { Item below bottom } + If (NumCols = 1) Then TopItem := Item-Size.Y+1 { Set new top item } + Else TopItem := Item - Item MOD Size.Y - + (Size.Y*(NumCols-1)); { Set new top item } +END; + +{--TListViewer--------------------------------------------------------------} +{ SetTopItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 06Aug99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.SetTopItem (Item: Sw_Integer); +BEGIN + TopItem := Item; { Set the top item } +END; + +{--TListViewer--------------------------------------------------------------} +{ SetRange -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.SetRange (ARange: Sw_Integer); +BEGIN + Range := ARange; { Set new range } + If (VScrollBar <> Nil) Then Begin { Vertical scrollbar } + If (Focused > ARange) Then Focused := 0; { Clear focused } + VScrollBar^.SetParams(Focused, 0, ARange - 1, + VScrollBar^.PgStep, VScrollBar^.ArStep); { Set parameters } + End; +END; + +{--TListViewer--------------------------------------------------------------} +{ SelectItem -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.SelectItem (Item: Sw_Integer); +BEGIN + Message(Owner, evBroadcast, cmListItemSelected, + @Self); { Send message } +END; + +{--TListViewer--------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.SetState (AState: Word; Enable: Boolean); + + PROCEDURE ShowSBar(SBar: PScrollBar); + BEGIN + If (SBar <> Nil) Then { Valid scrollbar } + If GetState(sfActive) AND GetState(sfVisible) { Check states } + Then SBar^.Show Else SBar^.Hide; { Show or hide } + END; + +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState AND (sfSelected + sfActive + sfVisible) <> 0) + Then Begin { Check states } + DrawView; { Draw the view } + ShowSBar(HScrollBar); { Show horz scrollbar } + ShowSBar(VScrollBar); { Show vert scrollbar } + End; +END; + +{--TListViewer--------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.Store (Var S: TStream); +VAR w: Word; +BEGIN + TView.Store(S); { Call TView explicitly } + PutPeerViewPtr(S, HScrollBar); { Put horz scrollbar } + PutPeerViewPtr(S, VScrollBar); { Put vert scrollbar } + w:=NumCols;S.Write(w, SizeOf(w)); { Write column number } + w:=TopItem;S.Write(w, SizeOf(w)); { Write top most item } + w:=Focused;S.Write(w, SizeOf(w)); { Write focused item } + w:=Range;S.Write(w, SizeOf(w)); { Write listview range } +END; + +{--TListViewer--------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.HandleEvent (Var Event: TEvent); +CONST MouseAutosToSkip = 4; +VAR Oi, Ni: Sw_Integer; Ct, Cw: Word; Mouse: TPoint; + + PROCEDURE MoveFocus (Req: Sw_Integer); + BEGIN + FocusItemNum(Req); { Focus req item } + DrawView; { Redraw focus box } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speed up exit } + evKeyDown: Begin { Key down event } + If (Event.CharCode = ' ') AND (Focused < Range){ Spacebar select } + Then Begin + SelectItem(Focused); { Select focused item } + Ni := Focused; { Hold new item } + End Else Case CtrlToArrow(Event.KeyCode) Of + kbUp: Ni := Focused - 1; { One item up } + kbDown: Ni := Focused + 1; { One item down } + kbRight: If (NumCols > 1) Then + Ni := Focused + Size.Y Else Exit; { One column right } + kbLeft: If (NumCols > 1) Then + Ni := Focused - Size.Y Else Exit; { One column left } + kbPgDn: Ni := Focused + Size.Y * NumCols; { One page down } + kbPgUp: Ni := Focused - Size.Y * NumCols; { One page up } + kbHome: Ni := TopItem; { Move to top } + kbEnd: Ni := TopItem + (Size.Y*NumCols)-1; { Move to bottom } + kbCtrlPgDn: Ni := Range - 1; { Move to last item } + kbCtrlPgUp: Ni := 0; { Move to first item } + Else Exit; + End; + MoveFocus(Ni); { Move the focus } + ClearEvent(Event); { Event was handled } + End; + evBroadcast: Begin { Broadcast event } + If (Options AND ofSelectable <> 0) Then { View is selectable } + If (Event.Command = cmScrollBarClicked) AND { Scrollbar click } + ((Event.InfoPtr = HScrollBar) OR + (Event.InfoPtr = VScrollBar)) Then Select { Scrollbar selects us } + Else If (Event.Command = cmScrollBarChanged) { Scrollbar changed } + Then Begin + If (VScrollBar = Event.InfoPtr) Then Begin + MoveFocus(VScrollBar^.Value); { Focus us to item } + End Else If (HScrollBar = Event.InfoPtr) + Then DrawView; { Redraw the view } + End; + End; + evMouseDown: Begin { Mouse down event } + Cw := Size.X DIV NumCols + 1; { Column width } + Oi := Focused; { Hold focused item } + MakeLocal(Event.Where, Mouse); { Localize mouse } + If MouseInView(Event.Where) Then Ni := Mouse.Y + + (Size.Y*(Mouse.X DIV Cw))+TopItem { Calc item to focus } + Else Ni := Oi; { Focus old item } + Ct := 0; { Clear count value } + Repeat + If (Ni <> Oi) Then Begin { Item is different } + MoveFocus(Ni); { Move the focus } + Oi := Focused; { Hold as focused item } + End; + MakeLocal(Event.Where, Mouse); { Localize mouse } + If NOT MouseInView(Event.Where) Then Begin + If (Event.What = evMouseAuto) Then Inc(Ct);{ Inc auto count } + If (Ct = MouseAutosToSkip) Then Begin + Ct := 0; { Reset count } + If (NumCols = 1) Then Begin { Only one column } + If (Mouse.Y < 0) Then Ni := Focused-1; { Move up one item } + If (Mouse.Y >= Size.Y) Then + Ni := Focused+1; { Move down one item } + End Else Begin { Multiple columns } + If (Mouse.X < 0) Then { Mouse x below zero } + Ni := Focused-Size.Y; { Move down 1 column } + If (Mouse.X >= Size.X) Then { Mouse x above width } + Ni := Focused+Size.Y; { Move up 1 column } + If (Mouse.Y < 0) Then { Mouse y below zero } + Ni := Focused-Focused MOD Size.Y; { Move up one item } + If (Mouse.Y > Size.Y) Then { Mouse y above height } + Ni := Focused-Focused MOD + Size.Y+Size.Y-1; { Move down one item } + End; + End; + End Else Ni := Mouse.Y + (Size.Y*(Mouse.X + DIV Cw))+TopItem; { New item to focus } + Until NOT MouseEvent(Event, evMouseMove + + evMouseAuto); { Mouse stopped } + If (Oi <> Ni) Then MoveFocus(Ni); { Focus moved again } + If (Event.Double AND (Range > Focused)) Then + SelectItem(Focused); { Select the item } + ClearEvent(Event); { Event was handled } + End; + End; +END; + +{--TListViewer--------------------------------------------------------------} +{ ChangeBounds -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.ChangeBounds (Var Bounds: TRect); +BEGIN + Inherited ChangeBounds(Bounds); { Call ancestor } + If (HScrollBar <> Nil) Then { Valid horz scrollbar } + HScrollBar^.SetStep(Size.X DIV NumCols, + HScrollBar^.ArStep); { Update horz bar } + If (VScrollBar <> Nil) Then { Valid vert scrollbar } + VScrollBar^.SetStep(Size.Y * NumCols, + VScrollBar^.ArStep); { Update vert bar } +END; + +{***************************************************************************} +{ TListViewer OBJECT PRIVATE METHODS } +{***************************************************************************} + +{--TListViewer--------------------------------------------------------------} +{ FocusItemNum -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TListViewer.FocusItemNum (Item: Sw_Integer); +BEGIN + If (Item < 0) Then Item := 0 Else { Restrain underflow } + If (Item >= Range) AND (Range > 0) Then + Item := Range-1; { Restrain overflow } + If (Range <> 0) Then FocusItem(Item); { Set focus value } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TWindow OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{--TWindow------------------------------------------------------------------} +{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +CONSTRUCTOR TWindow.Init (Var Bounds: TRect; ATitle: TTitleStr; ANumber: Sw_Integer); +BEGIN + Inherited Init(Bounds); { Call ancestor } + State := State OR sfShadow; { View is shadowed } + Options := Options OR (ofSelectable+ofTopSelect); { Select options set } + GrowMode := gfGrowAll + gfGrowRel; { Set growmodes } + Flags := wfMove + wfGrow + wfClose + wfZoom; { Set flags } + Title := NewStr(ATitle); { Hold title } + Number := ANumber; { Hold number } + Palette := wpBlueWindow; { Default palette } + InitFrame; { Initialize frame } + If (Frame <> Nil) Then Insert(Frame); { Insert any frame } + GetBounds(ZoomRect); { Default zoom rect } +END; + +{--TWindow------------------------------------------------------------------} +{ Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +{ This load method will read old original TV data from a stream however } +{ although a frame view is read for compatability it is disposed of. } +{---------------------------------------------------------------------------} +CONSTRUCTOR TWindow.Load (Var S: TStream); +VAR I: Integer; +BEGIN + Inherited Load(S); { Call ancestor } + S.Read(Flags, SizeOf(Flags)); { Read window flags } + S.Read(i, SizeOf(i)); Number:=i; { Read window number } + S.Read(i, SizeOf(i)); Palette:=i; { Read window palette } + S.Read(i, SizeOf(i)); ZoomRect.A.X:=i; { Read zoom area x1 } + S.Read(i, SizeOf(i)); ZoomRect.A.Y:=i; { Read zoom area y1 } + S.Read(i, SizeOf(i)); ZoomRect.B.X:=i; { Read zoom area x2 } + S.Read(i, SizeOf(i)); ZoomRect.B.Y:=i; { Read zoom area y2 } + GetSubViewPtr(S, Frame); { Now read frame object } + Title := S.ReadStr; { Read title } +END; + +{--TWindow------------------------------------------------------------------} +{ Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +DESTRUCTOR TWindow.Done; +BEGIN + Inherited Done; { Call ancestor } + If (Title <> Nil) Then DisposeStr(Title); { Dispose title } +END; + +{--TWindow------------------------------------------------------------------} +{ GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TWindow.GetPalette: PPalette; +CONST P: ARRAY [wpBlueWindow..wpGrayWindow] Of String[Length(CBlueWindow)] = + (CBlueWindow, CCyanWindow, CGrayWindow); { Always normal string } +BEGIN + GetPalette := PPalette(@P[Palette]); { Return palette } +END; + +{--TWindow------------------------------------------------------------------} +{ GetTitle -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{ Modified 31may2002 PM (No number included anymore) } +{---------------------------------------------------------------------------} +FUNCTION TWindow.GetTitle (MaxSize: Sw_Integer): TTitleStr; +VAR S: String; +BEGIN + If (Title <> Nil) Then S:=Title^ + Else S := ''; + if Length(S)>MaxSize then + GetTitle:=Copy(S,1,MaxSize) + else + GetTitle:=S; +END; + +{--TWindow------------------------------------------------------------------} +{ StandardScrollBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION TWindow.StandardScrollBar (AOptions: Word): PScrollBar; +VAR R: TRect; S: PScrollBar; +BEGIN + GetExtent(R); { View extents } + If (AOptions AND sbVertical = 0) Then + R.Assign(R.A.X+2, R.B.Y-1, R.B.X-2, R.B.Y) { Horizontal scrollbar } + Else R.Assign(R.B.X-1, R.A.Y+1, R.B.X, R.B.Y-1); { Vertical scrollbar } + S := New(PScrollBar, Init(R)); { Create scrollbar } + Insert(S); { Insert scrollbar } + If (AOptions AND sbHandleKeyboard <> 0) Then + S^.Options := S^.Options or ofPostProcess; { Post process } + StandardScrollBar := S; { Return scrollbar } +END; + +{--TWindow------------------------------------------------------------------} +{ Zoom -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.Zoom; +VAR R: TRect; Max, Min: TPoint; +BEGIN + SizeLimits(Min, Max); { Return size limits } + If ((Size.X <> Max.X) OR (Size.Y <> Max.Y)) { Larger size possible } + Then Begin + GetBounds(ZoomRect); { Get zoom bounds } + R.A.X := 0; { Zero x origin } + R.A.Y := 0; { Zero y origin } + R.B := Max; { Bounds to max size } + Locate(R); { Locate the view } + End Else Locate(ZoomRect); { Move to zoom rect } +END; + +{--TWindow------------------------------------------------------------------} +{ Close -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.Close; +BEGIN + If Valid(cmClose) Then Free; { Dispose of self } +END; + +{--TWindow------------------------------------------------------------------} +{ InitFrame -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.InitFrame; +VAR + R: TRect; +BEGIN + GetExtent(R); + Frame := New(PFrame, Init(R)); +END; + +{--TWindow------------------------------------------------------------------} +{ SetState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Mar98 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.SetState (AState: Word; Enable: Boolean); +VAR WindowCommands: TCommandSet; +BEGIN + Inherited SetState(AState, Enable); { Call ancestor } + If (AState = sfSelected) Then + SetState(sfActive, Enable); { Set active state } + If (AState = sfSelected) OR ((AState = sfExposed) + AND (State AND sfSelected <> 0)) Then Begin { View is selected } + WindowCommands := [cmNext, cmPrev]; { Set window commands } + If (Flags AND (wfGrow + wfMove) <> 0) Then + WindowCommands := WindowCommands + [cmResize]; { Add resize command } + If (Flags AND wfClose <> 0) Then + WindowCommands := WindowCommands + [cmClose]; { Add close command } + If (Flags AND wfZoom <> 0) Then + WindowCommands := WindowCommands + [cmZoom]; { Add zoom command } + If Enable Then EnableCommands(WindowCommands) { Enable commands } + Else DisableCommands(WindowCommands); { Disable commands } + End; +END; + +{--TWindow------------------------------------------------------------------} +{ Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Mar98 LdB } +{---------------------------------------------------------------------------} +{ You can save data to the stream compatable with the old original TV by } +{ temporarily turning off the ofGrafVersion making the call to this store } +{ routine and resetting the ofGrafVersion flag after the call. } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.Store (Var S: TStream); +VAR i: Integer; +BEGIN + TGroup.Store(S); { Call group store } + S.Write(Flags, SizeOf(Flags)); { Write window flags } + i:=Number;S.Write(i, SizeOf(i)); { Write window number } + i:=Palette;S.Write(i, SizeOf(i)); { Write window palette } + i:=ZoomRect.A.X;S.Write(i, SizeOf(i)); { Write zoom area x1 } + i:=ZoomRect.A.Y;S.Write(i, SizeOf(i)); { Write zoom area y1 } + i:=ZoomRect.B.X;S.Write(i, SizeOf(i)); { Write zoom area x2 } + i:=ZoomRect.B.Y;S.Write(i, SizeOf(i)); { Write zoom area y2 } + PutSubViewPtr(S, Frame); { Write any frame } + S.WriteStr(Title); { Write title string } +END; + +{--TWindow------------------------------------------------------------------} +{ HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11Aug99 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.HandleEvent (Var Event: TEvent); +VAR + Min, Max: TPoint; Limits: TRect; + + PROCEDURE DragWindow (Mode: Byte); + VAR Limits: TRect; Min, Max: TPoint; + BEGIN + Owner^.GetExtent(Limits); { Get owner extents } + SizeLimits(Min, Max); { Restrict size } + DragView(Event, DragMode OR Mode, Limits, Min, + Max); { Drag the view } + ClearEvent(Event); { Clear the event } + END; + +BEGIN + Inherited HandleEvent(Event); { Call ancestor } + Case Event.What Of + evNothing: Exit; { Speeds up exit } + evCommand: { COMMAND EVENT } + Case Event.Command Of { Command type case } + cmResize: { RESIZE COMMAND } + If (Flags AND (wfMove + wfGrow) <> 0) { Window can resize } + AND (Owner <> Nil) Then Begin { Valid owner } + Owner^.GetExtent(Limits); { Owners extents } + SizeLimits(Min, Max); { Check size limits } + DragView(Event, DragMode OR (Flags AND + (wfMove + wfGrow)), Limits, Min, Max); { Drag the view } + ClearEvent(Event); { Clear the event } + End; + cmClose: { CLOSE COMMAND } + If (Flags AND wfClose <> 0) AND { Close flag set } + ((Event.InfoPtr = Nil) OR { None specific close } + (Event.InfoPtr = @Self)) Then Begin { Close to us } + ClearEvent(Event); { Clear the event } + If (State AND sfModal = 0) Then Close { Non modal so close } + Else Begin { Modal window } + Event.What := evCommand; { Command event } + Event.Command := cmCancel; { Cancel command } + PutEvent(Event); { Place on queue } + ClearEvent(Event); { Clear the event } + End; + End; + cmZoom: { ZOOM COMMAND } + If (Flags AND wfZoom <> 0) AND { Zoom flag set } + ((Event.InfoPtr = Nil) OR { No specific zoom } + (Event.InfoPtr = @Self)) Then Begin + Zoom; { Zoom our window } + ClearEvent(Event); { Clear the event } + End; + End; + evBroadcast: { BROADCAST EVENT } + If (Event.Command = cmSelectWindowNum) AND + (Event.InfoInt = Number) AND { Select our number } + (Options AND ofSelectable <> 0) Then Begin { Is view selectable } + Select; { Select our view } + ClearEvent(Event); { Clear the event } + End; + evKeyDown: Begin { KEYDOWN EVENT } + Case Event.KeyCode Of + kbTab: Begin { TAB KEY } + FocusNext(False); { Select next view } + ClearEvent(Event); { Clear the event } + End; + kbShiftTab: Begin { SHIFT TAB KEY } + FocusNext(True); { Select prior view } + ClearEvent(Event); { Clear the event } + End; + End; + End; + End; { Event.What case end } +END; + +{--TWindow------------------------------------------------------------------} +{ SizeLimits -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 15Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TWindow.SizeLimits (Var Min, Max: TPoint); +BEGIN + Inherited SizeLimits(Min, Max); { View size limits } + Min.X := MinWinSize.X; { Set min x size } + Min.Y := MinWinSize.Y; { Set min y size } +END; + + + +{--TView--------------------------------------------------------------------} +{ Exposed -> Platforms DOS/DPMI/WIN/OS2 - Checked 17Sep97 LdB } +{---------------------------------------------------------------------------} +function TView.do_ExposedRec1(x1,x2:sw_integer; p:PView):boolean; +var + G : PGroup; + dy,dx : sw_integer; +begin + while true do + begin + p:=p^.Next; + G:=p^.Owner; + if p=staticVar2.target then + begin + do_exposedRec1:=do_exposedRec2(x1,x2,G); + Exit; + end; + dy:=p^.origin.y; + dx:=p^.origin.x; + if ((p^.state and sfVisible)<>0) and (staticVar2.y>=dy) then + begin + if staticVar2.y<dy+p^.size.y then + begin + if x1<dx then + begin + if x2<=dx then + continue; + if x2>dx+p^.size.x then + begin + if do_exposedRec1(x1,dx,p) then + begin + do_exposedRec1:=True; + Exit; + end; + x1:=dx+p^.size.x; + end + else + x2:=dx; + end + else + begin + if x1<dx+p^.size.x then + x1:=dx+p^.size.x; + if x1>=x2 then + begin + do_exposedRec1:=False; + Exit; + end; + end; + end; + end; + end; +end; + + +function TView.do_ExposedRec2(x1,x2:Sw_integer; p:PView):boolean; +var + G : PGroup; + savedStat : TStatVar2; +begin + if (p^.state and sfVisible)=0 then + do_ExposedRec2:=false + else + begin + G:=p^.Owner; + if (G=Nil) or (G^.Buffer<>Nil) then + do_ExposedRec2:=true + else + begin + savedStat:=staticVar2; + inc(staticVar2.y,p^.origin.y); + inc(x1,p^.origin.x); + inc(x2,p^.origin.x); + staticVar2.target:=p; + if (staticVar2.y<G^.clip.a.y) or (staticVar2.y>=G^.clip.b.y) then + do_ExposedRec2:=false + else + begin + if (x1<G^.clip.a.x) then + x1:=G^.clip.a.x; + if (x2>G^.clip.b.x) then + x2:=G^.clip.b.x; + if (x1>=x2) then + do_ExposedRec2:=false + else + do_ExposedRec2:=do_exposedRec1(x1,x2,G^.Last); + end; + staticVar2 := savedStat; + end; + end; +end; + + +function TView.Exposed: Boolean; +var + OK : boolean; + y : sw_integer; +begin + if ((State and sfExposed)<>0) and (Size.X>0) and (Size.Y>0) then + begin + OK:=false; + y:=0; + while (y<Size.Y) and (not OK) do + begin + staticVar2.y:=y; + OK:=do_ExposedRec2(0,Size.X,@Self); + inc(y); + end; + Exposed:=OK; + end + else + Exposed:=False +end; + + +{--TView--------------------------------------------------------------------} +{ MakeLocal -> Platforms DOS/DPMI/WIN/OS2 - Checked 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.MakeLocal (Source: TPoint; Var Dest: TPoint); +var + cur : PView; +begin + cur:=@Self; + Dest:=Source; + repeat + dec(Dest.X,cur^.Origin.X); + if dest.x<0 then + break; + dec(Dest.Y,cur^.Origin.Y); + if dest.y<0 then + break; + cur:=cur^.Owner; + until cur=nil; +end; + + +{--TView--------------------------------------------------------------------} +{ MakeGlobal -> Platforms DOS/DPMI/WIN/OS2 - Checked 12Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TView.MakeGlobal (Source: TPoint; Var Dest: TPoint); +var + cur : PView; +begin + cur:=@Self; + Dest:=Source; + repeat + inc(Dest.X,cur^.Origin.X); + inc(Dest.Y,cur^.Origin.Y); + cur:=cur^.Owner; + until cur=nil; +end; + + +procedure TView.do_writeViewRec1(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); +var + G : PGroup; + c : Word; + BufPos, + SrcPos, + l,dx : Sw_integer; +begin + repeat + p:=p^.Next; + if (p=staticVar2.target) then + begin + G:=p^.Owner; + if (G^.buffer<>Nil) then + begin + BufPos:=G^.size.x * staticVar2.y + x1; + SrcPos:=x1 - staticVar2.offset; + l:=x2-x1; + if (shadowCounter=0) then + move(staticVar1^[SrcPos],PVideoBuf(G^.buffer)^[BufPos],l shl 1) + else + begin { paint with shadowAttr } + while (l>0) do + begin + c:=staticVar1^[SrcPos]; + WordRec(c).hi:=shadowAttr; + PVideoBuf(G^.buffer)^[BufPos]:=c; + inc(BufPos); + inc(SrcPos); + dec(l); + end; + end; + end; + if G^.lockFlag=0 then + do_writeViewRec2(x1,x2,G,shadowCounter); + exit; + end; { p=staticVar2.target } + + if ((p^.state and sfVisible)<>0) and (staticVar2.y>=p^.Origin.Y) then + begin + if staticVar2.y<p^.Origin.Y+p^.size.Y then + begin + if x1<p^.origin.x then + begin + if x2<=p^.origin.x then + continue; + do_writeViewRec1(x1,p^.origin.x,p,shadowCounter); + x1:=p^.origin.x; + end; + dx:=p^.origin.x+p^.size.x; + if (x2<=dx) then + exit; + if (x1<dx) then + x1:=dx; + inc(dx,shadowSize.x); + if ((p^.state and sfShadow)<>0) and (staticVar2.y>=p^.origin.y+shadowSize.y) then + if (x1>dx) then + continue + else + begin + inc(shadowCounter); + if (x2<=dx) then + continue + else + begin + do_writeViewRec1(x1,dx,p,shadowCounter); + x1:=dx; + dec(shadowCounter); + continue; + end; + end + else + continue; + end; + + if ((p^.state and sfShadow)<>0) and (staticVar2.y<p^.origin.y+p^.size.y+shadowSize.y) then + begin + dx:=p^.origin.x+shadowSize.x; + if x1<dx then + begin + if x2<=dx then + continue; + do_writeViewRec1(x1,dx,p,shadowCounter); + x1:=dx; + end; + inc(dx,p^.size.x); + if x1>=dx then + continue; + inc(shadowCounter); + if x2<=dx then + continue + else + begin + do_writeViewRec1(x1,dx,p,shadowCounter); + x1:=dx; + dec(shadowCounter); + end; + end; + end; + until false; +end; + + +procedure TView.do_writeViewRec2(x1,x2:Sw_integer; p:PView; shadowCounter:Sw_integer); +var + savedStatics : TstatVar2; + dx : Sw_integer; + G : PGroup; +begin + G:=P^.Owner; + if ((p^.State and sfVisible) <> 0) and (G<>Nil) then + begin + savedStatics:=staticVar2; + inc(staticVar2.y,p^.Origin.Y); + dx:=p^.Origin.X; + inc(x1,dx); + inc(x2,dx); + inc(staticVar2.offset,dx); + staticVar2.target:=p; + if (staticVar2.y >= G^.clip.a.y) and (staticVar2.y < G^.clip.b.y) then + begin + if (x1<g^.clip.a.x) then + x1 := g^.clip.a.x; + if (x2>g^.clip.b.x) then + x2 := g^.clip.b.x; + if x1<x2 then + do_writeViewRec1(x1,x2,G^.Last,shadowCounter); + end; + staticVar2 := savedStatics; + end; +end; + + +procedure TView.do_WriteView(x1,x2,y:Sw_integer; var Buf); +begin + if (y>=0) and (y<Size.Y) then + begin + if x1<0 then + x1:=0; + if x2>Size.X then + x2:=Size.X; + if x1<x2 then + begin + staticVar2.offset:=x1; + staticVar2.y:=y; + staticVar1:=@Buf; + do_writeViewRec2( x1, x2, @Self, 0 ); + end; + end; +end; + + +procedure TView.WriteBuf(X, Y, W, H: Sw_Integer; var Buf); +var + i : Sw_integer; +begin + if h>0 then + for i:= 0 to h-1 do + do_writeView(X,X+W,Y+i,TVideoBuf(Buf)[W*i]); +end; + + +procedure TView.WriteChar(X,Y:Sw_Integer; C:Char; Color:Byte; Count:Sw_Integer); +var + B : TDrawBuffer; + myChar : word; + i : Sw_integer; +begin + myChar:=MapColor(Color); + myChar:=(myChar shl 8) + ord(C); + if Count>0 then + begin + if Count>maxViewWidth then + Count:=maxViewWidth; + for i:=0 to Count-1 do + B[i]:=myChar; + do_writeView(X,X+Count,Y,B); + end; + DrawScreenBuf(false); +end; + + +procedure TView.WriteLine(X, Y, W, H: Sw_Integer; var Buf); +var + i:Sw_integer; +begin + if h>0 then + for i:=0 to h-1 do + do_writeView(x,x+w,y+i,buf); + DrawScreenBuf(false); +end; + + +procedure TView.WriteStr(X, Y: Sw_Integer; Str: String; Color: Byte); +var + l,i : Sw_word; + B : TDrawBuffer; + myColor : word; +begin + l:=length(Str); + if l>0 then + begin + if l>maxViewWidth then + l:=maxViewWidth; + MyColor:=MapColor(Color); + MyColor:=MyColor shl 8; + for i:=0 to l-1 do + B[i]:=MyColor+ord(Str[i+1]); + do_writeView(x,x+l,y,b); + end; + DrawScreenBuf(false); +end; + + +procedure TView.DragView(Event: TEvent; Mode: Byte; + var Limits: TRect; MinSize, MaxSize: TPoint); +var + P, S: TPoint; + SaveBounds: TRect; + + procedure MoveGrow(P, S: TPoint); + var + R: TRect; + begin + S.X := Min(Max(S.X, MinSize.X), MaxSize.X); + S.Y := Min(Max(S.Y, MinSize.Y), MaxSize.Y); + P.X := Min(Max(P.X, Limits.A.X - S.X + 1), Limits.B.X - 1); + P.Y := Min(Max(P.Y, Limits.A.Y - S.Y + 1), Limits.B.Y - 1); + if Mode and dmLimitLoX <> 0 then P.X := Max(P.X, Limits.A.X); + if Mode and dmLimitLoY <> 0 then P.Y := Max(P.Y, Limits.A.Y); + if Mode and dmLimitHiX <> 0 then P.X := Min(P.X, Limits.B.X - S.X); + if Mode and dmLimitHiY <> 0 then P.Y := Min(P.Y, Limits.B.Y - S.Y); + R.Assign(P.X, P.Y, P.X + S.X, P.Y + S.Y); + Locate(R); + end; + + procedure Change(DX, DY: Sw_Integer); + begin + if (Mode and dmDragMove <> 0) and (Event.KeyShift{GetShiftState} and $03 = 0) then + begin + Inc(P.X, DX); + Inc(P.Y, DY); + end else + if (Mode and dmDragGrow <> 0) and (Event.KeyShift{GetShiftState} and $03 <> 0) then + begin + Inc(S.X, DX); + Inc(S.Y, DY); + end; + end; + + procedure Update(X, Y: Sw_Integer); + begin + if Mode and dmDragMove <> 0 then + begin + P.X := X; + P.Y := Y; + end; + end; + +begin + SetState(sfDragging, True); + if Event.What = evMouseDown then + begin + if Mode and dmDragMove <> 0 then + begin + P.X := Origin.X - Event.Where.X; + P.Y := Origin.Y - Event.Where.Y; + repeat + Inc(Event.Where.X, P.X); + Inc(Event.Where.Y, P.Y); + MoveGrow(Event.Where, Size); + until not MouseEvent(Event, evMouseMove); + {We need to process the mouse-up event, since not all terminals + send drag events.} + Inc(Event.Where.X, P.X); + Inc(Event.Where.Y, P.Y); + MoveGrow(Event.Where, Size); + end else + begin + P.X := Size.X - Event.Where.X; + P.Y := Size.Y - Event.Where.Y; + repeat + Inc(Event.Where.X, P.X); + Inc(Event.Where.Y, P.Y); + MoveGrow(Origin, Event.Where); + until not MouseEvent(Event, evMouseMove); + {We need to process the mouse-up event, since not all terminals + send drag events.} + Inc(Event.Where.X, P.X); + Inc(Event.Where.Y, P.Y); + MoveGrow(Origin, Event.Where); + end; + end else + begin + GetBounds(SaveBounds); + repeat + P := Origin; + S := Size; + KeyEvent(Event); + case Event.KeyCode and $FF00 of + kbLeft: Change(-1, 0); + kbRight: Change(1, 0); + kbUp: Change(0, -1); + kbDown: Change(0, 1); + kbCtrlLeft: Change(-8, 0); + kbCtrlRight: Change(8, 0); + kbHome: Update(Limits.A.X, P.Y); + kbEnd: Update(Limits.B.X - S.X, P.Y); + kbPgUp: Update(P.X, Limits.A.Y); + kbPgDn: Update(P.X, Limits.B.Y - S.Y); + end; + MoveGrow(P, S); + until (Event.KeyCode = kbEnter) or (Event.KeyCode = kbEsc); + if Event.KeyCode = kbEsc then + Locate(SaveBounds); + end; + SetState(sfDragging, False); +end; + + +{***************************************************************************} +{ TScroller OBJECT METHODS } +{***************************************************************************} + +PROCEDURE TScroller.ScrollDraw; +VAR D: TPoint; +BEGIN + If (HScrollBar<>Nil) Then D.X := HScrollBar^.Value + Else D.X := 0; { Horz scroll value } + If (VScrollBar<>Nil) Then D.Y := VScrollBar^.Value + Else D.Y := 0; { Vert scroll value } + If (D.X<>Delta.X) OR (D.Y<>Delta.Y) Then Begin { View has moved } + SetCursor(Cursor.X+Delta.X-D.X, + Cursor.Y+Delta.Y-D.Y); { Move the cursor } + Delta := D; { Set new delta } + If (DrawLock<>0) Then DrawFlag := True { Draw will need draw } + Else DrawView; { Redraw the view } + End; +END; + +PROCEDURE TScroller.SetLimit (X, Y: Sw_Integer); +VAR PState: Word; +BEGIN + Limit.X := X; { Hold x limit } + Limit.Y := Y; { Hold y limit } + Inc(DrawLock); { Set draw lock } + If (HScrollBar<>Nil) Then Begin + PState := HScrollBar^.State; { Hold bar state } + HScrollBar^.State := PState AND NOT sfVisible; { Temp not visible } + HScrollBar^.SetParams(HScrollBar^.Value, 0, + X-Size.X, Size.X-1, HScrollBar^.ArStep); { Set horz scrollbar } + HScrollBar^.State := PState; { Restore bar state } + End; + If (VScrollBar<>Nil) Then Begin + PState := VScrollBar^.State; { Hold bar state } + VScrollBar^.State := PState AND NOT sfVisible; { Temp not visible } + VScrollBar^.SetParams(VScrollBar^.Value, 0, + Y-Size.Y, Size.Y-1, VScrollBar^.ArStep); { Set vert scrollbar } + VScrollBar^.State := PState; { Restore bar state } + End; + Dec(DrawLock); { Release draw lock } + CheckDraw; { Check need to draw } +END; + +{***************************************************************************} +{ TScroller OBJECT PRIVATE METHODS } +{***************************************************************************} +PROCEDURE TScroller.CheckDraw; +BEGIN + If (DrawLock = 0) AND DrawFlag Then Begin { Clear & draw needed } + DrawFlag := False; { Clear draw flag } + DrawView; { Draw now } + End; +END; + + + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ TGroup OBJECT METHODS } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + + + + +{--TGroup-------------------------------------------------------------------} +{ Lock -> Platforms DOS/DPMI/WIN/OS2 - Checked 23Sep97 LdB } +{---------------------------------------------------------------------------} +{$ifndef NoLock} +{$define UseLock} +{$endif ndef NoLock} +PROCEDURE TGroup.Lock; +BEGIN +{$ifdef UseLock} + {If (Buffer <> Nil) OR (LockFlag <> 0) + Then} Inc(LockFlag); { Increment count } +{$endif UseLock} +END; + +{--TGroup-------------------------------------------------------------------} +{ UnLock -> Platforms DOS/DPMI/WIN/OS2 - Checked 23Sep97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE TGroup.Unlock; +BEGIN +{$ifdef UseLock} + If (LockFlag <> 0) Then Begin + Dec(LockFlag); { Decrement count } + If (LockFlag = 0) Then DrawView; { Lock release draw } + End; +{$endif UseLock} +END; + + +{***************************************************************************} +{ INTERFACE ROUTINES } +{***************************************************************************} + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ WINDOW MESSAGE ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ Message -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION Message (Receiver: PView; What, Command: Word; + InfoPtr: Pointer): Pointer; +VAR Event: TEvent; +BEGIN + Message := Nil; { Preset nil } + If (Receiver <> Nil) Then Begin { Valid receiver } + Event.What := What; { Set what } + Event.Command := Command; { Set command } + Event.Id := 0; { Zero id field } + Event.Data := 0; { Zero data field } + Event.InfoPtr := InfoPtr; { Set info ptr } + Receiver^.HandleEvent(Event); { Pass to handler } + If (Event.What = evNothing) Then + Message := Event.InfoPtr; { Return handler } + End; +END; + +{---------------------------------------------------------------------------} +{ NewMessage -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19Sep97 LdB } +{---------------------------------------------------------------------------} +FUNCTION NewMessage (P: PView; What, Command: Word; Id: Sw_Integer; + Data: Real; InfoPtr: Pointer): Pointer; +VAR Event: TEvent; +BEGIN + NewMessage := Nil; { Preset failure } + If (P <> Nil) Then Begin + Event.What := What; { Set what } + Event.Command := Command; { Set event command } + Event.Id := Id; { Set up Id } + Event.Data := Data; { Set up data } + Event.InfoPtr := InfoPtr; { Set up event ptr } + P^.HandleEvent(Event); { Send to view } + If (Event.What = evNothing) Then + NewMessage := Event.InfoPtr; { Return handler } + End; +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ NEW VIEW ROUTINES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ CreateIdScrollBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Checked 22May97 LdB } +{---------------------------------------------------------------------------} +FUNCTION CreateIdScrollBar (X, Y, Size, Id: Sw_Integer; Horz: Boolean): PScrollBar; +VAR R: TRect; P: PScrollBar; +BEGIN + If Horz Then R.Assign(X, Y, X+Size, Y+1) Else { Horizontal bar } + R.Assign(X, Y, X+1, Y+Size); { Vertical bar } + P := New(PScrollBar, Init(R)); { Create scrollbar } + If (P <> Nil) Then Begin + P^.Id := Id; { Set scrollbar id } + P^.Options := P^.Options OR ofPostProcess; { Set post processing } + End; + CreateIdScrollBar := P; { Return scrollbar } +END; + +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} +{ OBJECT REGISTRATION PROCEDURES } +{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} + +{---------------------------------------------------------------------------} +{ RegisterViews -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 28May97 LdB } +{---------------------------------------------------------------------------} +PROCEDURE RegisterViews; +BEGIN + RegisterType(RView); { Register views } + RegisterType(RFrame); { Register frame } + RegisterType(RScrollBar); { Register scrollbar } + RegisterType(RScroller); { Register scroller } + RegisterType(RListViewer); { Register listview } + RegisterType(RGroup); { Register group } + RegisterType(RWindow); { Register window } +END; + +END. diff --git a/packages/fv/src/w32smsg.inc b/packages/fv/src/w32smsg.inc new file mode 100644 index 0000000000..b557d60dd8 --- /dev/null +++ b/packages/fv/src/w32smsg.inc @@ -0,0 +1,190 @@ +{ + System independent system interface for win32 + + Copyright (c) 2000 by Pierre Muller + + 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,winevent; + +var + ChangeSystemEvents : TCriticalSection; +Const + SystemEventActive : Boolean = false; + +procedure SystemEventHandler(var ir:INPUT_RECORD); + + var + e : TSystemEvent; + + begin + { WINDOW_BUFFER_SIZE_EVENT is triggered by buffer size changes + but we are interested in console size changes, thus its handled below + in PollSystemEvent } + if (ir.EventType in [FOCUS_EVENT{,WINDOW_BUFFER_SIZE_EVENT}]) then + begin + EnterCriticalSection(ChangeSystemEvents); + if (ir.EventType=FOCUS_EVENT) then + begin + if ir.Event.FocusEvent.bSetFocus then + e.typ:=SysSetFocus + else + e.typ:=SysReleaseFocus; + end + else + begin + e.typ:=SysResize; + e.x:=ir.Event.WindowBufferSizeEvent.dwSize.x; + e.y:=ir.Event.WindowBufferSizeEvent.dwSize.y; + end; + PutSystemEvent(e); + LeaveCriticalSection(ChangeSystemEvents); + end; + end; + + +var + Xsize, YSize : longint; + +function HandleConsoleCtrl(typ : dword) : BOOL; stdcall; +var + SE : TSystemEvent; +begin + HandleConsoleCtrl:=false; + case typ of + CTRL_CLOSE_EVENT, + CTRL_LOGOFF_EVENT, + CTRL_SHUTDOWN_EVENT : + begin + SE.typ:=SysClose; + SE.CloseTyp:=typ; + PutSystemEvent(SE); + HandleConsoleCtrl:=true; + end; + end; +end; + + +procedure InitSystemMsg; + +var + mode : dword; + ConsoleScreenBufferInfo : Console_screen_buffer_info; + +begin + if SystemEventActive then + exit; + // enable Window events + GetConsoleMode(TextRec(Input).Handle,@mode); + mode:=mode or ENABLE_WINDOW_INPUT; + SetConsoleMode(TextRec(Input).Handle,mode); + GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), + @ConsoleScreenBufferInfo); + XSize:=ConsoleScreenBufferInfo.srWindow.right-ConsoleScreenBufferInfo.srWindow.left+1; + YSize:=ConsoleScreenBufferInfo.srWindow.bottom-ConsoleScreenBufferInfo.srWindow.top+1; + PendingSystemHead:=@PendingSystemEvent; + PendingSystemTail:=@PendingSystemEvent; + PendingSystemEvents:=0; + FillChar(LastSystemEvent,sizeof(TSystemEvent),0); + InitializeCriticalSection(ChangeSystemEvents); + SetResizeEventHandler(@SystemEventHandler); + SetFocusEventHandler(@SystemEventHandler); + SetConsoleCtrlHandler(@HandleConsoleCtrl,true); + SystemEventActive:=true; +end; + + +procedure DoneSystemMsg; +var + mode : dword; +begin + if not SystemEventActive then + exit; + // disable System events + GetConsoleMode(TextRec(Input).Handle,@mode); + mode:=mode and (not ENABLE_WINDOW_INPUT); + SetConsoleMode(TextRec(Input).Handle,mode); + + SetResizeEventHandler(nil); + SetFocusEventHandler(nil); + DeleteCriticalSection(ChangeSystemEvents); + SetConsoleCtrlHandler(@HandleConsoleCtrl,false); + SystemEventActive:=false; +end; + + + +procedure GetSystemEvent(var SystemEvent: TSystemEvent); + +var + b : byte; + +begin + repeat + EnterCriticalSection(ChangeSystemEvents); + b:=PendingSystemEvents; + LeaveCriticalSection(ChangeSystemEvents); + if b>0 then + break + else + sleep(50); + until false; + EnterCriticalSection(ChangeSystemEvents); + SystemEvent:=PendingSystemHead^; + inc(PendingSystemHead); + if longint(PendingSystemHead)=longint(@PendingSystemEvent)+sizeof(PendingSystemEvent) then + PendingSystemHead:=@PendingSystemEvent; + dec(PendingSystemEvents); + LastSystemEvent:=SystemEvent; + LeaveCriticalSection(ChangeSystemEvents); +end; + + +function PollSystemEvent(var SystemEvent: TSystemEvent):boolean; +var + ConsoleScreenBufferInfo : Console_screen_buffer_info; + NewXSize, NewYSize : longint; +begin + EnterCriticalSection(ChangeSystemEvents); + if PendingSystemEvents>0 then + begin + SystemEvent:=PendingSystemHead^; + PollSystemEvent:=true; + end + else + begin + GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), + @ConsoleScreenBufferInfo); + NewXSize:=ConsoleScreenBufferInfo.srWindow.right-ConsoleScreenBufferInfo.srWindow.left+1; + NewYSize:=ConsoleScreenBufferInfo.srWindow.bottom-ConsoleScreenBufferInfo.srWindow.top+1; + if (XSize<>NewXSize) or (YSize<>NewYSize) then + begin + SystemEvent.typ:=SysResize; + SystemEvent.x:=NewXSize; + SystemEvent.y:=NewYSize; + PutSystemEvent(SystemEvent); + XSize:=NewXSize; + YSize:=NewYSize; + PollSystemEvent:=true; + end + else + PollSystemEvent:=false; + end; + LeaveCriticalSection(ChangeSystemEvents); +end; + |