Compare commits

..
18 Commits
Author SHA1 Message Date
dgp 0d1dc9780c merge Itk 3 2016-02-22 16:17:07 +00:00
dgp 339acd56d0 Backport fix for [8a022f72e7]. 2016-02-22 16:16:20 +00:00
dgp 91f69d62ce Bump to Itk 3.4.2 2016-02-16 20:08:46 +00:00
dgp 74d572d124 TEA update 2016-02-11 20:49:07 +00:00
dgp ab2b92a888 The Itk_ConfigOptionPartProc "Itk_PropagatePublicVar" can only work on
a scalar variable, so screen out array variables from having an ArchOptionPart
created.
2016-02-11 20:15:49 +00:00
dgp d3b395675c Make version demand in testing to avoid worst testing errors. 2015-12-10 18:50:30 +00:00
dgp 314ab41be8 Accept more Win native build improvements from Ralf Fassel. 2015-03-19 16:44:32 +00:00
dgp eb4468f65e Recover the rules.vc from CVS toplevel 2015-03-18 13:16:34 +00:00
dgp ba0d4a9bf3 merge release 2015-03-11 17:47:06 +00:00
dgp 0dfec72677 Accommodate the changed Tcl_GetHashKey() signature. 2015-01-26 16:56:19 +00:00
dgp 7bba62b94a Bump to Itk 3.4.1 for release. TEA update to use autoconf-2.69. 2015-01-07 14:53:55 +00:00
dgp f8f8061fa1 Purge RCS keywords and .cvsignore files 2011-04-20 14:56:16 +00:00
hobbs c08668adfb * itcl/Makefile.in, itk/Makefile.in (TCL_TOP_DIR_NATIVE): no longer
necessary for private header builds
2010-08-17 21:20:26 +00:00
hobbs 6ac755e0ee * itcl/Makefile.in, itcl/configure, itcl/configure.in:
* itk/Makefile.in, itk/configure, itk/configure.in:
        * configure, configure.in: update to TEA 3.9, regen with ac-2.59
2010-08-17 01:20:49 +00:00
andreas_kupries 5aeb446da4 * itcl/generic/itcl_cmds.c: Handle TIP#336 addition of API to access
* itcl/generic/itcl_ensemble.c: interp->errorLine.
	* itcl/generic/itclInt.h:
	* itcl/generic/itcl_methods.c:
	* itcl/generic/itcl_parse.c:
2008-12-15 20:02:58 +00:00
davygrvy ad0245d1e4 Itk can now load into a safe interp 2007-11-05 22:41:32 +00:00
davygrvy 548bc49665 made the test suite work 2007-11-05 22:35:17 +00:00
davygrvy 2aa842bb62 * makefile.vc:
* itcl/win/makefile.vc:
* itk/win/makefile.vc:  'depend' target added.
2007-11-03 17:57:16 +00:00
62 changed files with 11352 additions and 14284 deletions
-12
View File
@@ -1,12 +0,0 @@
*.a
*.bmp
*.dll
*.exe
*.gif
*.gz
*.jpg
*.lib
*.pdf
*.png
*.xlsx
*.zip
-18
View File
@@ -1,18 +0,0 @@
compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs
compat/zlib/contrib/vstudio/readme.txt
compat/zlib/contrib/vstudio/*/zlib.rc
compat/zlib/contrib/vstudio/*/*.sln
compat/zlib/win32/*.txt
compat/zlib/win64/*.txt
libtommath/*.dsp
libtommath/*.sln
libtommath/*.vcproj
tools/tcl.wse.in
win/buildall.vc.bat
win/coffbase.txt
win/makefile.vc
win/rules.vc
win/rules-ext.vc
win/targets.vc
win/tcl.dsp
win/tcl.dsw
-7
View File
@@ -1,7 +0,0 @@
tools/tcl.wse.in
win/buildall.vc.bat
win/coffbase.txt
win/makefile.vc
win/rules.vc
win/tcl.dsp
win/tcl.dsw
-29
View File
@@ -1,29 +0,0 @@
*.a
*.dll
*.dylib
*.dylib.E
*.exe
*.exp
*.la
*.lib
*.lo
*.o
*.obj
*.pdb
*.res
*.sl
*.so
Makefile
autom4te.cache
config.cache
config.log
config.status
itkConfig.sh
pkgIndex.tcl
versions.vc
version.vc
libitk.vfs
libitk_*.zip
html
win/nmakehlp.out
win/nmhlp-out.txt
-1
View File
@@ -1 +0,0 @@
u
-40
View File
@@ -1,40 +0,0 @@
# Set the default behavior, in case people don't have core.autocrlf set.
* eol=lf
* text=auto
# Explicitly declare text files you want to always be normalized and converted
# to native line endings on checkout.
*.3 text
*.c text
*.css text
*.enc text
*.h text
*.htm text
*.html text
*.java text
*.js text
*.json text
*.n text
*.svg text
*.ts text
*.tcl text
*.test text
# Declare files that will always have CRLF line endings on checkout.
*.bat eol=crlf
*.sln eol=crlf
*.vc eol=crlf
# Denote all files that are truly binary and should not be modified.
*.a binary
*.bmp binary
*.dll binary
*.exe binary
*.gif binary
*.gz binary
*.jpg binary
*.lib binary
*.pdf binary
*.png binary
*.xlsx binary
*.zip binary
-33
View File
@@ -1,33 +0,0 @@
*.a
*.bundle
*.dll
*.dylib
*.dylib.E
*.exe
*.exp
*.lib
*.o
*.obj
*.pdb
*.res
*.sl
*.so
.fslckout
Makefile
autom4te.cache
config.cache
config.log
config.status
config.status.lineno
html
manifest.uuid
_FOSSIL_
itkConfig.sh
pkgIndex.tcl
versions.vc
version.vc
libitk.vfs
libitk_*.zip
html
win/nmakehlp.out
win/nmhlp-out.txt
-27
View File
@@ -1,27 +0,0 @@
NOTICE: This ChangeLog is no longer being maintained. To examine
the series of changes checked into Itk sources, follow the Timeline
https://core.tcl.tk/itk/timeline
2014-09-07 Arnulf P. Wiedemann <wiede@users.sf.net>
* generic/itkArchetype.c: Fix for SF bug #253.
2013-02-03 Arnulf P. Wiedemann <wiede@users.sf.net>
* bumped version to 4.0.0 for release
* added tools directory
* Makefile.in: added genstubs tag for generating stubs entries
* generic/itkArchBase.c: fixed some param types to fit to itcl changes
2011-04-29 Arnulf P. Wiedemann <wiede@users.sf.net>
* configure, configure.in, generic/itk.h: Bump version to 4.0b6
2010-08-17 Jeff Hobbs <jeffh@ActiveState.com>
* configure, configure.in, generic/itk.h: Bump version to 4.0b5
* tclconfig/tcl.m4: full update to TEA 3.9
2007-09-08 Arnulf P. Wiedemann <wiede@users.sf.net>
* all new modules installed and added
This is the ChangeLog file for itcl-ng/itk
it is here as Itk and itcl-ng/itk will be different modules in the future
+132 -183
View File
@@ -7,24 +7,11 @@
# replaced in the actual Makefile.
#
# Copyright (c) 1999 Scriptics Corporation.
# Copyright (c) 2002-2005 ActiveState Corporation.
# Copyright (c) 2002-2004 ActiveState Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#========================================================================
# Add additional lines to handle any additional AC_SUBST cases that
# have been added in a customized configure script.
#========================================================================
#SAMPLE_NEW_VAR = @SAMPLE_NEW_VAR@
#========================================================================
# Nothing of the variables below this line should need to be changed.
# Please check the TARGETS section below to make sure the make targets
# are correct.
#========================================================================
#========================================================================
# The names of the source files is defined in the configure script.
# The object files are used for linking into the final library.
@@ -55,16 +42,40 @@ PKG_TCL_SOURCES = @PKG_TCL_SOURCES@
PKG_HEADERS = @PKG_HEADERS@
#========================================================================
# "PKG_LIB_FILE" refers to the library (dynamic or static as per
# configuration options) composed of the named objects.
# Nothing of the variables below this line should need to be changed.
# Please check the TARGETS section below to make sure the make targets
# are correct.
#========================================================================
itk_LIB_FILE = @itk_LIB_FILE@
itkstub_LIB_FILE = @itkstub_LIB_FILE@
itclstub_LIB_FILE = @itclstub_LIB_FILE@
#========================================================================
# Add additional lines to handle any additional AC_SUBST cases that
# have been added to the configure script.
#========================================================================
ITK_GENERIC_DIR_NATIVE = @ITK_GENERIC_DIR_NATIVE@
ITK_UNIX_DIR_NATIVE = @ITK_UNIX_DIR_NATIVE@
ITK_WIN_DIR_NATIVE = @ITK_WIN_DIR_NATIVE@
#========================================================================
# Nothing of the variables below this line need to be changed. Please
# check the TARGETS section below to make sure the make targets are
# correct.
#========================================================================
#========================================================================
# Change the name of the variable "exampleA_LIB_FILE" to match the one
# used in the configure script. This is the parameterized name of the
# library that we are building.
#========================================================================
PKG_LIB_FILE = @PKG_LIB_FILE@
PKG_LIB_FILE8 = @PKG_LIB_FILE8@
PKG_LIB_FILE9 = @PKG_LIB_FILE9@
PKG_STUB_LIB_FILE = @PKG_STUB_LIB_FILE@
lib_BINARIES = $(PKG_LIB_FILE) $(PKG_STUB_LIB_FILE)
lib_BINARIES = $(PKG_LIB_FILE)
BINARIES = $(lib_BINARIES)
SHELL = @SHELL@
@@ -75,11 +86,9 @@ exec_prefix = @exec_prefix@
bindir = @bindir@
libdir = @libdir@
includedir = @includedir@
datarootdir = @datarootdir@
runstatedir = @runstatedir@
datadir = @datadir@
mandir = @mandir@
includedir = @includedir@
DESTDIR =
@@ -88,21 +97,19 @@ pkgdatadir = $(datadir)/$(PKG_DIR)
pkglibdir = $(libdir)/$(PKG_DIR)
pkgincludedir = $(includedir)/$(PKG_DIR)
top_builddir = @abs_top_builddir@
top_builddir = .
INSTALL_OPTIONS =
INSTALL = @INSTALL@ $(INSTALL_OPTIONS)
INSTALL_DATA_DIR = @INSTALL_DATA_DIR@
INSTALL_DATA = @INSTALL_DATA@
INSTALL = @INSTALL@
INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_DATA = @INSTALL_DATA@
INSTALL_SCRIPT = @INSTALL_SCRIPT@
INSTALL_LIBRARY = @INSTALL_LIBRARY@
PACKAGE_NAME = @PACKAGE_NAME@
PACKAGE_VERSION = @PACKAGE_VERSION@
CC = @CC@
CFLAGS_DEFAULT = @CFLAGS_DEFAULT@
CFLAGS_WARNING = @CFLAGS_WARNING@
CLEANFILES = @CLEANFILES@
EXEEXT = @EXEEXT@
LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@
MAKE_LIB = @MAKE_LIB@
@@ -116,15 +123,14 @@ SHLIB_CFLAGS = @SHLIB_CFLAGS@
SHLIB_LD = @SHLIB_LD@
SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
STLIB_LD = @STLIB_LD@
#TCL_DEFS = @TCL_DEFS@
TCL_DEFS = @TCL_DEFS@
TCL_BIN_DIR = @TCL_BIN_DIR@
TCL_SRC_DIR = @TCL_SRC_DIR@
TK_SRC_DIR = @TK_SRC_DIR@
TK_BIN_DIR = @TK_BIN_DIR@
ITCL_TOOLS_DIR = @itcl_SRC_DIR@/tools
# Not used, but retained for reference of what libs Tcl required
#TCL_LIBS = @TCL_LIBS@
TCL_LIBS = @TCL_LIBS@
#========================================================================
# TCLLIBPATH seeds the auto_path in Tcl's init.tcl so we can test our
@@ -133,40 +139,27 @@ ITCL_TOOLS_DIR = @itcl_SRC_DIR@/tools
# require for testing here (like TCLX_LIBRARY).
#========================================================================
#EXTRA_PATH = $(top_builddir):$(TCL_BIN_DIR)
EXTRA_PATH = $(top_builddir):$(TCL_BIN_DIR):$(TK_BIN_DIR)
TCLLIBPATH = $(top_builddir) @itcl_BIN_DIR@
TCLSH_ENV = TCL_LIBRARY=`@CYGPATH@ $(TCL_SRC_DIR)/library`
PKG_ENV = @LD_LIBRARY_PATH_VAR@="$(EXTRA_PATH):$(@LD_LIBRARY_PATH_VAR@)" \
PATH="$(EXTRA_PATH):$(PATH)" \
TCLSH_ENV = TCL_LIBRARY=`@CYGPATH@ $(TCL_SRC_DIR)/library` \
TK_LIBRARY=`@CYGPATH@ $(TK_SRC_DIR)/library` \
ITCL_LIBRARY=`@CYGPATH@ @itcl_SRC_DIR@/library` \
ITK_LIBRARY=`@CYGPATH@ $(srcdir)/library` \
TCLLIBPATH="$(TCLLIBPATH)"
@LD_LIBRARY_PATH_VAR@="$(EXTRA_PATH):$(@LD_LIBRARY_PATH_VAR@)" \
PATH="$(EXTRA_PATH):$(PATH)" \
TCLLIBPATH="$(top_builddir) @itcl_BIN_DIR@"
TCLSH_PROG = @TCLSH_PROG@
TCLSH = $(TCLSH_ENV) $(PKG_ENV) $(TCLSH_PROG)
WISH_ENV = TK_LIBRARY=`@CYGPATH@ $(TK_SRC_DIR)/library`
WISH_PROG = @WISH_PROG@
WISH = $(PKG_ENV) $(TCLSH_ENV) $(WISH_ENV) $(WISH_PROG)
TCLSH = $(TCLSH_ENV) $(TCLSH_PROG)
WISH = $(TCLSH_ENV) $(WISH_PROG)
SHARED_BUILD = @SHARED_BUILD@
#INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@
INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@ @TK_INCLUDES@ @TK_XINCLUDES@
PKG_CFLAGS = @PKG_CFLAGS@
# TCL_DEFS is not strictly need here, but if you remove it, then you
# must make sure that configure.ac checks for the necessary components
# that your library may use. TCL_DEFS can actually be a problem if
# you do not compile with a similar machine setup as the Tcl core was
# compiled with.
#DEFS = $(TCL_DEFS) @DEFS@ $(PKG_CFLAGS)
DEFS = @DEFS@ $(PKG_CFLAGS) -DITK_LIBRARY=\"$(pkglibdir)\"
DEFS = @DEFS@ $(PKG_CFLAGS) \
-DITK_LIBRARY=\"$(pkglibdir)\" -DUSE_NON_CONST
CONFIG_CLEAN_FILES = @CONFIG_CLEAN_FILES@ Makefile itkConfig.sh pkgIndex.tcl
CLEANFILES = @CLEANFILES@
CPPFLAGS = @CPPFLAGS@
LIBS = @PKG_LIBS@ @LIBS@
@@ -174,20 +167,13 @@ AR = @AR@
CFLAGS = @CFLAGS@
COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
GDB = gdb
VALGRIND = valgrind
VALGRINDARGS = --tool=memcheck --num-callers=8 --leak-resolution=high \
--leak-check=yes --show-reachable=yes -v
.SUFFIXES: .c .$(OBJEXT)
#========================================================================
# Start of user-definable TARGETS section
#========================================================================
#========================================================================
# TEA TARGETS. Please note that the "libraries:" target refers to platform
# independent files, and the "binaries:" target includes executable programs and
# independent files, and the "binaries:" target inclues executable programs and
# platform-dependent libraries. Modify these targets so that they install
# the various pieces of your package. The make and install rules
# for the BINARIES that you specified above have already been done.
@@ -206,12 +192,6 @@ binaries: $(BINARIES)
libraries:
#========================================================================
# Your doc target should differentiate from doc builds (by the developer)
# and doc installs (see install-doc), which just install the docs on the
# end user machine when building from source.
#========================================================================
doc:
install: all install-binaries install-libraries install-doc
@@ -220,15 +200,14 @@ install-binaries: binaries install-lib-binaries install-bin-binaries
#========================================================================
# This rule installs platform-independent files, such as header files.
# The list=...; for p in $$list handles the empty list case x-platform.
#========================================================================
install-libraries: libraries
@$(INSTALL_DATA_DIR) "$(DESTDIR)$(includedir)"
@mkdir -p $(DESTDIR)$(includedir)
@echo "Installing header files in $(DESTDIR)$(includedir)"
@list='$(PKG_HEADERS)'; for i in $$list; do \
echo "Installing $(srcdir)/$$i" ; \
$(INSTALL_DATA) $(srcdir)/$$i "$(DESTDIR)$(includedir)" ; \
$(INSTALL_DATA) $(srcdir)/$$i $(DESTDIR)$(includedir) ; \
done;
#========================================================================
@@ -237,45 +216,27 @@ install-libraries: libraries
#========================================================================
install-doc: doc
@$(INSTALL_DATA_DIR) "$(DESTDIR)$(mandir)/mann"
@echo "Installing documentation in $(DESTDIR)$(mandir)"
@list='$(srcdir)/doc/*.n'; for i in $$list; do \
if test X"$$i" = X'$(srcdir)/doc/*.n'; then break; fi; \
bi=`basename $$i`; \
echo "Installing $$bi"; \
sed -e '/man\.macros/r $(srcdir)/doc/man.macros' -e '/man\.macros/d' $$i > $$bi.tmp \
&& $(INSTALL_DATA) $$bi.tmp "$(DESTDIR)$(mandir)/mann/$$bi" \
&& rm -f $$bi.tmp; \
@mkdir -p $(DESTDIR)$(mandir)/mann
@echo "Installing man pages in $(DESTDIR)$(mandir)"
@cd $(srcdir)/doc; for i in *.n; do \
echo "Installing $$i"; \
rm -f $(DESTDIR)$(mandir)/mann/`basename $$i`; \
sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
$$i > $(DESTDIR)$(mandir)/mann/$$i; \
chmod 444 $(DESTDIR)$(mandir)/mann/$$i; \
done
test: binaries libraries
$(WISH) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) -load "package require -exact itk $(PACKAGE_VERSION)"
$(WISH) `@CYGPATH@ $(srcdir)/tests/all.tcl` -load "package require Itk $(PACKAGE_VERSION)" $(TESTFLAGS) | cat
shell: binaries libraries
@$(WISH) $(SCRIPT)
gdb:
$(TCLSH_ENV) $(PKG_ENV) $(GDB) $(WISH_PROG) $(SCRIPT)
gdb-test: binaries libraries
$(TCLSH_ENV) $(PKG_ENV) $(GDB) \
--args $(WISH_PROG) `@CYGPATH@ $(srcdir)/tests/all.tcl` \
$(TESTFLAGS) -singleproc 1 \
-load "package ifneeded $(PACKAGE_NAME) $(PACKAGE_VERSION) \
[list load `@CYGPATH@ $(PKG_LIB_FILE)` $(PACKAGE_NAME)]"
valgrind: binaries libraries
$(TCLSH_ENV) $(PKG_ENV) $(VALGRIND) $(VALGRINDARGS) $(WISH_PROG) \
`@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS)
valgrindshell: binaries libraries
$(TCLSH_ENV) $(PKG_ENV) $(VALGRIND) $(VALGRINDARGS) $(WISH_PROG) $(SCRIPT)
$(TCLSH_ENV) gdb $(WISH_PROG) $(SCRIPT)
depend:
genstubs: $(ITCL_TOOLS_DIR)/genStubs.tcl $(srcdir)/generic/itk.decls
$(TCLSH) $(ITCL_TOOLS_DIR)/genStubs.tcl $(srcdir)/generic $(srcdir)/generic/itk.decls
#========================================================================
# $(PKG_LIB_FILE) should be listed as part of the BINARIES variable
# mentioned above. That will ensure that this target is built when you
@@ -303,79 +264,63 @@ $(PKG_STUB_LIB_FILE): $(PKG_STUB_OBJECTS)
# containing your extension. If your sources are in a subdirectory,
# you will have to modify the paths to reflect this:
#
# sample.$(OBJEXT): $(srcdir)/generic/sample.c
# $(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/sample.c` -o $@
# exampleA.$(OBJEXT): $(srcdir)/src/win/exampleA.c
# $(COMPILE) -c `@CYGPATH@ $(srcdir)/src/win/exampleA.c` -o $@
#
# Setting the VPATH variable to a list of paths will cause the makefile
# to look into these paths when resolving .c to .obj dependencies.
# As necessary, add $(srcdir):$(srcdir)/compat:....
#========================================================================
VPATH = $(srcdir):$(srcdir)/generic:$(srcdir)/unix:$(srcdir)/win:$(srcdir)/macosx
VPATH = $(srcdir)/unix:$(srcdir)/generic:$(srcdir)/win
.c.@OBJEXT@:
$(COMPILE) -c `@CYGPATH@ $<` -I. -o $@
itkBase.@OBJEXT@: itkUuid.h
$(srcdir)/manifest.uuid:
printf "git-" >$(srcdir)/manifest.uuid
(cd $(srcdir); git rev-parse HEAD >>$(srcdir)/manifest.uuid || \
(printf "svn-r" >$(srcdir)/manifest.uuid ; \
svn info --show-item last-changed-revision >>$(srcdir)/manifest.uuid) || \
printf "unknown" >$(srcdir)/manifest.uuid)
itkUuid.h: $(srcdir)/manifest.uuid
echo "#define ITK_VERSION_UUID \\" >$@
cat $(srcdir)/manifest.uuid >>$@
echo "" >>$@
.c.$(OBJEXT):
$(COMPILE) -c `@CYGPATH@ $<` -o $@
#========================================================================
# Distribution creation
# You may need to tweak this target to make it work correctly.
#========================================================================
#COMPRESS = tar cvf $(PKG_DIR).tar $(PKG_DIR); compress $(PKG_DIR).tar
COMPRESS = tar zcvf $(PKG_DIR).tar.gz $(PKG_DIR)
DIST_ROOT = /tmp/dist
DIST_DIR = $(DIST_ROOT)/$(PKG_DIR)
DIST_INSTALL_DATA = CPPROG='cp -p' $(INSTALL) -m 644
DIST_INSTALL_SCRIPT = CPPROG='cp -p' $(INSTALL) -m 755
TAR = tar
#COMPRESS = tar cvf $(PKG_DIR).tar $(PKG_DIR); compress $(PKG_DIR).tar
COMPRESS = $(TAR) zcvf $(PKG_DIR).tar.gz $(PKG_DIR)
DIST_ROOT = /tmp/dist
DIST_DIR = $(DIST_ROOT)/$(PKG_DIR)
dist-clean:
rm -rf $(DIST_DIR) $(DIST_ROOT)/$(PKG_DIR).tar.*
dist: dist-clean $(srcdir)/manifest.uuid
$(INSTALL_DATA_DIR) $(DIST_DIR)
dist: dist-clean doc
mkdir -p $(DIST_DIR)
cp -p $(srcdir)/license* $(srcdir)/aclocal.m4 $(srcdir)/configure \
$(srcdir)/*.in $(DIST_DIR)/
chmod 664 $(DIST_DIR)/Makefile.in $(DIST_DIR)/aclocal.m4
chmod 775 $(DIST_DIR)/configure $(DIST_DIR)/configure.in
# TEA files
$(DIST_INSTALL_DATA) $(srcdir)/Makefile.in \
$(srcdir)/manifest.uuid $(DISTDIR) \
$(srcdir)/aclocal.m4 $(srcdir)/configure.ac \
$(DIST_DIR)/
$(DIST_INSTALL_SCRIPT) $(srcdir)/configure $(DIST_DIR)/
$(INSTALL_DATA_DIR) $(DIST_DIR)/tclconfig
$(DIST_INSTALL_DATA) $(srcdir)/tclconfig/README.txt \
$(srcdir)/tclconfig/tcl.m4 $(srcdir)/tclconfig/install-sh \
$(DIST_DIR)/tclconfig/
# Extension files
$(DIST_INSTALL_DATA) \
$(srcdir)/ChangeLog \
$(srcdir)/license.terms \
$(srcdir)/pkgIndex.tcl.in \
$(srcdir)/itkConfig.sh.in \
$(DIST_DIR)/
mkdir $(DIST_DIR)/tclconfig
cp $(srcdir)/tclconfig/install-sh $(srcdir)/tclconfig/tcl.m4 \
$(DIST_DIR)/tclconfig/
chmod 664 $(DIST_DIR)/tclconfig/tcl.m4
chmod +x $(DIST_DIR)/tclconfig/install-sh
list='demos doc examples generic library tests win win/rc'; \
for p in $$list; do \
$(INSTALL_DATA_DIR) $(DIST_DIR)/$$p; \
for f in $(srcdir)/$$p/*; do \
if ! test -f $$f; then continue; fi; \
$(DIST_INSTALL_DATA) $$f $(DIST_DIR)/$$p/; \
done; \
if test -d $(srcdir)/$$p ; then \
mkdir $(DIST_DIR)/$$p; \
for q in $(srcdir)/$$p/*; do \
if test -f $$q ; then \
cp -p $$q $(DIST_DIR)/$$p/; \
fi; \
done; \
fi; \
done
list='CHANGES ChangeLog INCOMPATIBLE README TODO'; \
for p in $$list; do \
if test -f $(srcdir)/../$$p ; then \
cp -p $(srcdir)/../$$p $(DIST_DIR)/; \
fi; \
done
(cd $(DIST_ROOT); $(COMPRESS);)
@@ -386,12 +331,13 @@ dist: dist-clean $(srcdir)/manifest.uuid
#========================================================================
# Don't modify the file to clean here. Instead, set the "CLEANFILES"
# variable in configure.ac
# variable in configure.in
#========================================================================
clean:
clean:
-test -z "$(BINARIES)" || rm -f $(BINARIES)
-rm -f *.$(OBJEXT) core *.core
-rm -f *.o core *.core
-rm -f *.$(OBJEXT)
-test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
distclean: clean
@@ -403,25 +349,34 @@ distclean: clean
# Install binary object libraries. On Windows this includes both .dll and
# .lib files. Because the .lib files are not explicitly listed anywhere,
# we need to deduce their existence from the .dll file of the same name.
# Library files go into the lib directory.
# In addition, this will generate the pkgIndex.tcl
# file in the install location (assuming it can find a usable tclsh shell)
# Additionally, the .dll files go into the bin directory, but the .lib
# files go into the lib directory. On Unix platforms, all library files
# go into the lib directory. In addition, this will generate the pkgIndex.tcl
# file in the install location (assuming it can find a usable tclsh8.2 shell)
#
# You should not have to modify this target.
#========================================================================
install-lib-binaries: binaries
@$(INSTALL_DATA_DIR) "$(DESTDIR)$(pkglibdir)"
install-lib-binaries:
@mkdir -p $(DESTDIR)$(pkglibdir)
@list='$(lib_BINARIES)'; for p in $$list; do \
if test -f $$p; then \
echo " $(INSTALL_LIBRARY) $$p $(DESTDIR)$(pkglibdir)/$$p"; \
$(INSTALL_LIBRARY) $$p "$(DESTDIR)$(pkglibdir)/$$p"; \
echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(pkglibdir)/$$p"; \
$(INSTALL_PROGRAM) $$p $(DESTDIR)$(pkglibdir)/$$p; \
stub=`echo $$p|sed -e "s/.*\(stub\).*/\1/"`; \
if test "x$$stub" = "xstub"; then \
echo " $(RANLIB_STUB) $(DESTDIR)$(pkglibdir)/$$p"; \
$(RANLIB_STUB) $(DESTDIR)$(pkglibdir)/$$p; \
else \
echo " $(RANLIB) $(DESTDIR)$(pkglibdir)/$$p"; \
$(RANLIB) $(DESTDIR)$(pkglibdir)/$$p; \
fi; \
ext=`echo $$p|sed -e "s/.*\.//"`; \
if test "x$$ext" = "xdll"; then \
lib=`basename $$p|sed -e 's/.[^.]*$$//'`.lib; \
if test -f $$lib; then \
echo " $(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib"; \
$(INSTALL_DATA) $$lib "$(DESTDIR)$(pkglibdir)/$$lib"; \
$(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib; \
fi; \
fi; \
fi; \
@@ -430,52 +385,46 @@ install-lib-binaries: binaries
if test -f $(srcdir)/$$p; then \
destp=`basename $$p`; \
echo " Install $$destp $(DESTDIR)$(pkglibdir)/$$destp"; \
$(INSTALL_DATA) $(srcdir)/$$p "$(DESTDIR)$(pkglibdir)/$$destp"; \
$(INSTALL_DATA) $(srcdir)/$$p $(DESTDIR)$(pkglibdir)/$$destp; \
fi; \
done
@if test "x$(SHARED_BUILD)" = "x1"; then \
echo " Install pkgIndex.tcl $(DESTDIR)$(pkglibdir)"; \
$(INSTALL_DATA) pkgIndex.tcl "$(DESTDIR)$(pkglibdir)"; \
fi
$(INSTALL_DATA) itkConfig.sh "$(DESTDIR)$(pkglibdir)"
$(INSTALL_DATA) pkgIndex.tcl $(DESTDIR)$(pkglibdir)
: $(INSTALL_DATA) itkConfig.sh $(DESTDIR)$(libdir)
#========================================================================
# Install binary executables (e.g. .exe files and dependent .dll files)
# This is for files that must go in the bin directory (located next to
# wish and tclsh), like dependent .dll files on Windows.
# Install binary executables (e.g. .exe files)
#
# You should not have to modify this target, except to define bin_BINARIES
# above if necessary.
# You should not have to modify this target.
#========================================================================
install-bin-binaries: binaries
@$(INSTALL_DATA_DIR) "$(DESTDIR)$(bindir)"
install-bin-binaries:
@mkdir -p $(DESTDIR)$(bindir)
@list='$(bin_BINARIES)'; for p in $$list; do \
if test -f $$p; then \
echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p"; \
$(INSTALL_PROGRAM) $$p "$(DESTDIR)$(bindir)/$$p"; \
$(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p; \
fi; \
done
Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
cd $(top_builddir) \
&& CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
.SUFFIXES: .c .$(OBJEXT)
#Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
# cd $(top_builddir) \
# && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
uninstall-binaries:
list='$(lib_BINARIES)'; for p in $$list; do \
rm -f "$(DESTDIR)$(pkglibdir)/$$p"; \
rm -f $(DESTDIR)$(pkglibdir)/$$p; \
done
list='$(PKG_TCL_SOURCES)'; for p in $$list; do \
p=`basename $$p`; \
rm -f "$(DESTDIR)$(pkglibdir)/$$p"; \
rm -f $(DESTDIR)$(pkglibdir)/$$p; \
done
list='$(bin_BINARIES)'; for p in $$list; do \
rm -f "$(DESTDIR)$(bindir)/$$p"; \
rm -f $(DESTDIR)$(bindir)/$$p; \
done
.PHONY: all binaries clean depend distclean doc install libraries test
.PHONY: gdb gdb-test valgrind valgrindshell
.PHONY: genstubs
# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
Vendored
-8
View File
@@ -1,9 +1 @@
#
# Include the TEA standard macro set
#
builtin(include,tclconfig/tcl.m4)
#
# Add here whatever m4 macros you want to define for your package
#
Vendored
+3781 -4602
View File
File diff suppressed because it is too large Load Diff
+59 -105
View File
@@ -1,25 +1,16 @@
#!/bin/bash -norc
dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
#-----------------------------------------------------------------------
# Sample configure.ac for Tcl Extensions. The only places you should
#--------------------------------------------------------------------
# Sample configure.in for Tcl Extensions. The only places you should
# need to modify this file are marked by the string __CHANGE__
#-----------------------------------------------------------------------
#--------------------------------------------------------------------
#-----------------------------------------------------------------------
# __CHANGE__
# Set your package name and version numbers here.
#
# This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION
# set as provided. These will also be added as -D defs in your Makefile
# so you can encode the package version directly into the source files.
# This will also define a special symbol for Windows (BUILD_<PACKAGE_NAME>
# so that we create the export library with the dll.
#-----------------------------------------------------------------------
AC_INIT([itk],[4.2.7])
AC_INIT([itk], [3.4])
#--------------------------------------------------------------------
# Call TEA_INIT as the first TEA_ macro to set up initial vars.
@@ -27,29 +18,18 @@ AC_INIT([itk],[4.2.7])
# as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE.
#--------------------------------------------------------------------
TEA_INIT()
#--------------------------------------------------------------------
# Try to ensure the existence of a tclconfig directory in either
# $srcdir or the current dir, if one can't be found in $srcdir.
# If this package is being built as part of a bundle then a tclconfig
# directory might exist in $srcdir's parent directory.
#--------------------------------------------------------------------
TEA_INIT([3.9])
AC_PROG_LN_S
CONFIG_CLEAN_FILES=
if test ! -d $srcdir/tclconfig ; then
if test -d $srcdir/../tclconfig ; then
$LN_S $srcdir/../tclconfig tclconfig
$LN_S $srcdir/../tclconfig tclconfig
CONFIG_CLEAN_FILES=tclconfig
fi
fi
AC_SUBST(CONFIG_CLEAN_FILES)
#--------------------------------------------------------------------
# Tell autoconf where to find tcl.m4 and install.sh.
#--------------------------------------------------------------------
AC_CONFIG_AUX_DIR(tclconfig)
#--------------------------------------------------------------------
@@ -60,34 +40,30 @@ TEA_PATH_TCLCONFIG
TEA_LOAD_TCLCONFIG
#--------------------------------------------------------------------
# Load the tkConfig.sh file if necessary (Tk extension)
# Load the tkConfig.sh file
#--------------------------------------------------------------------
TEA_PATH_TKCONFIG
TEA_LOAD_TKCONFIG
#--------------------------------------------------------------------
# Load the itclConfig.sh file
#--------------------------------------------------------------------
TEA_PATH_CONFIG(itcl)
TEA_LOAD_CONFIG(itcl)
ITCL_INCLUDES="-I\"`${CYGPATH} ${itcl_SRC_DIR}/generic`\""
#-----------------------------------------------------------------------
#--------------------------------------------------------------------
# Handle the --prefix=... option by defaulting to what Tcl gave.
# Must be called after TEA_LOAD_TCLCONFIG and before TEA_SETUP_COMPILER.
#-----------------------------------------------------------------------
# Must be called after TEA_LOAD_TCLCONFIG and before $prefix is used.
#--------------------------------------------------------------------
TEA_PREFIX
#-----------------------------------------------------------------------
#------------------------------------------------------------------------
# Standard compiler checks.
# This sets up CC by using the CC env var, or looks for gcc otherwise.
# This also calls AC_PROG_CC and a few others to create the basic setup
# necessary to compile executables.
#-----------------------------------------------------------------------
# This also calls AC_PROG_CC, AC_PROG_INSTALL and a few others to create
# the basic setup necessary to compile executables.
#------------------------------------------------------------------------
TEA_SETUP_COMPILER
@@ -101,21 +77,16 @@ TEA_SETUP_COMPILER
# and PKG_TCL_SOURCES.
#-----------------------------------------------------------------------
TEA_ADD_SOURCES([
itkArchBase.c
itkArchetype.c
itkBase.c
itkCmd.c
itkHelpers.c
itkOption.c
itkUtil.c
itkStubInit.c
])
TEA_ADD_HEADERS([generic/itk.h generic/itkInt.h])
TEA_ADD_SOURCES([itk_cmds.c
itk_option.c
itk_archetype.c
itk_util.c
itkStubInit.c])
TEA_ADD_HEADERS([generic/itk.h generic/itkDecls.h])
TEA_ADD_INCLUDES([${ITCL_INCLUDES} -I\"`${CYGPATH} ${srcdir}/generic`\"])
TEA_ADD_LIBS([])
TEA_ADD_CFLAGS([])
TEA_ADD_STUB_SOURCES([itkStubLib.c])
#TEA_ADD_STUB_SOURCES([itkStubLib.c])
TEA_ADD_TCL_SOURCES([library/Archetype.itk
library/Toplevel.itk
library/Widget.itk
@@ -124,29 +95,17 @@ TEA_ADD_TCL_SOURCES([library/Archetype.itk
#--------------------------------------------------------------------
# __CHANGE__
# A few miscellaneous platform-specific items:
#
# Windows creates a few extra files that need to be cleaned up.
# You can add more files to clean if your extension creates any extra
# files by extending CLEANFILES.
# Add pkgIndex.tcl if it is generated in the Makefile instead of ./configure
# and change Makefile.in to move it from CONFIG_CLEAN_FILES to BINARIES var.
#
# A few miscellaneous platform-specific items:
# TEA_ADD_* any platform specific compiler/build info here.
#--------------------------------------------------------------------
#CLEANFILES="$CLEANFILES pkgIndex.tcl"
if test "${TEA_PLATFORM}" = "windows" ; then
# Ensure no empty if clauses
:
#TEA_ADD_SOURCES([win/winFile.c])
#TEA_ADD_INCLUDES([-I\"$(${CYGPATH} ${srcdir}/win)\"])
TEA_ADD_SOURCES([dllEntryPoint.c])
else
# Ensure no empty else clauses
:
#TEA_ADD_SOURCES([unix/unixFile.c])
#TEA_ADD_LIBS([-lsuperfly])
fi
#CLEANFILES="$CLEANFILES *.ext"
#--------------------------------------------------------------------
# __CHANGE__
@@ -154,14 +113,21 @@ fi
# hard to only rely on the Tcl public header files. Internal headers
# contain private data structures and are subject to change without
# notice.
# This MUST be called after TEA_LOAD_TCLCONFIG / TEA_LOAD_TKCONFIG
# This must be done AFTER calling TEA_PATH_TCLCONFIG/TEA_LOAD_TCLCONFIG
# so that we can extract TCL_SRC_DIR from the config file (in the case
# of private headers
#--------------------------------------------------------------------
#TEA_PUBLIC_TCL_HEADERS
TEA_PRIVATE_TCL_HEADERS
TEA_PUBLIC_TK_HEADERS
#TEA_PRIVATE_TK_HEADERS
#TEA_PUBLIC_TK_HEADERS
TEA_PRIVATE_TK_HEADERS
#--------------------------------------------------------------------
# For Unix/Tk builds, make sure that the X libraries/headers are found.
#--------------------------------------------------------------------
TEA_PATH_X
#--------------------------------------------------------------------
@@ -172,7 +138,6 @@ TEA_PATH_X
#--------------------------------------------------------------------
AC_DEFINE(TCL_THREADS)
#--------------------------------------------------------------------
# Check whether --enable-threads or --disable-threads was given.
# This auto-enables if Tcl was compiled threaded.
@@ -196,16 +161,22 @@ TEA_ENABLE_SHARED
TEA_CONFIG_CFLAGS
#--------------------------------------------------------------------
# Set the default compiler switches based on the --enable-symbols option.
# Set the default compiler switches based on the --enable-symbols
# option.
#--------------------------------------------------------------------
TEA_ENABLE_SYMBOLS
#--------------------------------------------------------------------
# Itcl stubs
# Everyone should be linking against the Tcl stub library. If you
# can't for some reason, remove this definition. If you aren't using
# stubs, you also need to modify the SHLIB_LD_LIBS setting below to
# link against the non-stubbed Tcl library.
#--------------------------------------------------------------------
if test "${SHARED_BUILD}" = "1" ; then
AC_DEFINE(USE_TCL_STUBS)
AC_DEFINE(USE_TK_STUBS)
AC_DEFINE(USE_ITCL_STUBS)
fi
@@ -218,45 +189,28 @@ fi
TEA_MAKE_LIB
#--------------------------------------------------------------------
# Determine the name of the tclsh and/or wish executables in the
# Tcl and Tk build directories or the location they were installed
# into. These paths are used to support running test cases only,
# the Makefile should not be making use of these paths to generate
# a pkgIndex.tcl file or anything else at extension build time.
# __CHANGE__
# Change the name from exampeA_LIB_FILE to match your package name.
# Use the stub_LIB_FILE substitution if your package creates a stub
# library.
#--------------------------------------------------------------------
AC_SUBST(itkstub_LIB_FILE)
AC_SUBST(itk_LIB_FILE)
#--------------------------------------------------------------------
# Find tclsh so that we can run pkg_mkIndex to generate the pkgIndex.tcl
# file during the install process. Don't run the TCLSH_PROG through
# ${CYGPATH} because it's being used directly by make.
# Require that we use a tclsh shell version 8.2 or later since earlier
# versions have bugs in the pkg_mkIndex routine.
#--------------------------------------------------------------------
TEA_PROG_TCLSH
TEA_PROG_WISH
#--------------------------------------------------------------------
# Setup a *Config.sh.in configuration file.
# Finally, substitute all of the various values into the Makefile.
#--------------------------------------------------------------------
# itk_SRC_DIR must be a fully qualified path
eval itk_SRC_DIR="$srcdir"
itk_SRC_DIR="`(cd "${itk_SRC_DIR}"; pwd)`"
itk_LIB_FILE="${PKG_LIB_FILE}"
itk_STUB_LIB_FILE="${PKG_STUB_LIB_FILE}"
TEA_EXPORT_CONFIG([itk])
AC_SUBST(ITCL_VERSION)
AC_SUBST(itk_SRC_DIR)
AC_SUBST(itk_LIB_FILE)
AC_SUBST(itk_STUB_LIB_FILE)
#--------------------------------------------------------------------
# Specify files to substitute AC variables in. You may alternatively
# have a special pkgIndex.tcl.in or other files which require
# substituting the AC variables in. Include these here.
#--------------------------------------------------------------------
AC_CONFIG_FILES([Makefile pkgIndex.tcl])
AC_CONFIG_FILES([itkConfig.sh])
#--------------------------------------------------------------------
# Finally, substitute all of the various values into the files
# specified with AC_CONFIG_FILES.
#--------------------------------------------------------------------
AC_OUTPUT
AC_OUTPUT([Makefile pkgIndex.tcl itkConfig.sh])
+45 -45
View File
@@ -53,26 +53,26 @@ proc file_load {} {
.files buttonconfigure OK -text "Load"
if {[.files activate]} {
set fname [.files get]
set cmd {
set fid [open $fname r]
set text [read $fid]
close $fid
}
if {[catch $cmd err] != 0} {
.notice configure -bitmap error \
-text "Cannot load file \"$fname\":\n$err"
.notice activate
return
}
set fname [.files get]
set cmd {
set fid [open $fname r]
set text [read $fid]
close $fid
}
if {[catch $cmd err] != 0} {
.notice configure -bitmap error \
-text "Cannot load file \"$fname\":\n$err"
.notice activate
return
}
set pane [$PaneMenu get]
set win [.edit childsite $pane]
clear_text $win
$win.text insert end $text
$win.text configure -labeltext "file: $fname"
set pane [$PaneMenu get]
set win [.edit childsite $pane]
clear_text $win
$win.text insert end $text
$win.text configure -labeltext "file: $fname"
set FileName($win) $fname
set FileName($win) $fname
}
}
@@ -89,12 +89,12 @@ proc file_save_as {} {
.files buttonconfigure OK -text "Save"
if {[.files activate]} {
set pane [$PaneMenu get]
set win [.edit childsite $pane]
set pane [$PaneMenu get]
set win [.edit childsite $pane]
set FileName($win) [.files get]
set FileName($win) [.files get]
file_save $win
file_save $win
}
}
@@ -108,16 +108,16 @@ proc file_save {win} {
global FileName FileChanged
set cmd {
set fid [open $FileName($win) w]
puts $fid [$win.text get 1.0 end]
close $fid
set FileChanged($win) 0
$win.text configure -labeltext "file: $FileName($win)"
set fid [open $FileName($win) w]
puts $fid [$win.text get 1.0 end]
close $fid
set FileChanged($win) 0
$win.text configure -labeltext "file: $FileName($win)"
}
if {[catch $cmd err] != 0} {
.notice configure -bitmap error \
-text "Cannot save file \"$FileName($win)\":\n$err"
.notice activate
.notice configure -bitmap error \
-text "Cannot save file \"$FileName($win)\":\n$err"
.notice activate
}
}
@@ -132,22 +132,22 @@ proc clear_text {{areas ""}} {
global FileName FileChanged FileWindows
if {$areas == ""} {
for {set i 0} {$i < $FileWindows} {incr i} {
set pane "area #[expr $i+1]"
lappend areas [.edit childsite $pane]
}
for {set i 0} {$i < $FileWindows} {incr i} {
set pane "area #[expr $i+1]"
lappend areas [.edit childsite $pane]
}
}
foreach win $areas {
if {$FileChanged($win)} {
set fname [file tail $FileName($win)]
.confirm configure -text "File \"$fname\" has changed.\nSave changes?"
if {[.confirm activate]} {
file_save $win
}
}
$win.text delete 1.0 end
set FileChanged($win) 0
if {$FileChanged($win)} {
set fname [file tail $FileName($win)]
.confirm configure -text "File \"$fname\" has changed.\nSave changes?"
if {[.confirm activate]} {
file_save $win
}
}
$win.text delete 1.0 end
set FileChanged($win) 0
}
}
@@ -169,11 +169,11 @@ proc split_view {} {
set FileChanged($win) 0
iwidgets::scrolledtext $win.text -wrap none -labeltext "file: $FileName($win)" \
-hscrollmode none -vscrollmode dynamic -visibleitems 1x1
-hscrollmode none -vscrollmode dynamic -visibleitems 1x1
pack $win.text -expand yes -fill both
bind [$win.text component text] <KeyPress> "
set FileChanged($win) 1
set FileChanged($win) 1
"
}
+1 -1
View File
@@ -48,7 +48,7 @@ inherits from \fBArchetype\fR, but adds a Tk toplevel which acts
as the "hull".
.PP
\fIEach derived class must invoke the \fBitk_initialize\fP method
within its constructor, so that all options are properly
within its constructor\fR, so that all options are properly
integrated and initialized in the composite list.
+2 -2
View File
@@ -28,9 +28,9 @@ or from a compiled-in value otherwise.
.sp
When \fB[incr\ Tk]\fR is added to an interpreter, it executes
the script "\fCinit.itk\fR" in this directory. This script,
in turn, looks for other script files with the name "\fCinit.\fR\fIxxx\fR".
in turn, looks for other script files with the name "\fCinit.\fIxxx\fR".
Mega-widget libraries will be automatically initialized if they
install a script named "\fCinit.\fR\fIxxx\fR" in this directory,
install a script named "\fCinit.\fIxxx\fR" in this directory,
where "\fIxxx\fR" is the name of the mega-widget library.
For example, the \fB[incr\ Widgets]\fR library installs
the script "\fCinit.iwidgets\fR" in this directory.
+88 -119
View File
@@ -1,86 +1,80 @@
.\" The -*- nroff -*- definitions below are for supplemental macros used
.\" in Tcl/Tk manual entries.
.\"
.\" .AP type name in/out ?indent?
.\" Start paragraph describing an argument to a library procedure.
.\" type is type of argument (int, etc.), in/out is either "in", "out",
.\" or "in/out" to describe whether procedure reads or modifies arg,
.\" and indent is equivalent to second arg of .IP (shouldn't ever be
.\" needed; use .AS below instead)
.\"
.\" .AS ?type? ?name?
.\" Give maximum sizes of arguments for setting tab stops. Type and
.\" name are examples of largest possible arguments that will be passed
.\" to .AP later. If args are omitted, default tab stops are used.
.\"
.\" .BS
.\" Start box enclosure. From here until next .BE, everything will be
.\" enclosed in one large box.
.\"
.\" .BE
.\" End of box enclosure.
.\"
.\" .CS
.\" Begin code excerpt.
.\"
.\" .CE
.\" End code excerpt.
.\"
.\" .VS ?version? ?br?
.\" Begin vertical sidebar, for use in marking newly-changed parts
.\" of man pages. The first argument is ignored and used for recording
.\" the version when the .VS was added, so that the sidebars can be
.\" found and removed when they reach a certain age. If another argument
.\" is present, then a line break is forced before starting the sidebar.
.\"
.\" .VE
.\" End of vertical sidebar.
.\"
.\" .DS
.\" Begin an indented unfilled display.
.\"
.\" .DE
.\" End of indented unfilled display.
.\"
.\" .SO ?manpage?
.\" Start of list of standard options for a Tk widget. The manpage
.\" argument defines where to look up the standard options; if
.\" omitted, defaults to "options". The options follow on successive
.\" lines, in three columns separated by tabs.
.\"
.\" .SE
.\" End of list of standard options for a Tk widget.
.\"
.\" .OP cmdName dbName dbClass
.\" Start of description of a specific option. cmdName gives the
.\" option's name as specified in the class command, dbName gives
.\" the option's name in the option database, and dbClass gives
.\" the option's class in the option database.
.\"
.\" .UL arg1 arg2
.\" Print arg1 underlined, then print arg2 normally.
.\"
.\" .QW arg1 ?arg2?
.\" Print arg1 in quotes, then arg2 normally (for trailing punctuation).
.\"
.\" .PQ arg1 ?arg2?
.\" Print an open parenthesis, arg1 in quotes, then arg2 normally
.\" (for trailing punctuation) and then a closing parenthesis.
.\"
.\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
'\" The definitions below are for supplemental macros used in Tcl/Tk
'\" manual entries.
'\"
'\" .AP type name in/out ?indent?
'\" Start paragraph describing an argument to a library procedure.
'\" type is type of argument (int, etc.), in/out is either "in", "out",
'\" or "in/out" to describe whether procedure reads or modifies arg,
'\" and indent is equivalent to second arg of .IP (shouldn't ever be
'\" needed; use .AS below instead)
'\"
'\" .AS ?type? ?name?
'\" Give maximum sizes of arguments for setting tab stops. Type and
'\" name are examples of largest possible arguments that will be passed
'\" to .AP later. If args are omitted, default tab stops are used.
'\"
'\" .BS
'\" Start box enclosure. From here until next .BE, everything will be
'\" enclosed in one large box.
'\"
'\" .BE
'\" End of box enclosure.
'\"
'\" .CS
'\" Begin code excerpt.
'\"
'\" .CE
'\" End code excerpt.
'\"
'\" .VS ?version? ?br?
'\" Begin vertical sidebar, for use in marking newly-changed parts
'\" of man pages. The first argument is ignored and used for recording
'\" the version when the .VS was added, so that the sidebars can be
'\" found and removed when they reach a certain age. If another argument
'\" is present, then a line break is forced before starting the sidebar.
'\"
'\" .VE
'\" End of vertical sidebar.
'\"
'\" .DS
'\" Begin an indented unfilled display.
'\"
'\" .DE
'\" End of indented unfilled display.
'\"
'\" .SO
'\" Start of list of standard options for a Tk widget. The
'\" options follow on successive lines, in four columns separated
'\" by tabs.
'\"
'\" .SE
'\" End of list of standard options for a Tk widget.
'\"
'\" .OP cmdName dbName dbClass
'\" Start of description of a specific option. cmdName gives the
'\" option's name as specified in the class command, dbName gives
'\" the option's name in the option database, and dbClass gives
'\" the option's class in the option database.
'\"
'\" .UL arg1 arg2
'\" Print arg1 underlined, then print arg2 normally.
'\"
'\" SCCS: @(#) man.macros 1.9 97/08/22 18:50:59
'\"
'\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
.\" # Start an argument description
'\" # Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
. ie !"\\$2"" .TP \\n()Cu
. el .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1 \\fI\\$2\\fP (\\$3)
.ta \\n()Au \\n()Bu
\&\\$1 \\fI\\$2\\fP (\\$3)
.\".b
.\}
.el \{\
@@ -93,7 +87,7 @@
.\}
.\}
..
.\" # define tabbing values for .AP
'\" # define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
@@ -103,9 +97,9 @@
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
.\" # BS - start boxed text
.\" # ^y = starting y location
.\" # ^b = 1
'\" # BS - start boxed text
'\" # ^y = starting y location
'\" # ^b = 1
.de BS
.br
.mk ^y
@@ -115,7 +109,7 @@
.if n \l'\\n(.lu\(ul'
.if n .fi
..
.\" # BE - end boxed text (draw box now)
'\" # BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
@@ -135,16 +129,16 @@
.br
.nr ^b 0
..
.\" # VS - start vertical sidebar
.\" # ^Y = starting y location
.\" # ^v = 1 (for troff; for nroff this doesn't matter)
'\" # VS - start vertical sidebar
'\" # ^Y = starting y location
'\" # ^v = 1 (for troff; for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
.\" # VE - end of vertical sidebar
'\" # VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
@@ -159,9 +153,9 @@
.\}
.nr ^v 0
..
.\" # Special macro to handle page bottom: finish off current
.\" # box/sidebar if in box/sidebar mode, then invoked standard
.\" # page bottom macro.
'\" # Special macro to handle page bottom: finish off current
'\" # box/sidebar if in box/sidebar mode, then invoked standard
'\" # page bottom macro.
.de ^B
.ev 2
'ti 0
@@ -188,36 +182,34 @@
.mk ^Y
.\}
..
.\" # DS - begin display
'\" # DS - begin display
.de DS
.RS
.nf
.sp
..
.\" # DE - end display
'\" # DE - end display
.de DE
.fi
.RE
.sp
..
.\" # SO - start of list of standard options
'\" # SO - start of list of standard options
.de SO
'ie '\\$1'' .ds So \\fBoptions\\fR
'el .ds So \\fB\\$1\\fR
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 5.5c 11c
.ta 4c 8c 12c
.ft B
..
.\" # SE - end of list of standard options
'\" # SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\*(So manual entry for details on the standard options.
See the \\fBoptions\\fR manual entry for details on the standard options.
..
.\" # OP - start of full description for a single option
'\" # OP - start of full description for a single option
.de OP
.LP
.nf
@@ -228,40 +220,17 @@ Database Class: \\fB\\$3\\fR
.fi
.IP
..
.\" # CS - begin code excerpt
'\" # CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
.\" # CE - end code excerpt
'\" # CE - end code excerpt
.de CE
.fi
.RE
..
.\" # UL - underline word
.de UL
\\$1\l'|0\(ul'\\$2
..
.\" # QW - apply quotation marks to word
.de QW
.ie '\\*(lq'"' ``\\$1''\\$2
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\$2
..
.\" # PQ - apply parens and quotation marks to word
.de PQ
.ie '\\*(lq'"' (``\\$1''\\$2)\\$3
.\"" fix emacs highlighting
.el (\\*(lq\\$1\\*(rq\\$2)\\$3
..
.\" # QR - quoted range
.de QR
.ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3
..
.\" # MT - "empty" string
.de MT
.QW ""
..
+27 -27
View File
@@ -13,42 +13,42 @@ class Info {
inherit itk::Toplevel
constructor {args} {
itk_component add dismiss {
button $itk_interior.dismiss -text "Dismiss" \
-command "destroy $itk_component(hull)"
}
pack $itk_component(dismiss) -side bottom -pady 4
itk_component add dismiss {
button $itk_interior.dismiss -text "Dismiss" \
-command "destroy $itk_component(hull)"
}
pack $itk_component(dismiss) -side bottom -pady 4
itk_component add separator {
frame $itk_interior.sep -height 2 -borderwidth 1 -relief sunken
}
pack $itk_component(separator) -side bottom -fill x -padx 4
itk_component add separator {
frame $itk_interior.sep -height 2 -borderwidth 1 -relief sunken
}
pack $itk_component(separator) -side bottom -fill x -padx 4
itk_component add icon {
label $itk_interior.icon -bitmap info
}
pack $itk_component(icon) -side left -padx 8 -pady 8
itk_component add icon {
label $itk_interior.icon -bitmap info
}
pack $itk_component(icon) -side left -padx 8 -pady 8
itk_component add infoFrame {
frame $itk_interior.info
}
pack $itk_component(infoFrame) -side left -expand yes \
-fill both -padx 4 -pady 4
itk_component add infoFrame {
frame $itk_interior.info
}
pack $itk_component(infoFrame) -side left -expand yes \
-fill both -padx 4 -pady 4
set itk_interior $itk_component(infoFrame)
set itk_interior $itk_component(infoFrame)
eval itk_initialize $args
eval itk_initialize $args
after idle [code $this centerOnScreen]
after idle [code $this centerOnScreen]
}
protected method centerOnScreen {} {
update idletasks
set wd [winfo reqwidth $itk_component(hull)]
set ht [winfo reqheight $itk_component(hull)]
set x [expr ([winfo screenwidth $itk_component(hull)]-$wd)/2]
set y [expr ([winfo screenheight $itk_component(hull)]-$ht)/2]
wm geometry $itk_component(hull) +$x+$y
update idletasks
set wd [winfo reqwidth $itk_component(hull)]
set ht [winfo reqheight $itk_component(hull)]
set x [expr ([winfo screenwidth $itk_component(hull)]-$wd)/2]
set y [expr ([winfo screenheight $itk_component(hull)]-$ht)/2]
wm geometry $itk_component(hull) +$x+$y
}
}
+13 -13
View File
@@ -13,23 +13,23 @@ class MessageInfo {
inherit Info
constructor {args} {
itk_component add message {
label $itk_interior.mesg -width 20
} {
usual
rename -text -message message Text
}
pack $itk_component(message) -expand yes -fill both
bind $itk_component(message) <Configure> [code $this resize]
itk_component add message {
label $itk_interior.mesg -width 20
} {
usual
rename -text -message message Text
}
pack $itk_component(message) -expand yes -fill both
bind $itk_component(message) <Configure> [code $this resize]
eval itk_initialize $args
eval itk_initialize $args
}
private method resize {} {
set w [winfo width $itk_component(message)]
if {$w > 1} {
$itk_component(message) configure -wraplength $w
}
set w [winfo width $itk_component(message)]
if {$w > 1} {
$itk_component(message) configure -wraplength $w
}
}
}
+54 -54
View File
@@ -18,36 +18,36 @@ class TextDisplay {
inherit itk::Widget
constructor {args} {
itk_option add hull.width hull.height
itk_option add hull.width hull.height
itk_component add text {
text $itk_interior.info -state disabled -width 1 -height 1 \
-yscrollcommand [code $itk_interior.sbar set]
} {
usual
keep -wrap -tabs
rename -background -textbackground textBackground Background
}
pack $itk_component(text) -side left -expand yes -fill both
itk_component add text {
text $itk_interior.info -state disabled -width 1 -height 1 \
-yscrollcommand [code $itk_interior.sbar set]
} {
usual
keep -wrap -tabs
rename -background -textbackground textBackground Background
}
pack $itk_component(text) -side left -expand yes -fill both
itk_component add scrollbar {
scrollbar $itk_interior.sbar \
-command [code $itk_interior.info yview]
}
pack $itk_component(scrollbar) -side right -fill y
itk_component add scrollbar {
scrollbar $itk_interior.sbar \
-command [code $itk_interior.info yview]
}
pack $itk_component(scrollbar) -side right -fill y
eval itk_initialize $args
eval itk_initialize $args
pack propagate $itk_component(hull) 0
pack propagate $itk_component(hull) 0
fixScrollbar
bind $itk_component(text) <Configure> [code $this fixScrollbar]
fixScrollbar
bind $itk_component(text) <Configure> [code $this fixScrollbar]
$itk_component(text) tag configure bold \
-font -*-courier-bold-r-normal--*-120-*
$itk_component(text) tag configure bold \
-font -*-courier-bold-r-normal--*-120-*
$itk_component(text) tag configure italic \
-font -*-courier-medium-o-normal--*-120-*
$itk_component(text) tag configure italic \
-font -*-courier-medium-o-normal--*-120-*
}
public method display {info}
@@ -55,14 +55,14 @@ class TextDisplay {
public method substitute {word newword}
itk_option define -scrollbar scrollbar Scrollbar "on" {
switch -- $itk_option(-scrollbar) {
on - off - auto {
fixScrollbar
}
default {
error "bad value \"$itk_option(-scollbar)\""
}
}
switch -- $itk_option(-scrollbar) {
on - off - auto {
fixScrollbar
}
default {
error "bad value \"$itk_option(-scollbar)\""
}
}
}
protected method fixScrollbar {}
@@ -89,13 +89,13 @@ body TextDisplay::substitute {word newword} {
set index 1.0
while {1} {
set index [$itk_component(text) search -count len $word $index]
if {$index != ""} {
$itk_component(text) delete $index "$index + $len chars"
$itk_component(text) insert $index $newword
} else {
break
}
set index [$itk_component(text) search -count len $word $index]
if {$index != ""} {
$itk_component(text) delete $index "$index + $len chars"
$itk_component(text) insert $index $newword
} else {
break
}
}
$itk_component(text) configure -state disabled
fixScrollbar
@@ -103,25 +103,25 @@ body TextDisplay::substitute {word newword} {
body TextDisplay::fixScrollbar {} {
switch $itk_option(-scrollbar) {
on { set sbstate 1 }
off { set sbstate 0 }
on { set sbstate 1 }
off { set sbstate 0 }
auto {
if {[$itk_component(text) bbox 1.0] == "" ||
[$itk_component(text) bbox end-1char] == ""} {
set sbstate 1
} else {
set sbstate 0
}
}
auto {
if {[$itk_component(text) bbox 1.0] == "" ||
[$itk_component(text) bbox end-1char] == ""} {
set sbstate 1
} else {
set sbstate 0
}
}
}
if {$sbstate != $sbvisible} {
if {$sbstate} {
pack $itk_component(scrollbar) -side right -fill y
} else {
pack forget $itk_component(scrollbar)
}
set sbvisible $sbstate
if {$sbstate} {
pack $itk_component(scrollbar) -side right -fill y
} else {
pack forget $itk_component(scrollbar)
}
set sbvisible $sbstate
}
}
+11 -11
View File
@@ -13,24 +13,24 @@ class TextInfo {
inherit Info
constructor {args} {
itk_component add textArea {
TextDisplay $itk_interior.txt -scrollbar auto
} {
usual
keep -wrap -tabs
rename -font -textfont textFont Font
}
pack $itk_component(textArea) -expand yes -fill both
itk_component add textArea {
TextDisplay $itk_interior.txt -scrollbar auto
} {
usual
keep -wrap -tabs
rename -font -textfont textFont Font
}
pack $itk_component(textArea) -expand yes -fill both
eval itk_initialize $args
eval itk_initialize $args
}
public method display {args} {
eval $itk_component(textArea) display $args
eval $itk_component(textArea) display $args
}
public method append {args} {
eval $itk_component(textArea) append $args
eval $itk_component(textArea) append $args
}
}
+6 -6
View File
@@ -31,14 +31,14 @@ bind .file <KeyPress-Return> {show_file [.file get]}
proc show_file {file} {
set cmd {
set fid [open $file r]
set info [read $fid]
close $fid
set fid [open $file r]
set info [read $fid]
close $fid
}
if {[catch $cmd] == 0} {
set win [TextInfo .#auto -wrap none]
$win display $info
set win [TextInfo .#auto -wrap none]
$win display $info
} else {
MessageInfo .#auto -message "Cannot read file:\n$file"
MessageInfo .#auto -message "Cannot read file:\n$file"
}
}
+68 -82
View File
@@ -1,20 +1,14 @@
# -*- tcl -*-
# itk.decls --
#
# This file contains the declarations for all supported public
# functions that are exported by the Itk library via the stubs table.
# This file is used to generate the itkDecls.h file.
#
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# public API
library itk
interface itk
hooks {itkInt}
epoch 0
scspec ITKAPI
# Declare each of the functions in the public Itk interface. Note that
# the an index should never be reused for a different function in order
@@ -25,11 +19,64 @@ scspec ITKAPI
# Exported functions:
#
declare 0 {
int Itk_Init(Tcl_Interp *interp)
declare 0 generic {
int Itk_Init (Tcl_Interp *interp)
}
declare 1 {
int Itk_SafeInit(Tcl_Interp *interp)
declare 1 generic {
int Itk_SafeInit (Tcl_Interp *interp)
}
#
# Functions used internally by this package:
#
declare 2 generic {
int Itk_ConfigBodyCmd (ClientData cdata, Tcl_Interp *interp, \
int objc, Tcl_Obj *CONST objv[])
}
declare 3 generic {
int Itk_UsualCmd (ClientData cdata, Tcl_Interp *interp, int objc, \
Tcl_Obj *CONST objv[])
}
#
# Functions for managing options included in class definitions:
#
declare 4 generic {
int Itk_ClassOptionDefineCmd (ClientData cdata, Tcl_Interp *interp, \
int objc, Tcl_Obj *CONST objv[])
}
declare 5 generic {
int Itk_ClassOptionIllegalCmd (ClientData cdata, Tcl_Interp *interp, \
int objc, Tcl_Obj *CONST objv[])
}
declare 6 generic {
int Itk_ConfigClassOption (Tcl_Interp *interp, ItclObject *contextObj, \
ClientData cdata, CONST char* newVal)
}
declare 7 generic {
ItkClassOptTable* Itk_CreateClassOptTable( Tcl_Interp *interp, \
ItclClass *cdefn)
}
declare 8 generic {
ItkClassOptTable* Itk_FindClassOptTable (ItclClass *cdefn)
}
#declare 9 generic {
# void Itk_DeleteClassOptTable (Tcl_Interp *interp, ItclClass *cdefn)
#}
declare 10 generic {
int Itk_CreateClassOption (Tcl_Interp *interp, ItclClass *cdefn, \
char *switchName, char *resName, char *resClass, char *defVal, \
char *config, ItkClassOption **optPtr)
}
declare 11 generic {
ItkClassOption* Itk_FindClassOption (ItclClass *cdefn, char *switchName)
}
declare 12 generic {
void Itk_DelClassOption (ItkClassOption *opt)
}
@@ -37,85 +84,24 @@ declare 1 {
# Functions needed for the Archetype base class:
#
declare 13 {
int Itk_ArchetypeInit(Tcl_Interp *interp)
declare 13 generic {
int Itk_ArchetypeInit (Tcl_Interp* interp)
}
# private API
interface itkInt
#
# Functions used within the package, but not considered "public"
#
#
# Functions used internally by this package:
#
declare 2 {
int Itk_ConfigBodyCmd(void *cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 3 {
int Itk_UsualCmd(void *cdata, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
#
# Functions for managing options included in class definitions:
#
declare 4 {
int Itk_ClassOptionDefineCmd(void *cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 5 {
int Itk_ClassOptionIllegalCmd(void *cdata, Tcl_Interp *interp, \
int objc, Tcl_Obj *const objv[])
}
declare 6 {
int Itk_ConfigClassOption(Tcl_Interp *interp, ItclObject *contextObj, \
void *cdata, const char *newVal)
}
declare 7 {
ItkClassOptTable* Itk_CreateClassOptTable(Tcl_Interp *interp, \
ItclClass *cdefn)
}
declare 8 {
ItkClassOptTable* Itk_FindClassOptTable(ItclClass *cdefn)
}
#declare 9 {
# void Itk_DeleteClassOptTable(Tcl_Interp *interp, ItclClass *cdefn)
#}
declare 10 {
int Itk_CreateClassOption(Tcl_Interp *interp, ItclClass *cdefn,
const char *switchName, const char *resName, const char *resClass, const char *defVal,
const char *config, ItkClassOption **optPtr)
}
declare 11 {
ItkClassOption* Itk_FindClassOption(ItclClass *cdefn, const char *switchName)
}
declare 12 {
void Itk_DelClassOption(ItkClassOption *opt)
}
#
# Functions for maintaining the ordered option list:
#
declare 14 {
void Itk_OptListInit(ItkOptList *olist, Tcl_HashTable *options)
declare 14 generic {
void Itk_OptListInit (ItkOptList* olist, Tcl_HashTable *options)
}
declare 15 {
void Itk_OptListFree(ItkOptList *olist)
declare 15 generic {
void Itk_OptListFree (ItkOptList* olist)
}
declare 16 {
void Itk_OptListAdd(ItkOptList *olist, Tcl_HashEntry *entry)
declare 16 generic {
void Itk_OptListAdd (ItkOptList* olist, Tcl_HashEntry *entry)
}
declare 17 {
void Itk_OptListRemove(ItkOptList *olist, Tcl_HashEntry *entry)
declare 17 generic {
void Itk_OptListRemove (ItkOptList* olist, Tcl_HashEntry *entry)
}
+50 -18
View File
@@ -46,21 +46,24 @@
#ifndef ITK_H
#define ITK_H
#if defined(BUILD_itk)
# define ITKAPI DLLEXPORT
# undef USE_ITK_STUBS
# undef USE_ITCL_STUBS
#else
# define ITKAPI DLLIMPORT
#ifndef TCL_ALPHA_RELEASE
# define TCL_ALPHA_RELEASE 0
#endif
#ifndef TCL_BETA_RELEASE
# define TCL_BETA_RELEASE 1
#endif
#ifndef TCL_FINAL_RELEASE
# define TCL_FINAL_RELEASE 2
#endif
#define ITK_MAJOR_VERSION 4
#define ITK_MINOR_VERSION 2
#define ITK_RELEASE_LEVEL TCL_FINAL_RELEASE
#define ITK_RELEASE_SERIAL 7
#define ITK_VERSION "4.2"
#define ITK_PATCH_LEVEL "4.2.7"
#define ITK_MAJOR_VERSION 3
#define ITK_MINOR_VERSION 4
#define ITK_RELEASE_LEVEL TCL_FINAL_RELEASE
#define ITK_RELEASE_SERIAL 2
#define ITK_VERSION "3.4"
#define ITK_PATCH_LEVEL "3.4.2"
/*
@@ -72,7 +75,8 @@
#ifndef RC_INVOKED
#include <tk.h>
#include "tk.h"
#include "itclInt.h"
#undef TCL_STORAGE_CLASS
#ifdef BUILD_itk
@@ -85,21 +89,49 @@
# endif
#endif
/*
* List of options in alphabetical order:
*/
typedef struct ItkOptList {
Tcl_HashTable *options; /* list containing the real options */
Tcl_HashEntry **list; /* gives ordering of options */
int len; /* number of entries in order list */
int max; /* maximum size of order list */
} ItkOptList;
/*
* List of options created in the class definition:
*/
typedef struct ItkClassOptTable {
Tcl_HashTable options; /* option storage with fast lookup */
ItkOptList order; /* gives ordering of options */
} ItkClassOptTable;
/*
* Each option created in the class definition:
*/
typedef struct ItkClassOption {
ItclMember *member; /* info about this option */
char *resName; /* resource name in X11 database */
char *resClass; /* resource class name in X11 database */
char *init; /* initial value for option */
} ItkClassOption;
#include "itkDecls.h"
/*
* This function is contained in the itkstub static library
*/
#ifdef USE_ITK_STUBS
EXTERN const char *
Itk_InitStubs(Tcl_Interp *interp,
const char *version, int exact);
TCL_EXTERNC CONST char *
Itk_InitStubs _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *version, int exact));
#else
#define Itk_InitStubs(interp, version, exact) \
Tcl_PkgRequire(interp, "Itk", version, exact)
#endif
#include "itkDecls.h"
/*
* Public functions that are not accessible via the stubs table.
*/
File diff suppressed because it is too large Load Diff
File diff suppressed because it is too large Load Diff
-329
View File
@@ -1,329 +0,0 @@
/*
* ------------------------------------------------------------------------
* PACKAGE: [incr Tk]
* DESCRIPTION: Building mega-widgets with [incr Tcl]
*
* [incr Tk] provides a framework for building composite "mega-widgets"
* using [incr Tcl] classes. It defines a set of base classes that are
* specialized to create all other widgets.
*
* This file defines the initialization and facilities common to all
* mega-widgets.
*
* ========================================================================
* AUTHOR: Michael J. McLennan
* Bell Labs Innovations for Lucent Technologies
* mmclennan@lucent.com
* http://www.tcltk.com/itcl
* ========================================================================
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
* ------------------------------------------------------------------------
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "itkInt.h"
#include "itkUuid.h"
MODULE_SCOPE const ItkStubs itkStubs;
/*
* The following script is used to initialize Itcl in a safe interpreter.
*/
static char safeInitScript[] =
"proc ::itcl::local {class name args} {\n\
set ptr [uplevel [list $class $name] $args]\n\
uplevel [list set itcl-local-$ptr $ptr]\n\
set cmd [uplevel namespace which -command $ptr]\n\
uplevel [list trace variable itcl-local-$ptr u \"::itcl::delete object $cmd; list\"]\n\
return $ptr\n\
}";
/*
* FORWARD DECLARATIONS
*/
static int Initialize (Tcl_Interp *interp);
/*
* The following string is the startup script executed in new
* interpreters. It looks on disk in several different directories
* for a script "init.tcl" that is compatible with this version
* of Tcl. The init.tcl script does all of the real work of
* initialization.
*/
static char initScript[] = "\n\
namespace eval ::itk {\n\
proc _find_init {} {\n\
global env tcl_library\n\
variable library\n\
variable patchLevel\n\
rename _find_init {}\n\
if {[info exists library]} {\n\
lappend dirs $library\n\
} else {\n\
set dirs {}\n\
if {[info exists env(ITK_LIBRARY)]} {\n\
lappend dirs $env(ITK_LIBRARY)\n\
}\n\
lappend dirs [file join [file dirname $tcl_library] itk$patchLevel]\n\
set bindir [file dirname [info nameofexecutable]]\n\
lappend dirs [file join $bindir .. lib itk$patchLevel]\n\
lappend dirs [file join $bindir .. library]\n\
lappend dirs [file join $bindir .. .. library]\n\
lappend dirs [file join $bindir .. .. itk library]\n\
# On MacOSX, check the directories in the tcl_pkgPath\n\
if {[string equal $::tcl_platform(platform) \"unix\"] && \
[string equal $::tcl_platform(os) \"Darwin\"]} {\n\
foreach d $::tcl_pkgPath {\n\
lappend dirs [file join $d itk$patchLevel]\n\
}\n\
}\n\
}\n\
foreach i $dirs {\n\
set library $i\n\
set itkfile [file join $i itk.tcl]\n\
if {![catch {uplevel #0 [list source $itkfile]} msg]} {\n\
return\n\
}\n\
}\n\
set msg \"Can't find a usable itk.tcl in the following directories:\n\"\n\
append msg \" $dirs\n\"\n\
append msg \"This probably means that Itcl/Itk weren't installed properly.\n\"\n\
append msg \"If you know where the Itk library directory was installed,\n\"\n\
append msg \"you can set the environment variable ITK_LIBRARY to point\n\"\n\
append msg \"to the library directory.\n\"\n\
error $msg\n\
}\n\
_find_init\n\
}";
/*
* ------------------------------------------------------------------------
* Initialize()
*
* Invoked whenever a new interpeter is created to install the
* [incr Tk] package.
*
* Creates the "::itk" namespace and installs access commands.
*
* Returns TCL_OK on success, or TCL_ERROR (along with an error
* message in the interpreter) if anything goes wrong.
* ------------------------------------------------------------------------
*/
#ifndef STRINGIFY
# define STRINGIFY(x) STRINGIFY1(x)
# define STRINGIFY1(x) #x
#endif
static int
Initialize(
Tcl_Interp *interp) /* interpreter to be updated */
{
Tcl_Namespace *itkNs, *parserNs;
void *parserInfo;
Tcl_CmdInfo info;
if (Tcl_InitStubs(interp, "8.6-", 0) == NULL) {
return TCL_ERROR;
}
if (Tk_InitStubs(interp, "8.6-", 0) == NULL) {
return TCL_ERROR;
};
if (Itcl_InitStubs(interp, "4.1", 0) == NULL) {
return TCL_ERROR;
}
/*
* Add the "itk_option" ensemble to the itcl class definition parser.
*/
parserNs = Tcl_FindNamespace(interp, "::itcl::parser",
(Tcl_Namespace*)NULL, /* flags */ 0);
if (!parserNs) {
Tcl_AppendResult(interp,
"cannot initialize [incr Tk]: [incr Tcl] has not been installed\n",
"Make sure that Itcl_Init() is called before Itk_Init()",
(char*)NULL);
return TCL_ERROR;
}
parserInfo = parserNs->clientData;
if (Itcl_CreateEnsemble(interp, "::itcl::parser::itk_option") != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::parser::itk_option",
"define", "-switch resourceName resourceClass init ?config?",
Itk_ClassOptionDefineCmd,
parserInfo, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(parserInfo);
if (Itcl_AddEnsemblePart(interp, "::itcl::parser::itk_option",
"add", "name ?name name...?",
Itk_ClassOptionIllegalCmd,
(void *)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||
Itcl_AddEnsemblePart(interp, "::itcl::parser::itk_option",
"remove", "name ?name name...?",
Itk_ClassOptionIllegalCmd,
(void *)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {
return TCL_ERROR;
}
/*
* Install [incr Tk] facilities if not already installed.
*/
itkNs = Tcl_FindNamespace(interp, "::itk", (Tcl_Namespace*)NULL,
/* flags */ 0);
if (itkNs == NULL) {
/*
* Create the "itk" namespace. Export all the commands in
* the namespace so that they can be imported by a command
* such as "namespace import itk::*"
*/
itkNs = Tcl_CreateNamespace(interp, "::itk",
(void *)NULL, (Tcl_NamespaceDeleteProc*)NULL);
}
if (!itkNs ||
Tcl_Export(interp, itkNs, "*", /* resetListFirst */ 1) != TCL_OK) {
return TCL_ERROR;
}
/*
* Setup things for itk::Archetype base class.
*/
if (Itk_ArchetypeInit(interp) != TCL_OK) {
return TCL_ERROR;
}
/*
* Fix the "itcl::configbody" command to recognize mega-widget
* options.
*/
Tcl_CreateObjCommand(interp, "::itcl::configbody", Itk_ConfigBodyCmd,
(void *)NULL, (Tcl_CmdDeleteProc*)NULL);
Tcl_SetVar(interp, "::itk::version", ITK_VERSION, TCL_NAMESPACE_ONLY);
Tcl_SetVar(interp, "::itk::patchLevel", ITK_PATCH_LEVEL,
TCL_NAMESPACE_ONLY);
/*
* Signal that the package has been loaded and provide the Itk Stubs table
* for dependent modules. I know this is unlikely, but possible that
* someone could be extending Itk. Who is to say that Itk is the
* end-of-the-line?
*/
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
Tcl_CreateObjCommand(interp, "::itk::build-info",
info.objProc, (void *)(PACKAGE_VERSION "+" STRINGIFY(ITK_VERSION_UUID)
#if defined(__clang__) && defined(__clang_major__)
".clang-" STRINGIFY(__clang_major__)
#if __clang_minor__ < 10
"0"
#endif
STRINGIFY(__clang_minor__)
#endif
#if defined(__cplusplus) && !defined(__OBJC__)
".cplusplus"
#endif
#ifndef NDEBUG
".debug"
#endif
#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__)
".gcc-" STRINGIFY(__GNUC__)
#if __GNUC_MINOR__ < 10
"0"
#endif
STRINGIFY(__GNUC_MINOR__)
#endif
#ifdef __INTEL_COMPILER
".icc-" STRINGIFY(__INTEL_COMPILER)
#endif
#ifdef TCL_MEM_DEBUG
".memdebug"
#endif
#if defined(_MSC_VER)
".msvc-" STRINGIFY(_MSC_VER)
#endif
#ifdef USE_NMAKE
".nmake"
#endif
#ifndef TCL_CFG_OPTIMIZED
".no-optimize"
#endif
#ifdef __OBJC__
".objective-c"
#if defined(__cplusplus)
"plusplus"
#endif
#endif
#ifdef TCL_CFG_PROFILED
".profile"
#endif
#ifdef PURIFY
".purify"
#endif
#ifdef STATIC_BUILD
".static"
#endif
), NULL);
}
Tcl_PkgProvideEx(interp, "Itk", ITK_PATCH_LEVEL, (void *) &itkStubs);
return Tcl_PkgProvideEx(interp, "itk", ITK_PATCH_LEVEL,
(void *) &itkStubs);
}
/*
* ------------------------------------------------------------------------
* Itk_Init()
*
* Invoked whenever a new interpreter is created to install the
* [incr Tcl] package. Usually invoked within Tcl_AppInit() at
* the start of execution.
*
* Creates the "::itk" namespace and installs access commands.
*
* Returns TCL_OK on success, or TCL_ERROR (along with an error
* message in the interpreter) if anything goes wrong.
* ------------------------------------------------------------------------
*/
int
Itk_Init(
Tcl_Interp *interp) /* interpreter to be updated */
{
if (Initialize(interp) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_EvalEx(interp, initScript, -1, 0);
}
/*
* ------------------------------------------------------------------------
* Itk_SafeInit()
*
* Invoked whenever a new SAFE INTERPRETER is created to install
* the [incr Tcl] package.
*
* Creates the "::itk" namespace and installs access commands for
* creating classes and querying info.
*
* Returns TCL_OK on success, or TCL_ERROR (along with an error
* message in the interpreter) if anything goes wrong.
* ------------------------------------------------------------------------
*/
int
Itk_SafeInit(
Tcl_Interp *interp) /* interpreter to be updated */
{
if (Initialize(interp) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_EvalEx(interp, safeInitScript, -1, 0);
}
-148
View File
@@ -1,148 +0,0 @@
/*
* ------------------------------------------------------------------------
* PACKAGE: [incr Tk]
* DESCRIPTION: Building mega-widgets with [incr Tcl]
*
* [incr Tk] provides a framework for building composite "mega-widgets"
* using [incr Tcl] classes. It defines a set of base classes that are
* specialized to create all other widgets.
*
* This file defines the initialization and facilities common to all
* mega-widgets.
*
* ========================================================================
* AUTHOR: Michael J. McLennan
* Bell Labs Innovations for Lucent Technologies
* mmclennan@lucent.com
* http://www.tcltk.com/itcl
* ========================================================================
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
* ------------------------------------------------------------------------
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "itkInt.h"
/*
* ------------------------------------------------------------------------
* Itk_ConfigBodyCmd()
*
* Replacement for the usual "itcl::configbody" command. Recognizes
* mega-widget options included in a class definition. Options are
* identified by their "switch" name, but without the "-" prefix:
*
* itcl::configbody <class>::<itkOption> <body>
*
* Handles bodies for public variables as well:
*
* itcl::configbody <class>::<publicVar> <body>
*
* If an <itkOption> is found, it has priority over public variables.
* If <body> has the form "@name" then it is treated as a reference
* to a C handling procedure; otherwise, it is taken as a body of
* Tcl statements.
*
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
* ------------------------------------------------------------------------
*/
int
Itk_ConfigBodyCmd(
void *dummy, /* unused */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
int result = TCL_OK;
char *token;
const char *head;
const char *tail;
ItclClass *iclsPtr;
ItclMemberCode *mcode;
ItkClassOptTable *optTable;
Tcl_HashEntry *entry;
ItkClassOption *opt;
Tcl_DString buffer;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "class::option body");
return TCL_ERROR;
}
/*
* Parse the member name "namesp::namesp::class::option".
* Make sure that a class name was specified, and that the
* class exists.
*/
token = Tcl_GetString(objv[1]);
Itcl_ParseNamespPath(token, &buffer, &head, &tail);
if (!head || *head == '\0') {
Tcl_AppendResult(interp,
"missing class specifier for body declaration \"", token, "\"",
(char*)NULL);
result = TCL_ERROR;
goto configBodyCmdDone;
}
iclsPtr = Itcl_FindClass(interp, head, /* autoload */ 1);
if (iclsPtr == NULL) {
result = TCL_ERROR;
goto configBodyCmdDone;
}
/*
* Look first for a configuration option with that name.
* If it is not found, assume the reference is for a public
* variable, and use the usual "configbody" implementation
* to handle it.
*/
optTable = Itk_FindClassOptTable(iclsPtr);
opt = NULL;
if (optTable) {
Tcl_DString optName;
Tcl_DStringInit(&optName);
Tcl_DStringAppend(&optName, "-", -1);
Tcl_DStringAppend(&optName, tail, -1);
entry = Tcl_FindHashEntry(&optTable->options,
Tcl_DStringValue(&optName));
if (entry) {
opt = (ItkClassOption*)Tcl_GetHashValue(entry);
}
Tcl_DStringFree(&optName);
}
if (opt == NULL) {
result = Itcl_ConfigBodyCmd(dummy, interp, objc, objv);
goto configBodyCmdDone;
}
/*
* Otherwise, change the implementation for this option.
*/
token = Tcl_GetString(objv[2]);
if (Itcl_CreateMemberCode(interp, iclsPtr, (char*)NULL, token,
&mcode) != TCL_OK) {
result = TCL_ERROR;
goto configBodyCmdDone;
}
Itcl_PreserveData((void *)mcode);
#ifdef NOTDEF
Itcl_EventuallyFree((void *)mcode, (Tcl_FreeProc *)Itcl_DeleteMemberCode);
#endif
if (opt->codePtr) {
Itcl_ReleaseData((void *)opt->codePtr);
}
opt->codePtr = mcode;
configBodyCmdDone:
Tcl_DStringFree(&buffer);
return result;
}
+214 -58
View File
@@ -1,91 +1,247 @@
/*
* itkDecls.h --
*
* Declarations of functions in the platform independent public Itk API.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _ITKDECLS
#define _ITKDECLS
#ifdef BUILD_itk
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
#endif
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
* script. Any modifications to the function declarations below should be made
* in the generic/tk.decls script.
*/
/* !BEGIN!: Do not edit below this line. */
#define ITK_STUBS_EPOCH 0
#define ITK_STUBS_REVISION 17
#ifdef __cplusplus
extern "C" {
#endif
/*
* Exported function declarations:
*/
#ifndef Itk_Init_TCL_DECLARED
#define Itk_Init_TCL_DECLARED
/* 0 */
ITKAPI int Itk_Init(Tcl_Interp *interp);
TCL_EXTERN(int) Itk_Init _ANSI_ARGS_((Tcl_Interp * interp));
#endif
#ifndef Itk_SafeInit_TCL_DECLARED
#define Itk_SafeInit_TCL_DECLARED
/* 1 */
ITKAPI int Itk_SafeInit(Tcl_Interp *interp);
/* Slot 2 is reserved */
/* Slot 3 is reserved */
/* Slot 4 is reserved */
/* Slot 5 is reserved */
/* Slot 6 is reserved */
/* Slot 7 is reserved */
/* Slot 8 is reserved */
TCL_EXTERN(int) Itk_SafeInit _ANSI_ARGS_((Tcl_Interp * interp));
#endif
#ifndef Itk_ConfigBodyCmd_TCL_DECLARED
#define Itk_ConfigBodyCmd_TCL_DECLARED
/* 2 */
TCL_EXTERN(int) Itk_ConfigBodyCmd _ANSI_ARGS_((ClientData cdata,
Tcl_Interp * interp, int objc,
Tcl_Obj *CONST objv[]));
#endif
#ifndef Itk_UsualCmd_TCL_DECLARED
#define Itk_UsualCmd_TCL_DECLARED
/* 3 */
TCL_EXTERN(int) Itk_UsualCmd _ANSI_ARGS_((ClientData cdata,
Tcl_Interp * interp, int objc,
Tcl_Obj *CONST objv[]));
#endif
#ifndef Itk_ClassOptionDefineCmd_TCL_DECLARED
#define Itk_ClassOptionDefineCmd_TCL_DECLARED
/* 4 */
TCL_EXTERN(int) Itk_ClassOptionDefineCmd _ANSI_ARGS_((
ClientData cdata, Tcl_Interp * interp,
int objc, Tcl_Obj *CONST objv[]));
#endif
#ifndef Itk_ClassOptionIllegalCmd_TCL_DECLARED
#define Itk_ClassOptionIllegalCmd_TCL_DECLARED
/* 5 */
TCL_EXTERN(int) Itk_ClassOptionIllegalCmd _ANSI_ARGS_((
ClientData cdata, Tcl_Interp * interp,
int objc, Tcl_Obj *CONST objv[]));
#endif
#ifndef Itk_ConfigClassOption_TCL_DECLARED
#define Itk_ConfigClassOption_TCL_DECLARED
/* 6 */
TCL_EXTERN(int) Itk_ConfigClassOption _ANSI_ARGS_((
Tcl_Interp * interp, ItclObject * contextObj,
ClientData cdata, CONST char* newVal));
#endif
#ifndef Itk_CreateClassOptTable_TCL_DECLARED
#define Itk_CreateClassOptTable_TCL_DECLARED
/* 7 */
TCL_EXTERN(ItkClassOptTable*) Itk_CreateClassOptTable _ANSI_ARGS_((
Tcl_Interp * interp, ItclClass * cdefn));
#endif
#ifndef Itk_FindClassOptTable_TCL_DECLARED
#define Itk_FindClassOptTable_TCL_DECLARED
/* 8 */
TCL_EXTERN(ItkClassOptTable*) Itk_FindClassOptTable _ANSI_ARGS_((
ItclClass * cdefn));
#endif
/* Slot 9 is reserved */
/* Slot 10 is reserved */
/* Slot 11 is reserved */
/* Slot 12 is reserved */
#ifndef Itk_CreateClassOption_TCL_DECLARED
#define Itk_CreateClassOption_TCL_DECLARED
/* 10 */
TCL_EXTERN(int) Itk_CreateClassOption _ANSI_ARGS_((
Tcl_Interp * interp, ItclClass * cdefn,
char * switchName, char * resName,
char * resClass, char * defVal,
char * config, ItkClassOption ** optPtr));
#endif
#ifndef Itk_FindClassOption_TCL_DECLARED
#define Itk_FindClassOption_TCL_DECLARED
/* 11 */
TCL_EXTERN(ItkClassOption*) Itk_FindClassOption _ANSI_ARGS_((
ItclClass * cdefn, char * switchName));
#endif
#ifndef Itk_DelClassOption_TCL_DECLARED
#define Itk_DelClassOption_TCL_DECLARED
/* 12 */
TCL_EXTERN(void) Itk_DelClassOption _ANSI_ARGS_((ItkClassOption * opt));
#endif
#ifndef Itk_ArchetypeInit_TCL_DECLARED
#define Itk_ArchetypeInit_TCL_DECLARED
/* 13 */
ITKAPI int Itk_ArchetypeInit(Tcl_Interp *interp);
typedef struct {
const struct ItkIntStubs *itkIntStubs;
} ItkStubHooks;
TCL_EXTERN(int) Itk_ArchetypeInit _ANSI_ARGS_((Tcl_Interp* interp));
#endif
#ifndef Itk_OptListInit_TCL_DECLARED
#define Itk_OptListInit_TCL_DECLARED
/* 14 */
TCL_EXTERN(void) Itk_OptListInit _ANSI_ARGS_((ItkOptList* olist,
Tcl_HashTable * options));
#endif
#ifndef Itk_OptListFree_TCL_DECLARED
#define Itk_OptListFree_TCL_DECLARED
/* 15 */
TCL_EXTERN(void) Itk_OptListFree _ANSI_ARGS_((ItkOptList* olist));
#endif
#ifndef Itk_OptListAdd_TCL_DECLARED
#define Itk_OptListAdd_TCL_DECLARED
/* 16 */
TCL_EXTERN(void) Itk_OptListAdd _ANSI_ARGS_((ItkOptList* olist,
Tcl_HashEntry * entry));
#endif
#ifndef Itk_OptListRemove_TCL_DECLARED
#define Itk_OptListRemove_TCL_DECLARED
/* 17 */
TCL_EXTERN(void) Itk_OptListRemove _ANSI_ARGS_((ItkOptList* olist,
Tcl_HashEntry * entry));
#endif
typedef struct ItkStubs {
int magic;
int epoch;
int revision;
const ItkStubHooks *hooks;
struct ItkStubHooks *hooks;
int (*itk_Init) (Tcl_Interp *interp); /* 0 */
int (*itk_SafeInit) (Tcl_Interp *interp); /* 1 */
void (*reserved2)(void);
void (*reserved3)(void);
void (*reserved4)(void);
void (*reserved5)(void);
void (*reserved6)(void);
void (*reserved7)(void);
void (*reserved8)(void);
void (*reserved9)(void);
void (*reserved10)(void);
void (*reserved11)(void);
void (*reserved12)(void);
int (*itk_ArchetypeInit) (Tcl_Interp *interp); /* 13 */
int (*itk_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 0 */
int (*itk_SafeInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 1 */
int (*itk_ConfigBodyCmd) _ANSI_ARGS_((ClientData cdata, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 2 */
int (*itk_UsualCmd) _ANSI_ARGS_((ClientData cdata, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 3 */
int (*itk_ClassOptionDefineCmd) _ANSI_ARGS_((ClientData cdata, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 4 */
int (*itk_ClassOptionIllegalCmd) _ANSI_ARGS_((ClientData cdata, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 5 */
int (*itk_ConfigClassOption) _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj, ClientData cdata, CONST char* newVal)); /* 6 */
ItkClassOptTable* (*itk_CreateClassOptTable) _ANSI_ARGS_((Tcl_Interp * interp, ItclClass * cdefn)); /* 7 */
ItkClassOptTable* (*itk_FindClassOptTable) _ANSI_ARGS_((ItclClass * cdefn)); /* 8 */
void *reserved9;
int (*itk_CreateClassOption) _ANSI_ARGS_((Tcl_Interp * interp, ItclClass * cdefn, char * switchName, char * resName, char * resClass, char * defVal, char * config, ItkClassOption ** optPtr)); /* 10 */
ItkClassOption* (*itk_FindClassOption) _ANSI_ARGS_((ItclClass * cdefn, char * switchName)); /* 11 */
void (*itk_DelClassOption) _ANSI_ARGS_((ItkClassOption * opt)); /* 12 */
int (*itk_ArchetypeInit) _ANSI_ARGS_((Tcl_Interp* interp)); /* 13 */
void (*itk_OptListInit) _ANSI_ARGS_((ItkOptList* olist, Tcl_HashTable * options)); /* 14 */
void (*itk_OptListFree) _ANSI_ARGS_((ItkOptList* olist)); /* 15 */
void (*itk_OptListAdd) _ANSI_ARGS_((ItkOptList* olist, Tcl_HashEntry * entry)); /* 16 */
void (*itk_OptListRemove) _ANSI_ARGS_((ItkOptList* olist, Tcl_HashEntry * entry)); /* 17 */
} ItkStubs;
extern const ItkStubs *itkStubsPtr;
TCL_EXTERNC ItkStubs *itkStubsPtr;
#ifdef __cplusplus
}
#endif
#if defined(USE_ITK_STUBS)
#if defined(USE_ITK_STUBS) && !defined(USE_ITK_STUB_PROCS)
/*
* Inline function declarations:
*/
#ifndef Itk_Init
#define Itk_Init \
(itkStubsPtr->itk_Init) /* 0 */
#endif
#ifndef Itk_SafeInit
#define Itk_SafeInit \
(itkStubsPtr->itk_SafeInit) /* 1 */
/* Slot 2 is reserved */
/* Slot 3 is reserved */
/* Slot 4 is reserved */
/* Slot 5 is reserved */
/* Slot 6 is reserved */
/* Slot 7 is reserved */
/* Slot 8 is reserved */
#endif
#ifndef Itk_ConfigBodyCmd
#define Itk_ConfigBodyCmd \
(itkStubsPtr->itk_ConfigBodyCmd) /* 2 */
#endif
#ifndef Itk_UsualCmd
#define Itk_UsualCmd \
(itkStubsPtr->itk_UsualCmd) /* 3 */
#endif
#ifndef Itk_ClassOptionDefineCmd
#define Itk_ClassOptionDefineCmd \
(itkStubsPtr->itk_ClassOptionDefineCmd) /* 4 */
#endif
#ifndef Itk_ClassOptionIllegalCmd
#define Itk_ClassOptionIllegalCmd \
(itkStubsPtr->itk_ClassOptionIllegalCmd) /* 5 */
#endif
#ifndef Itk_ConfigClassOption
#define Itk_ConfigClassOption \
(itkStubsPtr->itk_ConfigClassOption) /* 6 */
#endif
#ifndef Itk_CreateClassOptTable
#define Itk_CreateClassOptTable \
(itkStubsPtr->itk_CreateClassOptTable) /* 7 */
#endif
#ifndef Itk_FindClassOptTable
#define Itk_FindClassOptTable \
(itkStubsPtr->itk_FindClassOptTable) /* 8 */
#endif
/* Slot 9 is reserved */
/* Slot 10 is reserved */
/* Slot 11 is reserved */
/* Slot 12 is reserved */
#ifndef Itk_CreateClassOption
#define Itk_CreateClassOption \
(itkStubsPtr->itk_CreateClassOption) /* 10 */
#endif
#ifndef Itk_FindClassOption
#define Itk_FindClassOption \
(itkStubsPtr->itk_FindClassOption) /* 11 */
#endif
#ifndef Itk_DelClassOption
#define Itk_DelClassOption \
(itkStubsPtr->itk_DelClassOption) /* 12 */
#endif
#ifndef Itk_ArchetypeInit
#define Itk_ArchetypeInit \
(itkStubsPtr->itk_ArchetypeInit) /* 13 */
#endif
#ifndef Itk_OptListInit
#define Itk_OptListInit \
(itkStubsPtr->itk_OptListInit) /* 14 */
#endif
#ifndef Itk_OptListFree
#define Itk_OptListFree \
(itkStubsPtr->itk_OptListFree) /* 15 */
#endif
#ifndef Itk_OptListAdd
#define Itk_OptListAdd \
(itkStubsPtr->itk_OptListAdd) /* 16 */
#endif
#ifndef Itk_OptListRemove
#define Itk_OptListRemove \
(itkStubsPtr->itk_OptListRemove) /* 17 */
#endif
#endif /* defined(USE_ITK_STUBS) */
#endif /* defined(USE_ITK_STUBS) && !defined(USE_ITK_STUB_PROCS) */
/* !END!: Do not edit above this line. */
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _ITKDECLS */
-195
View File
@@ -1,195 +0,0 @@
/*
* ------------------------------------------------------------------------
* PACKAGE: [incr Tk]
* DESCRIPTION: Building mega-widgets with [incr Tcl]
*
* [incr Tk] provides a framework for building composite "mega-widgets"
* using [incr Tcl] classes. It defines a set of base classes that are
* specialized to create all other widgets.
*
* This part adds C implementations for some helxeper methods in the
* base class itk::Archetype.
*
* ========================================================================
* AUTHOR: Michael J. McLennan
* Bell Labs Innovations for Lucent Technologies
* mmclennan@lucent.com
* http://www.tcltk.com/itcl
* ========================================================================
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
* ------------------------------------------------------------------------
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include <assert.h>
#include "itkInt.h"
/*
* ------------------------------------------------------------------------
* Itk_ArchOptConfigError()
*
* Simply utility which adds error information after a option
* configuration fails. Adds traceback information to the given
* interpreter.
* ------------------------------------------------------------------------
*/
void
Itk_ArchOptConfigError(
Tcl_Interp *interp, /* interpreter handling this object */
ArchInfo *info, /* info associated with mega-widget */
ArchOption *archOpt) /* configuration option that failed */
{
Tcl_Obj *objPtr;
objPtr = Tcl_NewStringObj((char*)NULL, 0);
Tcl_IncrRefCount(objPtr);
Tcl_AppendToObj(objPtr, "\n (while configuring option \"", -1);
Tcl_AppendToObj(objPtr, archOpt->switchName, -1);
Tcl_AppendToObj(objPtr, "\"", -1);
if (info->itclObj && info->itclObj->accessCmd) {
Tcl_AppendToObj(objPtr, " for widget \"", -1);
Tcl_GetCommandFullName(interp, info->itclObj->accessCmd, objPtr);
Tcl_AppendToObj(objPtr, "\")", -1);
}
Tcl_AddErrorInfo(interp, Tcl_GetString(objPtr));
Tcl_DecrRefCount(objPtr);
}
/*
* ------------------------------------------------------------------------
* Itk_ArchOptAccessError()
*
* Simply utility which adds error information after an option
* value access fails. Adds traceback information to the given
* interpreter.
* ------------------------------------------------------------------------
*/
void
Itk_ArchOptAccessError(
Tcl_Interp *interp, /* interpreter handling this object */
ArchInfo *info, /* info associated with mega-widget */
ArchOption *archOpt) /* option that couldn't be accessed */
{
Tcl_ResetResult(interp);
Tcl_AppendResult(interp,
"internal error: cannot access itk_option(", archOpt->switchName, ")",
(char*)NULL);
if (info->itclObj->accessCmd) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(resultPtr, " in widget \"", -1);
Tcl_GetCommandFullName(interp, info->itclObj->accessCmd, resultPtr);
Tcl_AppendToObj(resultPtr, "\"", -1);
}
}
/*
* ------------------------------------------------------------------------
* Itk_GetArchInfo()
*
* Finds the extra Archetype info associated with the given object.
* Returns TCL_OK and a pointer to the info if found. Returns
* TCL_ERROR along with an error message in interp->result if not.
* ------------------------------------------------------------------------
*/
int
Itk_GetArchInfo(
Tcl_Interp *interp, /* interpreter handling this object */
ItclObject *contextObj, /* object with desired data */
ArchInfo **infoPtr) /* returns: pointer to extra info */
{
Tcl_HashTable *objsWithArchInfo;
Tcl_HashEntry *entry;
/*
* If there is any problem finding the info, return an error.
*/
objsWithArchInfo = ItkGetObjsWithArchInfo(interp);
entry = Tcl_FindHashEntry(objsWithArchInfo, (char*)contextObj);
if (!entry) {
Tcl_AppendResult(interp,
"internal error: no Archetype information for widget",
(char*)NULL);
if (contextObj->accessCmd) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(resultPtr, " \"", -1);
Tcl_GetCommandFullName(interp, contextObj->accessCmd, resultPtr);
Tcl_AppendToObj(resultPtr, "\"", -1);
}
return TCL_ERROR;
}
/*
* Otherwise, return the requested info.
*/
*infoPtr = (ArchInfo*)Tcl_GetHashValue(entry);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* ItkGetObjsWithArchInfo()
*
* Returns a pointer to a hash table containing the list of registered
* objects in the specified interpreter. If the hash table does not
* already exist, it is created.
* ------------------------------------------------------------------------
*/
Tcl_HashTable*
ItkGetObjsWithArchInfo(
Tcl_Interp *interp) /* interpreter handling this registration */
{
Tcl_HashTable* objTable;
/*
* If the registration table does not yet exist, then create it.
*/
objTable = (Tcl_HashTable*)Tcl_GetAssocData(interp,
"itk_objsWithArchInfo", (Tcl_InterpDeleteProc**)NULL);
if (!objTable) {
objTable = (Tcl_HashTable*)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(objTable, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, "itk_objsWithArchInfo",
ItkFreeObjsWithArchInfo, (void *)objTable);
}
return objTable;
}
/*
* ------------------------------------------------------------------------
* ItkFreeObjsWithArchInfo()
*
* When an interpreter is deleted, this procedure is called to
* free up the associated data created by ItkGetObjsWithArchInfo.
* ------------------------------------------------------------------------
*/
void
ItkFreeObjsWithArchInfo(
void *clientData, /* associated data */
TCL_UNUSED(Tcl_Interp *)) /* interpreter being freed */
{
Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData;
Tcl_HashSearch place;
Tcl_HashEntry *entry;
entry = Tcl_FirstHashEntry(tablePtr, &place);
while (entry) {
Itk_DelArchInfo( Tcl_GetHashValue(entry) );
entry = Tcl_NextHashEntry(&place);
}
Tcl_DeleteHashTable(tablePtr);
Tcl_Free(tablePtr);
}
-233
View File
@@ -1,233 +0,0 @@
/*
* ------------------------------------------------------------------------
* PACKAGE: [incr Tk]
* DESCRIPTION: Building mega-widgets with [incr Tcl]
*
* [incr Tk] provides a framework for building composite "mega-widgets"
* using [incr Tcl] classes. It defines a set of base classes that are
* specialized to create all other widgets.
*
*
* ========================================================================
* AUTHOR: Michael J. McLennan
* Bell Labs Innovations for Lucent Technologies
* mmclennan@lucent.com
* http://www.tcltk.com/itcl
* ========================================================================
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
* ------------------------------------------------------------------------
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include <itclInt.h>
#include "itk.h"
#if (TCL_MAJOR_VERSION == 8)
#undef Tcl_Free
#undef Tcl_Realloc
#if defined(USE_TCL_STUBS)
# define Tcl_Free(p) tclStubsPtr->tcl_Free((char *)(p))
# define Tcl_Realloc(p,m) tclStubsPtr->tcl_Realloc((char *)(p),(m))
#else
# define Tcl_Free(p) Tcl_Free((char *)(p))
# define Tcl_Realloc(p,m) Tcl_Realloc((char *)(p),(m))
#endif
#endif
/*
* List of options in alphabetical order:
*/
typedef struct ItkOptList {
Tcl_HashTable *options; /* list containing the real options */
Tcl_HashEntry **list; /* gives ordering of options */
int len; /* number of entries in order list */
int max; /* maximum size of order list */
} ItkOptList;
/*
* List of options created in the class definition:
*/
typedef struct ItkClassOptTable {
Tcl_HashTable options; /* option storage with fast lookup */
ItkOptList order; /* gives ordering of options */
} ItkClassOptTable;
/*
* Each option created in the class definition:
*/
typedef struct ItkClassOption {
Tcl_Obj* namePtr; /* member name */
Tcl_Obj* fullNamePtr; /* member name with "class::" qualifier */
ItclClass* iclsPtr; /* class containing this member */
int protection; /* protection level */
int flags; /* flags describing member (see above) */
ItclMemberCode *codePtr; /* code associated with member */
char *resName; /* resource name in X11 database */
char *resClass; /* resource class name in X11 database */
char *init; /* initial value for option */
} ItkClassOption;
/*
* Info associated with each Archetype mega-widget:
*/
typedef struct ArchInfo {
ItclObject *itclObj; /* object containing this info */
Tk_Window tkwin; /* window representing this mega-widget */
Tcl_HashTable components; /* list of all mega-widget components */
Tcl_HashTable options; /* list of all mega-widget options */
ItkOptList order; /* gives ordering of options */
} ArchInfo;
/*
* Each component widget in an Archetype mega-widget:
*/
typedef struct ArchComponent {
Tcl_Obj* namePtr; /* member name */
Tcl_Obj* fullNamePtr; /* member name with "class::" qualifier */
ItclClass* iclsPtr; /* class containing this member */
int protection; /* protection level */
int flags; /* flags describing member (see above) */
ItclMemberCode *codePtr; /* code associated with member */
Tcl_Command accessCmd; /* access command for component widget */
Tk_Window tkwin; /* Tk window for this component widget */
char *pathName; /* Tk path name for this component widget.
We can't use the tkwin pointer after
the window has been destroyed so we
need to save a copy for use in
Itk_ArchCompDeleteCmd() */
} ArchComponent;
/*
* Each option in an Archetype mega-widget:
*/
typedef struct ArchOption {
char *switchName; /* command-line switch for this option */
char *resName; /* resource name in X11 database */
char *resClass; /* resource class name in X11 database */
char *init; /* initial value for option */
int flags; /* flags representing option state */
Itcl_List parts; /* parts relating to this option */
} ArchOption;
/*
* Flag bits for ArchOption state:
*/
#define ITK_ARCHOPT_INIT 0x01 /* option has been initialized */
/*
* Various parts of a composite option in an Archetype mega-widget:
*/
typedef int (Itk_ConfigOptionPartProc) (Tcl_Interp *interp,
ItclObject *contextObj, void *cdata, const char* newVal);
typedef struct ArchOptionPart {
void *clientData; /* data associated with this part */
Itk_ConfigOptionPartProc *configProc; /* update when new vals arrive */
Tcl_CmdDeleteProc *deleteProc; /* clean up after clientData */
void *from; /* token that indicates who
* contributed this option part */
} ArchOptionPart;
/*
* Info kept by the itk::option-parser namespace and shared by
* all option processing commands:
*/
typedef struct ArchMergeInfo {
Tcl_HashTable usualCode; /* usual option handling code for the
* various widget classes */
ArchInfo *archInfo; /* internal option info for mega-widget */
ArchComponent *archComp; /* component being merged into mega-widget */
Tcl_HashTable *optionTable; /* table of valid configuration options
* for component being merged */
} ArchMergeInfo;
/*
* Used to capture component widget configuration options when a
* new component is being merged into a mega-widget:
*/
typedef struct GenericConfigOpt {
char *switchName; /* command-line switch for this option */
char *resName; /* resource name in X11 database */
char *resClass; /* resource class name in X11 database */
char *init; /* initial value for this option */
char *value; /* current value for this option */
char **storage; /* storage for above strings */
ArchOption *integrated; /* integrated into this mega-widget option */
ArchOptionPart *optPart; /* integrated as this option part */
} GenericConfigOpt;
/*
* Options that are propagated by a "configure" method:
*/
typedef struct ConfigCmdline {
Tcl_Obj *objv[4]; /* objects representing "configure" command */
} ConfigCmdline;
MODULE_SCOPE int Itk_ArchInitOptsCmd (void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchDeleteOptsCmd (void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchComponentCmd (void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchInitCmd (void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchOptionCmd (void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchCompAccessCmd (void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchConfigureCmd (void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchCgetCmd (void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchCompAddCmd(void *cdata,
Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchCompDeleteCmd(void *cdata,
Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchConfigOption(Tcl_Interp *interp,
ArchInfo *info, char *name, char *value);
MODULE_SCOPE int Itk_ArchOptionAddCmd(void *cdata,
Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchOptionRemoveCmd(void *cdata,
Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_PropagatePublicVar(Tcl_Interp *interp,
ItclObject *contextObj, void *cdata, const char *newval);
MODULE_SCOPE int Itk_GetArchInfo(Tcl_Interp *interp,
ItclObject* contextObj, ArchInfo **infoPtr);
MODULE_SCOPE void Itk_ArchOptConfigError(Tcl_Interp *interp,
ArchInfo *info, ArchOption *archOpt);
MODULE_SCOPE void Itk_ArchOptAccessError(Tcl_Interp *interp,
ArchInfo *info, ArchOption *archOpt);
MODULE_SCOPE ArchOptionPart* Itk_CreateOptionPart(
Tcl_Interp *interp, void *cdata, Itk_ConfigOptionPartProc* cproc,
Tcl_CmdDeleteProc *dproc, void *from);
MODULE_SCOPE int Itk_AddOptionPart(Tcl_Interp *interp,
ArchInfo *info, char *switchName, char *resName, char *resClass,
const char *defVal, char *currVal, ArchOptionPart *optPart,
ArchOption **raOpt);
MODULE_SCOPE ArchOptionPart* Itk_FindArchOptionPart(
ArchInfo *info, char *switchName, void *from);
MODULE_SCOPE void Itk_DelOptionPart(ArchOptionPart *optPart);
MODULE_SCOPE void Itk_DelArchInfo(void *cdata);
MODULE_SCOPE Tcl_HashTable* ItkGetObjsWithArchInfo
(Tcl_Interp *interp);
MODULE_SCOPE void ItkFreeObjsWithArchInfo(void *cdata,
Tcl_Interp *interp);
MODULE_SCOPE void Itk_DelMergeInfo(void *cdata);
MODULE_SCOPE int Itk_ArchOptKeepCmd(void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchOptIgnoreCmd(void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchOptRenameCmd(void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itk_ArchOptUsualCmd(void *cdata,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
#include "itkIntDecls.h"
-144
View File
@@ -1,144 +0,0 @@
/* !BEGIN!: Do not edit below this line. */
#define ITKINT_STUBS_EPOCH 0
#define ITKINT_STUBS_REVISION 17
#ifdef __cplusplus
extern "C" {
#endif
/*
* Exported function declarations:
*/
/* Slot 0 is reserved */
/* Slot 1 is reserved */
/* 2 */
ITKAPI int Itk_ConfigBodyCmd(void *cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
/* 3 */
ITKAPI int Itk_UsualCmd(void *cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
/* 4 */
ITKAPI int Itk_ClassOptionDefineCmd(void *cdata,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
/* 5 */
ITKAPI int Itk_ClassOptionIllegalCmd(void *cdata,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
/* 6 */
ITKAPI int Itk_ConfigClassOption(Tcl_Interp *interp,
ItclObject *contextObj, void *cdata,
const char *newVal);
/* 7 */
ITKAPI ItkClassOptTable* Itk_CreateClassOptTable(Tcl_Interp *interp,
ItclClass *cdefn);
/* 8 */
ITKAPI ItkClassOptTable* Itk_FindClassOptTable(ItclClass *cdefn);
/* Slot 9 is reserved */
/* 10 */
ITKAPI int Itk_CreateClassOption(Tcl_Interp *interp,
ItclClass *cdefn, const char *switchName,
const char *resName, const char *resClass,
const char *defVal, const char *config,
ItkClassOption **optPtr);
/* 11 */
ITKAPI ItkClassOption* Itk_FindClassOption(ItclClass *cdefn,
const char *switchName);
/* 12 */
ITKAPI void Itk_DelClassOption(ItkClassOption *opt);
/* Slot 13 is reserved */
/* 14 */
ITKAPI void Itk_OptListInit(ItkOptList *olist,
Tcl_HashTable *options);
/* 15 */
ITKAPI void Itk_OptListFree(ItkOptList *olist);
/* 16 */
ITKAPI void Itk_OptListAdd(ItkOptList *olist,
Tcl_HashEntry *entry);
/* 17 */
ITKAPI void Itk_OptListRemove(ItkOptList *olist,
Tcl_HashEntry *entry);
typedef struct ItkIntStubs {
int magic;
int epoch;
int revision;
void *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
int (*itk_ConfigBodyCmd) (void *cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 2 */
int (*itk_UsualCmd) (void *cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 3 */
int (*itk_ClassOptionDefineCmd) (void *cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 4 */
int (*itk_ClassOptionIllegalCmd) (void *cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 5 */
int (*itk_ConfigClassOption) (Tcl_Interp *interp, ItclObject *contextObj, void *cdata, const char *newVal); /* 6 */
ItkClassOptTable* (*itk_CreateClassOptTable) (Tcl_Interp *interp, ItclClass *cdefn); /* 7 */
ItkClassOptTable* (*itk_FindClassOptTable) (ItclClass *cdefn); /* 8 */
void (*reserved9)(void);
int (*itk_CreateClassOption) (Tcl_Interp *interp, ItclClass *cdefn, const char *switchName, const char *resName, const char *resClass, const char *defVal, const char *config, ItkClassOption **optPtr); /* 10 */
ItkClassOption* (*itk_FindClassOption) (ItclClass *cdefn, const char *switchName); /* 11 */
void (*itk_DelClassOption) (ItkClassOption *opt); /* 12 */
void (*reserved13)(void);
void (*itk_OptListInit) (ItkOptList *olist, Tcl_HashTable *options); /* 14 */
void (*itk_OptListFree) (ItkOptList *olist); /* 15 */
void (*itk_OptListAdd) (ItkOptList *olist, Tcl_HashEntry *entry); /* 16 */
void (*itk_OptListRemove) (ItkOptList *olist, Tcl_HashEntry *entry); /* 17 */
} ItkIntStubs;
extern const ItkIntStubs *itkIntStubsPtr;
#ifdef __cplusplus
}
#endif
#if defined(USE_ITK_STUBS)
/*
* Inline function declarations:
*/
/* Slot 0 is reserved */
/* Slot 1 is reserved */
#define Itk_ConfigBodyCmd \
(itkIntStubsPtr->itk_ConfigBodyCmd) /* 2 */
#define Itk_UsualCmd \
(itkIntStubsPtr->itk_UsualCmd) /* 3 */
#define Itk_ClassOptionDefineCmd \
(itkIntStubsPtr->itk_ClassOptionDefineCmd) /* 4 */
#define Itk_ClassOptionIllegalCmd \
(itkIntStubsPtr->itk_ClassOptionIllegalCmd) /* 5 */
#define Itk_ConfigClassOption \
(itkIntStubsPtr->itk_ConfigClassOption) /* 6 */
#define Itk_CreateClassOptTable \
(itkIntStubsPtr->itk_CreateClassOptTable) /* 7 */
#define Itk_FindClassOptTable \
(itkIntStubsPtr->itk_FindClassOptTable) /* 8 */
/* Slot 9 is reserved */
#define Itk_CreateClassOption \
(itkIntStubsPtr->itk_CreateClassOption) /* 10 */
#define Itk_FindClassOption \
(itkIntStubsPtr->itk_FindClassOption) /* 11 */
#define Itk_DelClassOption \
(itkIntStubsPtr->itk_DelClassOption) /* 12 */
/* Slot 13 is reserved */
#define Itk_OptListInit \
(itkIntStubsPtr->itk_OptListInit) /* 14 */
#define Itk_OptListFree \
(itkIntStubsPtr->itk_OptListFree) /* 15 */
#define Itk_OptListAdd \
(itkIntStubsPtr->itk_OptListAdd) /* 16 */
#define Itk_OptListRemove \
(itkIntStubsPtr->itk_OptListRemove) /* 17 */
#endif /* defined(USE_ITK_STUBS) */
/* !END!: Do not edit above this line. */
struct ItkStubAPI {
ItkStubs *stubsPtr;
ItkIntStubs *intStubsPtr;
};
+8 -37
View File
@@ -1,4 +1,4 @@
/*
/*
* tkStubInit.c --
*
* This file contains the initializers for the Itk stub vectors.
@@ -9,7 +9,7 @@
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "itkInt.h"
#include "itk.h"
/*
* Remove macros that will interfere with the definitions below.
@@ -21,17 +21,13 @@
* below should be made in the generic/itk.decls script.
*/
MODULE_SCOPE const ItkStubs itkStubs;
/* !BEGIN!: Do not edit below this line. */
static const ItkIntStubs itkIntStubs = {
ItkStubs itkStubs = {
TCL_STUB_MAGIC,
ITKINT_STUBS_EPOCH,
ITKINT_STUBS_REVISION,
0,
0, /* 0 */
0, /* 1 */
NULL,
Itk_Init, /* 0 */
Itk_SafeInit, /* 1 */
Itk_ConfigBodyCmd, /* 2 */
Itk_UsualCmd, /* 3 */
Itk_ClassOptionDefineCmd, /* 4 */
@@ -39,40 +35,15 @@ static const ItkIntStubs itkIntStubs = {
Itk_ConfigClassOption, /* 6 */
Itk_CreateClassOptTable, /* 7 */
Itk_FindClassOptTable, /* 8 */
0, /* 9 */
NULL, /* 9 */
Itk_CreateClassOption, /* 10 */
Itk_FindClassOption, /* 11 */
Itk_DelClassOption, /* 12 */
0, /* 13 */
Itk_ArchetypeInit, /* 13 */
Itk_OptListInit, /* 14 */
Itk_OptListFree, /* 15 */
Itk_OptListAdd, /* 16 */
Itk_OptListRemove, /* 17 */
};
static const ItkStubHooks itkStubHooks = {
&itkIntStubs
};
const ItkStubs itkStubs = {
TCL_STUB_MAGIC,
ITK_STUBS_EPOCH,
ITK_STUBS_REVISION,
&itkStubHooks,
Itk_Init, /* 0 */
Itk_SafeInit, /* 1 */
0, /* 2 */
0, /* 3 */
0, /* 4 */
0, /* 5 */
0, /* 6 */
0, /* 7 */
0, /* 8 */
0, /* 9 */
0, /* 10 */
0, /* 11 */
0, /* 12 */
Itk_ArchetypeInit, /* 13 */
};
/* !END!: Do not edit above this line. */
+14 -12
View File
@@ -1,4 +1,4 @@
/*
/*
* itkStubLib.c --
*
* Stub object that will be statically linked into extensions that wish
@@ -24,13 +24,14 @@
#undef USE_TCL_STUB_PROCS
#ifndef USE_ITK_STUBS
#define USE_ITK_STUBS 1
#define USE_ITK_STUBS
#endif
#undef USE_ITK_STUB_PROCS
#undef BUILD_itk
#include "itk.h"
ItkStubs *itkStubsPtr;
/*
*----------------------------------------------------------------------
@@ -50,20 +51,21 @@
*----------------------------------------------------------------------
*/
const char *
Itk_InitStubs (
Tcl_Interp *interp,
const char *version,
int exact)
CONST char *
Itk_InitStubs (interp, version, exact)
Tcl_Interp *interp;
CONST char *version;
int exact;
{
const char *actualVersion;
CONST char *actualVersion;
actualVersion = Tcl_PkgRequireEx(interp, "Itk", (CONST84 char *)version, exact,
(ClientData *) &itkStubsPtr);
actualVersion = Tcl_PkgRequireEx(interp, "itk", (const char *)version,
exact, &itkStubsPtr);
if (actualVersion == NULL) {
itkStubsPtr = NULL;
return NULL;
}
return actualVersion;
}
File diff suppressed because it is too large Load Diff
+414
View File
@@ -0,0 +1,414 @@
/*
* ------------------------------------------------------------------------
* PACKAGE: [incr Tk]
* DESCRIPTION: Building mega-widgets with [incr Tcl]
*
* [incr Tk] provides a framework for building composite "mega-widgets"
* using [incr Tcl] classes. It defines a set of base classes that are
* specialized to create all other widgets.
*
* This file defines the initialization and facilities common to all
* mega-widgets.
*
* ========================================================================
* AUTHOR: Michael J. McLennan
* Bell Labs Innovations for Lucent Technologies
* mmclennan@lucent.com
* http://www.tcltk.com/itcl
* ========================================================================
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
* ------------------------------------------------------------------------
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "itk.h"
/*
* The following script is used to initialize Itcl in a safe interpreter.
*/
static char safeInitScript[] =
"proc ::itcl::local {class name args} {\n\
set ptr [uplevel [list $class $name] $args]\n\
uplevel [list set itcl-local-$ptr $ptr]\n\
set cmd [uplevel namespace which -command $ptr]\n\
uplevel [list trace variable itcl-local-$ptr u \"::itcl::delete object $cmd; list\"]\n\
return $ptr\n\
}";
/*
* FORWARD DECLARATIONS
*/
static int Initialize _ANSI_ARGS_((Tcl_Interp *interp));
/*
* The following string is the startup script executed in new
* interpreters. It looks on disk in several different directories
* for a script "init.tcl" that is compatible with this version
* of Tcl. The init.tcl script does all of the real work of
* initialization.
*/
static char initScript[] = "\n\
namespace eval ::itk {\n\
proc _find_init {} {\n\
global env tcl_library\n\
variable library\n\
variable version\n\
rename _find_init {}\n\
if {[info exists library]} {\n\
lappend dirs $library\n\
} else {\n\
if {[catch {uplevel #0 source -rsrc itk}] == 0} {\n\
return\n\
}\n\
set dirs {}\n\
if {[info exists env(ITK_LIBRARY)]} {\n\
lappend dirs $env(ITK_LIBRARY)\n\
}\n\
lappend dirs [file join [file dirname $tcl_library] itk$version]\n\
set bindir [file dirname [info nameofexecutable]]\n\
lappend dirs [file join $bindir .. lib itk$version]\n\
lappend dirs [file join $bindir .. library]\n\
lappend dirs [file join $bindir .. .. library]\n\
lappend dirs [file join $bindir .. .. itk library]\n\
# On MacOSX, check the directories in the tcl_pkgPath\n\
if {[string equal $::tcl_platform(platform) \"unix\"] && \
[string equal $::tcl_platform(os) \"Darwin\"]} {\n\
foreach d $::tcl_pkgPath {\n\
lappend dirs [file join $d itk$version]\n\
}\n\
}\n\
}\n\
foreach i $dirs {\n\
set library $i\n\
set itkfile [file join $i itk.tcl]\n\
if {![catch {uplevel #0 [list source $itkfile]} msg]} {\n\
return\n\
}\n\
}\n\
set msg \"Can't find a usable itk.tcl in the following directories:\n\"\n\
append msg \" $dirs\n\"\n\
append msg \"This probably means that Itcl/Itk weren't installed properly.\n\"\n\
append msg \"If you know where the Itk library directory was installed,\n\"\n\
append msg \"you can set the environment variable ITK_LIBRARY to point\n\"\n\
append msg \"to the library directory.\n\"\n\
error $msg\n\
}\n\
_find_init\n\
}";
/*
* ------------------------------------------------------------------------
* Initialize()
*
* Invoked whenever a new interpeter is created to install the
* [incr Tk] package.
*
* Creates the "::itk" namespace and installs access commands.
*
* Returns TCL_OK on success, or TCL_ERROR (along with an error
* message in the interpreter) if anything goes wrong.
* ------------------------------------------------------------------------
*/
static int
Initialize(interp)
Tcl_Interp *interp; /* interpreter to be updated */
{
Tcl_Namespace *itkNs, *parserNs;
ClientData parserInfo;
#ifndef USE_TCL_STUBS
if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_PkgRequire(interp, "Tk", TK_VERSION, 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_PkgRequire(interp, "Itcl", ITCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
#else
if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
return TCL_ERROR;
}
if (Tk_InitStubs(interp, "8.1", 0) == NULL) {
return TCL_ERROR;
};
if (Itcl_InitStubs(interp, ITCL_VERSION, 1) == NULL) {
return TCL_ERROR;
}
#endif
/*
* Add the "itk_option" ensemble to the itcl class definition parser.
*/
parserNs = Tcl_FindNamespace(interp, "::itcl::parser",
(Tcl_Namespace*)NULL, /* flags */ 0);
if (!parserNs) {
Tcl_AppendResult(interp,
"cannot initialize [incr Tk]: [incr Tcl] has not been installed\n",
"Make sure that Itcl_Init() is called before Itk_Init()",
(char*)NULL);
return TCL_ERROR;
}
parserInfo = parserNs->clientData;
if (Itcl_CreateEnsemble(interp, "::itcl::parser::itk_option") != TCL_OK) {
return TCL_ERROR;
}
if (Itcl_AddEnsemblePart(interp, "::itcl::parser::itk_option",
"define", "-switch resourceName resourceClass init ?config?",
Itk_ClassOptionDefineCmd,
parserInfo, Itcl_ReleaseData) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData(parserInfo);
if (Itcl_AddEnsemblePart(interp, "::itcl::parser::itk_option",
"add", "name ?name name...?",
Itk_ClassOptionIllegalCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||
Itcl_AddEnsemblePart(interp, "::itcl::parser::itk_option",
"remove", "name ?name name...?",
Itk_ClassOptionIllegalCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {
return TCL_ERROR;
}
/*
* Install [incr Tk] facilities if not already installed.
*/
itkNs = Tcl_FindNamespace(interp, "::itk", (Tcl_Namespace*)NULL,
/* flags */ 0);
if (itkNs == NULL) {
/*
* Create the "itk" namespace. Export all the commands in
* the namespace so that they can be imported by a command
* such as "namespace import itk::*"
*/
itkNs = Tcl_CreateNamespace(interp, "::itk",
(ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL);
}
if (!itkNs ||
Tcl_Export(interp, itkNs, "*", /* resetListFirst */ 1) != TCL_OK) {
return TCL_ERROR;
}
/*
* Setup things for itk::Archetype base class.
*/
if (Itk_ArchetypeInit(interp) != TCL_OK) {
return TCL_ERROR;
}
/*
* Fix the "itcl::configbody" command to recognize mega-widget
* options.
*/
Tcl_CreateObjCommand(interp, "::itcl::configbody", Itk_ConfigBodyCmd,
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
Tcl_SetVar(interp, "::itk::version", ITK_VERSION, 0);
Tcl_SetVar(interp, "::itk::patchLevel", ITK_PATCH_LEVEL, 0);
/*
* Signal that the package has been loaded and provide the Itk Stubs table
* for dependent modules. I know this is unlikely, but possible that
* someone could be extending Itk. Who is to say that Itk is the
* end-of-the-line?
*/
#if TCL_DOES_STUBS
{
extern ItkStubs itkStubs;
if (Tcl_PkgProvideEx(interp, "Itk", ITK_VERSION,
(ClientData) &itkStubs) != TCL_OK) {
return TCL_ERROR;
}
}
#else
if (Tcl_PkgProvide(interp, "Itk", ITK_VERSION) != TCL_OK) {
return TCL_ERROR;
}
#endif
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itk_Init()
*
* Invoked whenever a new interpeter is created to install the
* [incr Tcl] package. Usually invoked within Tcl_AppInit() at
* the start of execution.
*
* Creates the "::itk" namespace and installs access commands.
*
* Returns TCL_OK on success, or TCL_ERROR (along with an error
* message in the interpreter) if anything goes wrong.
* ------------------------------------------------------------------------
*/
int
Itk_Init(interp)
Tcl_Interp *interp; /* interpreter to be updated */
{
if (Initialize(interp) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_Eval(interp, initScript);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itk_SafeInit()
*
* Invoked whenever a new SAFE INTERPRETER is created to install
* the [incr Tcl] package.
*
* Creates the "::itk" namespace and installs access commands for
* creating classes and querying info.
*
* Returns TCL_OK on success, or TCL_ERROR (along with an error
* message in the interpreter) if anything goes wrong.
* ------------------------------------------------------------------------
*/
int
Itk_SafeInit(interp)
Tcl_Interp *interp; /* interpreter to be updated */
{
if (Initialize(interp) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_Eval(interp, safeInitScript);
}
/*
* ------------------------------------------------------------------------
* Itk_ConfigBodyCmd()
*
* Replacement for the usual "itcl::configbody" command. Recognizes
* mega-widget options included in a class definition. Options are
* identified by their "switch" name, but without the "-" prefix:
*
* itcl::configbody <class>::<itkOption> <body>
*
* Handles bodies for public variables as well:
*
* itcl::configbody <class>::<publicVar> <body>
*
* If an <itkOption> is found, it has priority over public variables.
* If <body> has the form "@name" then it is treated as a reference
* to a C handling procedure; otherwise, it is taken as a body of
* Tcl statements.
*
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
* ------------------------------------------------------------------------
*/
/* ARGSUSED */
int
Itk_ConfigBodyCmd(dummy, interp, objc, objv)
ClientData dummy; /* unused */
Tcl_Interp *interp; /* current interpreter */
int objc; /* number of arguments */
Tcl_Obj *CONST objv[]; /* argument objects */
{
int result = TCL_OK;
char *token, *head, *tail;
ItclClass *cdefn;
ItclMemberCode *mcode;
ItkClassOptTable *optTable;
Tcl_HashEntry *entry;
ItkClassOption *opt;
Tcl_DString buffer;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "class::option body");
return TCL_ERROR;
}
/*
* Parse the member name "namesp::namesp::class::option".
* Make sure that a class name was specified, and that the
* class exists.
*/
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
Itcl_ParseNamespPath(token, &buffer, &head, &tail);
if (!head || *head == '\0') {
Tcl_AppendResult(interp,
"missing class specifier for body declaration \"", token, "\"",
(char*)NULL);
result = TCL_ERROR;
goto configBodyCmdDone;
}
cdefn = Itcl_FindClass(interp, head, /* autoload */ 1);
if (cdefn == NULL) {
result = TCL_ERROR;
goto configBodyCmdDone;
}
/*
* Look first for a configuration option with that name.
* If it is not found, assume the reference is for a public
* variable, and use the usual "configbody" implementation
* to handle it.
*/
optTable = Itk_FindClassOptTable(cdefn);
opt = NULL;
if (optTable) {
Tcl_DString optName;
Tcl_DStringInit(&optName);
Tcl_DStringAppend(&optName, "-", -1);
Tcl_DStringAppend(&optName, tail, -1);
entry = Tcl_FindHashEntry(&optTable->options,
Tcl_DStringValue(&optName));
if (entry) {
opt = (ItkClassOption*)Tcl_GetHashValue(entry);
}
Tcl_DStringFree(&optName);
}
if (opt == NULL) {
result = Itcl_ConfigBodyCmd(dummy, interp, objc, objv);
goto configBodyCmdDone;
}
/*
* Otherwise, change the implementation for this option.
*/
token = Tcl_GetStringFromObj(objv[2], (int*)NULL);
if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, token,
&mcode) != TCL_OK) {
result = TCL_ERROR;
goto configBodyCmdDone;
}
Itcl_PreserveData((ClientData)mcode);
Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);
if (opt->member->code) {
Itcl_ReleaseData((ClientData)opt->member->code);
}
opt->member->code = mcode;
configBodyCmdDone:
Tcl_DStringFree(&buffer);
return result;
}
+186 -258
View File
@@ -21,17 +21,17 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "itkInt.h"
#include "itk.h"
/*
* FORWARD DECLARATIONS
*/
static char* ItkTraceClassDestroy (void *cdata,
Tcl_Interp *interp, const char *name1, const char *name2, int flags);
static Tcl_HashTable* ItkGetClassesWithOptInfo (
Tcl_Interp *interp);
static void ItkFreeClassesWithOptInfo (void *cdata,
Tcl_Interp *interp);
static char* ItkTraceClassDestroy _ANSI_ARGS_((ClientData cdata,
Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags));
static Tcl_HashTable* ItkGetClassesWithOptInfo _ANSI_ARGS_((
Tcl_Interp *interp));
static void ItkFreeClassesWithOptInfo _ANSI_ARGS_((ClientData cdata,
Tcl_Interp *interp));
/*
@@ -53,74 +53,65 @@ static void ItkFreeClassesWithOptInfo (void *cdata,
* Returns TCL_OK/TCL_ERROR to indicate success/failure.
* ------------------------------------------------------------------------
*/
/* ARGSUSED */
int
Itk_ClassOptionDefineCmd(
void *clientData, /* class parser info */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
Itk_ClassOptionDefineCmd(clientData, interp, objc, objv)
ClientData clientData; /* class parser info */
Tcl_Interp *interp; /* current interpreter */
int objc; /* number of arguments */
Tcl_Obj *CONST objv[]; /* argument objects */
{
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&info->clsStack);
ItclClass *cdefn = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
int newEntry;
const char *switchName;
const char *resName;
const char *resClass;
const char *init;
const char *config;
char *switchName, *resName, *resClass, *init, *config;
ItkClassOptTable *optTable;
Tcl_HashEntry *entry;
ItkClassOption *opt;
ItclShowArgs(1, "Itk_ClassOptionDefineCmd", objc, objv);
/*
* Make sure that the arguments look right. The option switch
* name must start with a '-'.
*/
if (objc < 5 || objc > 6) {
Tcl_WrongNumArgs(interp, 1, objv,
"-switch resourceName resourceClass init ?config?");
return TCL_ERROR;
Tcl_WrongNumArgs(interp, 1, objv,
"-switch resourceName resourceClass init ?config?");
return TCL_ERROR;
}
switchName = Tcl_GetString(objv[1]);
switchName = Tcl_GetStringFromObj(objv[1], (int*)NULL);
if (*switchName != '-') {
Tcl_AppendResult(interp,
"bad option name \"", switchName, "\": should be -",
switchName, (char*)NULL);
return TCL_ERROR;
Tcl_AppendResult(interp,
"bad option name \"", switchName, "\": should be -", switchName,
(char*)NULL);
return TCL_ERROR;
}
if (strstr(switchName, ".")) {
Tcl_AppendResult(interp,
"bad option name \"", switchName,
"\": illegal character \".\"", (char*)NULL);
return TCL_ERROR;
Tcl_AppendResult(interp,
"bad option name \"", switchName, "\": illegal character \".\"",
(char*)NULL);
return TCL_ERROR;
}
resName = Tcl_GetString(objv[2]);
resName = Tcl_GetStringFromObj(objv[2], (int*)NULL);
if (!islower((int)*resName)) {
Tcl_AppendResult(interp,
"bad resource name \"", resName,
"\": should start with a lower case letter",
(char*)NULL);
return TCL_ERROR;
Tcl_AppendResult(interp,
"bad resource name \"", resName,
"\": should start with a lower case letter",
(char*)NULL);
return TCL_ERROR;
}
resClass = Tcl_GetString(objv[3]);
resClass = Tcl_GetStringFromObj(objv[3], (int*)NULL);
if (!isupper((int)*resClass)) {
Tcl_AppendResult(interp,
"bad resource class \"", resClass,
"\": should start with an upper case letter",
(char*)NULL);
return TCL_ERROR;
Tcl_AppendResult(interp,
"bad resource class \"", resClass,
"\": should start with an upper case letter",
(char*)NULL);
return TCL_ERROR;
}
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "can only handle options on class level",
NULL);
return TCL_ERROR;
}
/*
* Make sure that this option has not already been defined in
* the context of this class. Options can be redefined in
@@ -129,35 +120,35 @@ Itk_ClassOptionDefineCmd(
* which option is being referenced if the configuration code
* is redefined by a subsequent "body" command.
*/
optTable = Itk_CreateClassOptTable(interp, iclsPtr);
optTable = Itk_CreateClassOptTable(interp, cdefn);
entry = Tcl_CreateHashEntry(&optTable->options, switchName, &newEntry);
if (!newEntry) {
Tcl_AppendResult(interp,
"option \"", switchName, "\" already defined in class \"",
Tcl_GetString(iclsPtr->fullNamePtr), "\"",
(char*)NULL);
return TCL_ERROR;
Tcl_AppendResult(interp,
"option \"", switchName, "\" already defined in class \"",
cdefn->fullname, "\"",
(char*)NULL);
return TCL_ERROR;
}
/*
* Create a new option record and add it to the table for this
* class.
*/
init = Tcl_GetString(objv[4]);
init = Tcl_GetStringFromObj(objv[4], (int*)NULL);
if (objc == 6) {
config = Tcl_GetString(objv[5]);
config = Tcl_GetStringFromObj(objv[5], (int*)NULL);
} else {
config = NULL;
config = NULL;
}
if (Itk_CreateClassOption(interp, iclsPtr, switchName, resName, resClass,
init, config, &opt) != TCL_OK) {
return TCL_ERROR;
if (Itk_CreateClassOption(interp, cdefn, switchName, resName, resClass,
init, config, &opt) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetHashValue(entry, (void *)opt);
Tcl_SetHashValue(entry, (ClientData)opt);
Itk_OptListAdd(&optTable->order, entry);
return TCL_OK;
}
@@ -173,19 +164,20 @@ Itk_ClassOptionDefineCmd(
* been created. Returns TCL_ERROR along with an error message.
* ------------------------------------------------------------------------
*/
/* ARGSUSED */
int
Itk_ClassOptionIllegalCmd(
TCL_UNUSED(void *), /* class parser info */
Tcl_Interp *interp, /* current interpreter */
TCL_UNUSED(int), /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
Itk_ClassOptionIllegalCmd(clientData, interp, objc, objv)
ClientData clientData; /* class parser info */
Tcl_Interp *interp; /* current interpreter */
int objc; /* number of arguments */
Tcl_Obj *CONST objv[]; /* argument objects */
{
char *op = Tcl_GetString(objv[0]);
char *op = Tcl_GetStringFromObj(objv[0], (int*)NULL);
Tcl_AppendResult(interp,
"can only ", op, " options for a specific widget\n",
"(move this command into the constructor)",
(char*)NULL);
"can only ", op, " options for a specific widget\n",
"(move this command into the constructor)",
(char*)NULL);
return TCL_ERROR;
}
@@ -204,81 +196,26 @@ Itk_ClassOptionIllegalCmd(
* message in the interpreter) if anything goes wrong.
* ------------------------------------------------------------------------
*/
/* ARGSUSED */
int
Itk_ConfigClassOption(
Tcl_Interp *interp, /* interpreter managing the class */
ItclObject *contextObj, /* object being configured */
void *cdata, /* class option */
TCL_UNUSED(const char *)) /* new value for this option */
Itk_ConfigClassOption(interp, contextObj, cdata, newval)
Tcl_Interp *interp; /* interpreter managing the class */
ItclObject *contextObj; /* object being configured */
ClientData cdata; /* class option */
CONST char *newval; /* new value for this option */
{
ItkClassOption *opt = (ItkClassOption*)cdata;
int result = TCL_OK;
ItclMemberCode *mcode;
Tcl_CallFrame frame;
/*
* If the option has any config code, execute it now.
* Make sure that the namespace context is set up correctly.
*/
mcode = opt->codePtr;
if (mcode && mcode->bodyPtr) {
Itcl_PushCallFrame(interp, &frame, opt->iclsPtr->nsPtr, 1);
Itcl_SetContext(interp, contextObj);
result = Tcl_EvalObjEx(interp, mcode->bodyPtr, 0);
Itcl_UnsetContext(interp);
Itcl_PopCallFrame(interp);
/*
* Here we engage in some ugly hackery workaround until
* someone has time to come back and implement this
* properly.
*
* In Itcl/Itk 3, the same machinery was used to implement
* method invocation and configbody invocation, and the
* code here looked like:
*
result = Itcl_EvalMemberCode(interp, (ItclMemberFunc*)NULL,
opt->member, contextObj, 0, (Tcl_Obj**)NULL);
*
* In Itcl 4, Itcl methods have become (a particular variant)
* of TclOO methods. It's not clear whether config bodies
* should also do that, or what?
*
* Instead the existing solution above has been to just "eval"
* the configbody body script in a suitable context, which
* works very nearly correctly. The trouble is that unlike
* method invocation, we've not pushed a proper frame, nor
* have we unwound a return level, so when the "eval" returns
* TCL_RETURN we've not been handling that right. You will
* find some configbody bodies out there that expect to be
* able to use [return] for early exit. Iwidgets test
* Extbutton-2.8 is an example.
*
* As a cheap workaround, we put in explicit special treatment
* for (result == TCL_RETURN) here. This is essentially a
* reproduction of the Tcl internal routine TclUpdateReturnInfo()
* but without the benefit of internals access.
*/
if (result == TCL_RETURN) {
Tcl_Obj *opts = Tcl_GetReturnOptions(interp, TCL_RETURN);
Tcl_Obj *levelKey = Tcl_NewStringObj("-level", -1);
Tcl_Obj *levelObj;
int level;
Tcl_DictObjGet(NULL, opts, levelKey, &levelObj);
Tcl_GetIntFromObj(NULL, levelObj, &level);
Tcl_DictObjPut(NULL, opts, levelKey, Tcl_NewIntObj(--level));
result = Tcl_SetReturnOptions(interp, opts);
Tcl_DecrRefCount(levelKey);
}
mcode = opt->member->code;
if (mcode && mcode->procPtr->bodyPtr) {
result = Itcl_EvalMemberCode(interp, (ItclMemberFunc*)NULL,
opt->member, contextObj, 0, (Tcl_Obj**)NULL);
}
return result;
}
@@ -303,15 +240,15 @@ Itk_ConfigClassOption(
* ------------------------------------------------------------------------
*/
ItkClassOptTable*
Itk_CreateClassOptTable(
Tcl_Interp *interp, /* interpreter managing the class */
ItclClass *iclsPtr) /* class definition */
Itk_CreateClassOptTable(interp, cdefn)
Tcl_Interp *interp; /* interpreter managing the class */
ItclClass *cdefn; /* class definition */
{
int newEntry, result;
Tcl_HashTable *itkClasses;
Tcl_HashEntry *entry;
ItkClassOptTable *optTable;
Tcl_CallFrame frame;
Itcl_CallFrame frame;
/*
* Look for the specified class definition in the table.
@@ -324,25 +261,26 @@ Itk_CreateClassOptTable(
*/
itkClasses = ItkGetClassesWithOptInfo(interp);
entry = Tcl_CreateHashEntry(itkClasses, (char*)iclsPtr, &newEntry);
entry = Tcl_CreateHashEntry(itkClasses, (char*)cdefn, &newEntry);
if (newEntry) {
optTable = (ItkClassOptTable*)Tcl_Alloc(sizeof(ItkClassOptTable));
Tcl_InitHashTable(&optTable->options, TCL_STRING_KEYS);
Itk_OptListInit(&optTable->order, &optTable->options);
optTable = (ItkClassOptTable*)ckalloc(sizeof(ItkClassOptTable));
Tcl_InitHashTable(&optTable->options, TCL_STRING_KEYS);
Itk_OptListInit(&optTable->order, &optTable->options);
Tcl_SetHashValue(entry, (void *)optTable);
Tcl_SetHashValue(entry, (ClientData)optTable);
result = Itcl_PushCallFrame(interp, &frame,
iclsPtr->nsPtr, /* isProcCallFrame */ 0);
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame,
cdefn->namesp, /* isProcCallFrame */ 0);
if (result == TCL_OK) {
Tcl_TraceVar(interp, "_itk_option_data",
(TCL_TRACE_UNSETS | TCL_NAMESPACE_ONLY),
ItkTraceClassDestroy, (void *)iclsPtr);
Itcl_PopCallFrame(interp);
}
} else {
optTable = (ItkClassOptTable*)Tcl_GetHashValue(entry);
if (result == TCL_OK) {
Tcl_TraceVar(interp, "_itk_option_data",
(TCL_TRACE_UNSETS | TCL_NAMESPACE_ONLY),
(Tcl_VarTraceProc*) ItkTraceClassDestroy, (ClientData)cdefn);
Tcl_PopCallFrame(interp);
}
}
else {
optTable = (ItkClassOptTable*)Tcl_GetHashValue(entry);
}
return optTable;
}
@@ -363,8 +301,8 @@ Itk_CreateClassOptTable(
* ------------------------------------------------------------------------
*/
ItkClassOptTable*
Itk_FindClassOptTable(
ItclClass *iclsPtr) /* class definition */
Itk_FindClassOptTable(cdefn)
ItclClass *cdefn; /* class definition */
{
Tcl_HashTable *itkClasses;
Tcl_HashEntry *entry;
@@ -372,10 +310,10 @@ Itk_FindClassOptTable(
/*
* Look for the specified class definition in the table.
*/
itkClasses = ItkGetClassesWithOptInfo(iclsPtr->interp);
entry = Tcl_FindHashEntry(itkClasses, (char*)iclsPtr);
itkClasses = ItkGetClassesWithOptInfo(cdefn->interp);
entry = Tcl_FindHashEntry(itkClasses, (char*)cdefn);
if (entry) {
return (ItkClassOptTable*)Tcl_GetHashValue(entry);
return (ItkClassOptTable*)Tcl_GetHashValue(entry);
}
return NULL;
}
@@ -395,15 +333,16 @@ Itk_FindClassOptTable(
* error that is encountered.
* ------------------------------------------------------------------------
*/
/* ARGSUSED */
static char*
ItkTraceClassDestroy(
void *cdata, /* class definition data */
Tcl_Interp *interp, /* interpreter managing the class */
TCL_UNUSED(const char *), /* name of variable involved in trace */
TCL_UNUSED(const char *), /* name of array element within variable */
TCL_UNUSED(int)) /* flags describing trace */
ItkTraceClassDestroy(cdata, interp, name1, name2, flags)
ClientData cdata; /* class definition data */
Tcl_Interp *interp; /* interpreter managing the class */
CONST char *name1; /* name of variable involved in trace */
CONST char *name2; /* name of array element within variable */
int flags; /* flags describing trace */
{
ItclClass *iclsPtr = (ItclClass*)cdata;
ItclClass *cdefn = (ItclClass*)cdata;
Tcl_HashTable *itkClasses;
Tcl_HashEntry *entry;
@@ -416,21 +355,21 @@ ItkTraceClassDestroy(
* If it is found, delete all the option records and tear
* down the table.
*/
itkClasses = ItkGetClassesWithOptInfo(interp);
entry = Tcl_FindHashEntry(itkClasses, (char*)iclsPtr);
itkClasses = ItkGetClassesWithOptInfo(cdefn->interp);
entry = Tcl_FindHashEntry(itkClasses, (char*)cdefn);
if (entry) {
optTable = (ItkClassOptTable*)Tcl_GetHashValue(entry);
Tcl_DeleteHashEntry(entry);
optTable = (ItkClassOptTable*)Tcl_GetHashValue(entry);
Tcl_DeleteHashEntry(entry);
entry = Tcl_FirstHashEntry(&optTable->options, &place);
while (entry) {
opt = (ItkClassOption*)Tcl_GetHashValue(entry);
Itk_DelClassOption(opt);
entry = Tcl_NextHashEntry(&place);
}
Tcl_DeleteHashTable(&optTable->options);
Itk_OptListFree(&optTable->order);
Tcl_Free(optTable);
entry = Tcl_FirstHashEntry(&optTable->options, &place);
while (entry) {
opt = (ItkClassOption*)Tcl_GetHashValue(entry);
Itk_DelClassOption(opt);
entry = Tcl_NextHashEntry(&place);
}
Tcl_DeleteHashTable(&optTable->options);
Itk_OptListFree(&optTable->order);
ckfree((char*)optTable);
}
return NULL;
}
@@ -451,15 +390,17 @@ ItkTraceClassDestroy(
* ------------------------------------------------------------------------
*/
int
Itk_CreateClassOption(
Tcl_Interp *interp, /* interpreter managing the class */
ItclClass *iclsPtr, /* class containing this option */
const char *switchName, /* name of command-line switch */
const char *resName, /* resource name in X11 database */
const char *resClass, /* resource class name in X11 database */
const char *defVal, /* last-resort default value */
const char *config, /* configuration code */
ItkClassOption **optPtr) /* returns: option record */
Itk_CreateClassOption(interp, cdefn, switchName, resName, resClass,
defVal, config, optPtr)
Tcl_Interp *interp; /* interpreter managing the class */
ItclClass *cdefn; /* class containing this option */
char *switchName; /* name of command-line switch */
char *resName; /* resource name in X11 database */
char *resClass; /* resource class name in X11 database */
char *defVal; /* last-resort default value */
char *config; /* configuration code */
ItkClassOption **optPtr; /* returns: option record */
{
ItkClassOption *opt;
ItclMemberCode *mcode;
@@ -469,42 +410,33 @@ Itk_CreateClassOption(
* an implementation for it.
*/
if (config) {
if (Itcl_CreateMemberCode(interp, iclsPtr, (char*)NULL, config,
&mcode) != TCL_OK) {
if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, config,
&mcode) != TCL_OK) {
return TCL_ERROR;
}
Itcl_PreserveData((void *)mcode);
#ifdef NOTDEF
Itcl_EventuallyFree((void *)mcode, (Tcl_FreeProc *)Itcl_DeleteMemberCode);
#endif
} else {
mcode = NULL;
return TCL_ERROR;
}
Itcl_PreserveData((ClientData)mcode);
Itcl_EventuallyFree((ClientData)mcode,
(Tcl_FreeProc*) Itcl_DeleteMemberCode);
}
else {
mcode = NULL;
}
/*
* Create the record to represent this option.
*/
opt = (ItkClassOption*)Tcl_Alloc(sizeof(ItkClassOption));
memset(opt, 0, sizeof(ItkClassOption));
opt->iclsPtr = iclsPtr;
opt->flags = 0;
opt->protection = Itcl_Protection(interp, 0);
opt->namePtr = Tcl_NewStringObj(switchName, -1);
Tcl_IncrRefCount(opt->namePtr);
opt->fullNamePtr = Tcl_NewStringObj(Tcl_GetString(iclsPtr->fullNamePtr), -1);
Tcl_AppendToObj(opt->fullNamePtr, "::", 2);
Tcl_AppendToObj(opt->fullNamePtr, switchName, -1);
Tcl_IncrRefCount(opt->fullNamePtr);
opt->codePtr = mcode;
opt = (ItkClassOption*)ckalloc(sizeof(ItkClassOption));
opt->member = Itcl_CreateMember(interp, cdefn, switchName);
opt->member->code = mcode;
opt->resName = (char*)Tcl_Alloc((strlen(resName)+1));
opt->resName = (char*)ckalloc((unsigned)(strlen(resName)+1));
strcpy(opt->resName, resName);
opt->resClass = (char*)Tcl_Alloc((strlen(resClass)+1));
opt->resClass = (char*)ckalloc((unsigned)(strlen(resClass)+1));
strcpy(opt->resClass, resClass);
opt->init = (char*)Tcl_Alloc((strlen(defVal)+1));
opt->init = (char*)ckalloc((unsigned)(strlen(defVal)+1));
strcpy(opt->init, defVal);
*optPtr = opt;
@@ -526,9 +458,9 @@ Itk_CreateClassOption(
* ------------------------------------------------------------------------
*/
ItkClassOption*
Itk_FindClassOption(
ItclClass *iclsPtr, /* class containing this option */
const char *switchName) /* name of command-line switch */
Itk_FindClassOption(cdefn, switchName)
ItclClass *cdefn; /* class containing this option */
char *switchName; /* name of command-line switch */
{
ItkClassOption *opt = NULL;
@@ -541,21 +473,21 @@ Itk_FindClassOption(
*/
Tcl_DStringInit(&buffer);
if (*switchName != '-') {
Tcl_DStringAppend(&buffer, "-", -1);
Tcl_DStringAppend(&buffer, switchName, -1);
switchName = Tcl_DStringValue(&buffer);
Tcl_DStringAppend(&buffer, "-", -1);
Tcl_DStringAppend(&buffer, switchName, -1);
switchName = Tcl_DStringValue(&buffer);
}
/*
* Look for the option table for the specified class, and check
* for the requested switch.
*/
optTable = Itk_FindClassOptTable(iclsPtr);
optTable = Itk_FindClassOptTable(cdefn);
if (optTable) {
entry = Tcl_FindHashEntry(&optTable->options, switchName);
if (entry) {
opt = (ItkClassOption*)Tcl_GetHashValue(entry);
}
entry = Tcl_FindHashEntry(&optTable->options, switchName);
if (entry) {
opt = (ItkClassOption*)Tcl_GetHashValue(entry);
}
}
Tcl_DStringFree(&buffer);
return opt;
@@ -570,17 +502,15 @@ Itk_FindClassOption(
* ------------------------------------------------------------------------
*/
void
Itk_DelClassOption(
ItkClassOption *opt) /* pointer to option data */
Itk_DelClassOption(opt)
ItkClassOption *opt; /* pointer to option data */
{
#ifdef NOTDEF
Itcl_DeleteMember(opt->member);
#endif
Tcl_Free(opt->resName);
Tcl_Free(opt->resClass);
Tcl_Free(opt->init);
ckfree(opt->resName);
ckfree(opt->resClass);
ckfree(opt->init);
Tcl_Free(opt);
ckfree((char*)opt);
}
@@ -594,8 +524,8 @@ Itk_DelClassOption(
* ------------------------------------------------------------------------
*/
static Tcl_HashTable*
ItkGetClassesWithOptInfo(
Tcl_Interp *interp) /* interpreter handling this registration */
ItkGetClassesWithOptInfo(interp)
Tcl_Interp *interp; /* interpreter handling this registration */
{
Tcl_HashTable* classesTable;
@@ -603,13 +533,13 @@ ItkGetClassesWithOptInfo(
* If the registration table does not yet exist, then create it.
*/
classesTable = (Tcl_HashTable*)Tcl_GetAssocData(interp,
"itk_classesWithOptInfo", (Tcl_InterpDeleteProc**)NULL);
"itk_classesWithOptInfo", (Tcl_InterpDeleteProc**)NULL);
if (!classesTable) {
classesTable = (Tcl_HashTable*)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(classesTable, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, "itk_classesWithOptInfo",
ItkFreeClassesWithOptInfo, (void *)classesTable);
classesTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(classesTable, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, "itk_classesWithOptInfo",
ItkFreeClassesWithOptInfo, (ClientData)classesTable);
}
return classesTable;
}
@@ -623,35 +553,33 @@ ItkGetClassesWithOptInfo(
* ------------------------------------------------------------------------
*/
static void
ItkFreeClassesWithOptInfo(
void *clientData, /* associated data */
TCL_UNUSED(Tcl_Interp *)) /* interpreter being freed */
ItkFreeClassesWithOptInfo(clientData, interp)
ClientData clientData; /* associated data */
Tcl_Interp *interp; /* interpreter being freed */
{
Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData;
Tcl_HashSearch place;
Tcl_HashSearch place2;
Tcl_HashEntry *entry;
Tcl_HashEntry *entry2;
Tcl_HashSearch place, place2;
Tcl_HashEntry *entry, *entry2;
ItkClassOptTable *optTable;
ItkClassOption *opt;
entry = Tcl_FirstHashEntry(tablePtr, &place);
while (entry) {
optTable = (ItkClassOptTable*)Tcl_GetHashValue(entry);
optTable = (ItkClassOptTable*)Tcl_GetHashValue(entry);
entry2 = Tcl_FirstHashEntry(&optTable->options, &place2);
while (entry2) {
opt = (ItkClassOption*)Tcl_GetHashValue(entry2);
Itk_DelClassOption(opt);
entry2 = Tcl_NextHashEntry(&place2);
}
Tcl_DeleteHashTable(&optTable->options);
Itk_OptListFree(&optTable->order);
Tcl_Free(optTable);
entry2 = Tcl_FirstHashEntry(&optTable->options, &place2);
while (entry2) {
opt = (ItkClassOption*)Tcl_GetHashValue(entry2);
Itk_DelClassOption(opt);
entry2 = Tcl_NextHashEntry(&place2);
}
Tcl_DeleteHashTable(&optTable->options);
Itk_OptListFree(&optTable->order);
ckfree((char*)optTable);
entry = Tcl_NextHashEntry(&place);
entry = Tcl_NextHashEntry(&place);
}
Tcl_DeleteHashTable(tablePtr);
Tcl_Free(tablePtr);
ckfree((char*)tablePtr);
}
+73 -83
View File
@@ -21,7 +21,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "itkInt.h"
#include "itk.h"
/*
@@ -33,15 +33,15 @@
* ------------------------------------------------------------------------
*/
void
Itk_OptListInit(
ItkOptList *olist, /* list to be initialized */
Tcl_HashTable *options) /* table containing the real option entries */
Itk_OptListInit(olist, options)
ItkOptList *olist; /* list to be initialized */
Tcl_HashTable *options; /* table containing the real option entries */
{
olist->options = options;
olist->len = 0;
olist->max = 10;
olist->list = (Tcl_HashEntry**)Tcl_Alloc(
((size_t)olist->max*sizeof(Tcl_HashEntry*))
olist->list = (Tcl_HashEntry**)ckalloc(
(unsigned)(olist->max*sizeof(Tcl_HashEntry*))
);
}
@@ -56,10 +56,10 @@ Itk_OptListInit(
* ------------------------------------------------------------------------
*/
void
Itk_OptListFree(
ItkOptList *olist) /* list to be freed */
Itk_OptListFree(olist)
ItkOptList *olist; /* list to be freed */
{
Tcl_Free(olist->list);
ckfree((char*)olist->list);
olist->len = olist->max = 0;
}
@@ -74,32 +74,26 @@ Itk_OptListFree(
* ------------------------------------------------------------------------
*/
void
Itk_OptListAdd(
ItkOptList *olist, /* ordered list */
Tcl_HashEntry *entry) /* entry to be added to the list */
Itk_OptListAdd(olist, entry)
ItkOptList *olist; /* ordered list */
Tcl_HashEntry *entry; /* entry to be added to the list */
{
int i;
int first;
int last;
int cmp;
int pos;
size_t size;
int i, first, last, cmp, pos, size;
Tcl_HashEntry** newOrder;
const char *swname;
const char *optname;
char *swname, *optname;
/*
* Make sure that the option list is big enough. Resize
* if needed.
*/
if (olist->len >= olist->max) {
size = (size_t)olist->max*sizeof(Tcl_HashEntry*);
newOrder = (Tcl_HashEntry**)Tcl_Alloc(2*size);
memcpy((void*)newOrder, (void*)olist->list, size);
Tcl_Free(olist->list);
size = olist->max*sizeof(Tcl_HashEntry*);
newOrder = (Tcl_HashEntry**)ckalloc((unsigned)2*size);
memcpy((VOID*)newOrder, (VOID*)olist->list, (size_t)size);
ckfree((char*)olist->list);
olist->list = newOrder;
olist->max *= 2;
olist->list = newOrder;
olist->max *= 2;
}
/*
@@ -107,42 +101,42 @@ Itk_OptListAdd(
*/
first = 0;
last = olist->len-1;
swname = ((const char *)Tcl_GetHashKey(olist->options, entry)) + 1;
swname = ((char *)Tcl_GetHashKey(olist->options, entry)) + 1;
while (last >= first) {
pos = (first+last)/2;
optname = ((const char *)Tcl_GetHashKey(olist->options,
pos = (first+last)/2;
optname = ((char *)Tcl_GetHashKey(olist->options,
olist->list[pos])) + 1;
if (*swname == *optname) {
cmp = strcmp(swname, optname);
if (cmp == 0) {
break; /* found it! */
}
}
else if (*swname < *optname) {
cmp = -1;
}
else {
cmp = 1;
}
if (*swname == *optname) {
cmp = strcmp(swname, optname);
if (cmp == 0) {
break; /* found it! */
}
}
else if (*swname < *optname) {
cmp = -1;
}
else {
cmp = 1;
}
if (cmp > 0)
first = pos+1;
else
last = pos-1;
if (cmp > 0)
first = pos+1;
else
last = pos-1;
}
/*
* If a matching entry was not found, then insert one.
*/
if (last < first) {
pos = first;
pos = first;
for (i=olist->len; i > pos; i--) {
olist->list[i] = olist->list[i-1];
}
olist->list[pos] = entry;
olist->len++;
for (i=olist->len; i > pos; i--) {
olist->list[i] = olist->list[i-1];
}
olist->list[pos] = entry;
olist->len++;
}
}
@@ -159,52 +153,48 @@ Itk_OptListAdd(
* ------------------------------------------------------------------------
*/
void
Itk_OptListRemove(
ItkOptList *olist, /* ordered list */
Tcl_HashEntry *entry) /* entry to be removed from the list */
Itk_OptListRemove(olist, entry)
ItkOptList *olist; /* ordered list */
Tcl_HashEntry *entry; /* entry to be removed from the list */
{
int pos = 0;
int i;
int first;
int last;
int cmp;
const char *swname;
const char *optname;
int i, first, last, cmp;
char *swname, *optname;
first = 0;
last = olist->len-1;
swname = ((const char *)Tcl_GetHashKey(olist->options, entry)) + 1;
swname = ((char *)Tcl_GetHashKey(olist->options, entry)) + 1;
while (last >= first) {
pos = (first+last)/2;
optname = ((const char *)Tcl_GetHashKey(olist->options,
pos = (first+last)/2;
optname = ((char *)Tcl_GetHashKey(olist->options,
olist->list[pos])) + 1;
if (*swname == *optname) {
cmp = strcmp(swname, optname);
if (cmp == 0) {
break; /* found it! */
}
}
else if (*swname < *optname) {
cmp = -1;
}
else {
cmp = 1;
}
if (*swname == *optname) {
cmp = strcmp(swname, optname);
if (cmp == 0) {
break; /* found it! */
}
}
else if (*swname < *optname) {
cmp = -1;
}
else {
cmp = 1;
}
if (cmp > 0)
first = pos+1;
else
last = pos-1;
if (cmp > 0)
first = pos+1;
else
last = pos-1;
}
/*
* If a matching entry was found, then remove it.
*/
if (last >= first) {
olist->len--;
for (i=pos; i < olist->len; i++) {
olist->list[i] = olist->list[i+1];
}
olist->len--;
for (i=pos; i < olist->len; i++) {
olist->list[i] = olist->list[i+1];
}
}
}
+8 -8
View File
@@ -1,5 +1,5 @@
# itkConfig.sh --
#
#
# This shell script (for sh) is generated automatically by Itk's
# configure script. It will create shell variables for most of
# the configuration options discovered by the configure script.
@@ -15,26 +15,26 @@
ITCL_VERSION='@ITCL_VERSION@'
# The name of the Itk library (may be either a .a file or a shared library):
ITK_LIB_FILE=@itk_LIB_FILE@
ITK_LIB_FILE=@ITK_LIB_FILE@
# String to pass to linker to pick up the Itk library from its
# build directory.
ITK_BUILD_LIB_SPEC='@itk_BUILD_LIB_SPEC@'
ITK_BUILD_LIB_SPEC='@ITK_BUILD_LIB_SPEC@'
# String to pass to linker to pick up the Itk library from its
# installed directory.
ITK_LIB_SPEC='@itk_LIB_SPEC@'
ITK_LIB_SPEC='@ITK_LIB_SPEC@'
# The name of the Itk stub library (a .a file):
ITK_STUB_LIB_FILE=@itk_STUB_LIB_FILE@
ITK_STUB_LIB_FILE=@ITK_STUB_LIB_FILE@
# String to pass to linker to pick up the Itk stub library from its
# build directory.
ITK_BUILD_STUB_LIB_SPEC='@itk_BUILD_STUB_LIB_SPEC@'
ITK_BUILD_STUB_LIB_SPEC='@ITK_BUILD_STUB_LIB_SPEC@'
# String to pass to linker to pick up the Itk stub library from its
# installed directory.
ITK_STUB_LIB_SPEC='@itk_STUB_LIB_SPEC@'
ITK_STUB_LIB_SPEC='@ITK_STUB_LIB_SPEC@'
# Location of the top-level source directories from which [incr Tk]
# was built. This is the directory that contains a README file as well
@@ -42,4 +42,4 @@ ITK_STUB_LIB_SPEC='@itk_STUB_LIB_SPEC@'
# compiled in a different place than the directory containing the source
# files, this points to the location of the sources, not the location
# where [incr Tk] was compiled.
ITK_SRC_DIR='@itk_SRC_DIR@'
ITK_SRC_DIR='@ITK_SRC_DIR@'
+16 -11
View File
@@ -54,27 +54,32 @@
itcl::class itk::Archetype {
constructor {args} {
::itcl::builtin::Archetype init
eval itk_initialize $args
_initOptionInfo
eval itk_initialize $args
}
destructor {
::itcl::builtin::Archetype delete
_deleteOptionInfo
}
method cget {option} @Archetype-cget
method configure {{option ""} args} \
@Archetype-configure
method config {{option ""} args} {
eval configure $option $args
}
method configure {{option ""} args} @Archetype-configure
method component {{name ""} args} \
@Archetype-component
method config {{option ""} args} @Archetype-configure
protected method itk_component {option args} \
@Archetype-itk_component
method component {{name ""} args} @Archetype-component
protected method itk_option {option args} \
@Archetype-itk_option
protected method itk_component {option args} @Archetype-itk_component
protected method itk_option {option args} @Archetype-itk_option
protected method itk_initialize {args} @Archetype-itk_initialize
protected method itk_initialize {args} \
@Archetype-itk_initialize
protected variable itk_option
protected variable itk_component
+33 -33
View File
@@ -33,49 +33,49 @@ itcl::class itk::Toplevel {
inherit itk::Archetype
constructor {args} {
#
# Create a toplevel window with the same name as this object
#
set itk_hull [namespace tail $this]
set itk_interior $itk_hull
#
# Create a toplevel window with the same name as this object
#
set itk_hull [namespace tail $this]
set itk_interior $itk_hull
itk_component add hull {
toplevel $itk_hull -class [namespace tail [info class]]
} {
keep -menu -background -cursor -takefocus
}
bind itk-delete-$itk_hull <Destroy> [list itcl::delete object $this]
itk_component add hull {
toplevel $itk_hull -class [namespace tail [info class]]
} {
keep -menu -background -cursor -takefocus
}
bind itk-delete-$itk_hull <Destroy> [list itcl::delete object $this]
set tags [bindtags $itk_hull]
bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull]
set tags [bindtags $itk_hull]
bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull]
eval itk_initialize $args
eval itk_initialize $args
}
destructor {
if {[winfo exists $itk_hull]} {
set tags [bindtags $itk_hull]
set i [lsearch $tags itk-delete-$itk_hull]
if {$i >= 0} {
bindtags $itk_hull [lreplace $tags $i $i]
}
destroy $itk_hull
}
itk_component delete hull
if {[winfo exists $itk_hull]} {
set tags [bindtags $itk_hull]
set i [lsearch $tags itk-delete-$itk_hull]
if {$i >= 0} {
bindtags $itk_hull [lreplace $tags $i $i]
}
destroy $itk_hull
}
itk_component delete hull
set components [component]
foreach component $components {
set path($component) [component $component]
}
foreach component $components {
if {[winfo exists $path($component)]} {
destroy $path($component)
}
}
set components [component]
foreach component $components {
set path($component) [component $component]
}
foreach component $components {
if {[winfo exists $path($component)]} {
destroy $path($component)
}
}
}
itk_option define -title title Title "" {
wm title $itk_hull $itk_option(-title)
wm title $itk_hull $itk_option(-title)
}
private variable itk_hull ""
+32 -32
View File
@@ -34,45 +34,45 @@ itcl::class itk::Widget {
# CONSTRUCTOR
# ------------------------------------------------------------------
constructor {args} {
#
# Create a window with the same name as this object
#
set itk_hull [namespace tail $this]
set itk_interior $itk_hull
#
# Create a window with the same name as this object
#
set itk_hull [namespace tail $this]
set itk_interior $itk_hull
itk_component add hull {
frame $itk_hull -class [namespace tail [info class]]
} {
keep -background -cursor
}
bind itk-delete-$itk_hull <Destroy> [list itcl::delete object $this]
itk_component add hull {
frame $itk_hull -class [namespace tail [info class]]
} {
keep -background -cursor
}
bind itk-delete-$itk_hull <Destroy> [list itcl::delete object $this]
set tags [bindtags $itk_hull]
bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull]
set tags [bindtags $itk_hull]
bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull]
eval itk_initialize $args
eval itk_initialize $args
}
destructor {
if {[winfo exists $itk_hull]} {
set tags [bindtags $itk_hull]
set i [lsearch $tags itk-delete-$itk_hull]
if {$i >= 0} {
bindtags $itk_hull [lreplace $tags $i $i]
}
destroy $itk_hull
}
itk_component delete hull
if {[winfo exists $itk_hull]} {
set tags [bindtags $itk_hull]
set i [lsearch $tags itk-delete-$itk_hull]
if {$i >= 0} {
bindtags $itk_hull [lreplace $tags $i $i]
}
destroy $itk_hull
}
itk_component delete hull
set components [component]
foreach component $components {
set path($component) [component $component]
}
foreach component $components {
if {[winfo exists $path($component)]} {
destroy $path($component)
}
}
set components [component]
foreach component $components {
set path($component) [component $component]
}
foreach component $components {
if {[winfo exists $path($component)]} {
destroy $path($component)
}
}
}
private variable itk_hull ""
+6 -3
View File
@@ -14,11 +14,14 @@
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require -exact Itk 4.2.7
#
# Provide transparent access to all [incr Tk] commands
#
lappend auto_path ${itk::library}
if {$tcl_platform(os) == "MacOS"} {
source -rsrc itk:tclIndex
} else {
lappend auto_path ${itk::library}
}
# ----------------------------------------------------------------------
# USAGE: itk::remove_destroy_hook <widget>
@@ -36,7 +39,7 @@ proc ::itk::remove_destroy_hook {widget} {
set tags [bindtags $widget]
set i [lsearch $tags "itk-destroy-$widget"]
if {$i >= 0} {
bindtags $widget [lreplace $tags $i $i]
bindtags $widget [lreplace $tags $i $i]
}
bind itk-destroy-$widget <Destroy> {}
}
+2 -2
View File
@@ -27,7 +27,7 @@ MODIFICATIONS.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
@@ -35,4 +35,4 @@ Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.
terms specified in this license.
+2 -15
View File
@@ -1,16 +1,3 @@
# -*- tcl -*-
# Tcl package index file, version 1.1
#
# Tcl package index file, version 1.0
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
if {[string length [package provide Itcl]] && ![package vsatisfies [package provide Itcl] 4.1]} return
if {[package vsatisfies [package provide Tcl] 9.0-]} {
package ifneeded itk @PACKAGE_VERSION@ \
[list load [file join $dir @PKG_LIB_FILE9@] Itk]
} else {
package ifneeded itk @PACKAGE_VERSION@ \
[list load [file join $dir @PKG_LIB_FILE8@] Itk]
}
package ifneeded Itk @PACKAGE_VERSION@ \
[list package require -exact itk @PACKAGE_VERSION@]
package ifneeded Itk @PACKAGE_VERSION@ [list load [file join $dir "@PKG_LIB_FILE@"] Itk]
+19
View File
@@ -0,0 +1,19 @@
# This file contains a top-level script to run all of the Tcl
# tests. Execute it by invoking "source all" when running tclTest
# in this directory.
# ------------------------------------------------------------------
# THIS SCRIPT IS NOW DEPRECATED! It is kept for older Tcl
# installations that don't have the "tcltest" package.
# Instead, use the "all.tcl" script to run the test suite.
# ------------------------------------------------------------------
foreach i [lsort [glob *.test]] {
if [string match l.*.test $i] {
# This is an SCCS lock file; ignore it.
continue
}
puts stdout $i
if [catch {source $i} msg] {
puts $msg
}
}
+2 -5
View File
@@ -7,12 +7,9 @@
# Copyright (c) 1998-2000 by Ajuba Solutions
# All rights reserved.
package prefer latest
package require tcltest 2.1
package require Tcl 8.6-
package require tcltest 2.2
tcltest::configure {*}$argv -testdir [file dir [info script]]
tcltest::testsDirectory [file dir [info script]]
tcltest::runAllTests
return
+348
View File
@@ -0,0 +1,348 @@
# This file contains support code for the Tcl test suite. It is
# normally sourced by the individual files in the test suite before
# they run their tests. This improved approach to testing was designed
# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
#
# Copyright (c) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ------------------------------------------------------------------
# THIS SCRIPT IS NOW DEPRECATED! It is kept for older Tcl
# installations that don't have the "tcltest" package.
# Instead, use "package require tcltest" in the test suite.
# ------------------------------------------------------------------
if ![info exists VERBOSE] {
set VERBOSE 0
}
if ![info exists TESTS] {
set TESTS {}
}
# If tests are being run as root, issue a warning message and set a
# variable to prevent some tests from running at all.
set user {}
if {$tcl_platform(platform) == "unix"} {
catch {set user [exec whoami]}
if {$user == ""} {
catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
}
if {$user == ""} {set user root}
if {$user == "root"} {
puts stdout "Warning: you're executing as root. I'll have to"
puts stdout "skip some of the tests, since they'll fail as root."
}
}
# Some of the tests don't work on some system configurations due to
# differences in word length, file system configuration, etc. In order
# to prevent false alarms, these tests are generally only run in the
# master development directory for Tcl. The presence of a file
# "doAllTests" in this directory is used to indicate that the non-portable
# tests should be run.
set doNonPortableTests [file exists doAllTests]
# If there is no "memory" command (because memory debugging isn't
# enabled), generate a dummy command that does nothing.
if {[info commands memory] == ""} {
proc memory args {}
}
# Check configuration information that will determine which tests
# to run. To do this, create an array testConfig. Each element
# has a 0 or 1 value, and the following elements are defined:
# unixOnly - 1 means this is a UNIX platform, so it's OK
# to run tests that only work under UNIX.
# macOnly - 1 means this is a Mac platform, so it's OK
# to run tests that only work on Macs.
# pcOnly - 1 means this is a PC platform, so it's OK to
# run tests that only work on PCs.
# unixOrPc - 1 means this is a UNIX or PC platform.
# macOrPc - 1 means this is a Mac or PC platform.
# macOrUnix - 1 means this is a Mac or UNIX platform.
# nonPortable - 1 means this the tests are being running in
# the master Tcl/Tk development environment;
# Some tests are inherently non-portable because
# they depend on things like word length, file system
# configuration, window manager, etc. These tests
# are only run in the main Tcl development directory
# where the configuration is well known. The presence
# of the file "doAllTests" in this directory indicates
# that it is safe to run non-portable tests.
# tempNotPc - The inverse of pcOnly. This flag is used to
# temporarily disable a test.
# nonBlockFiles - 1 means this platform supports setting files into
# nonblocking mode.
# asyncPipeClose- 1 means this platform supports async flush and
# async close on a pipe.
# unixExecs - 1 means this machine has commands such as 'cat',
# 'echo' etc available.
package require Itk
catch {unset testConfig}
if {$tcl_platform(platform) == "unix"} {
set testConfig(unixOnly) 1
set testConfig(tempNotPc) 1
} else {
set testConfig(unixOnly) 0
}
if {$tcl_platform(platform) == "macintosh"} {
set testConfig(tempNotPc) 1
set testConfig(macOnly) 1
} else {
set testConfig(macOnly) 0
}
if {$tcl_platform(platform) == "windows"} {
set testConfig(pcOnly) 1
} else {
set testConfig(pcOnly) 0
}
set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)]
set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)]
set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)]
set testConfig(nonPortable) [file exists doAllTests]
set f [open defs r]
if {[expr [catch {fconfigure $f -blocking off}]] == 0} {
set testConfig(nonBlockFiles) 1
} else {
set testConfig(nonBlockFiles) 0
}
close $f
# Test for SCO Unix - cannot run async flushing tests because a potential
# problem with select is apparently interfering. (Mark Diekhans).
if {$tcl_platform(platform) == "unix"} {
if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
set testConfig(asyncPipeClose) 0
} else {
set testConfig(asyncPipeClose) 1
}
} else {
set testConfig(asyncPipeClose) 1
}
# Test to see if execed commands such as cat, echo, rm and so forth are
# present on this machine.
set testConfig(unixExecs) 1
if {$tcl_platform(platform) == "macintosh"} {
set testConfig(unixExecs) 0
}
if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} {
if {[catch {exec cat defs}] == 1} {
set testConfig(unixExecs) 0
}
if {($testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} {
set testConfig(unixExecs) 0
}
if {($testConfig(unixExecs) == 1) && \
([catch {exec sh -c echo hello}] == 1)} {
set testConfig(unixExecs) 0
}
if {($testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} {
set testConfig(unixExecs) 0
}
if {$testConfig(unixExecs) == 1} {
exec echo hello > removeMe
if {[catch {exec rm removeMe}] == 1} {
set testConfig(unixExecs) 0
}
}
if {($testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} {
set testConfig(unixExecs) 0
}
if {($testConfig(unixExecs) == 1) && \
([catch {exec fgrep unixExecs defs}] == 1)} {
set testConfig(unixExecs) 0
}
if {($testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} {
set testConfig(unixExecs) 0
}
if {($testConfig(unixExecs) == 1) && \
([catch {exec echo abc > removeMe}] == 0) && \
([catch {exec chmod 644 removeMe}] == 1) && \
([catch {exec rm removeMe}] == 0)} {
set testConfig(unixExecs) 0
} else {
catch {exec rm -f removeMe}
}
if {($testConfig(unixExecs) == 1) && \
([catch {exec mkdir removeMe}] == 1)} {
set testConfig(unixExecs) 0
} else {
catch {exec rm -r removeMe}
}
if {$testConfig(unixExecs) == 0} {
puts stdout "Warning: Unix-style executables are not available, so"
puts stdout "some tests will be skipped."
}
}
proc print_verbose {name description script code answer} {
puts stdout "\n"
puts stdout "==== $name $description"
puts stdout "==== Contents of test case:"
puts stdout "$script"
if {$code != 0} {
if {$code == 1} {
puts stdout "==== Test generated error:"
puts stdout $answer
} elseif {$code == 2} {
puts stdout "==== Test generated return exception; result was:"
puts stdout $answer
} elseif {$code == 3} {
puts stdout "==== Test generated break exception"
} elseif {$code == 4} {
puts stdout "==== Test generated continue exception"
} else {
puts stdout "==== Test generated exception $code; message was:"
puts stdout $answer
}
} else {
puts stdout "==== Result was:"
puts stdout "$answer"
}
}
# test --
# This procedure runs a test and prints an error message if the
# test fails. If VERBOSE has been set, it also prints a message
# even if the test succeeds. The test will be skipped if it
# doesn't match the TESTS variable, or if one of the elements
# of "constraints" turns out not to be true.
#
# Arguments:
# name - Name of test, in the form foo-1.2.
# description - Short textual description of the test, to
# help humans understand what it does.
# constraints - A list of one or more keywords, each of
# which must be the name of an element in
# the array "testConfig". If any of these
# elements is zero, the test is skipped.
# This argument may be omitted.
# script - Script to run to carry out the test. It must
# return a result that can be checked for
# correctness.
# answer - Expected result from script.
proc test {name description script answer args} {
global VERBOSE TESTS testConfig
if {[string compare $TESTS ""] != 0} then {
set ok 0
foreach test $TESTS {
if [string match $test $name] then {
set ok 1
break
}
}
if !$ok then return
}
set i [llength $args]
if {$i == 0} {
# Empty body
} elseif {$i == 1} {
# "constraints" argument exists; shuffle arguments down, then
# make sure that the constraints are satisfied.
set constraints $script
set script $answer
set answer [lindex $args 0]
foreach constraint $constraints {
if {![info exists testConfig($constraint)]
|| !$testConfig($constraint)} {
return
}
}
} else {
error "wrong # args: must be \"test name description ?constraints? script answer\""
}
memory tag $name
set code [catch {uplevel $script} result]
if {$code != 0} {
print_verbose $name $description $script \
$code $result
} elseif {[string compare $result $answer] == 0} then {
if $VERBOSE then {
if {$VERBOSE > 0} {
print_verbose $name $description $script \
$code $result
}
puts stdout "++++ $name PASSED"
}
} else {
print_verbose $name $description $script \
$code $result
puts stdout "---- Result should have been:"
puts stdout "$answer"
puts stdout "---- $name FAILED"
}
}
proc dotests {file args} {
global TESTS
set savedTests $TESTS
set TESTS $args
source $file
set TESTS $savedTests
}
proc normalizeMsg {msg} {
regsub "\n$" [string tolower $msg] "" msg
regsub -all "\n\n" $msg "\n" msg
regsub -all "\n\}" $msg "\}" msg
return $msg
}
proc makeFile {contents name} {
set fd [open $name w]
fconfigure $fd -translation lf
if {[string index $contents [expr [string length $contents] - 1]] == "\n"} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
}
proc removeFile {name} {
file delete $name
}
proc makeDirectory {name} {
file mkdir $name
}
proc removeDirectory {name} {
file delete -force $name
}
proc viewFile {name} {
global tcl_platform testConfig
if {($tcl_platform(platform) == "macintosh") || \
($testConfig(unixExecs) == 0)} {
set f [open $name]
set data [read -nonewline $f]
close $f
return $data
} else {
exec cat $name
}
}
# Locate tcltest executable
set tcltest [list [info nameofexecutable]]
if {$tcltest == "{}"} {
set tcltest {}
puts "Unable to find tcltest executable, multiple process tests will fail."
}
+2 -2
View File
@@ -44,8 +44,8 @@ test interp-1.3 {errors are okay when slave interp is deleted} {
load "" Tk slave
load "" Itk slave
slave eval {
label .l
bind .l <Destroy> {error "dying!"}
label .l
bind .l <Destroy> {error "dying!"}
}
interp delete slave
} {}
+83 -83
View File
@@ -22,59 +22,59 @@ namespace import -force ::tcltest::*
# ----------------------------------------------------------------------
test option-1.1 {create a widget for the following tests} {
itcl::class TestOptComp {
inherit itk::Widget
constructor {args} {
itk_component add test1 {
label $itk_interior.t1
} {
keep -background -foreground -cursor
keep -text
}
pack $itk_component(test1) -side left -padx 2
eval itk_initialize $args
}
private variable status ""
public method action {info} {
lappend status $info
}
public method do {cmd} {
eval $cmd
}
itk_option define -status status Status {} {
lappend status $itk_option(-status)
}
inherit itk::Widget
constructor {args} {
itk_component add test1 {
label $itk_interior.t1
} {
keep -background -foreground -cursor
keep -text
}
pack $itk_component(test1) -side left -padx 2
eval itk_initialize $args
}
private variable status ""
public method action {info} {
lappend status $info
}
public method do {cmd} {
eval $cmd
}
itk_option define -status status Status {} {
lappend status $itk_option(-status)
}
}
itcl::class TestOptWidget {
inherit itk::Widget
constructor {args} {
itk_component add test1 {
label $itk_interior.t1
} {
keep -background -foreground -cursor
keep -text
}
pack $itk_component(test1) -side left -padx 2
eval itk_initialize $args
}
public method do {cmd} {
eval $cmd
}
inherit itk::Widget
constructor {args} {
itk_component add test1 {
label $itk_interior.t1
} {
keep -background -foreground -cursor
keep -text
}
pack $itk_component(test1) -side left -padx 2
eval itk_initialize $args
}
public method do {cmd} {
eval $cmd
}
}
TestOptWidget .#auto
} {.testOptWidget0}
test option-1.2 {"keep" can be called more than once} {
.testOptWidget0 do {
itk_component add k0 {
TestOptComp $itk_interior.k0 -status "create"
} {
keep -background -foreground -cursor
keep -background -foreground -cursor
keep -status
keep -status
}
pack $itk_component(k0)
itk_component add k0 {
TestOptComp $itk_interior.k0 -status "create"
} {
keep -background -foreground -cursor
keep -background -foreground -cursor
keep -status
keep -status
}
pack $itk_component(k0)
}
.testOptWidget0 configure -status "foo"
.testOptWidget0 component k0 do {set status}
@@ -82,13 +82,13 @@ test option-1.2 {"keep" can be called more than once} {
test option-1.3 {"rename" can be called more than once} {
.testOptWidget0 do {
itk_component add k1 {
TestOptComp $itk_interior.k1 -status "create"
} {
rename -status -test test Test
rename -status -test test Test
}
pack $itk_component(k1)
itk_component add k1 {
TestOptComp $itk_interior.k1 -status "create"
} {
rename -status -test test Test
rename -status -test test Test
}
pack $itk_component(k1)
}
.testOptWidget0 configure -test "bar"
.testOptWidget0 component k1 do {set status}
@@ -96,14 +96,14 @@ test option-1.3 {"rename" can be called more than once} {
test option-1.4 {"ignore" overrides keep and rename} {
.testOptWidget0 do {
itk_component add k2 {
TestOptComp $itk_interior.k2 -status "create"
} {
keep -status
rename -status -test test Test
ignore -status
}
pack $itk_component(k2)
itk_component add k2 {
TestOptComp $itk_interior.k2 -status "create"
} {
keep -status
rename -status -test test Test
ignore -status
}
pack $itk_component(k2)
}
.testOptWidget0 configure -status k2 -test k2
.testOptWidget0 component k2 do {set status}
@@ -130,48 +130,48 @@ test option-2.4 {query back unknown "usual" code} {
test option-2.5 {add a component using "usual" code} {
.testUsual do {
itk_component add u0 {
label $itk_interior.u0 -text "Usual Test #0"
} {
usual TestOptComp-test
}
pack $itk_component(u0)
itk_component add u0 {
label $itk_interior.u0 -text "Usual Test #0"
} {
usual TestOptComp-test
}
pack $itk_component(u0)
}
.testUsual configure -foreground green -cursor gumby
list [.testUsual component u0 cget -foreground] \
[.testUsual component u0 cget -cursor]
[.testUsual component u0 cget -cursor]
} {green gumby}
test option-2.6 {override "usual" options} {
.testUsual do {
itk_component add u1 {
label $itk_interior.u1 -text "Usual Test #1"
} {
usual TestOptComp-test
ignore -cursor
keep -background
}
pack $itk_component(u1)
itk_component add u1 {
label $itk_interior.u1 -text "Usual Test #1"
} {
usual TestOptComp-test
ignore -cursor
keep -background
}
pack $itk_component(u1)
}
.testUsual configure -foreground red -background white -cursor dot
list [.testUsual component u1 cget -foreground] \
[.testUsual component u1 cget -background] \
[.testUsual component u1 cget -cursor]
[.testUsual component u1 cget -background] \
[.testUsual component u1 cget -cursor]
} {red white gumby}
set unique 0
foreach widget {button canvas checkbutton entry frame label listbox
menu menubutton message radiobutton scale scrollbar
text toplevel} {
menu menubutton message radiobutton scale scrollbar
text toplevel} {
set name "c[incr unique]"
test option-2.7.$name {verify "usual" options for all Tk widgets} {
.testUsual do [format {
itk_component add %s {
%s $itk_interior.%s
}
} $name $widget $name]
.testUsual do [format {
itk_component add %s {
%s $itk_interior.%s
}
} $name $widget $name]
} $name
}
+31 -31
View File
@@ -22,13 +22,13 @@ namespace import -force ::tcltest::*
# ----------------------------------------------------------------------
test privacy-1.1 {define simple mega-widget class} {
itcl::class TestPrivacy {
inherit itk::Widget
constructor {args} {
eval itk_initialize $args
}
method do {args} {
return [eval $args]
}
inherit itk::Widget
constructor {args} {
eval itk_initialize $args
}
method do {args} {
return [eval $args]
}
}
set testobj [TestPrivacy .#auto]
pack $testobj
@@ -36,58 +36,58 @@ test privacy-1.1 {define simple mega-widget class} {
test privacy-1.2 {"itk_component add" requires certain arguments} {
list [catch {$testobj do itk_component add foo} msg] $msg \
[catch {$testobj do itk_component add foo bar baz qux} msg] $msg
[catch {$testobj do itk_component add foo bar baz qux} msg] $msg
} {1 {wrong # args: should be "itk_component add ?-protected? ?-private? ?--? name createCmds ?optionCmds?"} 1 {wrong # args: should be "add ?-protected? ?-private? ?--? name createCmds ?optionCmds?}}
test privacy-1.3 {"itk_component add" rejects invalid options} {
list [catch {
$testobj do itk_component add -foo bar baz qux
} msg] $msg \
[catch {
$testobj do itk_component add -- -foo {label $itk_interior.l}
} msg] $msg
$testobj do itk_component add -foo bar baz qux
} msg] $msg \
[catch {
$testobj do itk_component add -- -foo {label $itk_interior.l}
} msg] $msg
} {1 {bad option "-foo": should be -private, -protected or --} 0 -foo}
test privacy-1.4 {"itk_component add" recognizes privacy options} {
list [catch {
$testobj do itk_component add -protected x {label $itk_interior.x}
} msg] $msg \
[catch {
$testobj do itk_component add -private y {label $itk_interior.y}
} msg] $msg
$testobj do itk_component add -protected x {label $itk_interior.x}
} msg] $msg \
[catch {
$testobj do itk_component add -private y {label $itk_interior.y}
} msg] $msg
} {0 x 0 y}
test privacy-1.5 {protected/private components are hidden} {
list [lsort [$testobj component]] \
[lsort [$testobj do component]]
[lsort [$testobj do component]]
} {{-foo hull} {-foo hull x y}}
test privacy-1.6 {define a derived class and add protected/private comps} {
itcl::class TestMorePrivacy {
inherit TestPrivacy
constructor {args} {
eval itk_initialize $args
}
method do {args} {
return [eval $args]
}
inherit TestPrivacy
constructor {args} {
eval itk_initialize $args
}
method do {args} {
return [eval $args]
}
}
set testobj2 [TestMorePrivacy .#auto]
$testobj2 TestPrivacy::do itk_component add -private x {
label $itk_interior.x
label $itk_interior.x
}
$testobj2 TestPrivacy::do itk_component add -protected y {
label $itk_interior.y
label $itk_interior.y
}
$testobj2 TestPrivacy::do itk_component add z {
label $itk_interior.z
label $itk_interior.z
}
} {z}
test privacy-1.7 {components are visible depending on namespace context} {
list [lsort [$testobj2 component]] \
[lsort [$testobj2 do component]] \
[lsort [$testobj2 TestPrivacy::do component]]
[lsort [$testobj2 do component]] \
[lsort [$testobj2 TestPrivacy::do component]]
} {{hull z} {hull y z} {hull x y z}}
# ----------------------------------------------------------------------
+18 -18
View File
@@ -22,17 +22,17 @@ namespace import -force ::tcltest::*
# ----------------------------------------------------------------------
test public-1.1 {define base class and simple mega-widget class} {
itcl::class test_public_base {
public variable null
public variable background "not used"
public variable message
public variable null
public variable background "not used"
public variable message
}
itcl::configbody test_public_base::message {
global ::test_public_status
lappend test_public_status "message: $message"
global ::test_public_status
lappend test_public_status "message: $message"
}
itcl::configbody test_public_base::background {
global ::test_public_status
lappend test_public_status "background: $background"
global ::test_public_status
lappend test_public_status "background: $background"
}
option add *TestPublic.background red
option add *TestPublic.foreground white
@@ -40,18 +40,18 @@ test public-1.1 {define base class and simple mega-widget class} {
option add *TestPublic.message "Hello, World!"
itcl::class TestPublic {
inherit itk::Widget test_public_base
constructor {args} {
itk_component add mesg {
label $itk_interior.mesg
} {
keep -background -foreground -cursor
rename -text -message message Message
}
pack $itk_component(mesg) -side left -padx 2
inherit itk::Widget test_public_base
constructor {args} {
itk_component add mesg {
label $itk_interior.mesg
} {
keep -background -foreground -cursor
rename -text -message message Message
}
pack $itk_component(mesg) -side left -padx 2
eval itk_initialize $args
}
eval itk_initialize $args
}
}
set testobj [TestPublic .#auto]
pack $testobj
+60 -60
View File
@@ -29,25 +29,25 @@ test toplevel-1.1 {define a toplevel mega-widget class} {
option add *TestToplevel.text ""
itcl::class TestToplevel {
inherit itk::Toplevel
constructor {args} {
itk_component add test1 {
label $itk_interior.t1
} {
keep -background -foreground -cursor
keep -text
}
pack $itk_component(test1) -side left -padx 2
eval itk_initialize $args
}
public method do {cmd} {
eval $cmd
}
inherit itk::Toplevel
constructor {args} {
itk_component add test1 {
label $itk_interior.t1
} {
keep -background -foreground -cursor
keep -text
}
pack $itk_component(test1) -side left -padx 2
eval itk_initialize $args
}
public method do {cmd} {
eval $cmd
}
private variable status ""
itk_option define -background background Background {} {
lappend status "background: $itk_option(-background)"
}
private variable status ""
itk_option define -background background Background {} {
lappend status "background: $itk_option(-background)"
}
}
TestToplevel .#auto
} {.testToplevel0}
@@ -63,8 +63,8 @@ test toplevel-1.3 {check the list components} {
test toplevel-1.4 {check the propagation of configuration options} {
.testToplevel0 configure -background red
list [.testToplevel0 component hull cget -background] \
[.testToplevel0 component test1 cget -background] \
[.testToplevel0 do {set status}]
[.testToplevel0 component test1 cget -background] \
[.testToplevel0 do {set status}]
} {red red {{background: linen} {background: red}}}
test toplevel-1.5 {mega-widgets show up on the object list} {
@@ -77,7 +77,7 @@ test toplevel-1.6 {when a mega-widget is destroyed, its object is deleted} {
} {}
test toplevel-1.7 {when an mega-widget object is deleted, its window and any
components are destroyed } {
components are destroyed } {
TestToplevel .delme
set label [.delme component test1]
itcl::delete object .delme
@@ -85,25 +85,25 @@ test toplevel-1.7 {when an mega-widget object is deleted, its window and any
} {0 0}
test toplevel-1.8 {when a mega-widget object is deleted, its window and any
components are destroyed (even if in another window) } {
components are destroyed (even if in another window) } {
catch {destroy .t1}
catch {destroy .t2}
catch {rename .t2 {}}
catch {itcl::delete class ButtonTop}
itcl::class ButtonTop {
inherit itk::Toplevel
inherit itk::Toplevel
constructor {args} {
eval itk_initialize $args
constructor {args} {
eval itk_initialize $args
itk_component add button {
button $itk_option(-container).b -text Button
} {}
pack $itk_component(button)
}
itk_component add button {
button $itk_option(-container).b -text Button
} {}
pack $itk_component(button)
}
itk_option define -container container Container {}
itk_option define -container container Container {}
}
toplevel .t1
@@ -117,25 +117,25 @@ test toplevel-1.8 {when a mega-widget object is deleted, its window and any
} {.t1.b 0}
test toplevel-1.9 {when a window that contains a megawidget component
is destroyed, the component is removed from the megawidget} {
is destroyed, the component is removed from the megawidget} {
catch {destroy .t1}
catch {destroy .t2}
catch {rename .t2 {}}
catch {itcl::delete class ButtonTop}
itcl::class ButtonTop {
inherit itk::Toplevel
inherit itk::Toplevel
constructor {args} {
eval itk_initialize $args
constructor {args} {
eval itk_initialize $args
itk_component add button {
button $itk_option(-container).b -text Button
} {}
pack $itk_component(button)
}
itk_component add button {
button $itk_option(-container).b -text Button
} {}
pack $itk_component(button)
}
itk_option define -container container Container {}
itk_option define -container container Container {}
}
toplevel .t1
@@ -149,36 +149,36 @@ test toplevel-1.9 {when a window that contains a megawidget component
} {{button hull} hull}
test toplevel-1.10 {when destroying a component that is inside another
window protect against that case where one component destroy
actually destroys other contained components} {
window protect against that case where one component destroy
actually destroys other contained components} {
catch {destroy .t1}
catch {destroy .t2}
catch {rename .t2 {}}
catch {itcl::delete class ButtonTop}
itcl::class ButtonTop {
inherit itk::Toplevel
inherit itk::Toplevel
constructor {args} {
eval itk_initialize $args
constructor {args} {
eval itk_initialize $args
# Note, the component names matter here since
# [.t2 component] returns names in hash order.
# We need to delete cframe first since it
# is the parent of cbutton.
# Note, the component names matter here since
# [.t2 component] returns names in hash order.
# We need to delete cframe first since it
# is the parent of cbutton.
itk_component add cframe {
button $itk_option(-container).cframe
} {}
pack $itk_component(cframe)
itk_component add cframe {
button $itk_option(-container).cframe
} {}
pack $itk_component(cframe)
itk_component add cbutton {
button $itk_component(cframe).b -text Button
} {}
pack $itk_component(cbutton)
}
itk_component add cbutton {
button $itk_component(cframe).b -text Button
} {}
pack $itk_component(cbutton)
}
itk_option define -container container Container {}
itk_option define -container container Container {}
}
toplevel .t1
+96 -96
View File
@@ -31,39 +31,39 @@ test widget-1.1 {define a simple mega-widget class} {
option add *TestWidget.text ""
itcl::class TestWidget {
inherit itk::Widget
constructor {args} {
itk_component add test1 {
label $itk_interior.t1
} {
keep -background -foreground -cursor
keep -text
}
pack $itk_component(test1) -side left -padx 2
inherit itk::Widget
constructor {args} {
itk_component add test1 {
label $itk_interior.t1
} {
keep -background -foreground -cursor
keep -text
}
pack $itk_component(test1) -side left -padx 2
itk_component add test2 {
button $itk_interior.t2 -text "Push Me"
} {
keep -foreground -cursor -borderwidth -command
rename -background -normal normal Background
rename -activebackground -highlight highlight Foreground
}
pack $itk_component(test2) -side right -fill x -pady 2
itk_component add test2 {
button $itk_interior.t2 -text "Push Me"
} {
keep -foreground -cursor -borderwidth -command
rename -background -normal normal Background
rename -activebackground -highlight highlight Foreground
}
pack $itk_component(test2) -side right -fill x -pady 2
eval itk_initialize $args
}
private variable status ""
public method action {info} {
lappend status $info
}
eval itk_initialize $args
}
private variable status ""
public method action {info} {
lappend status $info
}
public method do {cmd} {
eval $cmd
}
public method do {cmd} {
eval $cmd
}
itk_option define -status status Status {} {
lappend status $itk_option(-status)
}
itk_option define -status status Status {} {
lappend status $itk_option(-status)
}
}
TestWidget .#auto
} {.testWidget0}
@@ -91,7 +91,7 @@ foreach test {
set result [lindex $test 1]
test widget-1.3.[incr unique] {check individual configuration options} {
.testWidget0 configure $opt
.testWidget0 configure $opt
} $result
}
@@ -112,9 +112,9 @@ foreach test {
set value [lindex $test 1]
test widget-1.4.[incr unique] {set individual configuration options} {
list [.testWidget0 configure $opt $value] \
[.testWidget0 cget $opt] \
[.testWidget0 do "set itk_option($opt)"]
list [.testWidget0 configure $opt $value] \
[.testWidget0 cget $opt] \
[.testWidget0 do "set itk_option($opt)"]
} [list "" $value $value]
}
@@ -132,26 +132,26 @@ foreach test {
set win [lindex $test 1]
test widget-1.6 {check the window for each component} {
list [.testWidget0 component $name] \
[.testWidget0 do "set itk_component($name)"]
list [.testWidget0 component $name] \
[.testWidget0 do "set itk_component($name)"]
} [list $win $win]
}
test widget-1.7 {check the propagation of configuration options} {
list [.testWidget0 component hull cget -cursor] \
[.testWidget0 component test1 cget -cursor] \
[.testWidget0 component test2 cget -cursor]
[.testWidget0 component test1 cget -cursor] \
[.testWidget0 component test2 cget -cursor]
} {trek trek trek}
test widget-1.8 {check the propagation of configuration options} {
list [.testWidget0 component hull cget -background] \
[.testWidget0 component test1 cget -background] \
[.testWidget0 component test2 cget -background]
[.testWidget0 component test1 cget -background] \
[.testWidget0 component test2 cget -background]
} {red red MistyRose2}
test widget-1.9 {check the propagation of configuration options} {
list [.testWidget0 component test1 cget -text] \
[.testWidget0 component test2 cget -text]
[.testWidget0 component test2 cget -text]
} {Label: {Push Me}}
test widget-1.10 {check the invocation of "config" code} {
@@ -173,17 +173,17 @@ test widget-1.11b {execute some code created by "code" command} {
test widget-1.12a {components can be added on the fly} {
.testWidget0 do {
itk_component add test3 {
label $itk_interior.t3 -text "Temporary"
} {
keep -background -foreground -cursor
}
itk_component add test3 {
label $itk_interior.t3 -text "Temporary"
} {
keep -background -foreground -cursor
}
}
} {test3}
test widget-1.12b {components can be added on the fly} {
.testWidget0 do {
pack $itk_component(test3) -fill x
pack $itk_component(test3) -fill x
}
} {}
@@ -193,8 +193,8 @@ test widget-1.13 {new components show up on the component list} {
test widget-1.14 {new components are initialized properly} {
list [.testWidget0 component test3 cget -background] \
[.testWidget0 component test3 cget -foreground] \
[.testWidget0 component test3 cget -cursor]
[.testWidget0 component test3 cget -foreground] \
[.testWidget0 component test3 cget -cursor]
} {red IndianRed trek}
test widget-1.15 {components can be deleted like ordinary widgets} {
@@ -245,42 +245,42 @@ test widget-1.24 {recreate another test widget} {
test widget-1.25 {when an internal component is destroyed, it is removed from the list of components, and any dead options disappear} {
list [lsort [.testWidget component]] \
[.testWidget configure] \
[.testWidget configure] \
[catch {destroy [.testWidget component test1]}] \
[.testWidget component] \
[.testWidget do {return [lsort [array names itk_component]]}] \
[.testWidget configure]
[.testWidget component] \
[.testWidget do {return [lsort [array names itk_component]]}] \
[.testWidget configure]
} {{hull test1 test2} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}} {-text text Text {} {}}} 0 {hull test2} {hull test2} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}}}}
test widget-1.26 {when an internal component is deleted (but not destroyed) it is disconnected from the option list and its binding tags are updated} {
set comp [.testWidget component test2]
list [bindtags $comp] \
[bind itk-destroy-$comp <Destroy>] \
[bind itk-destroy-$comp <Destroy>] \
[catch {.testWidget do {itk_component delete test2}}] \
[bindtags $comp] \
[bind itk-destroy-$comp <Destroy>] \
[.testWidget configure]
} {{itk-destroy-.testWidget.t2 .testWidget.t2 Button . all} {namespace inscope ::TestWidget {::.testWidget itk_component delete test2}} 0 {.testWidget.t2 Button . all} {} {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-status status Status {} {}}}}
[bindtags $comp] \
[bind itk-destroy-$comp <Destroy>] \
[.testWidget configure]
} {{itk-destroy-.testWidget.t2 .testWidget.t2 Button . all} {namespace inscope ::itk::Archetype {::.testWidget itk_component delete test2}} 0 {.testWidget.t2 Button . all} {} {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-status status Status {} {}}}}
test widget-1.27 {when a mega-widget object is deleted, its window and any
components are destroyed (even if in another window) } {
components are destroyed (even if in another window) } {
catch {destroy .t1}
catch {rename .t1.bw {}}
catch {itcl::delete class ButtonWidget}
itcl::class ButtonWidget {
inherit itk::Widget
inherit itk::Widget
constructor {args} {
eval itk_initialize $args
constructor {args} {
eval itk_initialize $args
itk_component add button {
button $itk_option(-container).b -text Button
} {}
pack $itk_component(button)
}
itk_component add button {
button $itk_option(-container).b -text Button
} {}
pack $itk_component(button)
}
itk_option define -container container Container {}
itk_option define -container container Container {}
}
toplevel .t1
@@ -299,24 +299,24 @@ test widget-1.27 {when a mega-widget object is deleted, its window and any
} {.t1.f.b 0}
test widget-1.28 {when a window that contains a megawidget component
is destroyed, the component is removed from the megawidget} {
is destroyed, the component is removed from the megawidget} {
catch {destroy .t1}
catch {rename .t1.bw {}}
catch {itcl::delete class ButtonWidget}
itcl::class ButtonWidget {
inherit itk::Widget
inherit itk::Widget
constructor {args} {
eval itk_initialize $args
constructor {args} {
eval itk_initialize $args
itk_component add button {
button $itk_option(-container).b -text Button
} {}
pack $itk_component(button)
}
itk_component add button {
button $itk_option(-container).b -text Button
} {}
pack $itk_component(button)
}
itk_option define -container container Container {}
itk_option define -container container Container {}
}
toplevel .t1
@@ -336,35 +336,35 @@ test widget-1.28 {when a window that contains a megawidget component
} {{button hull} hull}
test widget-1.29 {when destroying a component that is inside another
window protect against that case where one component destroy
actually destroys other contained components} {
window protect against that case where one component destroy
actually destroys other contained components} {
catch {destroy .t1}
catch {rename .t1.bw {}}
catch {itcl::delete class ButtonWidget}
itcl::class ButtonWidget {
inherit itk::Widget
inherit itk::Widget
constructor {args} {
eval itk_initialize $args
constructor {args} {
eval itk_initialize $args
# Note, the component names matter here since
# [.t2 component] returns names in hash order.
# We need to delete cframe first since it
# is the parent of cbutton.
# Note, the component names matter here since
# [.t2 component] returns names in hash order.
# We need to delete cframe first since it
# is the parent of cbutton.
itk_component add cframe {
button $itk_option(-container).cframe
} {}
pack $itk_component(cframe)
itk_component add cframe {
button $itk_option(-container).cframe
} {}
pack $itk_component(cframe)
itk_component add cbutton {
button $itk_component(cframe).b -text Button
} {}
pack $itk_component(cbutton)
}
itk_component add cbutton {
button $itk_component(cframe).b -text Button
} {}
pack $itk_component(cbutton)
}
itk_option define -container container Container {}
itk_option define -container container Container {}
}
toplevel .t1
+1 -1
View File
@@ -1,4 +1,4 @@
/*
/*
* dllEntryPoint.c --
*
* This file implements the Dll entry point as needed by Windows.
-1
View File
@@ -1 +0,0 @@
git-
-1
View File
@@ -1 +0,0 @@
#define ITK_VERSION_UUID \
+486 -163
View File
@@ -1,163 +1,486 @@
#------------------------------------------------------------- -*- makefile -*-
#
# Makefile for [Incr Tk] interface
#
# Basic build, test and install
# nmake /f makefile.vc INSTALLDIR=c:\path\to\installdir
# nmake /f makefile.vc INSTALLDIR=c:\path\to\installdir test
# nmake /f makefile.vc INSTALLDIR=c:\path\to\installdir install
#
# For other build options (debug, static etc.),
# See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for
# detailed documentation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------
PROJECT = itk
# Tcl 8.6 etc. compile with /DUNICODE. ITK pre-nmake reform compiled
# without -DUNICODE. Keep that behaviour for now.
USE_WIDECHAR_API = 0
NEED_TK = 1
PRJ_DEFINES = $(PRJ_DEFINES) -Dinline=__inline
PRJ_DEFINES = $(PRJ_DEFINES)
PRJ_DEFINES = $(PRJ_DEFINES) -I$(TMP_DIR)
!include "rules-ext.vc"
# nmakehelp -V <file> <tag> will search the file for tag, skips until a
# number and returns all character until a character not in [0-9.ab]
# is read.
!if [echo REM = This file is generated from Makefile.vc > versions.vc]
!endif
!if [echo TCL_VERSION_REQ = \>> versions.vc] \
&& [nmakehlp -V ..\configure.ac TCL_VERSION_REQ >> versions.vc]
!endif
!include "versions.vc"
PRJ_OBJS = \
$(TMP_DIR)\itkArchBase.obj \
$(TMP_DIR)\itkArchetype.obj \
$(TMP_DIR)\itkBase.obj \
$(TMP_DIR)\itkCmd.obj \
$(TMP_DIR)\itkHelpers.obj \
$(TMP_DIR)\itkOption.obj \
$(TMP_DIR)\itkUtil.obj \
$(TMP_DIR)\itkStubInit.obj
# Uncomment the following line if you want to build and install stubs
PRJ_STUBOBJS = $(TMP_DIR)\itkStubLib.obj
PRJ_HEADERS = \
$(GENERICDIR)\itkInt.h \
$(GENERICDIR)\itk.h
# Locate ITCL headers and libraries.
# In principle, we don't need the ITCL source directory, and an installed
# ITCL should suffice. But that needs additional machinery not implemented
# yet.
!if [echo ITCL_DIR = \> nmakehlp.out] \
|| [nmakehlp -L generic\itcl.h >> nmakehlp.out]
!error Could not locate ITCL source directory.
!endif
# Locate TK headers and libraries.
# In principle, we don't need the TK source directory, and an installed
# TK should suffice. But that needs additional machinery not implemented
# yet.
!if [echo TK_DIR = \> nmakehlp.out] \
|| [nmakehlp -L generic\tk.h >> nmakehlp.out]
!error Could not locate TK source directory.
!endif
!include nmakehlp.out
# Get the ITCL version from its configure.ac
!if [echo ITCL_DOTVERSION = \> versions.vc] \
&& [nmakehlp -V "$(ITCL_DIR)\configure.ac" itcl >> versions.vc]
!error Could not retrieve ITCL version.
!endif
# Get the TK version from its configure.ac
!if [echo TK_DOTVERSION = \> versions.vc] \
&& [nmakehlp -V "$(TK_DIR)\configure.ac" tk >> versions.vc]
!error Could not retrieve TK version.
!endif
!include versions.vc
ITCL_VERSION = $(ITCL_DOTVERSION:.=)
ITCL_GENERIC_DIR = $(ITCL_DIR)\generic
!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8"
ITCLSTUBLIBNAME = itclstub$(ITCL_VERSION).lib
ITCL_LIB_FILE = itcl$(ITCL_VERSION).dll
!else
ITCLSTUBLIBNAME = itclstub.lib
ITCL_LIB_FILE = tcl9itcl$(ITCL_VERSION).dll
!endif
ITCLSTUBLIB = $(ITCL_DIR)\win\$(BUILDDIRTOP)\$(ITCLSTUBLIBNAME)
ITCL_BIN_DIR = $(ITCL_DIR)/win/$(BUILDDIRTOP)
TK_VERSION = $(TK_DOTVERSION:.=)
TK_GENERIC_DIR = $(TK_DIR)\generic
TK_XLIB_DIR = $(TK_DIR)\xlib
!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8"
TKSTUBLIBNAME = tkstub$(TK_VERSION).lib
!else
TKSTUBLIBNAME = tkstub.lib
!endif
TKSTUBLIB = $(TK_DIR)\win\$(BUILDDIRTOP)\$(TKSTUBLIBNAME)
TK_BIN_DIR = $(TK_DIR)/win/$(BUILDDIRTOP)
PRJ_INCLUDES = -I"$(ITCL_GENERIC_DIR)" -I"$(TK_GENERIC_DIR)" -I"$(TK_XLIB_DIR)"
!if !$(STATIC_BUILD)
PRJ_LIBS = $(ITCLSTUBLIB) $(TKSTUBLIB)
!endif
# Disable standard test target because we have a custom one
DISABLE_TARGET_test = 1
!include "$(_RULESDIR)\targets.vc"
# Additional default actions for install
install: default-install-docs-n
# The TIP 477 generation of pkgIndex.tcl from pkgIndex.tcl.in does not include
# all replacements below so define our own target.
pkgindex: $(OUT_DIR)\pkgIndex.tcl
$(OUT_DIR)\pkgIndex.tcl: $(ROOT)\pkgIndex.tcl.in
@nmakehlp -s << $** > $@
@PACKAGE_NAME@ $(PROJECT)
@PACKAGE_VERSION@ $(DOTVERSION)
@TCL_VERSION_REQ@ $(TCL_VERSION_REQ)
@PKG_LIB_FILE@ $(PRJLIBNAME)
@PKG_LIB_FILE8@ $(PRJLIBNAME8)
@PKG_LIB_FILE9@ $(PRJLIBNAME9)
<<
$(ROOT)\manifest.uuid:
copy $(WIN_DIR)\gitmanifest.in $(ROOT)\manifest.uuid
git rev-parse HEAD >>$(ROOT)\manifest.uuid
$(TMP_DIR)\itkUuid.h: $(ROOT)\manifest.uuid
copy $(WIN_DIR)\itkUuid.h.in+$(ROOT)\manifest.uuid $(TMP_DIR)\itkUuid.h
test: setup $(PROJECT)
@echo testing itk
@set ITK_LIBRARY=$(LIBDIR:\=/)
@$(CPY) $(LIBDIR)\*.tcl $(OUT_DIR)
!if $(TKINSTALL)
@set PATH=$(_TKDIR)\bin;$(PATH)
$(DEBUGGER) $(WISH) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS)
!else
@set PATH=$(_TKDIR)\win\$(BUILDDIRTOP);$(PATH)
$(DEBUGGER) $(WISH) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) \
-load "package ifneeded itk $(DOTVERSION) \
{source {$(LIBDIR:\=/)/itk.tcl};load {$(PRJLIB:\=/)} [string totitle $(PROJECT)]};\
package ifneeded itcl $(ITCL_DOTVERSION) \
{source {$(ITCL_BIN_DIR:\=/)/itcl.tcl};load {$(ITCL_BIN_DIR:\=/)/$(ITCL_LIB_FILE)} Itcl}"
!endif
# Explicit dependency rules
$(GENERICDIR)\itkBase.c : $(TMP_DIR)\itkUuid.h
#------------------------------------------------------------------------------
# Visual C++ 5.0+ makefile for [Incr Tk]
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
#------------------------------------------------------------------------------
# Do not modify this file!
#------------------------------------------------------------------------------
!if !exist("makefile.vc")
MSG = ^
You must run this makefile only from the directory it is in.^
Please `cd` to its location first.
!error $(MSG)
!endif
PROJECT = itk
!include "rules.vc"
!if $(TCLINSTALL)
!message *** Warning: [Incr Tk] requires the source distribution of Tcl to build from,
!message *** at this time, sorry. Please set the TCLDIR and TKDIR macros to point
!message *** to the sources.
!endif
ITCLDIR = ..\..\itcl
!if [nmakehlp -g $(ITCLDIR)\generic\itcl.h ITCL_VERSION] == 33
ITCL_DOTVERSION = 3.3
!elseif [nmakehlp -g $(ITCLDIR)\generic\itcl.h ITCL_VERSION] == 34
ITCL_DOTVERSION = 3.4
!elseif [nmakehlp -g $(ITCLDIR)\generic\itcl.h ITCL_VERSION] == 35
ITCL_DOTVERSION = 3.5
!elseif [nmakehlp -g $(ITCLDIR)\generic\itcl.h ITCL_VERSION] == 0
MSG =^
Can't get version string from ..\generic\itcl.h
!error $(MSG)
!endif
ITCL_VERSION = $(ITCL_DOTVERSION:.=)
!if [nmakehlp -g ..\generic\itk.h ITK_VERSION] == 33
ITK_DOTVERSION = 3.3
!elseif [nmakehlp -g ..\generic\itk.h ITK_VERSION] == 34
ITK_DOTVERSION = 3.4
!elseif [nmakehlp -g ..\generic\itk.h ITK_VERSION] == 35
ITK_DOTVERSION = 3.5
!elseif [nmakehlp -g ..\generic\itk.h ITK_VERSION] == 0
MSG =^
Can't get version string from ..\generic\itk.h
!error $(MSG)
!endif
ITK_VERSION = $(ITK_DOTVERSION:.=)
BINROOT = .
ROOT = ..
STUBPREFIX = $(PROJECT)stub
PKGINDEX = "$(TMP_DIR)\pkgIndex.tcl"
ITCLLIBNAME = itcl$(ITCL_VERSION)$(SUFX).$(EXT)
ITCLLIB = "$(ITCLDIR)\win\$(OUT_DIR)\$(ITCLLIBNAME)"
ITKIMPLIB = "$(OUT_DIR)\$(PROJECT)$(ITK_VERSION)$(SUFX).lib"
ITKSTUBLIBNAME = $(STUBPREFIX)$(ITK_VERSION).lib
ITKSTUBLIB = "$(OUT_DIR)\$(ITKSTUBLIBNAME)"
!if $(TCL_DOES_STUBS)
ITKLIBNAME = $(PROJECT)$(ITK_VERSION)$(SUFX).$(EXT)
ITCLIMPLIBNAME = itcl$(ITCL_VERSION)$(SUFX).$(EXT)
!else
ITKLIBNAME = $(PROJECT)$(ITK_VERSION)80$(SUFX).$(EXT)
ITCLIMPLIBNAME = itcl$(ITCL_VERSION)80$(SUFX).lib
!endif
ITKLIB = "$(OUT_DIR)\$(ITKLIBNAME)"
ITCLIMPLIB = "$(ITCLDIR)\win\$(BUILDDIRTOP)\$(ITCLIMPLIBNAME)"
!if $(TCLINSTALL)
TKSTUBLIB = "$(TCLDIR)\lib\tkstub$(TCL_VERSION).lib"
TKIMPLIB = "$(TCLDIR)\lib\tk$(TCL_VERSION)$(DBGX).lib"
TKLIB = "$(TCLDIR)\bin\tk$(TCL_VERSION)$(DBGX).dll"
WISH = "$(TCLDIR)\bin\wish$(TCL_VERSION)$(DBGX).exe"
TCL_LIBRARY =
TK_LIBRARY =
!else
TKSTUBLIB = "$(TKDIR)\win\$(BUILDDIRTOP)\tkstub$(TCL_VERSION).lib"
TKIMPLIB = "$(TKDIR)\win\$(OUT_DIR)\tk$(TCL_VERSION)$(DBGX).lib"
TKLIB = "$(TKDIR)\win\$(OUT_DIR)\tk$(TCL_VERSION)$(DBGX).dll"
WISH = "$(TKDIR)\win\$(OUT_DIR)\wish$(TCL_VERSION)$(DBGX).exe"
TCL_LIBRARY = "$(TCLDIR)\library"
TK_LIBRARY = "$(TKDIR)\library"
!endif
ITCL_LIBRARY = "$(ITCLDIR:\=/)/library"
ITK_LIBRARY = "$(ROOT)/library"
ITCLSTUBLIBNAME = itclstub$(ITCL_VERSION).lib
ITCLSTUBLIB = "$(ITCLDIR)\win\$(BUILDDIRTOP)\$(ITCLSTUBLIBNAME)"
### For Tcl 8.0
!if !$(TCL_DOES_STUBS)
TCLSTUBLIB = $(TCLIMPLIB)
TKSTUBLIB = $(TKIMPLIB)
ITCLSTUBLIB = $(ITCLIMPLIB)
!endif
BIN_INSTALL_DIR = $(_INSTALLDIR)\bin
DOC_INSTALL_DIR = $(_INSTALLDIR)\doc
LIB_INSTALL_DIR = $(_INSTALLDIR)\lib
SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\itk$(ITK_DOTVERSION)
INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include
ITKOBJS = \
$(TMP_DIR)\itk_archetype.obj \
$(TMP_DIR)\itk_cmds.obj \
$(TMP_DIR)\itk_option.obj \
$(TMP_DIR)\itk_util.obj \
!if !$(STATIC_BUILD)
$(TMP_DIR)\dllEntryPoint.obj \
$(TMP_DIR)\itk.res \
!endif
!if $(TCL_DOES_STUBS)
$(TMP_DIR)\itkStubInit.obj
!endif
ITKSTUBOBJS = \
!if $(TCL_DOES_STUBS)
$(TMP_DIR)\itkStubLib.obj
!endif
GENERICDIR = $(ROOT)\generic
DOCDIR = $(ROOT)\doc
WINDIR = $(ROOT)\win
RCDIR = $(ROOT)\win\rc
TOOLSDIR = ..\..\tools
#---------------------------------------------------------------------
# Link flags
#---------------------------------------------------------------------
!if $(DEBUG)
ldebug = -debug:full -debugtype:cv
!else
ldebug = -release -opt:ref -opt:icf,3
!endif
# declarations common to all linker options
lflags = -nologo -machine:$(MACHINE) $(ldebug)
!if $(PROFILE)
lflags = $(lflags) -profile
!endif
!if $(ALIGN98_HACK) && !$(STATIC_BUILD)
# align sections for PE size savings.
lflags = $(lflags) -opt:nowin98
!else if !$(ALIGN98_HACK) && $(STATIC_BUILD)
# align sections for speed in loading by choosing the virtual page size.
lflags = $(lflags) -align:4096
!endif
!if $(LOIMPACT)
lflags = $(lflags) -ws:aggressive
!endif
ITK_LFLAGS = $(lflags) -subsystem:windows -dll
ITK_LLIBS = $(TCLSTUBLIB) $(TKSTUBLIB) $(ITCLSTUBLIB)
!if exist("$(TCLDIR)\win\coffbase.txt")
ITK_DLLBASE = -base:@$(TCLDIR)\win\coffbase.txt,itk
!else
ITK_DLLBASE =
!endif
#---------------------------------------------------------------------
# Compile flags
#---------------------------------------------------------------------
!if $(DEBUG)
!if "$(MACHINE)" == "IA64"
cdebug = -Od -Zi
!else
cdebug = -Z7 -Od -WX
!endif
!else
# This cranks the optimization level up to max.
cdebug = -O2
!endif
# declarations common to all compiler options
cflags = -nologo -c -W3 -YX -D_USE_32BIT_TIME_T -Fp$(TMP_DIR)^\
!if $(PENT_0F_ERRATA)
cflags = $(cflags) -QI0f
!endif
!if $(ITAN_B_ERRATA)
cflags = $(cflags) -QIA64_Bx
!endif
!if $(MSVCRT)
crt = -MD$(DBGX)
!else
crt = -MT$(DBGX)
!endif
!if $(TCLINSTALL)
TCL_INCLUDES = -I"$(TCLDIR)\include"
TK_INCLUDES =
!else
TCL_INCLUDES = -I"$(TCLDIR)\generic" -I"$(TCLDIR)\win"
TK_INCLUDES = -I"$(TKDIR)\generic" -I"$(TKDIR)\xlib"
!endif
ITK_INCLUDES = -I$(WINDIR) -I$(GENERICDIR)
ITCL_INCLUDES = -I"$(ITCLDIR)\generic"
ITK_DEFINES = -DBUILD_itk -DTCL_THREADS=1
ITK_EXE_CFLAGS = $(cdebug) $(cflags) $(crt) $(ITCL_INCLUDES) $(ITK_INCLUDES) \
$(TCL_INCLUDES) $(TK_INCLUDES) $(ITK_DEFINES)
### By convention, static builds do not use Stubs. This is just a practice,
### not a technical limitation.
!if $(STATIC_BUILD)
ITK_CFLAGS = $(ITK_EXE_CFLAGS) -DSTATIC_BUILD $(OPTDEFINES)
!elseif $(TCL_DOES_STUBS)
ITK_CFLAGS = $(ITK_EXE_CFLAGS) -DUSE_TCL_STUBS -DUSE_TK_STUBS -DUSE_ITCL_STUBS $(OPTDEFINES)
!else
ITK_CFLAGS = $(ITK_EXE_CFLAGS) $(OPTDEFINES)
!endif
#---------------------------------------------------------------------
# Project specific targets
#---------------------------------------------------------------------
all : setup $(ITKLIB) $(ITKSTUBLIB)
release : setup $(ITKLIB) $(ITKSTUBLIB)
install : install-binaries install-docs
!if $(STATIC_BUILD)
test :
@echo test target not supported for a static library.
!else
test : setup $(ITKLIB) $(ITKSTUBLIB)
$(TCLSH) ..\tests\all.tcl $(TESTFLAGS) -loadfile <<
set env(TK_LIBRARY) $(TK_LIBRARY:\=/)
set env(ITCL_LIBRARY) [file normalize $(ITCL_LIBRARY:\=/)]
set env(ITK_LIBRARY) [file normalize $(ITK_LIBRARY:\=/)]
load [file normalize $(ITCLLIB:\=/)] Itcl
load [file normalize $(TKLIB:\=/)] Tk
load [file normalize $(ITKLIB:\=/)] Itk
<<
!endif
setup :
@if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR)
@if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR)
$(ITKLIB): $(ITKOBJS)
!if $(STATIC_BUILD)
$(lib32) -nologo -machine:$(MACHINE) -out:$@ @<<
!else
$(link32) $(ITK_LFLAGS) $(ITK_DLLBASE) -out:$@ $(ITK_LLIBS) @<<
!endif
$(ITKOBJS)
<<
!if $(TCL_DOES_STUBS)
$(ITKSTUBLIB) : $(ITKSTUBOBJS)
$(lib32) -nologo -out:$@ $(ITKSTUBOBJS)
!endif
install-binaries:
if not exist "$(_INSTALLDIR)" mkdir "$(_INSTALLDIR)"
if not exist "$(BIN_INSTALL_DIR)" mkdir "$(BIN_INSTALL_DIR)"
if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)"
if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)"
if not exist "$(INCLUDE_INSTALL_DIR)" mkdir "$(INCLUDE_INSTALL_DIR)"
copy $(ITKLIB) "$(SCRIPT_INSTALL_DIR)"
!if $(ITKSTUBLIB) != ""
copy $(ITKSTUBLIB) "$(LIB_INSTALL_DIR)"
!endif
copy $(ROOT)\generic\itk.h "$(INCLUDE_INSTALL_DIR)"
copy $(ROOT)\generic\itkDecls.h "$(INCLUDE_INSTALL_DIR)"
copy $(ROOT)\library\*.* "$(SCRIPT_INSTALL_DIR)"
echo if {[package vsatisfies 8.0 [package provide Tcl]]} {\
> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo ^ ^ ^ ^ set add 80>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo } else {>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo ^ ^ ^ ^ set add {}>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo }>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo if {[info exists ::tcl_platform(debug)] ^&^&\
$$::tcl_platform(debug) ^&^& \>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo ^ ^ ^ ^ ^ ^ ^ ^ [file exists [file join $$dir\
$(PROJECT)$(ITK_VERSION)$${add}g.dll]]}\
{>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo ^ ^ ^ ^ package ifneeded Itk $(ITK_DOTVERSION) [list load\
[file join $$dir $(PROJECT)$(ITK_VERSION)$${add}g.dll]\
Itk]>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo } else {>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo ^ ^ ^ ^ package ifneeded Itk $(ITK_DOTVERSION) [list load\
[file join $$dir $(PROJECT)$(ITK_VERSION)$${add}.dll]\
Itk]>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo }>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
echo unset add>> "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
#---------------------------------------------------------------------
# Regenerate the stubs files.
#---------------------------------------------------------------------
!if !$(TCLINSTALL)
# Only from the sources of Tcl does genStubs.tcl exist.
genstubs:
$(TCLSH) $(TOOLSDIR)\genStubs.tcl $(GENERICDIR) \
$(GENERICDIR)\itk.decls
!else
genstubs:
@echo ERROR: Can't rebuild stubs tables without the Tcl source distribution
!endif
#---------------------------------------------------------------------
# Generate the source dependencies.
#---------------------------------------------------------------------
depend:
!if !exist($(TCLSH))
@echo Build tclsh first!
!else
$(TCLSH) $(TCLTOOLSDIR)\mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \
-passthru:"-DBUILD_itcl $(ITCL_INCLUDES) $(TCL_INCLUDES) $(ITK_INCLUDES) $(TK_INCLUDES)" \
$(GENERICDIR),$$(GENERICDIR) $(WINDIR),$$(WINDIR) @<<
$(ITKOBJS)
<<
!endif
#---------------------------------------------------------------------
# Dependency rules
#---------------------------------------------------------------------
!if exist("$(OUT_DIR)\depend.mk")
!include "$(OUT_DIR)\depend.mk"
!message *** Dependency rules in use.
!else
!message *** Dependency rules are not being used.
!endif
### add a spacer in the output
!message
#---------------------------------------------------------------------
# Special case object file targets
#---------------------------------------------------------------------
# The following object is part of the stub library and should not
# be built as DLL objects but none of the symbols should be exported
$(TMP_DIR)\itkStubLib.obj : $(GENERICDIR)\itkStubLib.c
$(cc32) -DSTATIC_BUILD $(ITK_EXE_CFLAGS) -Zl -Fo$@ $?
#---------------------------------------------------------------------
# Inference rules.
#---------------------------------------------------------------------
{$(WINDIR)}.c{$(TMP_DIR)}.obj ::
$(cc32) $(ITK_CFLAGS) -Fo$(TMP_DIR)\ @<<
$<
<<
{$(GENERICDIR)}.c{$(TMP_DIR)}.obj ::
$(cc32) $(ITK_CFLAGS) -Fo$(TMP_DIR)\ @<<
$<
<<
{$(RCDIR)}.rc{$(TMP_DIR)}.res :
$(rc32) -fo $@ -DDEBUG=$(DEBUG) $(ITK_INCLUDES) $(TCL_INCLUDES) $(ITCL_INCLUDES) $(ITK_DEFINES) $<
#---------------------------------------------------------------------
# Generate the windows help files.
#---------------------------------------------------------------------
HLPBASE = $(PROJECT)$(ITK_VERSION)
HELPFILE = $(OUT_DIR)\$(HLPBASE).hlp
HELPCNT = $(OUT_DIR)\$(HLPBASE).cnt
DOCTMP_DIR = $(OUT_DIR)\$(PROJECT)_docs
HELPRTF = $(DOCTMP_DIR)\$(PROJECT).rtf
MAN2HELP = $(DOCTMP_DIR)\man2help.tcl
MAN2HELP2 = $(DOCTMP_DIR)\man2help2.tcl
INDEX = $(DOCTMP_DIR)\index.tcl
BMP = $(DOCTMP_DIR)\toaster.bmp
BMP_NOPATH = toaster.bmp
MAN2TCL = $(DOCTMP_DIR)\man2tcl.exe
winhelp: docsetup $(HELPFILE)
docsetup:
@if not exist $(DOCTMP_DIR)\nul mkdir $(DOCTMP_DIR)
$(MAN2HELP) $(MAN2HELP2) $(INDEX): $(TCLTOOLSDIR)\$$(@F)
copy $(TCLTOOLSDIR)\$(@F) $(@D)
$(BMP):
copy $(WINDIR)\$(@F) $(@D)
$(HELPFILE): $(HELPRTF) $(BMP)
cd $(DOCTMP_DIR)
start /wait hcrtf.exe -x <<$(PROJECT).hpj
[OPTIONS]
COMPRESS=12 Hall Zeck
LCID=0x409 0x0 0x0 ; English (United States)
TITLE=[Incr Tk] Reference Manual
BMROOT=.
CNT=$(@B).cnt
HLP=$(@B).hlp
[FILES]
$(PROJECT).rtf
[WINDOWS]
main="[Incr Tk] Reference Manual",,27648,(r15263976),(r65280)
[CONFIG]
BrowseButtons()
CreateButton(1, "Web", ExecFile("http://www.tcl.tk"))
CreateButton(2, "SF", ExecFile("http://sf.net/projects/incrtcl"))
CreateButton(3, "Wiki", ExecFile("http://wiki.tcl.tk"))
CreateButton(4, "FAQ", ExecFile("http://www.purl.org/NET/Tcl-FAQ/"))
<<
cd $(MAKEDIR)
copy "$(DOCTMP_DIR)\$(@B).hlp" "$(OUT_DIR)"
copy "$(DOCTMP_DIR)\$(@B).cnt" "$(OUT_DIR)"
$(MAN2TCL): $(TCLTOOLSDIR)\$$(@B).c
$(cc32) -nologo -G4 -ML -O2 -Fo$(@D)\ $(TCLTOOLSDIR)\$(@B).c -link -out:$@
$(HELPRTF): $(MAN2TCL) $(MAN2HELP) $(MAN2HELP2) $(INDEX)
$(TCLSH) $(MAN2HELP) -bitmap $(BMP_NOPATH) $(PROJECT) $(ITK_VERSION) $(DOCDIR:\=/)
install-docs:
!if exist($(HELPFILE))
@xcopy /i /y "$(HELPFILE)" "$(DOC_INSTALL_DIR)\"
@xcopy /i /y "$(HELPCNT)" "$(DOC_INSTALL_DIR)\"
$(TCLSH) <<
puts "Installing $(PROJECT)'s helpfile contents into Tcl's ..."
set f [open {$(DOC_INSTALL_DIR:\=/)/tcl$(TCL_VERSION).cnt} r]
while {![eof $$f]} {
if {[regexp {:Include $(PROJECT)([0-9]{2}).cnt} [gets $$f] dummy ver]} {
if {$$ver == $(ITK_VERSION)} {
puts "Already installed."
exit
} else {
# do something here logical to remove (or replace) it.
puts "$$ver != $(ITK_VERSION), unfinished code path, die, die!"
exit 1
}
}
}
close $$f
set f [open {$(DOC_INSTALL_DIR:\=/)/tcl$(TCL_VERSION).cnt} a]
puts $$f {:Include $(HLPBASE).cnt}
close $$f
<<
start /wait winhlp32 -g $(DOC_INSTALL_DIR)\tcl$(TCL_VERSION).hlp
!endif
#---------------------------------------------------------------------
# Clean up
#---------------------------------------------------------------------
tidy :
-del $(TMP_DIR)\*.pch
-del $(TMP_DIR)\*.obj
-del $(TMP_DIR)\*.res
clean : tidy
-del $(OUT_DIR)\*.exp
-del $(OUT_DIR)\*.lib
-del $(OUT_DIR)\*.dll
hose : clean
-rmdir $(OUT_DIR)
-rmdir $(TMP_DIR)
+133 -597
View File
@@ -1,53 +1,28 @@
/*
* ----------------------------------------------------------------------------
/* ----------------------------------------------------------------------------
* nmakehlp.c --
*
* This is used to fix limitations within nmake and the environment.
*
* Copyright (c) 2002 David Gravereaux.
* Copyright (c) 2006 Pat Thoyts
* Copyright (c) 2002 by David Gravereaux.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ----------------------------------------------------------------------------
*/
#define _CRT_SECURE_NO_DEPRECATE
#include <windows.h>
#ifdef _MSC_VER
#pragma comment (lib, "user32.lib")
#pragma comment (lib, "kernel32.lib")
#endif
#include <stdio.h>
/*
* This library is required for x64 builds with _some_ versions of MSVC
*/
#if defined(_M_IA64) || defined(_M_AMD64)
#if _MSC_VER >= 1400 && _MSC_VER < 1500
#pragma comment(lib, "bufferoverflowU")
#endif
#endif
/* ISO hack for dumb VC++ */
#if defined(_WIN32) && defined(_MSC_VER) && _MSC_VER < 1900
#define snprintf _snprintf
#endif
#include <math.h>
/* protos */
static int CheckForCompilerFeature(const char *option);
static int CheckForLinkerFeature(char **options, int count);
static int IsIn(const char *string, const char *substring);
static int SubstituteFile(const char *substs, const char *filename);
static int QualifyPath(const char *path);
static int LocateDependency(const char *keyfile);
static const char *GetVersionFromFile(const char *filename, const char *match, int numdots);
static DWORD WINAPI ReadFromPipe(LPVOID args);
int CheckForCompilerFeature (const char *option);
int CheckForLinkerFeature (const char *option);
int IsIn (const char *string, const char *substring);
int GrepForDefine (const char *file, const char *string);
DWORD WINAPI ReadFromPipe (LPVOID args);
/* globals */
#define CHUNK 25
#define STATICBUFFERSIZE 1000
typedef struct {
@@ -55,33 +30,23 @@ typedef struct {
char buffer[STATICBUFFERSIZE];
} pipeinfo;
pipeinfo Out = {INVALID_HANDLE_VALUE, ""};
pipeinfo Err = {INVALID_HANDLE_VALUE, ""};
/*
* exitcodes: 0 == no, 1 == yes, 2 == error
*/
pipeinfo Out = {INVALID_HANDLE_VALUE, '\0'};
pipeinfo Err = {INVALID_HANDLE_VALUE, '\0'};
/* exitcodes: 0 == no, 1 == yes, 2 == error */
int
main(
int argc,
char *argv[])
main (int argc, char *argv[])
{
char msg[300];
DWORD dwWritten;
int chars;
const char *s;
/*
* Make sure children (cl.exe and link.exe) are kept quiet.
*/
/* make sure children (cl.exe and link.exe) are kept quiet. */
SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOOPENFILEERRORBOX);
/*
* Make sure the compiler and linker aren't effected by the outside world.
*/
/* Make sure the compiler and linker aren't effected by the outside world. */
SetEnvironmentVariable("CL", "");
SetEnvironmentVariable("LINK", "");
@@ -89,111 +54,56 @@ main(
switch (*(argv[1]+1)) {
case 'c':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -c <compiler option>\n"
chars = wsprintf(msg, "usage: %s -c <compiler option>\n"
"Tests for whether cl.exe supports an option\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
return 2;
}
return CheckForCompilerFeature(argv[2]);
case 'l':
if (argc < 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -l <linker option> ?<mandatory option> ...?\n"
if (argc != 3) {
chars = wsprintf(msg, "usage: %s -l <linker option>\n"
"Tests for whether link.exe supports an option\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
return 2;
}
return CheckForLinkerFeature(&argv[2], argc-2);
return CheckForLinkerFeature(argv[2]);
case 'f':
if (argc == 2) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -f <string> <substring>\n"
"Find a substring within another\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
chars = wsprintf(msg, "usage: %s -f <string> <substring>\n"
"Find a substring within another\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
return 2;
} else if (argc == 3) {
/*
* If the string is blank, there is no match.
*/
/* if the string is blank, there is no match */
return 0;
} else {
return IsIn(argv[2], argv[3]);
}
case 's':
case 'g':
if (argc == 2) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -s <substitutions file> <file>\n"
"Perform a set of string map type substutitions on a file\n"
"exitcodes: 0\n",
argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
chars = wsprintf(msg, "usage: %s -g <file> <string>\n"
"grep for a #define\n"
"exitcodes: integer of the found string (no decimals)\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
return 2;
}
return SubstituteFile(argv[2], argv[3]);
case 'V':
if (argc != 4) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -V filename matchstring\n"
"Extract a version from a file:\n"
"eg: pkgIndex.tcl \"package ifneeded http\"",
argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 0;
}
s = GetVersionFromFile(argv[2], argv[3], *(argv[1]+2) - '0');
if (s && *s) {
printf("%s\n", s);
return 0;
} else
return 1; /* Version not found. Return non-0 exit code */
case 'Q':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -Q path\n"
"Emit the fully qualified path\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return QualifyPath(argv[2]);
case 'L':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -L keypath\n"
"Emit the fully qualified path of directory containing keypath\n"
"exitcodes: 0 == success, 1 == not found, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return LocateDependency(argv[2]);
return GrepForDefine(argv[2], argv[3]);
}
}
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -c|-f|-l|-Q|-s|-V ...\n"
chars = wsprintf(msg, "usage: %s -c|-l|-f ...\n"
"This is a little helper app to equalize shell differences between WinNT and\n"
"Win9x and get nmake.exe to accomplish its job.\n",
argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
return 2;
}
static int
CheckForCompilerFeature(
const char *option)
int
CheckForCompilerFeature (const char *option)
{
STARTUPINFO si;
PROCESS_INFORMATION pi;
@@ -206,55 +116,35 @@ CheckForCompilerFeature(
hProcess = GetCurrentProcess();
memset(&pi, 0, sizeof(PROCESS_INFORMATION));
memset(&si, 0, sizeof(STARTUPINFO));
ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
ZeroMemory(&si, sizeof(STARTUPINFO));
si.cb = sizeof(STARTUPINFO);
si.dwFlags = STARTF_USESTDHANDLES;
si.hStdInput = INVALID_HANDLE_VALUE;
memset(&sa, 0, sizeof(SECURITY_ATTRIBUTES));
ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
sa.lpSecurityDescriptor = NULL;
sa.bInheritHandle = FALSE;
/*
* Create a non-inheritable pipe.
*/
/* create a non-inheritible pipe. */
CreatePipe(&Out.pipe, &h, &sa, 0);
/*
* Dupe the write side, make it inheritable, and close the original.
*/
DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Same as above, but for the error side.
*/
/* dupe the write side, make it inheritible, and close the original. */
DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput,
0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/* Same as above, but for the error side. */
CreatePipe(&Err.pipe, &h, &sa, 0);
DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
DuplicateHandle(hProcess, h, hProcess, &si.hStdError,
0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Base command line.
*/
lstrcpy(cmdline, "cl.exe -nologo -c -TC -Zs -X -Fp.\\_junk.pch ");
/*
* Append our option for testing
*/
lstrcat(cmdline, option);
/*
* Filename to compile, which exists, but is nothing and empty.
*/
lstrcat(cmdline, " .\\nul");
/* base command line */
strcpy(cmdline, "cl.exe -nologo -c -TC -Zs -X ");
/* append our option for testing */
strcat(cmdline, option);
/* filename to compile, which exists, but is nothing and empty. */
strcat(cmdline, " .\\nul");
ok = CreateProcess(
NULL, /* Module name. */
@@ -270,65 +160,41 @@ CheckForCompilerFeature(
if (!ok) {
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
int chars = wsprintf(msg, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS |
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID) &msg[chars],
(300-chars), 0);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, strlen(msg), &err, NULL);
return 2;
}
/*
* Close our references to the write handles that have now been inherited.
*/
/* close our references to the write handles that have now been inherited. */
CloseHandle(si.hStdOutput);
CloseHandle(si.hStdError);
WaitForInputIdle(pi.hProcess, 5000);
CloseHandle(pi.hThread);
/*
* Start the pipe reader threads.
*/
/* start the pipe reader threads. */
pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID);
pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID);
/*
* Block waiting for the process to end.
*/
/* block waiting for the process to end. */
WaitForSingleObject(pi.hProcess, INFINITE);
CloseHandle(pi.hProcess);
/*
* Wait for our pipe to get done reading, should it be a little slow.
*/
/* wait for our pipe to get done reading, should it be a little slow. */
WaitForMultipleObjects(2, pipeThreads, TRUE, 500);
CloseHandle(pipeThreads[0]);
CloseHandle(pipeThreads[1]);
/*
* Look for the commandline warning code in both streams.
* - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002.
*/
return !(strstr(Out.buffer, "D4002") != NULL
|| strstr(Err.buffer, "D4002") != NULL
|| strstr(Out.buffer, "D9002") != NULL
|| strstr(Err.buffer, "D9002") != NULL
|| strstr(Out.buffer, "D2021") != NULL
|| strstr(Err.buffer, "D2021") != NULL);
/* look for the commandline warning code in both streams. */
return !(strstr(Out.buffer, "D4002") != NULL || strstr(Err.buffer, "D4002") != NULL);
}
static int
CheckForLinkerFeature(
char **options,
int count)
int
CheckForLinkerFeature (const char *option)
{
STARTUPINFO si;
PROCESS_INFORMATION pi;
@@ -337,58 +203,37 @@ CheckForLinkerFeature(
char msg[300];
BOOL ok;
HANDLE hProcess, h, pipeThreads[2];
int i;
char cmdline[255];
char cmdline[100];
hProcess = GetCurrentProcess();
memset(&pi, 0, sizeof(PROCESS_INFORMATION));
memset(&si, 0, sizeof(STARTUPINFO));
ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
ZeroMemory(&si, sizeof(STARTUPINFO));
si.cb = sizeof(STARTUPINFO);
si.dwFlags = STARTF_USESTDHANDLES;
si.hStdInput = INVALID_HANDLE_VALUE;
memset(&sa, 0, sizeof(SECURITY_ATTRIBUTES));
ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
sa.lpSecurityDescriptor = NULL;
sa.bInheritHandle = TRUE;
/*
* Create a non-inheritible pipe.
*/
/* create a non-inheritible pipe. */
CreatePipe(&Out.pipe, &h, &sa, 0);
/*
* Dupe the write side, make it inheritable, and close the original.
*/
DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Same as above, but for the error side.
*/
/* dupe the write side, make it inheritible, and close the original. */
DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput,
0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/* Same as above, but for the error side. */
CreatePipe(&Err.pipe, &h, &sa, 0);
DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
DuplicateHandle(hProcess, h, hProcess, &si.hStdError,
0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Base command line.
*/
lstrcpy(cmdline, "link.exe -nologo ");
/*
* Append our option for testing.
*/
for (i = 0; i < count; i++) {
lstrcat(cmdline, " \"");
lstrcat(cmdline, options[i]);
lstrcat(cmdline, "\"");
}
/* base command line */
strcpy(cmdline, "link.exe -nologo ");
/* append our option for testing */
strcat(cmdline, option);
ok = CreateProcess(
NULL, /* Module name. */
@@ -404,73 +249,51 @@ CheckForLinkerFeature(
if (!ok) {
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
int chars = wsprintf(msg, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS |
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID) &msg[chars],
(300-chars), 0);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, strlen(msg), &err, NULL);
return 2;
}
/*
* Close our references to the write handles that have now been inherited.
*/
/* close our references to the write handles that have now been inherited. */
CloseHandle(si.hStdOutput);
CloseHandle(si.hStdError);
WaitForInputIdle(pi.hProcess, 5000);
CloseHandle(pi.hThread);
/*
* Start the pipe reader threads.
*/
/* start the pipe reader threads. */
pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID);
pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID);
/*
* Block waiting for the process to end.
*/
/* block waiting for the process to end. */
WaitForSingleObject(pi.hProcess, INFINITE);
CloseHandle(pi.hProcess);
/*
* Wait for our pipe to get done reading, should it be a little slow.
*/
/* wait for our pipe to get done reading, should it be a little slow. */
WaitForMultipleObjects(2, pipeThreads, TRUE, 500);
CloseHandle(pipeThreads[0]);
CloseHandle(pipeThreads[1]);
/*
* Look for the commandline warning code in the stderr stream.
*/
return !(strstr(Out.buffer, "LNK1117") != NULL ||
strstr(Err.buffer, "LNK1117") != NULL ||
strstr(Out.buffer, "LNK4044") != NULL ||
strstr(Err.buffer, "LNK4044") != NULL ||
strstr(Out.buffer, "LNK4224") != NULL ||
strstr(Err.buffer, "LNK4224") != NULL);
/* look for the commandline warning code in the stderr stream. */
return !(strstr(Out.buffer, "LNK1117") != NULL || strstr(Err.buffer, "LNK1117") != NULL);
}
static DWORD WINAPI
ReadFromPipe(
LPVOID args)
DWORD WINAPI
ReadFromPipe (LPVOID args)
{
pipeinfo *pi = (pipeinfo *) args;
char *lastBuf = pi->buffer;
DWORD dwRead;
BOOL ok;
again:
again:
if (lastBuf - pi->buffer + CHUNK > STATICBUFFERSIZE) {
CloseHandle(pi->pipe);
return (DWORD)-1;
return -1;
}
ok = ReadFile(pi->pipe, lastBuf, CHUNK, &dwRead, 0L);
if (!ok || dwRead == 0) {
@@ -482,339 +305,52 @@ ReadFromPipe(
return 0; /* makes the compiler happy */
}
static int
IsIn(
const char *string,
const char *substring)
int
IsIn (const char *string, const char *substring)
{
return (strstr(string, substring) != NULL);
}
/*
* GetVersionFromFile --
* Looks for a match string in a file and then returns the version
* following the match where a version is anything acceptable to
* package provide or package ifneeded.
*/
static const char *
GetVersionFromFile(
const char *filename,
const char *match,
int numdots)
{
static char szBuffer[100];
char *szResult = NULL;
FILE *fp = fopen(filename, "rt");
if (fp != NULL) {
/*
* Read data until we see our match string.
*/
while (fgets(szBuffer, sizeof(szBuffer), fp) != NULL) {
LPSTR p, q;
p = strstr(szBuffer, match);
if (p != NULL) {
/*
* Skip to first digit after the match.
*/
p += strlen(match);
while (*p && !isdigit((unsigned char)*p)) {
++p;
}
/*
* Find ending whitespace.
*/
q = p;
while (*q && (strchr("0123456789.ab", *q)) && (((!strchr(".ab", *q)
&& !strchr("ab", q[-1])) || --numdots))) {
++q;
}
*q = 0;
szResult = p;
break;
}
}
fclose(fp);
}
return szResult;
}
/*
* List helpers for the SubstituteFile function
*/
typedef struct list_item_t {
struct list_item_t *nextPtr;
char * key;
char * value;
} list_item_t;
/* insert a list item into the list (list may be null) */
static list_item_t *
list_insert(list_item_t **listPtrPtr, const char *key, const char *value)
{
list_item_t *itemPtr = (list_item_t *)malloc(sizeof(list_item_t));
if (itemPtr) {
itemPtr->key = strdup(key);
itemPtr->value = strdup(value);
itemPtr->nextPtr = NULL;
while(*listPtrPtr) {
listPtrPtr = &(*listPtrPtr)->nextPtr;
}
*listPtrPtr = itemPtr;
}
return itemPtr;
}
static void
list_free(list_item_t **listPtrPtr)
{
list_item_t *tmpPtr, *listPtr = *listPtrPtr;
while (listPtr) {
tmpPtr = listPtr;
listPtr = listPtr->nextPtr;
free(tmpPtr->key);
free(tmpPtr->value);
free(tmpPtr);
}
}
/*
* SubstituteFile --
* As windows doesn't provide anything useful like sed and it's unreliable
* to use the tclsh you are building against (consider x-platform builds -
* e.g. compiling AMD64 target from IX86) we provide a simple substitution
* option here to handle autoconf style substitutions.
* The substitution file is whitespace and line delimited. The file should
* consist of lines matching the regular expression:
* \s*\S+\s+\S*$
* Find a specified #define by name.
*
* Usage is something like:
* nmakehlp -S << $** > $@
* @PACKAGE_NAME@ $(PACKAGE_NAME)
* @PACKAGE_VERSION@ $(PACKAGE_VERSION)
* <<
* If the line is '#define TCL_VERSION "8.5"', it returns
* 85 as the result.
*/
static int
SubstituteFile(
const char *substitutions,
const char *filename)
int
GrepForDefine (const char *file, const char *string)
{
static char szBuffer[1024], szCopy[1024];
list_item_t *substPtr = NULL;
FILE *fp, *sp;
FILE *f;
char s1[51], s2[51], s3[51];
int r = 0;
double d1;
fp = fopen(filename, "rt");
if (fp != NULL) {
/*
* Build a list of substitutions from the first filename
*/
sp = fopen(substitutions, "rt");
if (sp != NULL) {
while (fgets(szBuffer, sizeof(szBuffer), sp) != NULL) {
unsigned char *ks, *ke, *vs, *ve;
ks = (unsigned char*)szBuffer;
while (ks && *ks && isspace(*ks)) ++ks;
ke = ks;
while (ke && *ke && !isspace(*ke)) ++ke;
vs = ke;
while (vs && *vs && isspace(*vs)) ++vs;
ve = vs;
while (ve && *ve && !(*ve == '\r' || *ve == '\n')) ++ve;
*ke = 0, *ve = 0;
list_insert(&substPtr, (char*)ks, (char*)vs);
}
fclose(sp);
}
/* debug: dump the list */
#ifndef NDEBUG
{
int n = 0;
list_item_t *p = NULL;
for (p = substPtr; p != NULL; p = p->nextPtr, ++n) {
fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value);
}
}
#endif
/*
* Run the substitutions over each line of the input
*/
while (fgets(szBuffer, sizeof(szBuffer), fp) != NULL) {
list_item_t *p = NULL;
for (p = substPtr; p != NULL; p = p->nextPtr) {
char *m = strstr(szBuffer, p->key);
if (m) {
char *cp, *op, *sp;
cp = szCopy;
op = szBuffer;
while (op != m) *cp++ = *op++;
sp = p->value;
while (sp && *sp) *cp++ = *sp++;
op += strlen(p->key);
while (*op) *cp++ = *op++;
*cp = 0;
memcpy(szBuffer, szCopy, sizeof(szCopy));
}
}
printf("%s", szBuffer);
}
list_free(&substPtr);
}
fclose(fp);
return 0;
}
BOOL FileExists(LPCTSTR szPath)
{
#ifndef INVALID_FILE_ATTRIBUTES
#define INVALID_FILE_ATTRIBUTES ((DWORD)-1)
#endif
DWORD pathAttr = GetFileAttributes(szPath);
return (pathAttr != INVALID_FILE_ATTRIBUTES &&
!(pathAttr & FILE_ATTRIBUTE_DIRECTORY));
}
/*
* QualifyPath --
*
* This composes the current working directory with a provided path
* and returns the fully qualified and normalized path.
* Mostly needed to setup paths for testing.
*/
static int
QualifyPath(
const char *szPath)
{
char szCwd[MAX_PATH + 1];
GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL);
printf("%s\n", szCwd);
return 0;
}
/*
* Implements LocateDependency for a single directory. See that command
* for an explanation.
* Returns 0 if found after printing the directory.
* Returns 1 if not found but no errors.
* Returns 2 on any kind of error
* Basically, these are used as exit codes for the process.
*/
static int LocateDependencyHelper(const char *dir, const char *keypath)
{
HANDLE hSearch;
char path[MAX_PATH+1];
size_t dirlen;
int keylen, ret;
WIN32_FIND_DATA finfo;
if (dir == NULL || keypath == NULL) {
return 2; /* Have no real error reporting mechanism into nmake */
}
dirlen = strlen(dir);
if (dirlen > sizeof(path) - 3) {
return 2;
}
strncpy(path, dir, dirlen);
strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */
keylen = strlen(keypath);
#if 0 /* This function is not available in Visual C++ 6 */
/*
* Use numerics 0 -> FindExInfoStandard,
* 1 -> FindExSearchLimitToDirectories,
* as these are not defined in Visual C++ 6
*/
hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0);
#else
hSearch = FindFirstFile(path, &finfo);
#endif
if (hSearch == INVALID_HANDLE_VALUE) {
return 1; /* Not found */
f = fopen(file, "rt");
if (f == NULL) {
return 0;
}
/* Loop through all subdirs checking if the keypath is under there */
ret = 1; /* Assume not found */
do {
int sublen;
/*
* We need to check it is a directory despite the
* FindExSearchLimitToDirectories in the above call. See SDK docs
*/
if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) {
continue;
r = fscanf(f, "%50s", s1);
if (r == 1 && !strcmp(s1, "#define")) {
/* get next two words */
r = fscanf(f, "%50s %50s", s2, s3);
if (r != 2) continue;
/* is the first word what we're looking for? */
if (!strcmp(s2, string)) {
fclose(f);
/* add 1 past first double quote char. "8.5" */
d1 = atof(s3 + 1); /* 8.5 */
while (floor(d1) != d1) {
d1 *= 10.0;
}
return ((int) d1); /* 85 */
}
}
sublen = strlen(finfo.cFileName);
if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) {
continue; /* Path does not fit, assume not matched */
}
strncpy(path+dirlen+1, finfo.cFileName, sublen);
path[dirlen+1+sublen] = '\\';
strncpy(path+dirlen+1+sublen+1, keypath, keylen+1);
if (FileExists(path)) {
/* Found a match, print to stdout */
path[dirlen+1+sublen] = '\0';
QualifyPath(path);
ret = 0;
break;
}
} while (FindNextFile(hSearch, &finfo));
FindClose(hSearch);
return ret;
} while (!feof(f));
fclose(f);
return 0;
}
/*
* LocateDependency --
*
* Locates a dependency for a package.
* keypath - a relative path within the package directory
* that is used to confirm it is the correct directory.
* The search path for the package directory is currently only
* the parent and grandparent of the current working directory.
* If found, the command prints
* name_DIRPATH=<full path of located directory>
* and returns 0. If not found, does not print anything and returns 1.
*/
static int LocateDependency(const char *keypath)
{
size_t i;
int ret;
static const char *paths[] = {"..", "..\\..", "..\\..\\.."};
for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) {
ret = LocateDependencyHelper(paths[i], keypath);
if (ret == 0) {
return ret;
}
}
return ret;
}
/*
* Local variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* indent-tabs-mode: t
* tab-width: 8
* End:
*/
-141
View File
@@ -1,141 +0,0 @@
# This file should only be included in makefiles for Tcl extensions,
# NOT in the makefile for Tcl itself.
!ifndef _RULES_EXT_VC
# We need to run from the directory the parent makefile is located in.
# nmake does not tell us what makefile was used to invoke it so parent
# makefile has to set the MAKEFILEVC macro or we just make a guess and
# warn if we think that is not the case.
!if "$(MAKEFILEVC)" == ""
!if exist("$(PROJECT).vc")
MAKEFILEVC = $(PROJECT).vc
!elseif exist("makefile.vc")
MAKEFILEVC = makefile.vc
!endif
!endif # "$(MAKEFILEVC)" == ""
!if !exist("$(MAKEFILEVC)")
MSG = ^
You must run nmake from the directory containing the project makefile.^
If you are doing that and getting this message, set the MAKEFILEVC^
macro to the name of the project makefile.
!message WARNING: $(MSG)
!endif
!if "$(PROJECT)" == "tcl"
!error The rules-ext.vc file is not intended for Tcl itself.
!endif
# We extract version numbers using the nmakehlp program. For now use
# the local copy of nmakehlp. Once we locate Tcl, we will use that
# one if it is newer.
!if [$(CC) -nologo -DNDEBUG "nmakehlp.c" -link -subsystem:console > nul]
!endif
# We need a nmakehlp that will run on the host machine as part of the build.
# if TCLSH_NATIVE is set for cross compilation, we'll try to find an associated
# nmakehlp.exe that runs on the build architecture.
!ifdef TCLSH_NATIVE
!ifndef NMAKEHLP_NATIVE
!if [$(TCLSH_NATIVE) $(TCLDIR)\win\find_nmakehlp.tcl $(TCLSH_NATIVE) > find_nmakehlp.out]
!error TCLSH_NATIVE is set, but unable to find associated nmakehlp.exe nearby.
!else
!include find_nmakehlp.out
!endif
!endif
!endif
!ifndef NMAKEHLP_NATIVE
NMAKEHLP_NATIVE=nmakehlp
!endif
# First locate the Tcl directory that we are working with.
!if "$(TCLDIR)" != ""
_RULESDIR = $(TCLDIR:/=\)
!else
# If an installation path is specified, that is also the Tcl directory.
# Also Tk never builds against an installed Tcl, it needs Tcl sources
!if defined(INSTALLDIR) && "$(PROJECT)" != "tk"
_RULESDIR=$(INSTALLDIR:/=\)
!else
# Locate Tcl sources
!if [echo _RULESDIR = \> nmakehlp.out] \
|| [$(NMAKEHLP_NATIVE) -L generic\tcl.h >> nmakehlp.out]
_RULESDIR = ..\..\tcl
!else
!include nmakehlp.out
!endif
!endif # defined(INSTALLDIR)....
!endif # ifndef TCLDIR
# Now look for the targets.vc file under the Tcl root. Note we check this
# file and not rules.vc because the latter also exists on older systems.
!if exist("$(_RULESDIR)\lib\nmake\targets.vc") # Building against installed Tcl
_RULESDIR = $(_RULESDIR)\lib\nmake
!elseif exist("$(_RULESDIR)\win\targets.vc") # Building against Tcl sources
_RULESDIR = $(_RULESDIR)\win
!else
# If we have not located Tcl's targets file, most likely we are compiling
# against an older version of Tcl and so must use our own support files.
_RULESDIR = .
!endif
!if "$(_RULESDIR)" != "."
# Potentially using Tcl's support files. If this extension has its own
# nmake support files, need to compare the versions and pick newer.
!if exist("rules.vc") # The extension has its own copy
!if [echo TCL_RULES_MAJOR = \> versions.vc] \
&& [$(NMAKEHLP_NATIVE) -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MAJOR >> versions.vc]
!endif
!if [echo TCL_RULES_MINOR = \>> versions.vc] \
&& [$(NMAKEHLP_NATIVE) -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MINOR >> versions.vc]
!endif
!if [echo OUR_RULES_MAJOR = \>> versions.vc] \
&& [$(NMAKEHLP_NATIVE) -V "rules.vc" RULES_VERSION_MAJOR >> versions.vc]
!endif
!if [echo OUR_RULES_MINOR = \>> versions.vc] \
&& [$(NMAKEHLP_NATIVE) -V "rules.vc" RULES_VERSION_MINOR >> versions.vc]
!endif
!include versions.vc
# We have a newer version of the support files, use them
!if ($(TCL_RULES_MAJOR) != $(OUR_RULES_MAJOR)) || ($(TCL_RULES_MINOR) < $(OUR_RULES_MINOR))
_RULESDIR = .
!endif
!endif # if exist("rules.vc")
!endif # if $(_RULESDIR) != "."
# Let rules.vc know what copy of nmakehlp.c to use.
NMAKEHLPC = $(_RULESDIR)\nmakehlp.c
# Get rid of our internal defines before calling rules.vc
!undef TCL_RULES_MAJOR
!undef TCL_RULES_MINOR
!undef OUR_RULES_MAJOR
!undef OUR_RULES_MINOR
!if exist("$(_RULESDIR)\rules.vc")
!include "$(_RULESDIR)\rules.vc"
!ifndef VERBOSE
# Backward compatibility
VERBOSE=1
!endif
!if $(VERBOSE)
!message *** Using $(_RULESDIR)\rules.vc
!endif
!else
!error *** Could not locate rules.vc in $(_RULESDIR)
!endif
!endif # _RULES_EXT_VC
+490 -1960
View File
File diff suppressed because it is too large Load Diff
-1
View File
@@ -1 +0,0 @@
svn-r
Binary file not shown.