diff --git a/.gitattributes b/.gitattributes index 70f6600080..b5aa16b404 100644 --- a/.gitattributes +++ b/.gitattributes @@ -8866,11 +8866,6 @@ utils/fpmc/test.mc -text utils/fppkg/Makefile svneol=native#text/plain utils/fppkg/Makefile.fpc svneol=native#text/plain utils/fppkg/README svneol=native#text/plain -utils/fppkg/fcl20/contnrs.pp svneol=native#text/plain -utils/fppkg/fcl20/streamcoll.pp svneol=native#text/plain -utils/fppkg/fcl20/uriparser.pp svneol=native#text/plain -utils/fppkg/fcl20/zipper.pp svneol=native#text/plain -utils/fppkg/fcl20/zstream.pp svneol=native#text/plain utils/fppkg/fpmkunitsrc.inc svneol=native#text/plain utils/fppkg/fppkg.lpi svneol=native#text/plain utils/fppkg/fppkg.pp svneol=native#text/plain diff --git a/utils/fppkg/Makefile b/utils/fppkg/Makefile index 7651f1986b..ce99ef2677 100644 --- a/utils/fppkg/Makefile +++ b/utils/fppkg/Makefile @@ -1,5 +1,5 @@ # -# Don't edit, this file is generated by FPCMake Version 2.0.0 [2007/11/08] +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2007/11/13] # 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 @@ -242,12 +242,6 @@ endif PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages $(FPCDIR)/packages/base $(FPCDIR)/packages/extra) override PACKAGE_NAME=fppkg override PACKAGE_VERSION=2.0.0 -ifneq ($(findstring 2.0.,$(FPC_VERSION)),) -FCL20=fcl20 -FCL20UNITS=zstream contnrs streamcoll zipper -else -PKGCURL=pkglibcurl -endif ifeq ($(FULL_TARGET),i386-linux) override TARGET_PROGRAMS+=fppkg endif @@ -408,85 +402,85 @@ ifeq ($(FULL_TARGET),powerpc64-embedded) override TARGET_PROGRAMS+=fppkg endif ifeq ($(FULL_TARGET),i386-linux) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),i386-win32) override TARGET_UNITS+=pkgwget pkglnet endif ifeq ($(FULL_TARGET),i386-freebsd) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),i386-beos) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),i386-netbsd) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),i386-solaris) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),i386-openbsd) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),i386-darwin) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),i386-wince) override TARGET_UNITS+=pkgwget pkglnet endif ifeq ($(FULL_TARGET),m68k-linux) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),m68k-freebsd) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),m68k-netbsd) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),m68k-openbsd) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),powerpc-linux) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),powerpc-netbsd) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),powerpc-darwin) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),sparc-linux) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),sparc-netbsd) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),sparc-solaris) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),x86_64-linux) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),x86_64-freebsd) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),x86_64-darwin) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),x86_64-win64) override TARGET_UNITS+=pkgwget pkglnet endif ifeq ($(FULL_TARGET),arm-linux) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),arm-wince) override TARGET_UNITS+=pkgwget pkglnet endif ifeq ($(FULL_TARGET),powerpc64-linux) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),powerpc64-darwin) -override TARGET_UNITS+=pkgwget pkglnet $(PKGCURL) +override TARGET_UNITS+=pkgwget pkglnet pkgcurl endif ifeq ($(FULL_TARGET),i386-linux) override TARGET_IMPLICITUNITS+=fprepos fpxmlrep pkgoptions pkgglobals pkgmessages pkghandler pkgmkconv pkgdownload pkgfpmake pkgcommands @@ -966,163 +960,163 @@ ifeq ($(FULL_TARGET),powerpc64-embedded) override TARGET_EXAMPLES+=rep2xml endif ifeq ($(FULL_TARGET),i386-linux) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-go32v2) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-win32) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-os2) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-freebsd) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-beos) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-netbsd) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-solaris) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-qnx) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-netware) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-openbsd) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-wdosx) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-darwin) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-emx) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-watcom) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-netwlibc) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-wince) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-embedded) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),i386-symbian) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),m68k-linux) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),m68k-freebsd) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),m68k-netbsd) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),m68k-amiga) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),m68k-atari) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),m68k-openbsd) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),m68k-palmos) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),m68k-embedded) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),powerpc-linux) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),powerpc-netbsd) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),powerpc-amiga) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),powerpc-macos) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),powerpc-darwin) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),powerpc-morphos) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),powerpc-embedded) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),sparc-linux) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),sparc-netbsd) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),sparc-solaris) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),sparc-embedded) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),x86_64-linux) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),x86_64-freebsd) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),x86_64-darwin) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),x86_64-win64) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),x86_64-embedded) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),arm-linux) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),arm-palmos) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),arm-wince) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),arm-gba) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),arm-nds) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),arm-embedded) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),arm-symbian) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),powerpc64-linux) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),powerpc64-darwin) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif ifeq ($(FULL_TARGET),powerpc64-embedded) -override CLEAN_UNITS+=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +override CLEAN_UNITS+=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer endif override INSTALL_FPCPACKAGE=y ifeq ($(FULL_TARGET),i386-linux) @@ -1285,163 +1279,163 @@ ifeq ($(FULL_TARGET),powerpc64-embedded) override COMPILER_INCLUDEDIR+=lnet/sys endif ifeq ($(FULL_TARGET),i386-linux) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-go32v2) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-win32) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-os2) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-freebsd) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-beos) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-netbsd) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-solaris) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-qnx) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-netware) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-openbsd) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-wdosx) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-darwin) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-emx) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-watcom) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-netwlibc) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-wince) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-embedded) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),i386-symbian) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),m68k-linux) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),m68k-freebsd) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),m68k-netbsd) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),m68k-amiga) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),m68k-atari) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),m68k-openbsd) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),m68k-palmos) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),m68k-embedded) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),powerpc-linux) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),powerpc-netbsd) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),powerpc-amiga) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),powerpc-macos) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),powerpc-darwin) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),powerpc-morphos) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),powerpc-embedded) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),sparc-linux) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),sparc-netbsd) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),sparc-solaris) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),sparc-embedded) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),x86_64-linux) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),x86_64-freebsd) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),x86_64-darwin) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),x86_64-win64) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),x86_64-embedded) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),arm-linux) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),arm-palmos) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),arm-wince) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),arm-gba) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),arm-nds) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),arm-embedded) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),arm-symbian) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),powerpc64-linux) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),powerpc64-darwin) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifeq ($(FULL_TARGET),powerpc64-embedded) -override COMPILER_UNITDIR+=$(FCL20) lnet +override COMPILER_UNITDIR+=lnet endif ifdef REQUIRE_UNITSDIR override UNITSDIR+=$(REQUIRE_UNITSDIR) diff --git a/utils/fppkg/Makefile.fpc b/utils/fppkg/Makefile.fpc index d1c042e975..269908588c 100644 --- a/utils/fppkg/Makefile.fpc +++ b/utils/fppkg/Makefile.fpc @@ -9,13 +9,13 @@ version=2.0.0 [target] programs=fppkg implicitunits=fprepos fpxmlrep pkgoptions pkgglobals pkgmessages pkghandler pkgmkconv pkgdownload pkgfpmake pkgcommands -units_linux=pkgwget pkglnet $(PKGCURL) -units_beos=pkgwget pkglnet $(PKGCURL) -units_freebsd=pkgwget pkglnet $(PKGCURL) -units_netbsd=pkgwget pkglnet $(PKGCURL) -units_openbsd=pkgwget pkglnet $(PKGCURL) -units_darwin=pkgwget pkglnet $(PKGCURL) -units_solaris=pkgwget pkglnet $(PKGCURL) +units_linux=pkgwget pkglnet pkgcurl +units_beos=pkgwget pkglnet pkgcurl +units_freebsd=pkgwget pkglnet pkgcurl +units_netbsd=pkgwget pkglnet pkgcurl +units_openbsd=pkgwget pkglnet pkgcurl +units_darwin=pkgwget pkglnet pkgcurl +units_solaris=pkgwget pkglnet pkgcurl units_win32=pkgwget pkglnet units_win64=pkgwget pkglnet units_wince=pkgwget pkglnet @@ -23,11 +23,11 @@ examples=rep2xml rsts=fprepos fpxmlrep pkgmessages [compiler] -unitdir=$(FCL20) lnet +unitdir=lnet includedir=lnet/sys [clean] -units=$(FCL20UNITS) lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer +units=lCommon lControlStack lEvents lTelnet lftp lhttp lhttputil lnet lstrbuffer [install] fpcpackage=y @@ -39,15 +39,6 @@ fpcdir=../.. packages=fcl-base fcl-xml fcl-process paszlib libcurl tools=data2inc -[prerules] -# Compatibility to compile with 2.0.x -ifneq ($(findstring 2.0.,$(FPC_VERSION)),) -FCL20=fcl20 -FCL20UNITS=zstream contnrs streamcoll zipper -else -PKGCURL=pkglibcurl -endif - [rules] .NOTPARALLEL: ifneq ($(DATA2INC),) diff --git a/utils/fppkg/fcl20/contnrs.pp b/utils/fppkg/fcl20/contnrs.pp deleted file mode 100644 index 09d0b8591b..0000000000 --- a/utils/fppkg/fcl20/contnrs.pp +++ /dev/null @@ -1,2344 +0,0 @@ -{ - This file is part of the Free Component Library (FCL) - Copyright (c) 2002 by Florian Klaempfl - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} -{$ifdef fpc} -{$mode objfpc} -{$endif} -{$H+} -{$ifdef CLASSESINLINE}{$inline on}{$endif} - -unit contnrs; - -interface - -uses - SysUtils,Classes; - - -Type - TObjectListCallback = procedure(data:TObject;arg:pointer) of object; - TObjectListStaticCallback = procedure(data:TObject;arg:pointer); - - TFPObjectList = class(TObject) - private - FFreeObjects : Boolean; - FList: TFPList; - function GetCount: integer; - procedure SetCount(const AValue: integer); - protected - function GetItem(Index: Integer): TObject; {$ifdef CLASSESINLINE}inline;{$endif} - procedure SetItem(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif} - procedure SetCapacity(NewCapacity: Integer); - function GetCapacity: integer; - public - constructor Create; - constructor Create(FreeObjects : Boolean); - destructor Destroy; override; - procedure Clear; - function Add(AObject: TObject): Integer; {$ifdef CLASSESINLINE}inline;{$endif} - procedure Delete(Index: Integer); {$ifdef CLASSESINLINE}inline;{$endif} - procedure Exchange(Index1, Index2: Integer); - function Expand: TFPObjectList; - function Extract(Item: TObject): TObject; - function Remove(AObject: TObject): Integer; - function IndexOf(AObject: TObject): Integer; - function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer; - procedure Insert(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif} - function First: TObject; - function Last: TObject; - procedure Move(CurIndex, NewIndex: Integer); - procedure Assign(Obj:TFPObjectList); - procedure Pack; - procedure Sort(Compare: TListSortCompare); - procedure ForEachCall(proc2call:TObjectListCallback;arg:pointer); - procedure ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer); - property Capacity: Integer read GetCapacity write SetCapacity; - property Count: Integer read GetCount write SetCount; - property OwnsObjects: Boolean read FFreeObjects write FFreeObjects; - property Items[Index: Integer]: TObject read GetItem write SetItem; default; - property List: TFPList read FList; - end; - - - TObjectList = class(TList) - private - ffreeobjects : boolean; - Protected - Procedure Notify(Ptr: Pointer; Action: TListNotification); override; - function GetItem(Index: Integer): TObject; - Procedure SetItem(Index: Integer; AObject: TObject); - public - constructor create; - constructor create(freeobjects : boolean); - function Add(AObject: TObject): Integer; - function Extract(Item: TObject): TObject; - function Remove(AObject: TObject): Integer; - function IndexOf(AObject: TObject): Integer; - function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer; - Procedure Insert(Index: Integer; AObject: TObject); - function First: TObject; - Function Last: TObject; - property OwnsObjects: Boolean read FFreeObjects write FFreeObjects; - property Items[Index: Integer]: TObject read GetItem write SetItem; default; - end; - - TComponentList = class(TObjectList) - Private - FNotifier : TComponent; - Protected - Procedure Notify(Ptr: Pointer; Action: TListNotification); override; - Function GetItems(Index: Integer): TComponent; - Procedure SetItems(Index: Integer; AComponent: TComponent); - Procedure HandleFreeNotify(Sender: TObject; AComponent: TComponent); - public - destructor Destroy; override; - Function Add(AComponent: TComponent): Integer; - Function Extract(Item: TComponent): TComponent; - Function Remove(AComponent: TComponent): Integer; - Function IndexOf(AComponent: TComponent): Integer; - Function First: TComponent; - Function Last: TComponent; - Procedure Insert(Index: Integer; AComponent: TComponent); - property Items[Index: Integer]: TComponent read GetItems write SetItems; default; - end; - - TClassList = class(TList) - protected - Function GetItems(Index: Integer): TClass; - Procedure SetItems(Index: Integer; AClass: TClass); - public - Function Add(AClass: TClass): Integer; - Function Extract(Item: TClass): TClass; - Function Remove(AClass: TClass): Integer; - Function IndexOf(AClass: TClass): Integer; - Function First: TClass; - Function Last: TClass; - Procedure Insert(Index: Integer; AClass: TClass); - property Items[Index: Integer]: TClass read GetItems write SetItems; default; - end; - - TOrderedList = class(TObject) - private - FList: TList; - protected - Procedure PushItem(AItem: Pointer); virtual; abstract; - Function PopItem: Pointer; virtual; - Function PeekItem: Pointer; virtual; - property List: TList read FList; - public - constructor Create; - destructor Destroy; override; - Function Count: Integer; - Function AtLeast(ACount: Integer): Boolean; - Function Push(AItem: Pointer): Pointer; - Function Pop: Pointer; - Function Peek: Pointer; - end; - -{ TStack class } - - TStack = class(TOrderedList) - protected - Procedure PushItem(AItem: Pointer); override; - end; - -{ TObjectStack class } - - TObjectStack = class(TStack) - public - Function Push(AObject: TObject): TObject; - Function Pop: TObject; - Function Peek: TObject; - end; - -{ TQueue class } - - TQueue = class(TOrderedList) - protected - Procedure PushItem(AItem: Pointer); override; - end; - -{ TObjectQueue class } - - TObjectQueue = class(TQueue) - public - Function Push(AObject: TObject): TObject; - Function Pop: TObject; - Function Peek: TObject; - end; - -{ --------------------------------------------------------------------- - TFPList with Hash support - ---------------------------------------------------------------------} - -type - THashItem=record - HashValue : LongWord; - StrIndex : Integer; - NextIndex : Integer; - Data : Pointer; - end; - PHashItem=^THashItem; - -const - MaxHashListSize = Maxint div 16; - MaxHashStrSize = Maxint; - MaxHashTableSize = Maxint div 4; - MaxItemsPerHash = 3; - -type - PHashItemList = ^THashItemList; - THashItemList = array[0..MaxHashListSize - 1] of THashItem; - PHashTable = ^THashTable; - THashTable = array[0..MaxHashTableSize - 1] of Integer; - - TFPHashList = class(TObject) - private - { ItemList } - FHashList : PHashItemList; - FCount, - FCapacity : Integer; - { Hash } - FHashTable : PHashTable; - FHashCapacity : Integer; - { Strings } - FStrs : PChar; - FStrCount, - FStrCapacity : Integer; - function InternalFind(AHash:LongWord;const AName:shortstring;out PrevIndex:Integer):Integer; - protected - function Get(Index: Integer): Pointer; {$ifdef CCLASSESINLINE}inline;{$endif} - procedure Put(Index: Integer; Item: Pointer); {$ifdef CCLASSESINLINE}inline;{$endif} - procedure SetCapacity(NewCapacity: Integer); - procedure SetCount(NewCount: Integer); - Procedure RaiseIndexError(Index : Integer); - function AddStr(const s:shortstring): Integer; - procedure AddToHashTable(Index: Integer); - procedure StrExpand(MinIncSize:Integer); - procedure SetStrCapacity(NewCapacity: Integer); - procedure SetHashCapacity(NewCapacity: Integer); - procedure ReHash; - public - constructor Create; - destructor Destroy; override; - function Add(const AName:shortstring;Item: Pointer): Integer; - procedure Clear; - function NameOfIndex(Index: Integer): ShortString; {$ifdef CCLASSESINLINE}inline;{$endif} - function HashOfIndex(Index: Integer): LongWord; {$ifdef CCLASSESINLINE}inline;{$endif} - procedure Delete(Index: Integer); - class procedure Error(const Msg: string; Data: PtrInt); - function Expand: TFPHashList; - function Extract(item: Pointer): Pointer; - function IndexOf(Item: Pointer): Integer; - function Find(const AName:shortstring): Pointer; - function FindIndexOf(const AName:shortstring): Integer; - function FindWithHash(const AName:shortstring;AHash:LongWord): Pointer; - function Rename(const AOldName,ANewName:shortstring): Integer; - function Remove(Item: Pointer): Integer; - procedure Pack; - procedure ShowStatistics; - procedure ForEachCall(proc2call:TListCallback;arg:pointer); - procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer); - property Capacity: Integer read FCapacity write SetCapacity; - property Count: Integer read FCount write SetCount; - property Items[Index: Integer]: Pointer read Get write Put; default; - property List: PHashItemList read FHashList; - property Strs: PChar read FStrs; - end; - - -{******************************************************* - TFPHashObjectList (From fcl/inc/contnrs.pp) -********************************************************} - - TFPHashObjectList = class; - - { TFPHashObject } - - TFPHashObject = class - private - FOwner : TFPHashObjectList; - FCachedStr : pshortstring; - FStrIndex : Integer; - procedure InternalChangeOwner(HashObjectList:TFPHashObjectList;const s:shortstring); - protected - function GetName:shortstring;virtual; - function GetHash:Longword;virtual; - public - constructor CreateNotOwned; - constructor Create(HashObjectList:TFPHashObjectList;const s:shortstring); - procedure ChangeOwner(HashObjectList:TFPHashObjectList); {$ifdef CCLASSESINLINE}inline;{$endif} - procedure ChangeOwnerAndName(HashObjectList:TFPHashObjectList;const s:shortstring); {$ifdef CCLASSESINLINE}inline;{$endif} - procedure Rename(const ANewName:shortstring); - property Name:shortstring read GetName; - property Hash:Longword read GetHash; - end; - - TFPHashObjectList = class(TObject) - private - FFreeObjects : Boolean; - FHashList: TFPHashList; - function GetCount: integer; {$ifdef CCLASSESINLINE}inline;{$endif} - procedure SetCount(const AValue: integer); {$ifdef CCLASSESINLINE}inline;{$endif} - protected - function GetItem(Index: Integer): TObject; {$ifdef CCLASSESINLINE}inline;{$endif} - procedure SetItem(Index: Integer; AObject: TObject); {$ifdef CCLASSESINLINE}inline;{$endif} - procedure SetCapacity(NewCapacity: Integer); {$ifdef CCLASSESINLINE}inline;{$endif} - function GetCapacity: integer; {$ifdef CCLASSESINLINE}inline;{$endif} - public - constructor Create(FreeObjects : boolean = True); - destructor Destroy; override; - procedure Clear; - function Add(const AName:shortstring;AObject: TObject): Integer; {$ifdef CCLASSESINLINE}inline;{$endif} - function NameOfIndex(Index: Integer): ShortString; {$ifdef CCLASSESINLINE}inline;{$endif} - function HashOfIndex(Index: Integer): LongWord; {$ifdef CCLASSESINLINE}inline;{$endif} - procedure Delete(Index: Integer); - function Expand: TFPHashObjectList; {$ifdef CCLASSESINLINE}inline;{$endif} - function Extract(Item: TObject): TObject; {$ifdef CCLASSESINLINE}inline;{$endif} - function Remove(AObject: TObject): Integer; - function IndexOf(AObject: TObject): Integer; {$ifdef CCLASSESINLINE}inline;{$endif} - function Find(const s:shortstring): TObject; {$ifdef CCLASSESINLINE}inline;{$endif} - function FindIndexOf(const s:shortstring): Integer; {$ifdef CCLASSESINLINE}inline;{$endif} - function FindWithHash(const AName:shortstring;AHash:LongWord): Pointer; - function Rename(const AOldName,ANewName:shortstring): Integer; {$ifdef CCLASSESINLINE}inline;{$endif} - function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer; - procedure Pack; {$ifdef CCLASSESINLINE}inline;{$endif} - procedure ShowStatistics; {$ifdef CCLASSESINLINE}inline;{$endif} - procedure ForEachCall(proc2call:TObjectListCallback;arg:pointer); {$ifdef CCLASSESINLINE}inline;{$endif} - procedure ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer); {$ifdef CCLASSESINLINE}inline;{$endif} - property Capacity: Integer read GetCapacity write SetCapacity; - property Count: Integer read GetCount write SetCount; - property OwnsObjects: Boolean read FFreeObjects write FFreeObjects; - property Items[Index: Integer]: TObject read GetItem write SetItem; default; - property List: TFPHashList read FHashList; - end; - -{ --------------------------------------------------------------------- - Hash support, implemented by Dean Zobec - ---------------------------------------------------------------------} - - - { Must return a Longword value in the range 0..TableSize, - usually via a mod operator; } - THashFunction = function(const S: string; const TableSize: Longword): Longword; - - - { THTNode } - - THTCustomNode = class(TObject) - private - FKey: string; - public - constructor CreateWith(const AString: String); - function HasKey(const AKey: string): boolean; - property Key: string read FKey; - end; - THTCustomNodeClass = Class of THTCustomNode; - - - { TFPCustomHashTable } - - TFPCustomHashTable = class(TObject) - private - FHashTable: TFPObjectList; - FHashTableSize: Longword; - FHashFunction: THashFunction; - FCount: Longword; - function GetDensity: Longword; - function GetNumberOfCollisions: Longword; - procedure SetHashTableSize(const Value: Longword); - procedure InitializeHashTable; - function GetVoidSlots: Longword; - function GetLoadFactor: double; - function GetAVGChainLen: double; - function GetMaxChainLength: Longword; - function Chain(const index: Longword):TFPObjectList; - protected - Function CreateNewNode(const aKey : string) : THTCustomNode; virtual; abstract; - Procedure AddNode(ANode : THTCustomNode); virtual; abstract; - function ChainLength(const ChainIndex: Longword): Longword; virtual; - function FindOrCreateNew(const aKey: string): THTCustomNode; virtual; - procedure SetHashFunction(AHashFunction: THashFunction); virtual; - Function FindChainForAdd(Const aKey : String) : TFPObjectList; - public - constructor Create; - constructor CreateWith(AHashTableSize: Longword; aHashFunc: THashFunction); - destructor Destroy; override; - procedure ChangeTableSize(const ANewSize: Longword); virtual; - procedure Clear; virtual; - procedure Delete(const aKey: string); virtual; - function Find(const aKey: string): THTCustomNode; - function IsEmpty: boolean; - property HashFunction: THashFunction read FHashFunction write SetHashFunction; - property Count: Longword read FCount; - property HashTableSize: Longword read FHashTableSize write SetHashTableSize; - property HashTable: TFPObjectList read FHashTable; - property VoidSlots: Longword read GetVoidSlots; - property LoadFactor: double read GetLoadFactor; - property AVGChainLen: double read GetAVGChainLen; - property MaxChainLength: Longword read GetMaxChainLength; - property NumberOfCollisions: Longword read GetNumberOfCollisions; - property Density: Longword read GetDensity; - end; - - { TFPDataHashTable : Hash table with simple data pointers } - - THTDataNode = Class(THTCustomNode) - Private - FData: pointer; - public - property Data: pointer read FData write FData; - end; - // For compatibility - THTNode = THTDataNode; - - TDataIteratorMethod = procedure(Item: Pointer; const Key: string; var Continue: Boolean) of object; - // For compatibility - TIteratorMethod = TDataIteratorMethod; - - TFPDataHashTable = Class(TFPCustomHashTable) - Protected - Function CreateNewNode(const aKey : String) : THTCustomNode; override; - Procedure AddNode(ANode : THTCustomNode); override; - procedure SetData(const index: string; const AValue: Pointer); virtual; - function GetData(const index: string):Pointer; virtual; - function ForEachCall(aMethod: TDataIteratorMethod): THTDataNode; virtual; - Public - procedure Add(const aKey: string; AItem: pointer); virtual; - property Items[const index: string]: Pointer read GetData write SetData; default; - end; - - { TFPStringHashTable : Hash table with simple strings as data } - THTStringNode = Class(THTCustomNode) - Private - FData : String; - public - property Data: String read FData write FData; - end; - TStringIteratorMethod = procedure(Item: String; const Key: string; var Continue: Boolean) of object; - - TFPStringHashTable = Class(TFPCustomHashTable) - Protected - Function CreateNewNode(const aKey : String) : THTCustomNode; override; - Procedure AddNode(ANode : THTCustomNode); override; - procedure SetData(const Index, AValue: string); virtual; - function GetData(const index: string): String; virtual; - function ForEachCall(aMethod: TStringIteratorMethod): THTStringNode; virtual; - Public - procedure Add(const aKey,aItem: string); virtual; - property Items[const index: string]: String read GetData write SetData; default; - end; - - { TFPStringHashTable : Hash table with simple strings as data } - - - THTObjectNode = Class(THTCustomNode) - Private - FData : TObject; - public - property Data: TObject read FData write FData; - end; - - THTOwnedObjectNode = Class(THTObjectNode) - public - Destructor Destroy; override; - end; - TObjectIteratorMethod = procedure(Item: TObject; const Key: string; var Continue: Boolean) of object; - - TFPObjectHashTable = Class(TFPCustomHashTable) - Private - FOwnsObjects : Boolean; - Protected - Function CreateNewNode(const aKey : String) : THTCustomNode; override; - Procedure AddNode(ANode : THTCustomNode); override; - procedure SetData(const Index: string; AObject : TObject); virtual; - function GetData(const index: string): TObject; virtual; - function ForEachCall(aMethod: TObjectIteratorMethod): THTObjectNode; virtual; - Public - constructor Create(AOwnsObjects : Boolean = True); - constructor CreateWith(AHashTableSize: Longword; aHashFunc: THashFunction; AOwnsObjects : Boolean = True); - procedure Add(const aKey: string; AItem : TObject); virtual; - property Items[const index: string]: TObject read GetData write SetData; default; - Property OwnsObjects : Boolean Read FOwnsObjects Write FOwnsObjects; - end; - - - EDuplicate = class(Exception); - EKeyNotFound = class(Exception); - - - function RSHash(const S: string; const TableSize: Longword): Longword; - -implementation - -uses - RtlConsts; - -ResourceString - DuplicateMsg = 'An item with key %0:s already exists'; - KeyNotFoundMsg = 'Method: %0:s key [''%1:s''] not found in container'; - NotEmptyMsg = 'Hash table not empty.'; - -const - NPRIMES = 28; - - PRIMELIST: array[0 .. NPRIMES-1] of Longword = - ( 53, 97, 193, 389, 769, - 1543, 3079, 6151, 12289, 24593, - 49157, 98317, 196613, 393241, 786433, - 1572869, 3145739, 6291469, 12582917, 25165843, - 50331653, 100663319, 201326611, 402653189, 805306457, - 1610612741, 3221225473, 4294967291 ); - -constructor TFPObjectList.Create(FreeObjects : boolean); -begin - Create; - FFreeObjects := Freeobjects; -end; - -destructor TFPObjectList.Destroy; -begin - if (FList <> nil) then - begin - Clear; - FList.Destroy; - end; - inherited Destroy; -end; - -procedure TFPObjectList.Clear; -var - i: integer; -begin - if FFreeObjects then - for i := 0 to FList.Count - 1 do - TObject(FList[i]).Free; - FList.Clear; -end; - -constructor TFPObjectList.Create; -begin - inherited Create; - FList := TFPList.Create; - FFreeObjects := True; -end; - -function TFPObjectList.GetCount: integer; -begin - Result := FList.Count; -end; - -procedure TFPObjectList.SetCount(const AValue: integer); -begin - if FList.Count <> AValue then - FList.Count := AValue; -end; - -function TFPObjectList.GetItem(Index: Integer): TObject; {$ifdef CLASSESINLINE}inline;{$endif} -begin - Result := TObject(FList[Index]); -end; - -procedure TFPObjectList.SetItem(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif} -begin - if OwnsObjects then - TObject(FList[Index]).Free; - FList[index] := AObject; -end; - -procedure TFPObjectList.SetCapacity(NewCapacity: Integer); -begin - FList.Capacity := NewCapacity; -end; - -function TFPObjectList.GetCapacity: integer; -begin - Result := FList.Capacity; -end; - -function TFPObjectList.Add(AObject: TObject): Integer; {$ifdef CLASSESINLINE}inline;{$endif} -begin - Result := FList.Add(AObject); -end; - -procedure TFPObjectList.Delete(Index: Integer); {$ifdef CLASSESINLINE}inline;{$endif} -begin - if OwnsObjects then - TObject(FList[Index]).Free; - FList.Delete(Index); -end; - -procedure TFPObjectList.Exchange(Index1, Index2: Integer); -begin - FList.Exchange(Index1, Index2); -end; - -function TFPObjectList.Expand: TFPObjectList; -begin - FList.Expand; - Result := Self; -end; - -function TFPObjectList.Extract(Item: TObject): TObject; -begin - Result := TObject(FList.Extract(Item)); -end; - -function TFPObjectList.Remove(AObject: TObject): Integer; -begin - Result := IndexOf(AObject); - if (Result <> -1) then - begin - if OwnsObjects then - TObject(FList[Result]).Free; - FList.Delete(Result); - end; -end; - -function TFPObjectList.IndexOf(AObject: TObject): Integer; -begin - Result := FList.IndexOf(Pointer(AObject)); -end; - -function TFPObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt : Integer): Integer; -var - I : Integer; -begin - I:=AStartAt; - Result:=-1; - If AExact then - while (I=Acount) -end; - -Function TOrderedList.Count: Integer; -begin - Result:=FList.Count; -end; - -constructor TOrderedList.Create; -begin - FList:=Tlist.Create; -end; - -destructor TOrderedList.Destroy; -begin - FList.Free; -end; - -Function TOrderedList.Peek: Pointer; -begin - If AtLeast(1) then - Result:=PeekItem - else - Result:=Nil; -end; - -Function TOrderedList.PeekItem: Pointer; -begin - With Flist do - Result:=Items[Count-1] -end; - -Function TOrderedList.Pop: Pointer; -begin - If Atleast(1) then - Result:=PopItem - else - Result:=Nil; -end; - -Function TOrderedList.PopItem: Pointer; -begin - With FList do - If Count>0 then - begin - Result:=Items[Count-1]; - Delete(Count-1); - end - else - Result:=Nil; -end; - -Function TOrderedList.Push(AItem: Pointer): Pointer; -begin - PushItem(Aitem); - Result:=AItem; -end; - -{ TStack } - -Procedure TStack.PushItem(AItem: Pointer); -begin - FList.Add(Aitem); -end; - -{ TObjectStack } - -Function TObjectStack.Peek: TObject; -begin - Result:=TObject(Inherited Peek); -end; - -Function TObjectStack.Pop: TObject; -begin - Result:=TObject(Inherited Pop); -end; - -Function TObjectStack.Push(AObject: TObject): TObject; -begin - Result:=TObject(Inherited Push(Pointer(AObject))); -end; - -{ TQueue } - -Procedure TQueue.PushItem(AItem: Pointer); -begin - With Flist Do - Insert(0,AItem); -end; - -{ TObjectQueue } - -Function TObjectQueue.Peek: TObject; -begin - Result:=TObject(Inherited Peek); -end; - -Function TObjectQueue.Pop: TObject; -begin - Result:=TObject(Inherited Pop); -end; - -Function TObjectQueue.Push(AObject: TObject): TObject; -begin - Result:=TObject(Inherited Push(Pointer(Aobject))); -end; - - -{***************************************************************************** - TFPHashList -*****************************************************************************} - - function FPHash1(const s:shortstring):LongWord; - Var - g : LongWord; - p,pmax : pchar; - begin - result:=0; - p:=@s[1]; - pmax:=@s[length(s)+1]; - while (p0 then - result:=result xor (g shr 24) xor g; - inc(p); - end; - If result=0 then - result:=$ffffffff; - end; - - function FPHash(const s:shortstring):LongWord; - Var - p,pmax : pchar; - begin -{$ifopt Q+} -{$define overflowon} -{$Q-} -{$endif} - result:=0; - p:=@s[1]; - pmax:=@s[length(s)+1]; - while (p= FCount) then - RaiseIndexError(Index); - Result:=FHashList^[Index].Data; -end; - - -procedure TFPHashList.Put(Index: Integer; Item: Pointer); -begin - if (Index < 0) or (Index >= FCount) then - RaiseIndexError(Index); - FHashList^[Index].Data:=Item;; -end; - - -function TFPHashList.NameOfIndex(Index: Integer): shortstring; -begin - If (Index < 0) or (Index >= FCount) then - RaiseIndexError(Index); - with FHashList^[Index] do - begin - if StrIndex>=0 then - Result:=PShortString(@FStrs[StrIndex])^ - else - Result:=''; - end; -end; - - -function TFPHashList.HashOfIndex(Index: Integer): LongWord; -begin - If (Index < 0) or (Index >= FCount) then - RaiseIndexError(Index); - Result:=FHashList^[Index].HashValue; -end; - - -function TFPHashList.Extract(item: Pointer): Pointer; -var - i : Integer; -begin - result := nil; - i := IndexOf(item); - if i >= 0 then - begin - Result := item; - Delete(i); - end; -end; - - -procedure TFPHashList.SetCapacity(NewCapacity: Integer); -begin - If (NewCapacity < FCount) or (NewCapacity > MaxHashListSize) then - Error (SListCapacityError, NewCapacity); - if NewCapacity = FCapacity then - exit; - ReallocMem(FHashList, NewCapacity*SizeOf(THashItem)); - FCapacity := NewCapacity; -end; - - -procedure TFPHashList.SetCount(NewCount: Integer); -begin - if (NewCount < 0) or (NewCount > MaxHashListSize)then - Error(SListCountError, NewCount); - If NewCount > FCount then - begin - If NewCount > FCapacity then - SetCapacity(NewCount); - If FCount < NewCount then - FillChar(FHashList^[FCount], (NewCount-FCount) div Sizeof(THashItem), 0); - end; - FCount := Newcount; -end; - - -procedure TFPHashList.SetStrCapacity(NewCapacity: Integer); -begin - If (NewCapacity < FStrCount) or (NewCapacity > MaxHashStrSize) then - Error (SListCapacityError, NewCapacity); - if NewCapacity = FStrCapacity then - exit; - ReallocMem(FStrs, NewCapacity); - FStrCapacity := NewCapacity; -end; - - -procedure TFPHashList.SetHashCapacity(NewCapacity: Integer); -begin - If (NewCapacity < 1) then - Error (SListCapacityError, NewCapacity); - if FHashCapacity=NewCapacity then - exit; - FHashCapacity:=NewCapacity; - ReallocMem(FHashTable, FHashCapacity*sizeof(Integer)); - ReHash; -end; - - -procedure TFPHashList.ReHash; -var - i : Integer; -begin - FillDword(FHashTable^,FHashCapacity,LongWord(-1)); - For i:=0 To FCount-1 Do - AddToHashTable(i); -end; - - -constructor TFPHashList.Create; -begin - SetHashCapacity(1); -end; - - -destructor TFPHashList.Destroy; -begin - Clear; - if assigned(FHashTable) then - FreeMem(FHashTable); - inherited Destroy; -end; - - -function TFPHashList.AddStr(const s:shortstring): Integer; -var - Len : Integer; -begin - len:=length(s)+1; - if FStrCount+Len >= FStrCapacity then - StrExpand(Len); - System.Move(s[0],FStrs[FStrCount],Len); - result:=FStrCount; - inc(FStrCount,Len); -end; - - -procedure TFPHashList.AddToHashTable(Index: Integer); -var - HashIndex : Integer; -begin - with FHashList^[Index] do - begin - if not assigned(Data) then - exit; - HashIndex:=HashValue mod LongWord(FHashCapacity); - NextIndex:=FHashTable^[HashIndex]; - FHashTable^[HashIndex]:=Index; - end; -end; - - -function TFPHashList.Add(const AName:shortstring;Item: Pointer): Integer; -begin - if FCount = FCapacity then - Expand; - with FHashList^[FCount] do - begin - HashValue:=FPHash(AName); - Data:=Item; - StrIndex:=AddStr(AName); - end; - AddToHashTable(FCount); - Result := FCount; - inc(FCount); -end; - -procedure TFPHashList.Clear; -begin - if Assigned(FHashList) then - begin - FCount:=0; - SetCapacity(0); - FHashList := nil; - end; - SetHashCapacity(1); - if Assigned(FStrs) then - begin - FStrCount:=0; - SetStrCapacity(0); - FStrs := nil; - end; -end; - -procedure TFPHashList.Delete(Index: Integer); -begin - If (Index<0) or (Index>=FCount) then - Error (SListIndexError, Index); - { Remove from HashList } - dec(FCount); - System.Move (FHashList^[Index+1], FHashList^[Index], (FCount - Index) * Sizeof(THashItem)); - { All indexes are updated, we need to build the hashtable again } - Rehash; - { Shrink the list if appropriate } - if (FCapacity > 256) and (FCount < FCapacity shr 2) then - begin - FCapacity := FCapacity shr 1; - ReallocMem(FHashList, Sizeof(THashItem) * FCapacity); - end; -end; - -function TFPHashList.Remove(Item: Pointer): Integer; -begin - Result := IndexOf(Item); - If Result <> -1 then - Self.Delete(Result); -end; - -class procedure TFPHashList.Error(const Msg: string; Data: PtrInt); -begin - Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame); -end; - -function TFPHashList.Expand: TFPHashList; -var - IncSize : Longint; -begin - Result := Self; - if FCount < FCapacity then - exit; - IncSize := sizeof(ptrint)*2; - if FCapacity > 127 then - Inc(IncSize, FCapacity shr 2) - else if FCapacity > sizeof(ptrint)*3 then - Inc(IncSize, FCapacity shr 1) - else if FCapacity >= sizeof(ptrint) then - inc(IncSize,sizeof(ptrint)); - SetCapacity(FCapacity + IncSize); - { Maybe expand hash also } - if FCount>FHashCapacity*MaxItemsPerHash then - SetHashCapacity(FCount div MaxItemsPerHash); -end; - -procedure TFPHashList.StrExpand(MinIncSize:Integer); -var - IncSize : Longint; -begin - if FStrCount+MinIncSize < FStrCapacity then - exit; - IncSize := 64; - if FStrCapacity > 255 then - Inc(IncSize, FStrCapacity shr 2); - SetStrCapacity(FStrCapacity + IncSize + MinIncSize); -end; - -function TFPHashList.IndexOf(Item: Pointer): Integer; -var - psrc : PHashItem; - Index : integer; -begin - Result:=-1; - psrc:=@FHashList^[0]; - For Index:=0 To FCount-1 Do - begin - if psrc^.Data=Item then - begin - Result:=Index; - exit; - end; - inc(psrc); - end; -end; - -function TFPHashList.InternalFind(AHash:LongWord;const AName:shortstring;out PrevIndex:Integer):Integer; -var - HashIndex : Integer; - Len, - LastChar : Char; -begin - HashIndex:=AHash mod LongWord(FHashCapacity); - Result:=FHashTable^[HashIndex]; - Len:=Char(Length(AName)); - LastChar:=AName[Byte(Len)]; - PrevIndex:=-1; - while Result<>-1 do - begin - with FHashList^[Result] do - begin - if assigned(Data) and - (HashValue=AHash) and - (Len=FStrs[StrIndex]) and - (LastChar=FStrs[StrIndex+Byte(Len)]) and - (AName=PShortString(@FStrs[StrIndex])^) then - exit; - PrevIndex:=Result; - Result:=NextIndex; - end; - end; -end; - - -function TFPHashList.Find(const AName:shortstring): Pointer; -var - Index, - PrevIndex : Integer; -begin - Result:=nil; - Index:=InternalFind(FPHash(AName),AName,PrevIndex); - if Index=-1 then - exit; - Result:=FHashList^[Index].Data; -end; - - -function TFPHashList.FindIndexOf(const AName:shortstring): Integer; -var - PrevIndex : Integer; -begin - Result:=InternalFind(FPHash(AName),AName,PrevIndex); -end; - - -function TFPHashList.FindWithHash(const AName:shortstring;AHash:LongWord): Pointer; -var - Index, - PrevIndex : Integer; -begin - Result:=nil; - Index:=InternalFind(AHash,AName,PrevIndex); - if Index=-1 then - exit; - Result:=FHashList^[Index].Data; -end; - - -function TFPHashList.Rename(const AOldName,ANewName:shortstring): Integer; -var - PrevIndex, - Index : Integer; - OldHash : LongWord; -begin - Result:=-1; - OldHash:=FPHash(AOldName); - Index:=InternalFind(OldHash,AOldName,PrevIndex); - if Index=-1 then - exit; - { Remove from current Hash } - if PrevIndex<>-1 then - FHashList^[PrevIndex].NextIndex:=FHashList^[Index].NextIndex - else - FHashTable^[OldHash mod LongWord(FHashCapacity)]:=FHashList^[Index].NextIndex; - { Set new name and hash } - with FHashList^[Index] do - begin - HashValue:=FPHash(ANewName); - StrIndex:=AddStr(ANewName); - end; - { Insert back in Hash } - AddToHashTable(Index); - { Return Index } - Result:=Index; -end; - -procedure TFPHashList.Pack; -var - NewCount, - i : integer; - pdest, - psrc : PHashItem; -begin - NewCount:=0; - psrc:=@FHashList^[0]; - pdest:=psrc; - For I:=0 To FCount-1 Do - begin - if assigned(psrc^.Data) then - begin - pdest^:=psrc^; - inc(pdest); - inc(NewCount); - end; - inc(psrc); - end; - FCount:=NewCount; - { We need to ReHash to update the IndexNext } - ReHash; - { Release over-capacity } - SetCapacity(FCount); - SetStrCapacity(FStrCount); -end; - - -procedure TFPHashList.ShowStatistics; -var - HashMean, - HashStdDev : Double; - Index, - i,j : Integer; -begin - { Calculate Mean and StdDev } - HashMean:=0; - HashStdDev:=0; - for i:=0 to FHashCapacity-1 do - begin - j:=0; - Index:=FHashTable^[i]; - while (Index<>-1) do - begin - inc(j); - Index:=FHashList^[Index].NextIndex; - end; - HashMean:=HashMean+j; - HashStdDev:=HashStdDev+Sqr(j); - end; - HashMean:=HashMean/FHashCapacity; - HashStdDev:=(HashStdDev-FHashCapacity*Sqr(HashMean)); - If FHashCapacity>1 then - HashStdDev:=Sqrt(HashStdDev/(FHashCapacity-1)) - else - HashStdDev:=0; - { Print info to stdout } - Writeln('HashSize : ',FHashCapacity); - Writeln('HashMean : ',HashMean:1:4); - Writeln('HashStdDev : ',HashStdDev:1:4); - Writeln('ListSize : ',FCount,'/',FCapacity); - Writeln('StringSize : ',FStrCount,'/',FStrCapacity); -end; - - -procedure TFPHashList.ForEachCall(proc2call:TListCallback;arg:pointer); -var - i : integer; - p : pointer; -begin - For I:=0 To Count-1 Do - begin - p:=FHashList^[i].Data; - if assigned(p) then - proc2call(p,arg); - end; -end; - - -procedure TFPHashList.ForEachCall(proc2call:TListStaticCallback;arg:pointer); -var - i : integer; - p : pointer; -begin - For I:=0 To Count-1 Do - begin - p:=FHashList^[i].Data; - if assigned(p) then - proc2call(p,arg); - end; -end; - - -{***************************************************************************** - TFPHashObject -*****************************************************************************} - -procedure TFPHashObject.InternalChangeOwner(HashObjectList:TFPHashObjectList;const s:shortstring); -var - Index : integer; -begin - FOwner:=HashObjectList; - Index:=HashObjectList.Add(s,Self); - FStrIndex:=HashObjectList.List.List^[Index].StrIndex; - FCachedStr:=PShortString(@FOwner.List.Strs[FStrIndex]); -end; - - -constructor TFPHashObject.CreateNotOwned; -begin - FStrIndex:=-1; -end; - - -constructor TFPHashObject.Create(HashObjectList:TFPHashObjectList;const s:shortstring); -begin - InternalChangeOwner(HashObjectList,s); -end; - - -procedure TFPHashObject.ChangeOwner(HashObjectList:TFPHashObjectList); -begin - InternalChangeOwner(HashObjectList,PShortString(@FOwner.List.Strs[FStrIndex])^); -end; - - -procedure TFPHashObject.ChangeOwnerAndName(HashObjectList:TFPHashObjectList;const s:shortstring); -begin - InternalChangeOwner(HashObjectList,s); -end; - - -procedure TFPHashObject.Rename(const ANewName:shortstring); -var - Index : integer; -begin - Index:=FOwner.Rename(PShortString(@FOwner.List.Strs[FStrIndex])^,ANewName); - if Index<>-1 then - begin - FStrIndex:=FOwner.List.List^[Index].StrIndex; - FCachedStr:=PShortString(@FOwner.List.Strs[FStrIndex]); - end; -end; - - -function TFPHashObject.GetName:shortstring; -begin - if FOwner<>nil then - begin - FCachedStr:=PShortString(@FOwner.List.Strs[FStrIndex]); - Result:=FCachedStr^; - end - else - Result:=''; -end; - - -function TFPHashObject.GetHash:Longword; -begin - if FOwner<>nil then - Result:=FPHash(PShortString(@FOwner.List.Strs[FStrIndex])^) - else - Result:=$ffffffff; -end; - - -{***************************************************************************** - TFPHashObjectList (Copied from rtl/objpas/classes/lists.inc) -*****************************************************************************} - -constructor TFPHashObjectList.Create(FreeObjects : boolean = True); -begin - inherited Create; - FHashList := TFPHashList.Create; - FFreeObjects := Freeobjects; -end; - -destructor TFPHashObjectList.Destroy; -begin - if (FHashList <> nil) then - begin - Clear; - FHashList.Destroy; - end; - inherited Destroy; -end; - -procedure TFPHashObjectList.Clear; -var - i: integer; -begin - if FFreeObjects then - for i := 0 to FHashList.Count - 1 do - TObject(FHashList[i]).Free; - FHashList.Clear; -end; - -function TFPHashObjectList.GetCount: integer; -begin - Result := FHashList.Count; -end; - -procedure TFPHashObjectList.SetCount(const AValue: integer); -begin - if FHashList.Count <> AValue then - FHashList.Count := AValue; -end; - -function TFPHashObjectList.GetItem(Index: Integer): TObject; -begin - Result := TObject(FHashList[Index]); -end; - -procedure TFPHashObjectList.SetItem(Index: Integer; AObject: TObject); -begin - if OwnsObjects then - TObject(FHashList[Index]).Free; - FHashList[index] := AObject; -end; - -procedure TFPHashObjectList.SetCapacity(NewCapacity: Integer); -begin - FHashList.Capacity := NewCapacity; -end; - -function TFPHashObjectList.GetCapacity: integer; -begin - Result := FHashList.Capacity; -end; - -function TFPHashObjectList.Add(const AName:shortstring;AObject: TObject): Integer; -begin - Result := FHashList.Add(AName,AObject); -end; - -function TFPHashObjectList.NameOfIndex(Index: Integer): shortstring; -begin - Result := FHashList.NameOfIndex(Index); -end; - -function TFPHashObjectList.HashOfIndex(Index: Integer): LongWord; -begin - Result := FHashList.HashOfIndex(Index); -end; - -procedure TFPHashObjectList.Delete(Index: Integer); -begin - if OwnsObjects then - TObject(FHashList[Index]).Free; - FHashList.Delete(Index); -end; - -function TFPHashObjectList.Expand: TFPHashObjectList; -begin - FHashList.Expand; - Result := Self; -end; - -function TFPHashObjectList.Extract(Item: TObject): TObject; -begin - Result := TObject(FHashList.Extract(Item)); -end; - -function TFPHashObjectList.Remove(AObject: TObject): Integer; -begin - Result := IndexOf(AObject); - if (Result <> -1) then - begin - if OwnsObjects then - TObject(FHashList[Result]).Free; - FHashList.Delete(Result); - end; -end; - -function TFPHashObjectList.IndexOf(AObject: TObject): Integer; -begin - Result := FHashList.IndexOf(Pointer(AObject)); -end; - - -function TFPHashObjectList.Find(const s:shortstring): TObject; -begin - result:=TObject(FHashList.Find(s)); -end; - - -function TFPHashObjectList.FindIndexOf(const s:shortstring): Integer; -begin - result:=FHashList.FindIndexOf(s); -end; - - -function TFPHashObjectList.FindWithHash(const AName:shortstring;AHash:LongWord): Pointer; -begin - Result:=TObject(FHashList.FindWithHash(AName,AHash)); -end; - - -function TFPHashObjectList.Rename(const AOldName,ANewName:shortstring): Integer; -begin - Result:=FHashList.Rename(AOldName,ANewName); -end; - - -function TFPHashObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt : Integer): Integer; -var - I : Integer; -begin - I:=AStartAt; - Result:=-1; - If AExact then - while (I0 then - for i := 1 to Length(S) do - begin - Result := Result * a + Ord(S[i]); - a := a * b; - end; - Result := (Result and $7FFFFFFF) mod TableSize; -end; - -{ THTNode } - -constructor THTCustomNode.CreateWith(const AString: string); -begin - inherited Create; - FKey := AString; -end; - -function THTCustomNode.HasKey(const AKey: string): boolean; -begin - if Length(AKey) <> Length(FKey) then - begin - Result := false; - exit; - end - else - Result := CompareMem(PChar(FKey), PChar(AKey), length(AKey)); -end; - -{ TFPCustomHashTable } - -constructor TFPCustomHashTable.Create; -begin - CreateWith(196613,@RSHash); -end; - -constructor TFPCustomHashTable.CreateWith(AHashTableSize: Longword; - aHashFunc: THashFunction); -begin - Inherited Create; - FHashTable := TFPObjectList.Create(True); - HashTableSize := AHashTableSize; - FHashFunction := aHashFunc; -end; - -destructor TFPCustomHashTable.Destroy; -begin - FHashTable.Free; - inherited Destroy; -end; - -function TFPCustomHashTable.GetDensity: Longword; -begin - Result := FHashTableSize - VoidSlots -end; - -function TFPCustomHashTable.GetNumberOfCollisions: Longword; -begin - Result := FCount -(FHashTableSize - VoidSlots) -end; - -procedure TFPCustomHashTable.SetHashTableSize(const Value: Longword); -var - i: Longword; - newSize: Longword; -begin - if Value <> FHashTableSize then - begin - i := 0; - while (PRIMELIST[i] < Value) and (i < 27) do - inc(i); - newSize := PRIMELIST[i]; - if Count = 0 then - begin - FHashTableSize := newSize; - InitializeHashTable; - end - else - ChangeTableSize(newSize); - end; -end; - -procedure TFPCustomHashTable.InitializeHashTable; -var - i: LongWord; -begin - if FHashTableSize>0 Then - for i := 0 to FHashTableSize-1 do - FHashTable.Add(nil); - FCount := 0; -end; - -procedure TFPCustomHashTable.ChangeTableSize(const ANewSize: Longword); -var - SavedTable: TFPObjectList; - SavedTableSize: Longword; - i, j: Longword; - temp: THTCustomNode; -begin - SavedTable := FHashTable; - SavedTableSize := FHashTableSize; - FHashTableSize := ANewSize; - FHashTable := TFPObjectList.Create(True); - InitializeHashTable; - If SavedTableSize>0 Then - for i := 0 to SavedTableSize-1 do - begin - if Assigned(SavedTable[i]) then - for j := 0 to TFPObjectList(SavedTable[i]).Count -1 do - begin - temp := THTCustomNode(TFPObjectList(SavedTable[i])[j]); - AddNode(temp); - end; - end; - SavedTable.Free; -end; - -procedure TFPCustomHashTable.SetHashFunction(AHashFunction: THashFunction); -begin - if IsEmpty then - FHashFunction := AHashFunction - else - raise Exception.Create(NotEmptyMsg); -end; - -function TFPCustomHashTable.Find(const aKey: string): THTCustomNode; -var - hashCode: Longword; - chn: TFPObjectList; - i: Longword; -begin - hashCode := FHashFunction(aKey, FHashTableSize); - chn := Chain(hashCode); - if Assigned(chn) then - begin - if chn.count>0 then - for i := 0 to chn.Count - 1 do - if THTCustomNode(chn[i]).HasKey(aKey) then - begin - result := THTCustomNode(chn[i]); - exit; - end; - end; - Result := nil; -end; - -Function TFPCustomHashTable.FindChainForAdd(Const aKey : String) : TFPObjectList; - -var - hashCode: Longword; - i: Longword; - -begin - hashCode := FHashFunction(aKey, FHashTableSize); - Result := Chain(hashCode); - if Assigned(Result) then - begin - if Result.count>0 then - for i := 0 to Result.Count - 1 do - if THTCustomNode(Result[i]).HasKey(aKey) then - Raise EDuplicate.CreateFmt(DuplicateMsg, [aKey]); - end - else - begin - FHashTable[hashcode] := TFPObjectList.Create(true); - Result := Chain(hashcode); - end; - inc(FCount); -end; - - -procedure TFPCustomHashTable.Delete(const aKey: string); -var - hashCode: Longword; - chn: TFPObjectList; - i: Longword; -begin - hashCode := FHashFunction(aKey, FHashTableSize); - chn := Chain(hashCode); - if Assigned(chn) then - begin - if chn.count>0 then - for i := 0 to chn.Count - 1 do - if THTCustomNode(chn[i]).HasKey(aKey) then - begin - chn.Delete(i); - dec(FCount); - exit; - end; - end; - raise EKeyNotFound.CreateFmt(KeyNotFoundMsg, ['Delete', aKey]); -end; - -function TFPCustomHashTable.IsEmpty: boolean; -begin - Result := (FCount = 0); -end; - -function TFPCustomHashTable.Chain(const index: Longword): TFPObjectList; -begin - Result := TFPObjectList(FHashTable[index]); -end; - -function TFPCustomHashTable.GetVoidSlots: Longword; -var - i: Longword; - num: Longword; -begin - num := 0; - if FHashTableSize>0 Then - for i:= 0 to FHashTableSize-1 do - if Not Assigned(Chain(i)) then - inc(num); - result := num; -end; - -function TFPCustomHashTable.GetLoadFactor: double; -begin - Result := Count / FHashTableSize; -end; - -function TFPCustomHashTable.GetAVGChainLen: double; -begin - result := Count / (FHashTableSize - VoidSlots); -end; - -function TFPCustomHashTable.GetMaxChainLength: Longword; -var - i: Longword; -begin - Result := 0; - if FHashTableSize>0 Then - for i := 0 to FHashTableSize-1 do - if ChainLength(i) > Result then - Result := ChainLength(i); -end; - -function TFPCustomHashTable.FindOrCreateNew(const aKey: string): THTCustomNode; -var - hashCode: Longword; - chn: TFPObjectList; - i: Longword; -begin - hashCode := FHashFunction(aKey, FHashTableSize); - chn := Chain(hashCode); - if Assigned(chn) then - begin - if chn.count>0 then - for i := 0 to chn.Count - 1 do - if THTCustomNode(chn[i]).HasKey(aKey) then - begin - Result := THTNode(chn[i]); - exit; - end - end - else - begin - FHashTable[hashcode] := TFPObjectList.Create(true); - chn := Chain(hashcode); - end; - inc(FCount); - Result := CreateNewNode(aKey); - chn.Add(Result); -end; - -function TFPCustomHashTable.ChainLength(const ChainIndex: Longword): Longword; -begin - if Assigned(Chain(ChainIndex)) then - Result := Chain(ChainIndex).Count - else - Result := 0; -end; - -procedure TFPCustomHashTable.Clear; -var - i: Longword; -begin - if FHashTableSize>0 Then - for i := 0 to FHashTableSize - 1 do - begin - if Assigned(Chain(i)) then - Chain(i).Clear; - end; - FCount := 0; -end; - - - -{ TFPDataHashTable } - -procedure TFPDataHashTable.Add(const aKey: string; aItem: pointer); -var - chn: TFPObjectList; - NewNode: THtDataNode; -begin - chn:=FindChainForAdd(akey); - NewNode := THtDataNode(CreateNewNode(aKey)); - NewNode.Data := aItem; - chn.Add(NewNode); -end; - -function TFPDataHashTable.GetData(const Index: string): Pointer; -var - node: THTDataNode; -begin - node := THTDataNode(Find(Index)); - if Assigned(node) then - Result := node.Data - else - Result := nil; -end; - -procedure TFPDataHashTable.SetData(const index: string; const AValue: Pointer); -begin - THTDataNode(FindOrCreateNew(index)).Data := AValue; -end; - -Function TFPDataHashTable.CreateNewNode(const aKey : string) : THTCustomNode; - -begin - Result:=THTDataNode.CreateWith(aKey); -end; - -function TFPDataHashTable.ForEachCall(aMethod: TDataIteratorMethod): THTDataNode; -var - i, j: Longword; - continue: boolean; -begin - Result := nil; - continue := true; - if FHashTableSize>0 then - for i := 0 to FHashTableSize-1 do - begin - if assigned(Chain(i)) then - begin - if chain(i).count>0 then - for j := 0 to Chain(i).Count-1 do - begin - aMethod(THTDataNode(Chain(i)[j]).Data, THTDataNode(Chain(i)[j]).Key, continue); - if not continue then - begin - Result := THTDataNode(Chain(i)[j]); - Exit; - end; - end; - end; - end; -end; - -Procedure TFPDataHashTable.AddNode(ANode : THTCustomNode); - -begin - With THTDataNode(ANode) do - Add(Key,Data); -end; - -{ TFPStringHashTable } - -Procedure TFPStringHashTable.AddNode(ANode : THTCustomNode); - -begin - With THTStringNode(ANode) do - Add(Key,Data); -end; - -function TFPStringHashTable.GetData(const Index: string): String; -var - node: THTStringNode; -begin - node := THTStringNode(Find(Index)); - if Assigned(node) then - Result := node.Data - else - Result := ''; -end; - -procedure TFPStringHashTable.SetData(const index, AValue: string); -begin - THTStringNode(FindOrCreateNew(index)).Data := AValue; -end; - -procedure TFPStringHashTable.Add(const aKey, aItem: string); -var - chn: TFPObjectList; - NewNode: THtStringNode; - -begin - chn:=FindChainForAdd(akey); - NewNode := THtStringNode(CreateNewNode(aKey)); - NewNode.Data := aItem; - chn.Add(NewNode); -end; - -Function TFPStringHashTable.CreateNewNode(const aKey : string) : THTCustomNode; - -begin - Result:=THTStringNode.CreateWith(aKey); -end; - - -function TFPStringHashTable.ForEachCall(aMethod: TStringIteratorMethod): THTStringNode; -var - i, j: Longword; - continue: boolean; -begin - Result := nil; - continue := true; - if FHashTableSize>0 then - for i := 0 to FHashTableSize-1 do - begin - if assigned(Chain(i)) then - begin - if chain(i).count>0 then - for j := 0 to Chain(i).Count-1 do - begin - aMethod(THTStringNode(Chain(i)[j]).Data, THTStringNode(Chain(i)[j]).Key, continue); - if not continue then - begin - Result := THTStringNode(Chain(i)[j]); - Exit; - end; - end; - end; - end; -end; - -{ TFPObjectHashTable } - -Procedure TFPObjectHashTable.AddNode(ANode : THTCustomNode); - -begin - With THTObjectNode(ANode) do - Add(Key,Data); -end; - -function TFPObjectHashTable.GetData(const Index: string): TObject; -var - node: THTObjectNode; -begin - node := THTObjectNode(Find(Index)); - if Assigned(node) then - Result := node.Data - else - Result := Nil; -end; - -procedure TFPObjectHashTable.SetData(const index : string; AObject : TObject); -begin - THTObjectNode(FindOrCreateNew(index)).Data := AObject; -end; - -procedure TFPObjectHashTable.Add(const aKey: string; AItem : TObject); -var - chn: TFPObjectList; - NewNode: THTObjectNode; - -begin - chn:=FindChainForAdd(akey); - NewNode := THTObjectNode(CreateNewNode(aKey)); - NewNode.Data := aItem; - chn.Add(NewNode); -end; - -Function TFPObjectHashTable.CreateNewNode(const aKey : string) : THTCustomNode; - -begin - If OwnsObjects then - Result:=THTOwnedObjectNode.CreateWith(aKey) - else - Result:=THTObjectNode.CreateWith(aKey); -end; - - -function TFPObjectHashTable.ForEachCall(aMethod: TObjectIteratorMethod): THTObjectNode; -var - i, j: Longword; - continue: boolean; -begin - Result := nil; - continue := true; - if FHashTableSize>0 then - for i := 0 to FHashTableSize-1 do - begin - if assigned(Chain(i)) then - begin - if chain(i).count>0 then - for j := 0 to Chain(i).Count-1 do - begin - aMethod(THTObjectNode(Chain(i)[j]).Data, THTObjectNode(Chain(i)[j]).Key, continue); - if not continue then - begin - Result := THTObjectNode(Chain(i)[j]); - Exit; - end; - end; - end; - end; -end; - -constructor TFPObjectHashTable.Create(AOwnsObjects : Boolean = True); - -begin - Inherited Create; - FOwnsObjects:=AOwnsObjects; -end; - -constructor TFPObjectHashTable.CreateWith(AHashTableSize: Longword; aHashFunc: THashFunction; AOwnsObjects : Boolean = True); - -begin - Inherited CreateWith(AHashTableSize,AHashFunc); - FOwnsObjects:=AOwnsObjects; -end; - -Destructor THTOwnedObjectNode.Destroy; - -begin - FreeAndNil(FData); - Inherited; -end; - -end. diff --git a/utils/fppkg/fcl20/streamcoll.pp b/utils/fppkg/fcl20/streamcoll.pp deleted file mode 100644 index c17c815a53..0000000000 --- a/utils/fppkg/fcl20/streamcoll.pp +++ /dev/null @@ -1,363 +0,0 @@ -{ - This file is part of the Free Component Library (FCL) - Copyright (c) 1999-2000 by the Free Pascal development team - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} - -{$ifndef ver2_0} - {$fatal This unit is only for compiling with 2.0.x, use the streamcoll from the FCL} -{$endif} - -{$mode objfpc} -{$h+} -unit streamcoll; - -interface - -uses - Classes,SysUtils; - -type - TStreamCollectionItem = Class(TCollectionItem) - Protected - Procedure WriteInteger(S : TStream; AValue : Integer); - Procedure WriteBoolean(S : TStream; AValue : Boolean); - Procedure WriteString(S : TStream; AValue : String); - Procedure WriteCurrency(S : TStream; AValue : Currency); - Procedure WriteDateTime(S : TStream; AValue : TDateTime); - Procedure WriteFloat(S : TStream; AValue : Double); - Function ReadInteger(S : TStream) : Integer; - Function ReadBoolean(S : TStream) : Boolean; - Function ReadString(S : TStream) : String; - Function ReadCurrency(S : TStream) : Currency; - Function ReadDateTime(S : TStream) : TDateTime; - Function ReadFloat(S : TStream) : Double; - Procedure LoadFromStream(S : TStream; Streamversion : Integer); virtual; abstract; - Procedure SaveToStream(S : TStream); virtual; abstract; - end; - - TStreamCollection = Class(TCollection) - Private - FStreaming : Boolean; - Protected - Procedure WriteInteger(S : TStream; AValue : Integer); - Procedure WriteBoolean(S : TStream; AValue : Boolean); - Procedure WriteString(S : TStream; AValue : String); - Procedure WriteCurrency(S : TStream; AValue : Currency); - Procedure WriteDateTime(S : TStream; AValue : TDateTime); - Procedure WriteFloat(S : TStream; AValue : Double); - Function ReadInteger(S : TStream) : Integer; - Function ReadBoolean(S : TStream) : Boolean; - Function ReadString(S : TStream) : String; - Function ReadCurrency(S : TStream) : Currency; - Function ReadDateTime(S : TStream) : TDateTime; - Function ReadFloat(S : TStream) : Double; - Procedure DoSaveToStream(S : TStream); virtual; - Function CurrentStreamVersion : Integer; Virtual; - Procedure DoLoadFromStream(S : TStream; Streamversion : Integer); virtual; - Public - Procedure LoadFromStream(S : TStream); - Procedure SaveToStream(S : TStream); - Property Streaming : Boolean Read FStreaming; - end; - - - EStreamColl = Class(Exception); - -Procedure ColWriteInteger(S : TStream; AValue : Integer); -Procedure ColWriteBoolean(S : TStream; AValue : Boolean); -Procedure ColWriteString(S : TStream; AValue : String); -Procedure ColWriteCurrency(S : TStream; AValue : Currency); -Procedure ColWriteDateTime(S : TStream; AValue : TDateTime); -Procedure ColWriteFloat(S : TStream; AValue : Double); -Function ColReadInteger(S : TStream) : Integer; -Function ColReadBoolean(S : TStream) : Boolean; -Function ColReadString(S : TStream) : String; -Function ColReadCurrency(S : TStream) : Currency; -Function ColReadDateTime(S : TStream) : TDateTime; -Function ColReadFloat(S : TStream) : Double; - -implementation - -Resourcestring - SErrIllegalStreamVersion = 'Illegal stream version: %d > %d.'; - -Procedure ColWriteInteger(S : TStream; AValue : Integer); - -begin - S.WriteBuffer(AValue,SizeOf(Integer)); -end; - -Procedure ColWriteBoolean(S : TStream; AValue : Boolean); - -begin - ColWriteInteger(S,Ord(AValue)); -end; - -Procedure ColWriteString(S : TStream; AValue : String); - -Var - L : Integer; - -begin - L:=Length(AValue); - ColWriteInteger(S,L); - If (L>0) then - S.WriteBuffer(AValue[1],L); -end; - -Procedure ColWriteCurrency(S : TStream; AValue : Currency); - -begin - S.WriteBuffer(AValue,SizeOf(Currency)); -end; - -Procedure ColWriteDateTime(S : TStream; AValue : TDateTime); - -begin - S.WriteBuffer(AValue,SizeOf(TDateTime)); -end; - -Procedure ColWriteFloat(S : TStream; AValue : Double); - -begin - S.WriteBuffer(AValue,SizeOf(Double)); -end; - -Function ColReadInteger(S : TStream) : Integer; - -begin - S.ReadBuffer(Result,SizeOf(Integer)); -end; - -Function ColReadBoolean(S : TStream) : Boolean; - -Var - I : Integer; - -begin - S.ReadBuffer(I,SizeOf(Integer)); - Result:=(I<>0); -end; - -Function ColReadString(S : TStream) : String; - -Var - L : Integer; - -begin - L:=ColReadInteger(S); - SetLength(Result,L); - If (L>0) then - S.ReadBuffer(Result[1],L); -end; - -Function ColReadCurrency(S : TStream) : Currency; - -begin - S.ReadBuffer(Result,SizeOf(Currency)); -end; - -Function ColReadDateTime(S : TStream) : TDateTime; - -begin - S.ReadBuffer(Result,SizeOf(TDateTime)); -end; - -Function ColReadFloat(S : TStream) : Double; - -begin - S.ReadBuffer(Result,SizeOf(Double)); -end; - -{ TStreamCollectionItem } - -function TStreamCollectionItem.ReadBoolean(S: TStream): Boolean; -begin - Result:=ColReadBoolean(S); -end; - -function TStreamCollectionItem.ReadCurrency(S: TStream): Currency; -begin - Result:=ColReadCurrency(S); -end; - -function TStreamCollectionItem.ReadDateTime(S: TStream): TDateTime; -begin - Result:=ColReadDateTime(S); -end; - -function TStreamCollectionItem.ReadFloat(S: TStream): Double; -begin - Result:=ColReadFloat(S); -end; - -function TStreamCollectionItem.ReadInteger(S: TStream): Integer; -begin - Result:=ColReadinteger(S); -end; - -function TStreamCollectionItem.ReadString(S: TStream): String; -begin - Result:=ColReadString(S); -end; - -procedure TStreamCollectionItem.WriteBoolean(S: TStream; AValue: Boolean); -begin - ColWriteBoolean(S,AValue); -end; - -procedure TStreamCollectionItem.WriteCurrency(S: TStream; - AValue: Currency); -begin - ColWriteCurrency(S,AValue); -end; - -procedure TStreamCollectionItem.WriteDateTime(S: TStream; - AValue: TDateTime); -begin - ColWriteDateTime(S,AValue); -end; - -procedure TStreamCollectionItem.WriteFloat(S: TStream; AValue: Double); -begin - ColWriteFloat(S,AValue); -end; - -procedure TStreamCollectionItem.WriteInteger(S: TStream; AValue: Integer); -begin - ColWriteInteger(S,AValue); -end; - -procedure TStreamCollectionItem.WriteString(S: TStream; AValue: String); -begin - ColWriteString(S,AValue); -end; - -{ TStreamCollection } - -function TStreamCollection.CurrentStreamVersion: Integer; -begin - Result:=0; -end; - -procedure TStreamCollection.DoLoadFromStream(S: TStream; - Streamversion: Integer); -begin - If (Streamversion>CurrentStreamVersion) then - Raise EStreamColl.CreateFmt(SErrIllegalStreamVersion,[Streamversion,CurrentStreamVersion]); -end; - -procedure TStreamCollection.DoSaveToStream(S: TStream); -begin - // Do nothing. -end; - -procedure TStreamCollection.LoadFromStream(S: TStream); - -Var - I,V,C : Integer; - -begin - FStreaming:=True; - Try - V:=ReadInteger(S); - DoLoadFromStream(S,V); - Clear; - C:=ReadInteger(S); - For I:=1 to C do - With Add as TStreamCollectionItem do - LoadFromStream(S,V); - Finally - FStreaming:=False; - end; -end; - -function TStreamCollection.ReadBoolean(S: TStream): Boolean; -begin - Result:=ColReadBoolean(S); -end; - -function TStreamCollection.ReadCurrency(S: TStream): Currency; -begin - Result:=ColReadCurrency(S); -end; - -function TStreamCollection.ReadDateTime(S: TStream): TDateTime; -begin - Result:=ColReadDateTime(S); -end; - -function TStreamCollection.ReadFloat(S: TStream): Double; -begin - Result:=ColReadFloat(S); -end; - -function TStreamCollection.ReadInteger(S: TStream): Integer; -begin - Result:=ColReadInteger(S); -end; - -function TStreamCollection.ReadString(S: TStream): String; -begin - Result:=ColReadString(S); -end; - -procedure TStreamCollection.SaveToStream(S: TStream); - -Var - I : Integer; - -begin - FStreaming:=True; - Try - WriteInteger(S,CurrentStreamVersion); - DoSaveToStream(S); - WriteInteger(S,Count); - For I:=0 to Count-1 do - With TStreamCollectionItem(Items[i]) do - SaveToStream(S); - Finally - FStreaming:=False; - end; -end; - -procedure TStreamCollection.WriteBoolean(S: TStream; AValue: Boolean); -begin - ColWriteBoolean(S,AValue); -end; - -procedure TStreamCollection.WriteCurrency(S: TStream; AValue: Currency); -begin - ColWriteCurrency(S,AValue); -end; - -procedure TStreamCollection.WriteDateTime(S: TStream; AValue: TDateTime); -begin - ColWriteDateTime(S,AValue); -end; - -procedure TStreamCollection.WriteFloat(S: TStream; AValue: Double); -begin - ColWriteFloat(S,AValue); -end; - -procedure TStreamCollection.WriteInteger(S: TStream; AValue: Integer); -begin - ColWriteInteger(S,AValue); -end; - -procedure TStreamCollection.WriteString(S: TStream; AValue: String); -begin - ColWriteString(S,AValue); -end; - - -end. diff --git a/utils/fppkg/fcl20/uriparser.pp b/utils/fppkg/fcl20/uriparser.pp deleted file mode 100644 index 170e257dd4..0000000000 --- a/utils/fppkg/fcl20/uriparser.pp +++ /dev/null @@ -1,425 +0,0 @@ -{ - This file is part of the Free Pascal run time library. - Copyright (c) 2003 by the Free Pascal development team - Original author: Sebastian Guenther - - Unit to parse complete URI in its parts or to reassemble an URI - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} -{$IFDEF FPC} -{$MODE objfpc} -{$H+} -{$ENDIF} - -unit URIParser; - -interface - -type - TURI = record - Protocol: String; - Username: String; - Password: String; - Host: String; - Port: Word; - Path: String; - Document: String; - Params: String; - Bookmark: String; - HasAuthority: Boolean; - end; - -function EncodeURI(const URI: TURI): String; -function ParseURI(const URI: String): TURI; overload; -function ParseURI(const URI, DefaultProtocol: String; DefaultPort: Word): TURI; overload; - -function ResolveRelativeURI(const BaseUri, RelUri: WideString; - out ResultUri: WideString): Boolean; overload; - -function ResolveRelativeURI(const BaseUri, RelUri: UTF8String; - out ResultUri: UTF8String): Boolean; overload; - -function URIToFilename(const URI: string; out Filename: string): Boolean; -function FilenameToURI(const Filename: string): string; - -function IsAbsoluteURI(const UriReference: string): Boolean; - -implementation - -uses SysUtils; - -const - GenDelims = [':', '/', '?', '#', '[', ']', '@']; - SubDelims = ['!', '$', '&', '''', '(', ')', '*', '+', ',', ';', '=']; - ALPHA = ['A'..'Z', 'a'..'z']; - DIGIT = ['0'..'9']; - Unreserved = ALPHA + DIGIT + ['-', '.', '_', '~']; - ValidPathChars = Unreserved + SubDelims + ['@', ':', '/']; - -function Escape(const s: String; const Allowed: TSysCharSet): String; -var - i: Integer; -begin - SetLength(Result, 0); - for i := 1 to Length(s) do - if not (s[i] in Allowed) then - Result := Result + '%' + IntToHex(ord(s[i]), 2) - else - Result := Result + s[i]; -end; - -function EncodeURI(const URI: TURI): String; -// ! if no scheme then first colon in path should be escaped -begin - SetLength(Result, 0); - if Length(URI.Protocol) > 0 then - Result := LowerCase(URI.Protocol) + ':'; - if URI.HasAuthority then - begin - Result := Result + '//'; - if Length(URI.Username) > 0 then - begin - Result := Result + URI.Username; - if Length(URI.Password) > 0 then - Result := Result + ':' + URI.Password; - Result := Result + '@'; - end; - Result := Result + URI.Host; - end; - if URI.Port <> 0 then - Result := Result + ':' + IntToStr(URI.Port); - Result := Result + Escape(URI.Path, ValidPathChars); - if Length(URI.Document) > 0 then - begin - if (Length(URI.Path) > 0) and ((Length(Result) = 0) or (Result[Length(Result)] <> '/')) then - Result := Result + '/'; - Result := Result + Escape(URI.Document, ValidPathChars); - end; - if Length(URI.Params) > 0 then - Result := Result + '?' + Escape(URI.Params, ValidPathChars); - if Length(URI.Bookmark) > 0 then - Result := Result + '#' + Escape(URI.Bookmark, ValidPathChars); -end; - -function ParseURI(const URI: String): TURI; -begin - Result := ParseURI(URI, '', 0); -end; - -function HexValue(c: Char): Integer; -begin - case c of - '0'..'9': Result := ord(c) - ord('0'); - 'A'..'F': Result := ord(c) - (ord('A') - 10); - 'a'..'f': Result := ord(c) - (ord('a') - 10); - else - Result := 0; - end; -end; - -function Unescape(const s: String): String; -var - i, RealLength: Integer; -begin - SetLength(Result, Length(s)); - i := 1; - RealLength := 0; - while i <= Length(s) do - begin - Inc(RealLength); - if s[i] = '%' then - begin - Result[RealLength] := Chr(HexValue(s[i + 1]) shl 4 or HexValue(s[i + 2])); - Inc(i, 3); - end else - begin - Result[RealLength] := s[i]; - Inc(i); - end; - end; - SetLength(Result, RealLength); -end; - -function ParseURI(const URI, DefaultProtocol: String; DefaultPort: Word): TURI; -var - s, Authority: String; - i: Integer; -begin - Result.Protocol := LowerCase(DefaultProtocol); - Result.Port := DefaultPort; - - s := URI; - - // Extract scheme - - for i := 1 to Length(s) do - if s[i] = ':' then - begin - Result.Protocol := Copy(s, 1, i - 1); - s := Copy(s, i + 1, MaxInt); - break; - end - else - if not (((i=1) and (s[i] in ALPHA)) or (s[i] in ALPHA + DIGIT + ['+', '-', '.'])) then - break; - - // Extract the bookmark - - i := LastDelimiter('#', s); - if i > 0 then - begin - Result.Bookmark := Unescape(Copy(s, i + 1, MaxInt)); - s := Copy(s, 1, i - 1); - end; - - // Extract the params - - i := LastDelimiter('?', s); - if i > 0 then - begin - Result.Params := Unescape(Copy(s, i + 1, MaxInt)); - s := Copy(s, 1, i - 1); - end; - - // extract authority - - if (Length(s) > 1) and (s[1] = '/') and (s[2] = '/') then - begin - i := 3; - while (i <= Length(s)) and (s[i] <> '/') do - Inc(i); - Authority := Copy(s, 3, i-3); - s := Copy(s, i, MaxInt); - Result.HasAuthority := True; // even if Authority is empty - end - else - begin - Result.HasAuthority := False; - Authority := ''; - end; - - // now s is 'hier-part' per RFC3986 - // Extract the document name (nasty...) - - for i := Length(s) downto 1 do - if s[i] = '/' then - begin - Result.Document := Unescape(Copy(s, i + 1, Length(s))); - if (Result.Document <> '.') and (Result.Document <> '..') then - s := Copy(s, 1, i) - else - Result.Document := ''; - break; - end else if s[i] = ':' then - break - else if i = 1 then - begin - Result.Document := Unescape(s); - if (Result.Document <> '.') and (Result.Document <> '..') then - s := '' - else - Result.Document := ''; - // break - not needed, last iteration - end; - - // Everything left is a path - - Result.Path := Unescape(s); - - // Extract the port number - - i := LastDelimiter(':@', Authority); - if (i > 0) and (Authority[i] = ':') then - begin - Result.Port := StrToInt(Copy(Authority, i + 1, MaxInt)); - Authority := Copy(Authority, 1, i - 1); - end; - - // Extract the hostname - - i := Pos('@', Authority); - if i > 0 then - begin - Result.Host := Copy(Authority, i+1, MaxInt); - Delete(Authority, i, MaxInt); - - // Extract username and password - if Length(Authority) > 0 then - begin - i := Pos(':', Authority); - if i = 0 then - Result.Username := Authority - else - begin - Result.Username := Copy(Authority, 1, i - 1); - Result.Password := Copy(Authority, i + 1, MaxInt); - end; - end; - end - else - Result.Host := Authority; -end; - -procedure RemoveDotSegments(var s: string); -var - Cur, Prev: Integer; -begin - Prev := Pos('/', s); - while (Prev > 0) and (Prev < Length(s)) do - begin - Cur := Prev+1; - while (Cur <= Length(s)) and (s[Cur] <> '/') do - Inc(Cur); - if (Cur - Prev = 2) and (s[Prev+1] = '.') then - Delete(s, Prev+1, 2) - else if (Cur - Prev = 3) and (s[Prev+1] = '.') and (s[Prev+2] = '.') then - begin - while (Prev > 1) and (s[Prev-1] <> '/') do - Dec(Prev); - if Prev > 1 then - Dec(Prev); - Delete(s, Prev+1, Cur-Prev); - end - else - Prev := Cur; - end; -end; - -// TODO: this probably must NOT percent-encode the result... -function ResolveRelativeURI(const BaseUri, RelUri: UTF8String; - out ResultUri: UTF8String): Boolean; -var - Base, Rel: TUri; -begin - Base := ParseUri(BaseUri); - Rel := ParseUri(RelUri); - - Result := (Base.Protocol <> '') or (Rel.Protocol <> ''); - if not Result then - Exit; - with Rel do - begin - if (Path = '') and (Document = '') then - begin - if (Protocol = '') and (Host = '') then - begin - if Params <> '' then - Base.Params := Params; - Base.Bookmark := Bookmark; - ResultUri := EncodeUri(Base); - Exit; - end; - end; - if (Protocol <> '') then // RelURI is absolute - return it... - begin - ResultUri := RelUri; - Exit; - end; - // Inherit protocol - Protocol := Base.Protocol; - if (Host = '') then // TODO: or "not HasAuthority"? - begin - // Inherit Authority (host, port, username, password) - Host := Base.Host; - Port := Base.Port; - Username := Base.Username; - Password := Base.Password; - HasAuthority := Base.HasAuthority; - if (Path = '') or (Path[1] <> '/') then // path is empty or relative - Path := Base.Path + Path; - RemoveDotSegments(Path); - end; - end; // with - ResultUri := EncodeUri(Rel); -end; - -function ResolveRelativeURI(const BaseUri, RelUri: WideString; - out ResultUri: WideString): Boolean; -var - rslt: UTF8String; -begin - Result := ResolveRelativeURI(UTF8Encode(BaseUri), UTF8Encode(RelUri), rslt); - if Result then - ResultURI := UTF8Decode(rslt); -end; - -function URIToFilename(const URI: string; out Filename: string): Boolean; -var - U: TURI; - I: Integer; -begin - Result := False; - U := ParseURI(URI); - if SameText(U.Protocol, 'file') then - begin - if (Length(U.Path) > 2) and (U.Path[1] = '/') and (U.Path[3] = ':') then - Filename := Copy(U.Path, 2, MaxInt) - else - Filename := U.Path; - Filename := Filename + U.Document; - Result := True; - end - else - if U.Protocol = '' then // fire and pray? - begin - Filename := U.Path + U.Document; - Result := True; - end; - if PathDelim <> '/' then - begin - I := Pos('/', Filename); - while I > 0 do - begin - Filename[I] := PathDelim; - I := Pos('/', Filename); - end; - end; -end; - -function FilenameToURI(const Filename: string): string; -var - I: Integer; -begin - // TODO: seems implemented, but not tested well - Result := 'file://'; - if (Length(Filename) > 2) and (Filename[1] <> PathDelim) and (Filename[2] = ':') then - Result := Result + '/'; - Result := Result + Filename; - if PathDelim <> '/' then - begin - I := Pos(PathDelim, Result); - while I <> 0 do - begin - Result[I] := '/'; - I := Pos(PathDelim, Result); - end; - end; -end; - - -function IsAbsoluteURI(const UriReference: string): Boolean; -var - I: Integer; -begin - Result := True; - for I := 1 to Length(UriReference) do - begin - if UriReference[I] = ':' then - Exit - else - if not (((I=1) and (UriReference[I] in ALPHA)) or - (UriReference[i] in ALPHA + DIGIT + ['+', '-', '.'])) then - Break; - end; - Result := False; -end; - - -end. diff --git a/utils/fppkg/fcl20/zipper.pp b/utils/fppkg/fcl20/zipper.pp deleted file mode 100644 index 21899d6970..0000000000 --- a/utils/fppkg/fcl20/zipper.pp +++ /dev/null @@ -1,1470 +0,0 @@ -{ - $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $ - This file is part of the Free Component Library (FCL) - Copyright (c) 1999-2000 by the Free Pascal development team - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} -{$mode objfpc} -{$h+} -unit zipper; - -Interface - -Uses - SysUtils,Classes,Contnrs,ZStream; - - -Const - { Signatures } -{$ifdef FPC_BIG_ENDIAN} - END_OF_CENTRAL_DIR_SIGNATURE = $504B0506; - LOCAL_FILE_HEADER_SIGNATURE = $504B0304; - CENTRAL_FILE_HEADER_SIGNATURE = $504B0102; -{$else FPC_BIG_ENDIAN} - END_OF_CENTRAL_DIR_SIGNATURE = $06054B50; - LOCAL_FILE_HEADER_SIGNATURE = $04034B50; - CENTRAL_FILE_HEADER_SIGNATURE = $02014B50; -{$endif FPC_BIG_ENDIAN} - -Type - Local_File_Header_Type = Packed Record - Signature : LongInt; - Extract_Version_Reqd : Word; - Bit_Flag : Word; - Compress_Method : Word; - Last_Mod_Time : Word; - Last_Mod_Date : Word; - Crc32 : LongWord; - Compressed_Size : LongInt; - Uncompressed_Size : LongInt; - Filename_Length : Word; - Extra_Field_Length : Word; - end; - - { Define the Central Directory record types } - - Central_File_Header_Type = Packed Record - Signature : LongInt; - MadeBy_Version : Word; - Extract_Version_Reqd : Word; - Bit_Flag : Word; - Compress_Method : Word; - Last_Mod_Time : Word; - Last_Mod_Date : Word; - Crc32 : LongWord; - Compressed_Size : LongInt; - Uncompressed_Size : LongInt; - Filename_Length : Word; - Extra_Field_Length : Word; - File_Comment_Length : Word; - Starting_Disk_Num : Word; - Internal_Attributes : Word; - External_Attributes : LongInt; - Local_Header_Offset : LongInt; - End; - - End_of_Central_Dir_Type = Packed Record - Signature : LongInt; - Disk_Number : Word; - Central_Dir_Start_Disk : Word; - Entries_This_Disk : Word; - Total_Entries : Word; - Central_Dir_Size : LongInt; - Start_Disk_Offset : LongInt; - ZipFile_Comment_Length : Word; - end; - -Const - Crc_32_Tab : Array[0..255] of LongWord = ( - $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535, $9e6495a3, - $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91, - $1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7, - $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, $fa0f3d63, $8d080df5, - $3b6e20c8, $4c69105e, $d56041e4, $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, - $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59, - $26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f, - $2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab, $b6662d3d, - $76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433, - $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01, - $6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, - $65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65, - $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb, - $4369e96a, $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9, - $5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f, - $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad, - $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, $73dc1683, - $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1, - $f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7, - $fed41b76, $89d32be0, $10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, - $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b, - $d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, $4669be79, - $cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703, $220216b9, $5505262f, - $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d, - $9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713, - $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, - $86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777, - $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45, - $a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d, $3e6e77db, - $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9, - $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23d967bf, - $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d - ); - -Type - - TZipItem = Class(TObject) - Path : String; - Name : String; - Size : LongInt; - DateTime : TDateTime; - HdrPos : Longint; - end; - - TProgressEvent = Procedure(Sender : TObject; Const Pct : Double) of object; - TOnEndOfFileEvent = Procedure(Sender : TObject; Const Ratio : Double) of object; - TOnStartFileEvent = Procedure(Sender : TObject; Const AFileName : String) of object; - -Type - - { TCompressor } - TCompressor = Class(TObject) - Protected - FInFile : TStream; { I/O file variables } - FOutFile : TStream; - FCrc32Val : LongWord; { CRC calculation variable } - FBufferSize : LongWord; - FOnPercent : Integer; - FOnProgress : TProgressEvent; - Procedure UpdC32(Octet: Byte); - Public - Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord); virtual; - Procedure Compress; Virtual; Abstract; - Class Function ZipID : Word; virtual; Abstract; - Property BufferSize : LongWord read FBufferSize; - Property OnPercent : Integer Read FOnPercent Write FOnPercent; - Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress; - Property Crc32Val : LongWord Read FCrc32Val Write FCrc32Val; - end; - - { TDeCompressor } - TDeCompressor = Class(TObject) - Protected - FInFile : TStream; { I/O file variables } - FOutFile : TStream; - FCrc32Val : LongWord; { CRC calculation variable } - FBufferSize : LongWord; - FOnPercent : Integer; - FOnProgress : TProgressEvent; - Procedure UpdC32(Octet: Byte); - Public - Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord); virtual; - Procedure DeCompress; Virtual; Abstract; - Class Function ZipID : Word; virtual; Abstract; - Property BufferSize : LongWord read FBufferSize; - Property OnPercent : Integer Read FOnPercent Write FOnPercent; - Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress; - Property Crc32Val : LongWord Read FCrc32Val Write FCrc32Val; - end; - - { TShrinker } - -Const - TABLESIZE = 8191; - FIRSTENTRY = 257; - -Type - CodeRec = Packed Record - Child : Smallint; - Sibling : Smallint; - Suffix : Byte; - end; - CodeArray = Array[0..TABLESIZE] of CodeRec; - TablePtr = ^CodeArray; - - FreeListPtr = ^FreeListArray; - FreeListArray = Array[FIRSTENTRY..TABLESIZE] of Word; - - BufPtr = PByte; - - TShrinker = Class(TCompressor) - Private - FBufSize : LongWord; - MaxInBufIdx : LongWord; { Count of valid chars in input buffer } - InputEof : Boolean; { End of file indicator } - CodeTable : TablePtr; { Points to code table for LZW compression } - FreeList : FreeListPtr; { Table of free code table entries } - NextFree : Word; { Index into free list table } - - ClearList : Array[0..1023] of Byte; { Bit mapped structure used in } - { during adaptive resets } - CodeSize : Byte; { Size of codes (in bits) currently being written } - MaxCode : Word; { Largest code that can be written in CodeSize bits } - InBufIdx, { Points to next char in buffer to be read } - OutBufIdx : LongWord; { Points to next free space in output buffer } - InBuf, { I/O buffers } - OutBuf : BufPtr; - FirstCh : Boolean; { Flag indicating the START of a shrink operation } - TableFull : Boolean; { Flag indicating a full symbol table } - SaveByte : Byte; { Output code buffer } - BitsUsed : Byte; { Index into output code buffer } - BytesIn : LongInt; { Count of input file bytes processed } - BytesOut : LongInt; { Count of output bytes } - FOnBytes : Longint; - Procedure FillInputBuffer; - Procedure WriteOutputBuffer; - Procedure FlushOutput; - Procedure PutChar(B : Byte); - procedure PutCode(Code : Smallint); - Procedure InitializeCodeTable; - Procedure Prune(Parent : Word); - Procedure Clear_Table; - Procedure Table_Add(Prefix : Word; Suffix : Byte); - function Table_Lookup(TargetPrefix : Smallint; - TargetSuffix : Byte; - Out FoundAt : Smallint) : Boolean; - Procedure Shrink(Suffix : Smallint); - Procedure ProcessLine(Const Source : String); - Procedure DoOnProgress(Const Pct : Double); Virtual; - Public - Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord); override; - Destructor Destroy; override; - Procedure Compress; override; - Class Function ZipID : Word; override; - end; - - { TDeflater } - - TDeflater = Class(TCompressor) - private - FCompressionLevel: TCompressionlevel; - Public - Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord);override; - Procedure Compress; override; - Class Function ZipID : Word; override; - Property CompressionLevel : TCompressionlevel Read FCompressionLevel Write FCompressionLevel; - end; - - { TInflater } - - TInflater = Class(TDeCompressor) - Public - Constructor Create(AInFile, AOutFile : TStream; ABufSize : LongWord);override; - Procedure DeCompress; override; - Class Function ZipID : Word; override; - end; - - { TZipper } - - TZipper = Class(TObject) - Private - FZipping : Boolean; - FBufSize : LongWord; - FFileName : String; { Name of resulting Zip file } - FFiles : TStrings; - FInMemSize : Integer; - FOutFile : TFileStream; - FInFile : TFileStream; { I/O file variables } - LocalHdr : Local_File_Header_Type; - CentralHdr : Central_File_Header_Type; - EndHdr : End_of_Central_Dir_Type; - FOnPercent : LongInt; - FOnProgress : TProgressEvent; - FOnEndOfFile : TOnEndOfFileEvent; - FOnStartFile : TOnStartFileEvent; - Protected - Procedure OpenOutput; - Procedure CloseOutput; - Procedure CloseInput; - Procedure StartZipFile(Item : TZipItem); - Function UpdateZipHeader(Item : TZipItem; FZip : TStream; ACRC : LongWord;AMethod : Word) : Boolean; - Procedure BuildZipDirectory; - Procedure DoEndOfFile; - Procedure ZipOneFile(Item : TZipItem); virtual; - Function OpenInput(InFileName : String) : Boolean; - Procedure GetFileInfo; - Procedure SetBufSize(Value : LongWord); - Procedure SetFileName(Value : String); - Function CreateCompressor(Item : TZipItem; AinFile,AZipStream : TStream) : TCompressor; virtual; - Public - Constructor Create; - Destructor Destroy;override; - Procedure ZipAllFiles; virtual; - Procedure ZipFiles(AFileName : String; FileList : TStrings); - Procedure Clear; - Public - Property BufferSize : LongWord Read FBufSize Write SetBufSize; - Property OnPercent : Integer Read FOnPercent Write FOnPercent; - Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress; - Property OnStartFile : TOnStartFileEvent Read FOnStartFile Write FOnStartFile; - Property OnEndFile : TOnEndOfFileEvent Read FOnEndOfFile Write FOnEndOfFile; - Property FileName : String Read FFileName Write SetFileName; - Property Files : TStrings Read FFiles; - Property InMemSize : Integer Read FInMemSize Write FInMemSize; - end; - - { TYbZipper } - - { TUnZipper } - - TUnZipper = Class(TObject) - Private - FUnZipping : Boolean; - FBufSize : LongWord; - FFileName : String; { Name of resulting Zip file } - FOutputPath : String; - FFiles : TStrings; - FZipEntries : TFPObjectList; - FOutFile : TFileStream; - FZipFile : TFileStream; { I/O file variables } - LocalHdr : Local_File_Header_Type; - CentralHdr : Central_File_Header_Type; - EndHdr : End_of_Central_Dir_Type; - - FOnPercent : LongInt; - FOnProgress : TProgressEvent; - FOnEndOfFile : TOnEndOfFileEvent; - FOnStartFile : TOnStartFileEvent; - Protected - Procedure OpenInput; - Procedure CloseOutput; - Procedure CloseInput; - Procedure ReadZipHeader(Item : TZipItem; out ACRC : LongWord;out AMethod : Word); - Procedure ReadZipDirectory; - Procedure DoEndOfFile; - Procedure UnZipOneFile(Item : TZipItem); virtual; - Function OpenOutput(OutFileName : String) : Boolean; - Procedure SetBufSize(Value : LongWord); - Procedure SetFileName(Value : String); - Procedure SetOutputPath(Value:String); - Function CreateDeCompressor(Item : TZipItem; AMethod : Word;AZipFile,AOutFile : TStream) : TDeCompressor; virtual; - Public - Constructor Create; - Destructor Destroy;override; - Procedure UnZipAllFiles; virtual; - Procedure UnZipFiles(AFileName : String; FileList : TStrings); - Procedure UnZipAllFiles(AFileName : String); - Procedure Clear; - Public - Property BufferSize : LongWord Read FBufSize Write SetBufSize; - Property OnPercent : Integer Read FOnPercent Write FOnPercent; - Property OnProgress : TProgressEvent Read FOnProgress Write FOnProgress; - Property OnStartFile : TOnStartFileEvent Read FOnStartFile Write FOnStartFile; - Property OnEndFile : TOnEndOfFileEvent Read FOnEndOfFile Write FOnEndOfFile; - Property FileName : String Read FFileName Write SetFileName; - Property OutputPath : String Read FOutputPath Write SetOutputPath; - Property Files : TStrings Read FFiles; - end; - - EZipError = Class(Exception); - -Implementation - -ResourceString - SErrBufsizeChange = 'Changing buffer size is not allowed while (un)zipping'; - SErrFileChange = 'Changing output file name is not allowed while (un)zipping'; - SErrInvalidCRC = 'Invalid CRC checksum while unzipping %s'; - SErrCorruptZIP = 'Corrupt ZIP file %s'; - SErrUnsupportedCompressionFormat = 'Unsupported compression format %d'; - -{ --------------------------------------------------------------------- - Auxiliary - ---------------------------------------------------------------------} - -Procedure DateTimeToZipDateTime(DT : TDateTime; out ZD,ZT : Word); - -Var - Y,M,D,H,N,S,MS : Word; - -begin - DecodeDate(DT,Y,M,D); - DecodeTime(DT,H,N,S,MS); - Y:=Y-1980; - ZD:=d+(32*M)+(512*Y); - ZT:=(S div 2)+(32*N)+(2048*h); -end; - -Procedure ZipDateTimeToDateTime(ZD,ZT : Word;out DT : TDateTime); - -Var - Y,M,D,H,N,S,MS : Word; - -begin - MS:=0; - S:=(ZT and 31) shl 1; - N:=(ZT shr 5) and 63; - H:=(ZT shr 12) and 31; - D:=ZD and 31; - M:=(ZD shr 5) and 15; - Y:=((ZD shr 9) and 127)+1980; - DT:=ComposeDateTime(EncodeDate(Y,M,D),EncodeTime(H,N,S,MS)); -end; - -{ --------------------------------------------------------------------- - TDeCompressor - ---------------------------------------------------------------------} - - -Procedure TDeCompressor.UpdC32(Octet: Byte); - -Begin - FCrc32Val := Crc_32_Tab[Byte(FCrc32Val XOR LongInt(Octet))] XOR ((FCrc32Val SHR 8) AND $00FFFFFF); -end; - -constructor TDeCompressor.Create(AInFile, AOutFile: TStream; ABufSize: LongWord); -begin - FinFile:=AInFile; - FoutFile:=AOutFile; - FBufferSize:=ABufSize; - CRC32Val:=$FFFFFFFF; -end; - - -{ --------------------------------------------------------------------- - TCompressor - ---------------------------------------------------------------------} - - -Procedure TCompressor.UpdC32(Octet: Byte); - -Begin - FCrc32Val := Crc_32_Tab[Byte(FCrc32Val XOR LongInt(Octet))] XOR ((FCrc32Val SHR 8) AND $00FFFFFF); -end; - -constructor TCompressor.Create(AInFile, AOutFile: TStream; ABufSize: LongWord); -begin - FinFile:=AInFile; - FoutFile:=AOutFile; - FBufferSize:=ABufSize; - CRC32Val:=$FFFFFFFF; -end; - - -{ --------------------------------------------------------------------- - TDeflater - ---------------------------------------------------------------------} - -constructor TDeflater.Create(AInFile, AOutFile: TStream; ABufSize: LongWord); -begin - Inherited; - FCompressionLevel:=clDefault; -end; - - -procedure TDeflater.Compress; - -Var - Buf : PByte; - I,Count,NewCount : Integer; - C : TCompressionStream; - -begin - CRC32Val:=$FFFFFFFF; - Buf:=GetMem(FBufferSize); - Try - C:=TCompressionStream.Create(FCompressionLevel,FOutFile,True); - Try - Repeat - Count:=FInFile.Read(Buf^,FBufferSize); - For I:=0 to Count-1 do - UpdC32(Buf[i]); - NewCount:=Count; - While (NewCount>0) do - NewCount:=NewCount-C.Write(Buf^,NewCount); - Until (Count=0); - Finally - C.Free; - end; - Finally - FreeMem(Buf); - end; - Crc32Val:=NOT Crc32Val; -end; - -class function TDeflater.ZipID: Word; -begin - Result:=8; -end; - -{ --------------------------------------------------------------------- - TInflater - ---------------------------------------------------------------------} - -constructor TInflater.Create(AInFile, AOutFile: TStream; ABufSize: LongWord); -begin - Inherited; -end; - - -procedure TInflater.DeCompress; - -Var - Buf : PByte; - I,Count : Integer; - C : TDeCompressionStream; - -begin - CRC32Val:=$FFFFFFFF; - Buf:=GetMem(FBufferSize); - Try - C:=TDeCompressionStream.Create(FInFile,True); - Try - Repeat - Count:=C.Read(Buf^,FBufferSize); - For I:=0 to Count-1 do - UpdC32(Buf[i]); - FOutFile.Write(Buf^,Count); - Until (Count=0); - Finally - C.Free; - end; - Finally - FreeMem(Buf); - end; - Crc32Val:=NOT Crc32Val; -end; - -class function TInflater.ZipID: Word; -begin - Result:=8; -end; - - -{ --------------------------------------------------------------------- - TShrinker - ---------------------------------------------------------------------} - -Const - DefaultInMemSize = 256*1024; { Files larger than 256k are processed on disk } - DefaultBufSize = 16384; { Use 16K file buffers } - MINBITS = 9; { Starting code size of 9 bits } - MAXBITS = 13; { Maximum code size of 13 bits } - SPECIAL = 256; { Special function code } - INCSIZE = 1; { Code indicating a jump in code size } - CLEARCODE = 2; { Code indicating code table has been cleared } - STDATTR = $23; { Standard file attribute for DOS Find First/Next } - -constructor TShrinker.Create(AInFile, AOutFile : TStream; ABufSize : LongWord); -begin - Inherited; - FBufSize:=ABufSize; - InBuf:=GetMem(FBUFSIZE); - OutBuf:=GetMem(FBUFSIZE); - CodeTable:=GetMem(SizeOf(CodeTable^)); - FreeList:=GetMem(SizeOf(FreeList^)); -end; - -destructor TShrinker.Destroy; -begin - FreeMem(CodeTable); - FreeMem(FreeList); - FreeMem(InBuf); - FreeMem(OutBuf); - inherited Destroy; -end; - -Procedure TShrinker.Compress; - -Var - OneString : String; - Remaining : Word; - -begin - BytesIn := 1; - BytesOut := 1; - InitializeCodeTable; - FillInputBuffer; - FirstCh:= TRUE; - Crc32Val:=$FFFFFFFF; - FOnBytes:=Round((FInFile.Size * FOnPercent) / 100); - While NOT InputEof do - begin - Remaining:=Succ(MaxInBufIdx - InBufIdx); - If Remaining>255 then - Remaining:=255; - If Remaining=0 then - FillInputBuffer - else - begin - SetLength(OneString,Remaining); - Move(InBuf[InBufIdx], OneString[1], Remaining); - Inc(InBufIdx, Remaining); - ProcessLine(OneString); - end; - end; - Crc32Val := NOT Crc32Val; - ProcessLine(''); -end; - -class function TShrinker.ZipID: Word; -begin - Result:=1; -end; - - -Procedure TShrinker.DoOnProgress(Const Pct: Double); - -begin - If Assigned(FOnProgress) then - FOnProgress(Self,Pct); -end; - - -Procedure TShrinker.FillInputBuffer; - -Begin - MaxInbufIDx:=FInfile.Read(InBuf[0], FBufSize); - If MaxInbufIDx=0 then - InputEof := TRUE - else - InputEOF := FALSE; - InBufIdx := 0; -end; - - -Procedure TShrinker.WriteOutputBuffer; -Begin - FOutFile.WriteBuffer(OutBuf[0], OutBufIdx); - OutBufIdx := 0; -end; - - -Procedure TShrinker.PutChar(B : Byte); - -Begin - OutBuf[OutBufIdx] := B; - Inc(OutBufIdx); - If OutBufIdx>=FBufSize then - WriteOutputBuffer; - Inc(BytesOut); -end; - -Procedure TShrinker.FlushOutput; -Begin - If OutBufIdx>0 then - WriteOutputBuffer; -End; - - -procedure TShrinker.PutCode(Code : Smallint); - -var - ACode : LongInt; - XSize : Smallint; - -begin - if (Code=-1) then - begin - if BitsUsed>0 then - PutChar(SaveByte); - end - else - begin - ACode := Longint(Code); - XSize := CodeSize+BitsUsed; - ACode := (ACode shl BitsUsed) or SaveByte; - while (XSize div 8) > 0 do - begin - PutChar(Lo(ACode)); - ACode := ACode shr 8; - Dec(XSize,8); - end; - BitsUsed := XSize; - SaveByte := Lo(ACode); - end; -end; - - -Procedure TShrinker.InitializeCodeTable; - -Var - I : Word; -Begin - For I := 0 to TableSize do - begin - With CodeTable^[I] do - begin - Child := -1; - Sibling := -1; - If (I<=255) then - Suffix := I; - end; - If (I>=257) then - FreeList^[I] := I; - end; - NextFree := FIRSTENTRY; - TableFull := FALSE; -end; - - -Procedure TShrinker.Prune(Parent : Word); - -Var - CurrChild : Smallint; - NextSibling : Smallint; -Begin - CurrChild := CodeTable^[Parent].Child; - { Find first Child that has descendants .. clear any that don't } - While (CurrChild <> -1) AND (CodeTable^[CurrChild].Child = -1) do - begin - CodeTable^[Parent].Child := CodeTable^[CurrChild].Sibling; - CodeTable^[CurrChild].Sibling := -1; - { Turn on ClearList bit to indicate a cleared entry } - ClearList[CurrChild DIV 8] := (ClearList[CurrChild DIV 8] OR (1 SHL (CurrChild MOD 8))); - CurrChild := CodeTable^[Parent].Child; - end; - If CurrChild <> -1 then - begin { If there are any children left ...} - Prune(CurrChild); - NextSibling := CodeTable^[CurrChild].Sibling; - While NextSibling <> -1 do - begin - If CodeTable^[NextSibling].Child = -1 then - begin - CodeTable^[CurrChild].Sibling := CodeTable^[NextSibling].Sibling; - CodeTable^[NextSibling].Sibling := -1; - { Turn on ClearList bit to indicate a cleared entry } - ClearList[NextSibling DIV 8] := (ClearList[NextSibling DIV 8] OR (1 SHL (NextSibling MOD 8))); - NextSibling := CodeTable^[CurrChild].Sibling; - end - else - begin - CurrChild := NextSibling; - Prune(CurrChild); - NextSibling := CodeTable^[CurrChild].Sibling; - end; - end; - end; -end; - - -Procedure TShrinker.Clear_Table; -Var - Node : Word; -Begin - FillChar(ClearList, SizeOf(ClearList), $00); - For Node := 0 to 255 do - Prune(Node); - NextFree := Succ(TABLESIZE); - For Node := TABLESIZE downto FIRSTENTRY do - begin - If (ClearList[Node DIV 8] AND (1 SHL (Node MOD 8))) <> 0 then - begin - Dec(NextFree); - FreeList^[NextFree] := Node; - end; - end; - If NextFree <= TABLESIZE then - TableFull := FALSE; -end; - - -Procedure TShrinker.Table_Add(Prefix : Word; Suffix : Byte); -Var - FreeNode : Word; -Begin - If NextFree <= TABLESIZE then - begin - FreeNode := FreeList^[NextFree]; - Inc(NextFree); - CodeTable^[FreeNode].Child := -1; - CodeTable^[FreeNode].Sibling := -1; - CodeTable^[FreeNode].Suffix := Suffix; - If CodeTable^[Prefix].Child = -1 then - CodeTable^[Prefix].Child := FreeNode - else - begin - Prefix := CodeTable^[Prefix].Child; - While CodeTable^[Prefix].Sibling <> -1 do - Prefix := CodeTable^[Prefix].Sibling; - CodeTable^[Prefix].Sibling := FreeNode; - end; - end; - if NextFree > TABLESIZE then - TableFull := TRUE; -end; - -function TShrinker.Table_Lookup( TargetPrefix : Smallint; - TargetSuffix : Byte; - Out FoundAt : Smallint ) : Boolean; - -var TempPrefix : Smallint; - -begin - TempPrefix := TargetPrefix; - Table_lookup := False; - if CodeTable^[TempPrefix].Child <> -1 then - begin - TempPrefix := CodeTable^[TempPrefix].Child; - repeat - if CodeTable^[TempPrefix].Suffix = TargetSuffix then - begin - Table_lookup := True; - break; - end; - if CodeTable^[TempPrefix].Sibling = -1 then - break; - TempPrefix := CodeTable^[TempPrefix].Sibling; - until False; - end; - if Table_Lookup then - FoundAt := TempPrefix - else - FoundAt := -1; -end; - -Procedure TShrinker.Shrink(Suffix : Smallint); - -Const - LastCode : Smallint = 0; - -Var - WhereFound : Smallint; - -Begin - If FirstCh then - begin - SaveByte := $00; - BitsUsed := 0; - CodeSize := MINBITS; - MaxCode := (1 SHL CodeSize) - 1; - LastCode := Suffix; - FirstCh := FALSE; - end - else - begin - If Suffix <> -1 then - begin - If TableFull then - begin - Putcode(LastCode); - PutCode(SPECIAL); - Putcode(CLEARCODE); - Clear_Table; - Table_Add(LastCode, Suffix); - LastCode := Suffix; - end - else - begin - If Table_Lookup(LastCode, Suffix, WhereFound) then - begin - LastCode := WhereFound; - end - else - begin - PutCode(LastCode); - Table_Add(LastCode, Suffix); - LastCode := Suffix; - If (FreeList^[NextFree] > MaxCode) and (CodeSize < MaxBits) then - begin - PutCode(SPECIAL); - PutCode(INCSIZE); - Inc(CodeSize); - MaxCode := (1 SHL CodeSize) -1; - end; - end; - end; - end - else - begin - PutCode(LastCode); - PutCode(-1); - FlushOutput; - end; - end; -end; - -Procedure TShrinker.ProcessLine(Const Source : String); - -Var - I : Word; - -Begin - If Source = '' then - Shrink(-1) - else - For I := 1 to Length(Source) do - begin - Inc(BytesIn); - If (Pred(BytesIn) MOD FOnBytes) = 0 then - DoOnProgress(100 * ( BytesIn / FInFile.Size)); - UpdC32(Ord(Source[I])); - Shrink(Ord(Source[I])); - end; -end; - -{ --------------------------------------------------------------------- - TZipper - ---------------------------------------------------------------------} - - -Procedure TZipper.GetFileInfo; - -Var - Info : TSearchRec; - I : Longint; - NewNode : TZipItem; - - -Begin - For I := 0 to FFiles.Count-1 do - begin - If FindFirst(FFiles[I], STDATTR, Info)=0 then - try - NewNode:=TZipItem.Create; - NewNode.Path := ExtractFilePath(FFiles[i]); - NewNode.Name := Info.Name; - NewNode.Size := Info.Size; - NewNode.DateTime:=FileDateToDateTime(Info.Time); - FFiles.Objects[i]:=NewNode; - finally - FindClose(Info); - end; - end; -end; - -Procedure TZipper.OpenOutput; - -Begin - FOutFile:=TFileStream.Create(FFileName,fmCreate); -End; - - -Function TZipper.OpenInput(InFileName : String) : Boolean; - -Begin - FInFile:=TFileStream.Create(InFileName,fmOpenRead); - Result:=True; - If Assigned(FOnStartFile) then - FOnStartFile(Self,InFileName); -End; - - -Procedure TZipper.CloseOutput; - -Begin - FreeAndNil(FOutFile); -end; - - -Procedure TZipper.CloseInput; - -Begin - FreeAndNil(FInFile); -end; - - -Procedure TZipper.StartZipFile(Item : TZipItem); - -Begin - FillChar(LocalHdr,SizeOf(LocalHdr),0); - With LocalHdr do - begin - Signature := LOCAL_FILE_HEADER_SIGNATURE; - Extract_Version_Reqd := 10; - Bit_Flag := 0; - Compress_Method := 1; - DateTimeToZipDateTime(Item.DateTime,Last_Mod_Date,Last_Mod_Time); - Crc32 := 0; - Compressed_Size := 0; - Uncompressed_Size := Item.Size; - FileName_Length := 0; - Extra_Field_Length := 0; - end ; -End; - - -Function TZipper.UpdateZipHeader(Item : TZipItem; FZip : TStream; ACRC : LongWord; AMethod : Word) : Boolean; -var - ZFileName : ShortString; -Begin - ZFileName:=Item.Path+Item.Name; - With LocalHdr do - begin - FileName_Length := Length(ZFileName); - Compressed_Size := FZip.Size; - Crc32 := ACRC; - Compress_method:=AMethod; - Result:=Not (Compressed_Size >= Uncompressed_Size); - If Not Result then - begin { No... } - Compress_Method := 0; { ...change stowage type } - Compressed_Size := Uncompressed_Size; { ...update compressed size } - end; - end; - FOutFile.WriteBuffer(LocalHdr,SizeOf(LocalHdr)); - FOutFile.WriteBuffer(ZFileName[1],Length(ZFileName)); -End; - - -Procedure TZipper.BuildZipDirectory; - -Var - SavePos : LongInt; - HdrPos : LongInt; - CenDirPos : LongInt; - Entries : Word; - ZFileName : ShortString; - -Begin - Entries := 0; - CenDirPos := FOutFile.Position; - FOutFile.Seek(0,soFrombeginning); { Rewind output file } - HdrPos := FOutFile.Position; - FOutFile.ReadBuffer(LocalHdr, SizeOf(LocalHdr)); - Repeat - SetLength(ZFileName,LocalHdr.FileName_Length); - FOutFile.ReadBuffer(ZFileName[1], LocalHdr.FileName_Length); - SavePos := FOutFile.Position; - FillChar(CentralHdr,SizeOf(CentralHdr),0); - With CentralHdr do - begin - Signature := CENTRAL_FILE_HEADER_SIGNATURE; - MadeBy_Version := LocalHdr.Extract_Version_Reqd; - Move(LocalHdr.Extract_Version_Reqd, Extract_Version_Reqd, 26); - Last_Mod_Time:=localHdr.Last_Mod_Time; - Last_Mod_Date:=localHdr.Last_Mod_Date; - File_Comment_Length := 0; - Starting_Disk_Num := 0; - Internal_Attributes := 0; - External_Attributes := faARCHIVE; - Local_Header_Offset := HdrPos; - end; - FOutFile.Seek(0,soFromEnd); - FOutFile.WriteBuffer(CentralHdr,SizeOf(CentralHdr)); - FOutFile.WriteBuffer(ZFileName[1],Length(ZFileName)); - Inc(Entries); - FOutFile.Seek(SavePos + LocalHdr.Compressed_Size,soFromBeginning); - HdrPos:=FOutFile.Position; - FOutFile.ReadBuffer(LocalHdr, SizeOf(LocalHdr)); - Until LocalHdr.Signature = CENTRAL_FILE_HEADER_SIGNATURE; - FOutFile.Seek(0,soFromEnd); - FillChar(EndHdr,SizeOf(EndHdr),0); - With EndHdr do - begin - Signature := END_OF_CENTRAL_DIR_SIGNATURE; - Disk_Number := 0; - Central_Dir_Start_Disk := 0; - Entries_This_Disk := Entries; - Total_Entries := Entries; - Central_Dir_Size := FOutFile.Size-CenDirPos; - Start_Disk_Offset := CenDirPos; - ZipFile_Comment_Length := 0; - FOutFile.WriteBuffer(EndHdr, SizeOf(EndHdr)); - end; -end; - -Function TZipper.CreateCompressor(Item : TZipItem; AInFile,AZipStream : TStream) : TCompressor; - -begin - Result:=TDeflater.Create(AinFile,AZipStream,FBufSize); -end; - -Procedure TZipper.ZipOneFile(Item : TZipItem); - -Var - CRC : LongWord; - ZMethod : Word; - ZipStream : TStream; - TmpFileName : String; - -Begin - OpenInput(Item.Path+Item.Name); - Try - StartZipFile(Item); - If (FInfile.Size<=FInMemSize) then - ZipStream:=TMemoryStream.Create - else - begin - TmpFileName:=ChangeFileExt(FFileName,'.tmp'); - ZipStream:=TFileStream.Create(TmpFileName,fmCreate); - end; - Try - With CreateCompressor(Item, FinFile,ZipStream) do - Try - OnProgress:=Self.OnProgress; - OnPercent:=Self.OnPercent; - Compress; - CRC:=Crc32Val; - ZMethod:=ZipID; - Finally - Free; - end; - If UpdateZipHeader(Item,ZipStream,CRC,ZMethod) then - // Compressed file smaller than original file. - FOutFile.CopyFrom(ZipStream,0) - else - begin - // Original file smaller than compressed file. - FInfile.Seek(0,soFromBeginning); - FOutFile.CopyFrom(FInFile,0); - end; - finally - ZipStream.Free; - If (TmpFileName<>'') then - DeleteFile(TmpFileName); - end; - Finally - CloseInput; - end; -end; - -Procedure TZipper.ZipAllFiles; -Var - Item : TZipItem; - I : Integer; - filecnt : integer; -Begin - if FFiles.Count=0 then - exit; - FZipping:=True; - Try - GetFileInfo; - OpenOutput; - Try - filecnt:=0; - For I:=0 to FFiles.Count-1 do - begin - Item:=FFiles.Objects[i] as TZipItem; - if assigned(Item) then - begin - ZipOneFile(Item); - inc(filecnt); - end; - end; - if filecnt>0 then - BuildZipDirectory; - finally - CloseOutput; - end; - finally - FZipping:=False; - end; -end; - - -Procedure TZipper.SetBufSize(Value : LongWord); - -begin - If FZipping then - Raise EZipError.Create(SErrBufsizeChange); - If Value>=DefaultBufSize then - FBufSize:=Value; -end; - -Procedure TZipper.SetFileName(Value : String); - -begin - If FZipping then - Raise EZipError.Create(SErrFileChange); - FFileName:=Value; -end; - -Procedure TZipper.ZipFiles(AFileName : String; FileList : TStrings); - -begin - FFiles.Assign(FileList); - FFileName:=AFileName; - ZipAllFiles; -end; - -Procedure TZipper.DoEndOfFile; - -Var - ComprPct : Double; - -begin - If (LocalHdr.Uncompressed_Size>0) then - ComprPct := (100.0 * (LocalHdr.Uncompressed_Size - LocalHdr.Compressed_Size)) / LocalHdr.Uncompressed_Size - else - ComprPct := 0; - If Assigned(FOnEndOfFile) then - FOnEndOfFile(Self,ComprPct); -end; - -Constructor TZipper.Create; - -begin - FBufSize:=DefaultBufSize; - FInMemSize:=DefaultInMemSize; - FFiles:=TStringList.Create; - TStringlist(FFiles).Sorted:=True; - FOnPercent:=1; -end; - -Procedure TZipper.Clear; - -Var - I : Integer; - -begin - For I:=0 to FFiles.Count-1 do - FFiles.Objects[i].Free; - FFiles.Clear; -end; - -Destructor TZipper.Destroy; - -begin - Clear; - FreeAndNil(FFiles); - Inherited; -end; - - -{ --------------------------------------------------------------------- - TUnZipper - ---------------------------------------------------------------------} - -Procedure TUnZipper.OpenInput; - -Begin - FZipFile:=TFileStream.Create(FFileName,fmOpenRead); -End; - - -Function TUnZipper.OpenOutput(OutFileName : String) : Boolean; - -Begin - FOutFile:=TFileStream.Create(OutFileName,fmCreate); - Result:=True; - If Assigned(FOnStartFile) then - FOnStartFile(Self,OutFileName); -End; - - -Procedure TUnZipper.CloseOutput; - -Begin - FreeAndNil(FOutFile); -end; - - -Procedure TUnZipper.CloseInput; - -Begin - FreeAndNil(FZipFile); -end; - - -Procedure TUnZipper.ReadZipHeader(Item : TZipItem; out ACRC : LongWord; out AMethod : Word); - -Begin - FZipFile.Seek(Item.HdrPos,soFromBeginning); - FZipFile.ReadBuffer(LocalHdr,SizeOf(LocalHdr)); - With LocalHdr do - begin - SetLength(Item.Name,Filename_Length); - FZipFile.ReadBuffer(Item.Name[1],Filename_Length); - FZipFile.Seek(Extra_Field_Length,soCurrent); - Item.Size:=Uncompressed_Size; - ZipDateTimeToDateTime(Last_Mod_Date,Last_Mod_Time,Item.DateTime); - ACrc:=Crc32; - AMethod:=Compress_method; - end; -End; - - -Procedure TUnZipper.ReadZipDirectory; - -Var - i, - EndHdrPos, - CenDirPos : LongInt; - NewNode : TZipItem; -Begin - EndHdrPos:=FZipFile.Size-SizeOf(EndHdr); - if EndHdrPos < 0 then - raise EZipError.CreateFmt(SErrCorruptZIP,[FZipFile.FileName]); - FZipFile.Seek(EndHdrPos,soFromBeginning); - FZipFile.ReadBuffer(EndHdr, SizeOf(EndHdr)); - With EndHdr do - begin - if Signature <> END_OF_CENTRAL_DIR_SIGNATURE then - raise EZipError.CreateFmt(SErrCorruptZIP,[FZipFile.FileName]); - CenDirPos:=Start_Disk_Offset; - end; - FZipFile.Seek(CenDirPos,soFrombeginning); - for i:=0 to EndHdr.Entries_This_Disk-1 do - begin - FZipFile.ReadBuffer(CentralHdr, SizeOf(CentralHdr)); - With CentralHdr do - begin - if Signature<>CENTRAL_FILE_HEADER_SIGNATURE then - raise EZipError.CreateFmt(SErrCorruptZIP,[FZipFile.FileName]); - NewNode:=TZipItem.Create; - NewNode.HdrPos := Local_Header_Offset; - SetLength(NewNode.Name,Filename_Length); - FZipFile.ReadBuffer(NewNode.Name[1],Filename_Length); - FZipFile.Seek(Extra_Field_Length+File_Comment_Length,soCurrent); - FZipEntries.Add(NewNode); - end; - end; -end; - -Function TUnZipper.CreateDeCompressor(Item : TZipItem; AMethod : Word;AZipFile,AOutFile : TStream) : TDeCompressor; -var - Count : Int64; -begin - case AMethod of - 8 : - Result:=TInflater.Create(AZipFile,AOutFile,FBufSize); - else - raise EZipError.CreateFmt(SErrUnsupportedCompressionFormat,[AMethod]); - end; -end; - -Procedure TUnZipper.UnZipOneFile(Item : TZipItem); - -Var - Count : Longint; - CRC : LongWord; - ZMethod : Word; - OutputFileName : string; -Begin - Try - ReadZipHeader(Item,CRC,ZMethod); - OutputFileName:=Item.Name; - if FOutputPath<>'' then - OutputFileName:=IncludeTrailingPathDelimiter(FOutputPath)+OutputFileName; - OpenOutput(OutputFileName); - if ZMethod=0 then - begin - Count:=FOutFile.CopyFrom(FZipFile,LocalHdr.Compressed_Size); -{$warning TODO: Implement CRC Check} - end - else - With CreateDecompressor(Item, ZMethod, FZipFile, FOutFile) do - Try - OnProgress:=Self.OnProgress; - OnPercent:=Self.OnPercent; - DeCompress; - if CRC<>Crc32Val then - raise EZipError.CreateFmt(SErrInvalidCRC,[Item.Name]); - Finally - Free; - end; - Finally - CloseOutput; - end; -end; - - -Procedure TUnZipper.UnZipAllFiles; -Var - Item : TZipItem; - I : Integer; - -Begin - FUnZipping:=True; - Try - OpenInput; - Try - ReadZipDirectory; - For I:=0 to FZipEntries.Count-1 do - begin - Item:=FZipEntries[i] as TZipItem; - if (FFiles=nil) or - (FFiles.IndexOf(Item.Name)<>-1) then - UnZipOneFile(Item); - end; - Finally - CloseInput; - end; - finally - FUnZipping:=False; - end; -end; - - -Procedure TUnZipper.SetBufSize(Value : LongWord); - -begin - If FUnZipping then - Raise EZipError.Create(SErrBufsizeChange); - If Value>=DefaultBufSize then - FBufSize:=Value; -end; - -Procedure TUnZipper.SetFileName(Value : String); - -begin - If FUnZipping then - Raise EZipError.Create(SErrFileChange); - FFileName:=Value; -end; - -Procedure TUnZipper.SetOutputPath(Value:String); -begin - If FUnZipping then - Raise EZipError.Create(SErrFileChange); - FOutputPath:=Value; -end; - -Procedure TUnZipper.UnZipFiles(AFileName : String; FileList : TStrings); - -begin - FFiles.Assign(FileList); - FFileName:=AFileName; - UnZipAllFiles; -end; - -Procedure TUnZipper.UnZipAllFiles(AFileName : String); - -begin - FFileName:=AFileName; - UnZipAllFiles; -end; - -Procedure TUnZipper.DoEndOfFile; - -Var - ComprPct : Double; - -begin - If (LocalHdr.Uncompressed_Size>0) then - ComprPct := (100.0 * (LocalHdr.Uncompressed_Size - LocalHdr.Compressed_Size)) / LocalHdr.Uncompressed_Size - else - ComprPct := 0; - If Assigned(FOnEndOfFile) then - FOnEndOfFile(Self,ComprPct); -end; - -Constructor TUnZipper.Create; - -begin - FBufSize:=DefaultBufSize; - FFiles:=TStringList.Create; - FZipEntries:=TFPObjectList.Create(true); - TStringlist(FFiles).Sorted:=True; - FOnPercent:=1; -end; - -Procedure TUnZipper.Clear; - -Var - I : Integer; - -begin - For I:=0 to FFiles.Count-1 do - FFiles.Objects[i].Free; - FFiles.Clear; - FZipEntries.Clear; -end; - -Destructor TUnZipper.Destroy; - -begin - Clear; - FreeAndNil(FFiles); - FreeAndNil(FZipEntries); - Inherited; -end; - -End. diff --git a/utils/fppkg/fcl20/zstream.pp b/utils/fppkg/fcl20/zstream.pp deleted file mode 100755 index 6246fa0234..0000000000 --- a/utils/fppkg/fcl20/zstream.pp +++ /dev/null @@ -1,440 +0,0 @@ -{ - This file is part of the Free Pascal run time library. - Copyright (c) 1999-2000 by the Free Pascal development team - - Implementation of compression streams. - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} -{$mode objfpc} - -unit zstream; - - -{ --------------------------------------------------------------------- - For linux and freebsd it's also possible to use ZLib instead - of paszlib. You need to undefine 'usepaszlib'. - ---------------------------------------------------------------------} - -{$define usepaszlib} - - -interface - -uses - Sysutils, Classes -{$ifdef usepaszlib} - ,paszlib,zbase -{$else} - ,zlib -{$endif} - ; - -{$H+} - -type - // Error reporting. - EZlibError = class(EStreamError); - ECompressionError = class(EZlibError); - EDecompressionError = class(EZlibError); - - TCustomZlibStream = class(TOwnerStream) - private - FStrmPos: Integer; - FOnProgress: TNotifyEvent; - FZRec: TZStream; - FBuffer: array [Word] of Byte; - protected - procedure Progress(Sender: TObject); dynamic; - property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; - public - constructor Create(Strm: TStream); - end; - - TCompressionLevel = (clNone, clFastest, clDefault, clMax); - - TCompressionStream = class(TCustomZlibStream) - private - function GetCompressionRate: extended; - function CompressionCheck(code: Integer): Integer; - procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; - var OutBuf: Pointer; var OutBytes: Integer); - public - constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream; ASkipHeader : Boolean = False); - destructor Destroy; override; - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - property CompressionRate: extended read GetCompressionRate; - property OnProgress; - end; - - TDecompressionStream = class(TCustomZlibStream) - private - function DecompressionCheck(code: Integer): Integer; - procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; - OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer); - public - constructor Create(ASource: TStream; ASkipHeader : Boolean = False); - destructor Destroy; override; - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - property OnProgress; - end; - - TGZOpenMode = (gzOpenRead,gzOpenWrite); - - TGZFileStream = Class(TStream) - Private - FOpenMode : TGZOpenmode; - FFIle : gzfile; - Public - Constructor Create(FileName: String;FileMode: TGZOpenMode); - Destructor Destroy;override; - Function Read(Var Buffer; Count : longint): longint;override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - end; - - -implementation - -Const - ErrorStrings : array [0..6] of string = - ('Unknown error %d','Z_ERRNO','Z_STREAM_ERROR', - 'Z_DATA_ERROR','Z_MEM_ERROR','Z_BUF_ERROR','Z_VERSION_ERROR'); - SCouldntOpenFile = 'Couldn''t open file : %s'; - SReadOnlyStream = 'Decompression streams are read-only'; - SWriteOnlyStream = 'Compression streams are write-only'; - SSeekError = 'Compression stream seek error'; - SInvalidSeek = 'Invalid Compression seek operation'; - -procedure TCompressionStream.CompressBuf(const InBuf: Pointer; InBytes: Integer; - var OutBuf: Pointer; var OutBytes: Integer); -var - strm: TZStream; - P: Pointer; -begin - FillChar(strm, sizeof(strm), 0); - OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255; - OutBuf:=GetMem(OutBytes); - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; - CompressionCheck(deflateInit(strm, Z_BEST_COMPRESSION)); - try - while CompressionCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do - begin - P := OutBuf; - Inc(OutBytes, 256); - ReallocMem(OutBuf,OutBytes); - strm.next_out := PByte(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); - strm.avail_out := 256; - end; - finally - CompressionCheck(deflateEnd(strm)); - end; - ReallocMem(OutBuf,strm.total_out); - OutBytes := strm.total_out; - except - FreeMem(OutBuf); - raise; - end; -end; - - -procedure TDecompressionStream.DecompressBuf(const InBuf: Pointer; InBytes: Integer; - OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer); -var - strm: TZStream; - P: Pointer; - BufInc: Integer; -Type - PByte = ^Byte; -begin - FillChar(strm, sizeof(strm), 0); - BufInc := (InBytes + 255) and not 255; - if OutEstimate = 0 then - OutBytes := BufInc - else - OutBytes := OutEstimate; - OutBuf:=GetMem(OutBytes); - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; - DecompressionCheck(inflateInit(strm)); - try - while DecompressionCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END do - begin - P := OutBuf; - Inc(OutBytes, BufInc); - ReallocMem(OutBuf, OutBytes); - strm.next_out := PByte(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); - strm.avail_out := BufInc; - end; - finally - DecompressionCheck(inflateEnd(strm)); - end; - ReallocMem(OutBuf, strm.total_out); - OutBytes := strm.total_out; - except - FreeMem(OutBuf); - raise; - end; -end; - - -// TCustomZlibStream - -constructor TCustomZLibStream.Create(Strm: TStream); -begin - inherited Create(Strm); - FStrmPos := Strm.Position; -end; - -procedure TCustomZLibStream.Progress(Sender: TObject); -begin - if Assigned(FOnProgress) then FOnProgress(Sender); -end; - - -// TCompressionStream - -constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel; - Dest: TStream; ASkipHeader : Boolean = False); -const - Levels: array [TCompressionLevel] of ShortInt = - (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION); -begin - inherited Create(Dest); - FZRec.next_out := @FBuffer[0]; - FZRec.avail_out := sizeof(FBuffer); - If ASkipHeader then - CompressionCheck(deflateInit2(FZRec, Levels[CompressionLevel],Z_DEFLATED, -MAX_WBITS, DEF_MEM_LEVEL, 0)) - else - CompressionCheck(deflateInit(FZRec, Levels[CompressionLevel])); -end; - -destructor TCompressionStream.Destroy; -begin - FZRec.next_in := nil; - FZRec.avail_in := 0; - try - if Source.Position <> FStrmPos then Source.Position := FStrmPos; - while (CompressionCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END) - and (FZRec.avail_out = 0) do - begin - Source.WriteBuffer(FBuffer, sizeof(FBuffer)); - FZRec.next_out := @FBuffer[0]; - FZRec.avail_out := sizeof(FBuffer); - end; - if FZRec.avail_out < sizeof(FBuffer) then - Source.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out); - finally - deflateEnd(FZRec); - end; - inherited Destroy; -end; - -function TCompressionStream.CompressionCheck(code: Integer): Integer; -begin - Result := code; - if (code < 0) then - if code < -6 then - raise ECompressionError.CreateFmt(Errorstrings[0],[Code]) - else - raise ECompressionError.Create(ErrorStrings[Abs(Code)]); -end; - - -function TCompressionStream.Read(var Buffer; Count: Longint): Longint; -begin - raise ECompressionError.Create('Invalid stream operation'); - result:=0; -end; - -function TCompressionStream.Write(const Buffer; Count: Longint): Longint; -begin - FZRec.next_in := @Buffer; - FZRec.avail_in := Count; - if Source.Position <> FStrmPos then Source.Position := FStrmPos; - while (FZRec.avail_in > 0) do - begin - CompressionCheck(deflate(FZRec, 0)); - if FZRec.avail_out = 0 then - begin - Source.WriteBuffer(FBuffer, sizeof(FBuffer)); - FZRec.next_out := @FBuffer[0]; - FZRec.avail_out := sizeof(FBuffer); - FStrmPos := Source.Position; - Progress(Self); - end; - end; - Result := Count; -end; - -function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint; -begin - if (Offset = 0) and (Origin = soFromCurrent) then - Result := FZRec.total_in - else - raise ECompressionError.Create(SInvalidSeek); -end; - -function TCompressionStream.GetCompressionRate: extended; -begin - Result:=0.0; -{ With FZrec do - if total_in = 0 then - GetCompressionRate:=0.0 - else - GetCompressionRate:=1.0E2*(1.0E0-(total_out/total_in)); -} -end; - - -// TDecompressionStream - -constructor TDecompressionStream.Create(ASource: TStream; ASkipHeader : Boolean = False); -begin - inherited Create(ASource); - FZRec.next_in := @FBuffer[0]; - If ASkipHeader then - DeCompressionCheck(inflateInit2(FZRec,-MAX_WBITS)) - else - DeCompressionCheck(inflateInit(FZRec)); -end; - -destructor TDecompressionStream.Destroy; -begin - if FZRec.avail_in <> 0 then - Source.Seek(-FZRec.avail_in, soFromCurrent); - inflateEnd(FZRec); - inherited Destroy; -end; - -function TDecompressionStream.DecompressionCheck(code: Integer): Integer; -begin - Result := code; - If Code<0 then - if code < -6 then - raise EDecompressionError.CreateFmt(Errorstrings[0],[Code]) - else - raise EDecompressionError.Create(ErrorStrings[Abs(Code)]); -end; - -function TDecompressionStream.Read(var Buffer; Count: Longint): Longint; -begin - FZRec.next_out := @Buffer; - FZRec.avail_out := Count; - if Source.Position <> FStrmPos then Source.Position := FStrmPos; - while (FZRec.avail_out > 0) do - begin - if FZRec.avail_in = 0 then - begin - FZRec.avail_in := Source.Read(FBuffer, sizeof(FBuffer)); - if FZRec.avail_in = 0 then - begin - Result := Count - FZRec.avail_out; - Exit; - end; - FZRec.next_in := @FBuffer[0]; - FStrmPos := Source.Position; - Progress(Self); - end; - if DeCompressionCheck(inflate(FZRec, 0)) = Z_STREAM_END then - begin - Result := Count - FZRec.avail_out; - Exit; - end; - end; - Result := Count; -end; - -function TDecompressionStream.Write(const Buffer; Count: Longint): Longint; -begin - raise EDecompressionError.Create('Invalid stream operation'); - result:=0; -end; - -function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint; -var - I: Integer; - Buf: array [0..4095] of Char; -begin - if (Offset = 0) and (Origin = soFromBeginning) then - begin - DecompressionCheck(inflateReset(FZRec)); - FZRec.next_in := @FBuffer[0]; - FZRec.avail_in := 0; - Source.Position := 0; - FStrmPos := 0; - end - else if ( (Offset >= 0) and (Origin = soFromCurrent)) or - ( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then - begin - if Origin = soFromBeginning then Dec(Offset, FZRec.total_out); - if Offset > 0 then - begin - for I := 1 to Offset div sizeof(Buf) do - ReadBuffer(Buf, sizeof(Buf)); - ReadBuffer(Buf, Offset mod sizeof(Buf)); - end; - end - else - raise EDecompressionError.Create(SInvalidSeek); - Result := FZRec.total_out; -end; - -// TGZFileStream - -Constructor TGZFileStream.Create(FileName: String;FileMode: TGZOpenMode); - -Const OpenStrings : array[TGZOpenMode] of pchar = ('rb','wb'); - -begin - FOpenMode:=FileMode; - FFile:=gzopen (PChar(FileName),Openstrings[FileMode]); - If FFile=Nil then - Raise ezlibError.CreateFmt (SCouldntOpenFIle,[FileName]); -end; - -Destructor TGZFileStream.Destroy; -begin - gzclose(FFile); - Inherited Destroy; -end; - -Function TGZFileStream.Read(Var Buffer; Count : longint): longint; -begin - If FOpenMode=gzOpenWrite then - Raise ezliberror.create(SWriteOnlyStream); - Result:=gzRead(FFile,@Buffer,Count); -end; - -function TGZFileStream.Write(const Buffer; Count: Longint): Longint; -begin - If FOpenMode=gzOpenRead then - Raise EzlibError.Create(SReadonlyStream); - Result:=gzWrite(FFile,@Buffer,Count); -end; - -function TGZFileStream.Seek(Offset: Longint; Origin: Word): Longint; -begin - Result:=gzseek(FFile,Offset,Origin); - If Result=-1 then - Raise eZlibError.Create(SSeekError); -end; - -end.