From f430950e7418bfa6d6bdf5bd495680cdcc209b57 Mon Sep 17 00:00:00 2001 From: "Eric L. Hernes" Date: Mon, 1 Dec 1997 19:49:08 +0000 Subject: [PATCH] (erich) lots of changes to gimptcl 1) better integration to automake/autoconf/configure... The rules are: * by default look at -ltcl and -ltk * you can specify --with-tcl and --with-tk to use different versions, e.g. you can use --with-tcl=tcl80 and --with-tk=tk80 to use them. * if your system has a dl library, it uses it, otherwise not. This may cause problems if you have a -ldl, but your tcl library doesn't need it :( There'll probably be a --with-tcldl=no someday 2) make a few arrays bigger, particularily in the PDB interface. 3) type most of the numeric returns from the PDB, e.g. a proc that returns a layer now returns `layer-#' instead of just `#'. This may cause problems for scripts that get an array and then iterate over it. (as in gimp-list-images or similar) 4) consolio is now based on Jeff Hobbs `tkcon', much better than the older one. And the license is much less restrictive. 5) The switch to tkcon unveiled several errors with the internal packages, so I fixed most of them. Now sub-interpreters can use the same PDB interface as the ``parent'' interp. I should be able to make something akin to the script-fu mechanism out of this... (someday) --- configure.in | 11 +- plug-ins/Makefile.am | 1 + plug-ins/gimptcl/Makefile | 88 +- plug-ins/gimptcl/Makefile.am | 2 +- plug-ins/gimptcl/frags/sphere.tcl | 20 +- plug-ins/gimptcl/gtcl.h | 3 + plug-ins/gimptcl/gtclConst.c | 1 + plug-ins/gimptcl/gtclMain.c | 44 +- plug-ins/gimptcl/gtclPDB.c | 77 +- plug-ins/gimptcl/gtcl_misc.c | 36 +- plug-ins/gimptcl/scripts/Makefile | 53 +- plug-ins/gimptcl/scripts/consolio | 3864 +++++++++++++++-- plug-ins/gimptcl/scripts/consolio.tcl | 3862 ++++++++++++++-- .../gimptcl/scripts/license.terms-consolio | 32 - plug-ins/gimptcl/scripts/pdb_help | 6 +- plug-ins/gimptcl/scripts/pdb_help.tcl | 4 + 16 files changed, 7182 insertions(+), 922 deletions(-) delete mode 100644 plug-ins/gimptcl/scripts/license.terms-consolio diff --git a/configure.in b/configure.in index 5e42188b5a..d77d65c3d1 100644 --- a/configure.in +++ b/configure.in @@ -150,9 +150,14 @@ dnl Test for libmpeg dnl Test for libtcl if test -z "$LIBTCL_LIB"; then - AC_CHECK_LIB(tcl, Tcl_Init, - GIMPTCL='gimptcl'; LIBTCL_LIB='-ltcl -ltk', - AC_MSG_WARN(*** gimptcl plug-in will not be built ***), -lm -ldl) + AC_CHECK_LIB(dl, dlopen, DL_LIBRARY=-ldl) + AC_ARG_WITH(tcl, --with-{tcl/tk} use this tcl/tk library, + AC_CHECK_LIB($with_tcl, Tcl_Init, + GIMPTCL='gimptcl'; LIBTCL_LIB="-l$with_tcl -l$with_tk $DL_LIBRARY", + AC_MSG_WARN(*** gimptcl plug-in will not be built ***), -lm), + AC_CHECK_LIB(tcl, Tcl_StaticPackage, + GIMPTCL='gimptcl'; LIBTCL_LIB="-ltcl -ltk $DL_LIBRARY", + AC_MSG_WARN(*** gimptcl plug-in will not be built ***), -lm)) fi dnl Test for libxdelta diff --git a/plug-ins/Makefile.am b/plug-ins/Makefile.am index a04eb40be7..29d3b83d7c 100644 --- a/plug-ins/Makefile.am +++ b/plug-ins/Makefile.am @@ -15,6 +15,7 @@ SUBDIRS = \ dgimp \ fuse \ gflare \ + @GIMPTCL@ \ refract \ script-fu \ struc \ diff --git a/plug-ins/gimptcl/Makefile b/plug-ins/gimptcl/Makefile index 40be3f896a..0ccf31132a 100644 --- a/plug-ins/gimptcl/Makefile +++ b/plug-ins/gimptcl/Makefile @@ -1,22 +1,16 @@ # Generated automatically from Makefile.in by configure. -# Makefile.in generated automatically by automake 1.2c from Makefile.am +# Makefile.in generated automatically by automake 1.2 from Makefile.am # Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy and/or distribute it, -# with or without modifications, as long as this notice is preserved. - -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY, to the extent permitted by law; without -# even the implied warranty of MERCHANTABILITY or FITNESS FOR A -# PARTICULAR PURPOSE. +# gives unlimited permission to copy, distribute and modify it. SHELL = /bin/sh srcdir = . top_srcdir = ../.. -prefix = /usr +prefix = /usr/X11R6/ exec_prefix = ${prefix} bindir = ${exec_prefix}/bin @@ -55,18 +49,18 @@ POST_INSTALL = true NORMAL_UNINSTALL = true PRE_UNINSTALL = true POST_UNINSTALL = true -host_alias = i486-pc-linux-gnu -host_triplet = i486-pc-linux-gnu +host_alias = i386-unknown-freebsd3.0 +host_triplet = i386-unknown-freebsd3.0 CC = gcc CPP = gcc -E -EMACS = /usr/bin/emacs +EMACS = GIMPTCL = gimptcl JPEG = jpeg -LD = /usr/lib/gcc-lib/i386-linux/egcs-2.90.18/ld +LD = /usr/bin/ld LIBJPEG_LIB = -ljpeg -LIBMPEG_LIB = +LIBMPEG_LIB = -lmpeg LIBPNG_LIB = -lpng -lz -LIBTCL_LIB = -ltcl -ltk +LIBTCL_LIB = -ltcl80 -ltk80 LIBTIFF_LIB = -ltiff LIBTOOL = $(SHELL) $(top_builddir)/libtool LIBXDELTA_LIB = @@ -74,8 +68,8 @@ LIBXPM_LIB = -lXpm LN_S = ln -s MAINT = #M# MAKEINFO = makeinfo -MPEG = -NM = /usr/bin/nm -B +MPEG = mpeg +NM = /usr/bin/nm -p PACKAGE = gimp PNG = png RANLIB = ranlib @@ -111,11 +105,11 @@ INCLUDES= \ -I$(top_srcdir) LDADD = \ - $(top_builddir)/libgimp/libgimp.la \ - -ltcl -ltk \ + -lgimp \ + -ltcl80 -ltk80 \ $(X_LIBS) \ -lc \ - -lm -ldl + -lm mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs CONFIG_HEADER = ../../config.h CONFIG_CLEAN_FILES = @@ -123,16 +117,16 @@ PROGRAMS = $(libexec_PROGRAMS) DEFS = -DHAVE_CONFIG_H -I. -I$(srcdir) -I../.. -CPPFLAGS = +CPPFLAGS = -I/usr/local/include -I/usr/local/include/tcl8.0 -I/usr/local/include/tk8.0 LDFLAGS = -L/usr/X11R6/lib -lgtk -lgdk -lglib -lXext -lX11 -lm -LIBS = +LIBS = -L/usr/local/lib X_CFLAGS = -I/usr/X11R6/include X_LIBS = -L/usr/X11R6/lib -lgtk -lgdk -lglib -lXext -lX11 -lm X_EXTRA_LIBS = X_PRE_LIBS = -lSM -lICE gimptcl_OBJECTS = gtclMain.o gtcl_misc.o gtclConst.o gtclPDB.o gimptcl_LDADD = $(LDADD) -gimptcl_DEPENDENCIES = $(top_builddir)/libgimp/libgimp.la +gimptcl_DEPENDENCIES = gimptcl_LDFLAGS = CFLAGS = -I/usr/X11R6/include -g -O2 -Wall COMPILE = $(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) @@ -155,15 +149,15 @@ default: all $(srcdir)/Makefile.in: #M# Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4) cd $(top_srcdir) && $(AUTOMAKE) --gnu plug-ins/gimptcl/Makefile -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - cd $(top_builddir) \ - && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status +#Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status +# cd $(top_builddir) \ +# && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status mostlyclean-libexecPROGRAMS: clean-libexecPROGRAMS: - -test -z "$(libexec_PROGRAMS)" || rm -f $(libexec_PROGRAMS) + test -z "$(libexec_PROGRAMS)" || rm -f $(libexec_PROGRAMS) distclean-libexecPROGRAMS: @@ -189,12 +183,12 @@ uninstall-libexecPROGRAMS: $(COMPILE) -c $< mostlyclean-compile: - -rm -f *.o core + rm -f *.o core clean-compile: distclean-compile: - -rm -f *.tab.c + rm -f *.tab.c maintainer-clean-compile: @@ -202,10 +196,10 @@ maintainer-clean-compile: $(LIBTOOL) --mode=compile $(COMPILE) -c $< mostlyclean-libtool: - -rm -f *.lo + rm -f *.lo clean-libtool: - -rm -rf .libs + rm -rf .libs distclean-libtool: @@ -238,7 +232,7 @@ check-recursive installcheck-recursive info-recursive dvi-recursive: mostlyclean-recursive clean-recursive distclean-recursive \ maintainer-clean-recursive: @set fnord $(MAKEFLAGS); amf=$$2; \ - rev=''; for subdir in $(SUBDIRS); do rev="$$subdir $$rev"; done; \ + rev=''; for subdir in $(SUBDIRS); do rev="$$rev $$subdir"; done; \ for subdir in $$rev; do \ target=`echo $@ | sed s/-recursive//`; \ echo "Making $$target in $$subdir"; \ @@ -269,7 +263,7 @@ mostlyclean-tags: clean-tags: distclean-tags: - -rm -f TAGS ID + rm -f TAGS ID maintainer-clean-tags: @@ -284,11 +278,11 @@ distdir: $(DISTFILES) || ln $$d/$$file $(distdir)/$$file 2> /dev/null \ || cp -p $$d/$$file $(distdir)/$$file; \ done - for subdir in $(SUBDIRS); do \ - test -d $(distdir)/$$subdir \ - || mkdir $(distdir)/$$subdir \ - || exit 1; \ - chmod 777 $(distdir)/$$subdir; \ + for subdir in $(SUBDIRS); do \ + test -d $(distdir)/$$subdir \ + || mkdir $(distdir)/$$subdir \ + || exit 1; \ + chmod 777 $(distdir)/$$subdir; \ (cd $$subdir && $(MAKE) top_distdir=../$(top_distdir) distdir=../$(distdir)/$$subdir distdir) \ || exit 1; \ done @@ -323,19 +317,19 @@ installdirs: installdirs-recursive mostlyclean-generic: - -test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) + test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) clean-generic: - -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) + test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) distclean-generic: - -rm -f Makefile $(DISTCLEANFILES) - -rm -f config.cache config.log stamp-h stamp-h[0-9]* - -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + rm -f Makefile $(DISTCLEANFILES) + rm -f config.cache config.log stamp-h stamp-h[0-9]* + test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) maintainer-clean-generic: - -test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) - -test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) + test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) + test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) mostlyclean-am: mostlyclean-libexecPROGRAMS mostlyclean-compile \ mostlyclean-libtool mostlyclean-tags \ mostlyclean-generic @@ -357,8 +351,8 @@ mostlyclean: mostlyclean-recursive mostlyclean-am clean: clean-recursive clean-am distclean: distclean-recursive distclean-am - -rm -f config.status - -rm -f libtool + rm -f config.status + rm -f libtool maintainer-clean: maintainer-clean-recursive maintainer-clean-am @echo "This command is intended for maintainers to use;" diff --git a/plug-ins/gimptcl/Makefile.am b/plug-ins/gimptcl/Makefile.am index ecf2c21f90..2bd4267fa1 100644 --- a/plug-ins/gimptcl/Makefile.am +++ b/plug-ins/gimptcl/Makefile.am @@ -28,7 +28,7 @@ LDADD = \ @LIBTCL_LIB@ \ $(X_LIBS) \ -lc \ - -lm -ldl + -lm gtclenums.h: ${top_srcdir}/libgimp/gimpenums.h gtclEnums.h misc/enum.pl ${top_srcdir}/libgimp/gimpenums.h gtclEnums.h >$@ diff --git a/plug-ins/gimptcl/frags/sphere.tcl b/plug-ins/gimptcl/frags/sphere.tcl index 20ebdcc63c..585fdc8805 100644 --- a/plug-ins/gimptcl/frags/sphere.tcl +++ b/plug-ins/gimptcl/frags/sphere.tcl @@ -12,9 +12,9 @@ proc Shadow_Sphere {radius sphere_color bg_color light shadow} { set w [expr $radius * 3.52] set h [expr $radius * 2.40] - set img [gimp-image-new $w $h $RGB] + set img [gimp-image-new $w $h RGB] set drawable [gimp-layer-new $img $w $h \ - $RGB_IMAGE "Sphere" 100 $NORMAL] + RGB_IMAGE "Sphere" 100 NORMAL] set radians [expr ($light * 3.1415926) / 180] set cx [expr $w / 2] @@ -35,7 +35,7 @@ proc Shadow_Sphere {radius sphere_color bg_color light shadow} { if {((($light >= 45) && ($light <= 75)) || (($light <= 135) && ($light >= 105))) - && ($shadow == $TRUE)} { + && ($shadow == 1)} { set shadow_w [expr ($radius * 2.5) * (cos(3.1415926 * $radians))] set shadow_h [expr $radius * 0.5] set shadow_x $cx @@ -45,20 +45,20 @@ proc Shadow_Sphere {radius sphere_color bg_color light shadow} { set shadow_w [expr -$shadow_w] } gimp-ellipse-select $img $shadow_x $shadow_y \ - $shadow_w $shadow_h $REPLACE $TRUE $TRUE 7.5 - gimp-bucket-fill $img $drawable $BG_BUCKET_FILL \ - $MULTIPLY 100 0 $FALSE 0 0 + $shadow_w $shadow_h REPLACE TRUE $TRUE 7.5 + gimp-bucket-fill $img $drawable BG_BUCKET_FILL \ + MULTIPLY 100 0 FALSE 0 0 } gimp-ellipse-select $img [expr $cx - $radius] \ [expr $cy - $radius] [expr 2 * $radius] [expr 2 * $radius] \ - $REPLACE $TRUE $FALSE 0 - gimp-blend $img $drawable $FG_BG_RGB $NORMAL $RADIAL 100 \ - $offset $light_x $light_y $light_end_x $light_end_y + REPLACE TRUE FALSE 0 + gimp-blend $img $drawable FG_BG_RGB NORMAL RADIAL 100 \ + $offset FALSE FALSE 0 0 $light_x $light_y $light_end_x $light_end_y gimp-selection-none $img gimp-image-enable-undo $img gimp-display-new $img return $img } -#Shadow_Sphere 100 {255 0 0} {255 255 255} 135 $TRUE +Shadow_Sphere 100 {255 0 0} {255 255 255} 45 FALSE diff --git a/plug-ins/gimptcl/gtcl.h b/plug-ins/gimptcl/gtcl.h index c2c814304c..26d5631bfe 100644 --- a/plug-ins/gimptcl/gtcl.h +++ b/plug-ins/gimptcl/gtcl.h @@ -34,6 +34,8 @@ int Gtcl_QueryDBProc(ClientData data, Tcl_Interp *interp, int ac, char *av[]); int Gtcl_QueryDB(ClientData data, Tcl_Interp *interp, int ac, char *av[]); int Gtcl_InstallProc(ClientData data, Tcl_Interp *interp, int ac, char *av[]); int Gtcl_GimpMain(ClientData data, Tcl_Interp *interp, int ac, char *av[]); +int Gtcl_SetData(ClientData data, Tcl_Interp *interp, int ac, char *av[]); +int Gtcl_GetData(ClientData data, Tcl_Interp *interp, int ac, char *av[]); int Argv_to_GParam(Tcl_Interp *interp, char *name, int ac, char **av, GParam *parr); @@ -46,6 +48,7 @@ void cvtfrom (char *str); void cvtto (char *str); extern char *GtclConst; +extern char *GtclProcs; #define debugging 1 diff --git a/plug-ins/gimptcl/gtclConst.c b/plug-ins/gimptcl/gtclConst.c index 0fe4773b7e..b9f65e82e7 100644 --- a/plug-ins/gimptcl/gtclConst.c +++ b/plug-ins/gimptcl/gtclConst.c @@ -59,6 +59,7 @@ int Gtcl_ConstInit(Tcl_Interp *interp){ char t[30], t1[30]; + Tcl_PkgProvide(interp, "GtclConstant", "1.0"); /* the auto-generated ones from */ #include "gtclenums.h" diff --git a/plug-ins/gimptcl/gtclMain.c b/plug-ins/gimptcl/gtclMain.c index b14600671c..0cb70fbf14 100644 --- a/plug-ins/gimptcl/gtclMain.c +++ b/plug-ins/gimptcl/gtclMain.c @@ -56,7 +56,6 @@ GPlugInInfo PLUG_IN_INFO = { int main(int ac, char *av[]){ char *tcllib_p, *tcllib; - char *tklib_p, *tklib; /* fprintf(stderr, "gimptcl: %d %s\n", ac, av[1]);*/ @@ -74,16 +73,8 @@ main(int ac, char *av[]){ free(tcllib); free(tcllib_p); - if (Tk_Init(theInterp) == TCL_OK) { - tklib_p = Tcl_GetVar(theInterp, "tk_library", TCL_GLOBAL_ONLY); - tklib = malloc(strlen(tklib_p)+10); - sprintf(tklib, "%s/init.tcl", tklib_p); - Tcl_EvalFile(theInterp, tklib); - free(tklib_p); - free(tklib); - } - Gimptcl_Init(theInterp); + Tcl_StaticPackage(theInterp, "Gimptcl", Gimptcl_Init, Gimptcl_Init); Tcl_EvalFile(theInterp, av[1]); @@ -95,6 +86,11 @@ main(int ac, char *av[]){ */ int Gimptcl_Init(Tcl_Interp *interp){ + char debuglevelvar[] = "DebugLevel"; + char GimpTclProcsVar[] = "GimpTclProcs"; + + Tcl_PkgProvide(interp, "Gimptcl", "1.0"); + Tcl_CreateCommand(interp, "gimp-run-procedure", Gtcl_GimpRunProc, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "gimp-query-dbproc", Gtcl_QueryDBProc, @@ -103,19 +99,26 @@ Gimptcl_Init(Tcl_Interp *interp){ (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); Tcl_CreateCommand(interp, "gimp-install-procedure", Gtcl_InstallProc, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); + Tcl_CreateCommand(interp, "gimp-set-data", Gtcl_SetData, + (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); + Tcl_CreateCommand(interp, "gimp-get-data", Gtcl_GetData, + (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); #ifdef SHLIB_METHOD Tcl_CreateCommand(interp, "gimp-main", Gtcl_GimpMain, (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); #endif - Tcl_LinkVar(interp, "DebugLevel", (char *)&debuglevel, + Tcl_LinkVar(interp, debuglevelvar, (char *)&debuglevel, TCL_LINK_INT); + Tcl_LinkVar(interp, GimpTclProcsVar, (char *)&GtclProcs, + TCL_LINK_STRING |TCL_LINK_READ_ONLY); + /* - * we have to belay adding PDB and Const to the interp + * we have to delay adding PDB and Const to the interp * until gtcl_run is called, because we need * gimp_main to setup the IPC to the PDB. */ - - theInterp=interp; + if (!theInterp) + theInterp=interp; return TCL_OK; } @@ -185,6 +188,8 @@ gtcl_run(char *name, int nparm, GParam *p, int *nrv, GParam **rv){ /* ok, add in our constants and the full PDB */ Gtcl_PDBInit(theInterp); Gtcl_ConstInit(theInterp); + Tcl_StaticPackage(theInterp, "GtclConstant", Gtcl_ConstInit, Gtcl_ConstInit); + Tcl_StaticPackage(theInterp, "GtclPDB", Gtcl_PDBInit, Gtcl_PDBInit); Tcl_Eval(theInterp, "info procs gimptcl_run"); if (strcmp(theInterp->result, "gimptcl_run")!=0){ @@ -204,6 +209,17 @@ gtcl_run(char *name, int nparm, GParam *p, int *nrv, GParam **rv){ free(pars); sprintf(cmd, "gimptcl_run %s", t); Tcl_Free(t); + if (p[0].data.d_int32 == RUN_INTERACTIVE) { + if (Tk_Init(theInterp) == TCL_OK) { + } else { + fprintf (stderr, "error in Tk_Init(): %s\n", theInterp->result); + } +#if TK_MAJOR_VERSION == 8 + Tcl_StaticPackage(theInterp, "Tk", Tk_Init, Tk_SafeInit); +#else + Tcl_StaticPackage(theInterp, "Tk", Tk_Init, NULL); +#endif + } if(Tcl_Eval(theInterp, cmd)==TCL_ERROR){ fprintf(stderr, "Error in gtcl_run:%s\n", theInterp->result); diff --git a/plug-ins/gimptcl/gtclPDB.c b/plug-ins/gimptcl/gtclPDB.c index 1da46b6f11..5b26827aeb 100644 --- a/plug-ins/gimptcl/gtclPDB.c +++ b/plug-ins/gimptcl/gtclPDB.c @@ -33,6 +33,8 @@ #include #include "gtcl.h" +char *GtclProcs = NULL; + static char *proc_types[] = { "undefined", "plug-in", @@ -84,16 +86,20 @@ Gtcl_PDBInit(Tcl_Interp *interp){ int nreturn_vals; GParamDef *params, *return_vals; int num_procs, i, j; - char whole_proc[2048]; - char arglist[400]; - char carglist[400]; + char whole_proc[4096]; + char arglist[1024]; + char carglist[1024]; + char **theproc_list; + Tcl_PkgProvide(interp, "GtclPDB", "1.0"); gimp_query_database (".*", ".*", ".*", ".*", ".*", ".*", ".*", &num_procs, &proc_list); + theproc_list = (char **)malloc(num_procs * sizeof(char *)); + for (i = 0; i < num_procs; i++) { - memset(whole_proc, 0, 2048); - memset(arglist, 0, 400); - memset(carglist, 0, 400); + memset(whole_proc, 0, sizeof(whole_proc)); + memset(arglist, 0, sizeof(arglist)); + memset(carglist, 0, (sizeof(carglist))); proc_name = strdup (proc_list[i]); /* fprintf(stderr, "(proc %d/%d %s)\n", i, num_procs, proc_name);*/ /* lookup the procedure */ @@ -102,19 +108,25 @@ Gtcl_PDBInit(Tcl_Interp *interp){ &nparams, &nreturn_vals, ¶ms, &return_vals) == TRUE) { cvtfrom(proc_name); + theproc_list[i] = (char *)malloc(strlen(proc_name)+1); + strcpy(theproc_list[i], proc_name); + /* fprintf(stderr, "adding %d `%s' -> `%s' %d\n", i, proc_name, + theproc_list[i], strlen(proc_name)); */ sprintf(carglist, "gimp-run-procedure %s ", proc_name); for(j=0;j ", (char *)NULL); + return(TCL_ERROR); + } + gimp_set_data(av[1], av[2], strlen(av[2])); + return TCL_OK; +} + +int +Gtcl_GetData(ClientData data, Tcl_Interp *interp, int ac, char *av[]){ + char tmp[1024]; + + memset(tmp, 0, 1024); + + if(ac!=2){ + Tcl_SetResult(interp, "gimp-get-data: wrong # args:\n", + TCL_STATIC); + Tcl_AppendResult(interp, "usage: ", av[0], + " ", (char *)NULL); + return(TCL_ERROR); + } + gimp_get_data(av[1], tmp); + + Tcl_SetResult(interp, tmp, TCL_VOLATILE); + return TCL_OK; +} + /* * static conveninence functions... */ diff --git a/plug-ins/gimptcl/gtcl_misc.c b/plug-ins/gimptcl/gtcl_misc.c index 1f70e102ce..57ea2e01d5 100644 --- a/plug-ins/gimptcl/gtcl_misc.c +++ b/plug-ins/gimptcl/gtcl_misc.c @@ -277,13 +277,28 @@ Argv_to_GParam(Tcl_Interp *interp, char *name, int ac, char **av, break; case PARAM_DISPLAY: + sscanf(av[i], "display-%d", &pc->data.d_int32); + DPRINTF(2,(stderr, " (display)%d ", pc->data.d_int32)); + break; case PARAM_IMAGE: + sscanf(av[i], "image-%d", &pc->data.d_int32); + DPRINTF(2,(stderr, " (image)%d ", pc->data.d_int32)); + break; case PARAM_LAYER: + sscanf(av[i], "layer-%d", &pc->data.d_int32); + DPRINTF(2,(stderr, " (layer)%d ", pc->data.d_int32)); + break; case PARAM_CHANNEL: + sscanf(av[i], "channel-%d", &pc->data.d_int32); + DPRINTF(2,(stderr, " (channel)%d ", pc->data.d_int32)); + break; case PARAM_DRAWABLE: + sscanf(av[i], "layer-%d", &pc->data.d_int32); + DPRINTF(2,(stderr, " (drawable)%d ", pc->data.d_int32)); + break; case PARAM_SELECTION: - pc->data.d_int32 = strtol(av[i], (char **)NULL, 0); - DPRINTF(2,(stderr, " (dsp,img,lay,chan,drw,sel)%d ", pc->data.d_int32)); + sscanf(av[i], "selection-%d", &pc->data.d_int32); + DPRINTF(2,(stderr, " (selection)%d ", pc->data.d_int32)); break; case PARAM_BOUNDARY: @@ -332,7 +347,10 @@ GParam_to_Argv(Tcl_Interp *interp, char *p_name, int p_nrv, sprintf(t, "%g", vals[i].data.d_float); break; case PARAM_STRING: - strcpy(t,vals[i].data.d_string); + if(vals[i].data.d_string) + strcpy(t,vals[i].data.d_string); + else + sprintf(t,"(null)"); break; case PARAM_INT32ARRAY: { char **ar, *t1; @@ -415,12 +433,22 @@ GParam_to_Argv(Tcl_Interp *interp, char *p_name, int p_nrv, return TCL_ERROR; break; case PARAM_DISPLAY: + sprintf(t, "display-%d", vals[i].data.d_int32); + break; case PARAM_IMAGE: + sprintf(t, "image-%d", vals[i].data.d_int32); + break; case PARAM_LAYER: + sprintf(t, "layer-%d", vals[i].data.d_int32); + break; case PARAM_CHANNEL: + sprintf(t, "channel-%d", vals[i].data.d_int32); + break; case PARAM_DRAWABLE: + sprintf(t, "layer-%d", vals[i].data.d_int32); + break; case PARAM_SELECTION: - sprintf(t, "%d", vals[i].data.d_int32); + sprintf(t, "selection-%d", vals[i].data.d_int32); break; case PARAM_BOUNDARY: Tcl_SetResult(interp, "Unsupported return type: Boundary", diff --git a/plug-ins/gimptcl/scripts/Makefile b/plug-ins/gimptcl/scripts/Makefile index b3a6997640..e502b0eefe 100644 --- a/plug-ins/gimptcl/scripts/Makefile +++ b/plug-ins/gimptcl/scripts/Makefile @@ -1,22 +1,16 @@ # Generated automatically from Makefile.in by configure. -# Makefile.in generated automatically by automake 1.2c from Makefile.am +# Makefile.in generated automatically by automake 1.2 from Makefile.am # Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy and/or distribute it, -# with or without modifications, as long as this notice is preserved. - -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY, to the extent permitted by law; without -# even the implied warranty of MERCHANTABILITY or FITNESS FOR A -# PARTICULAR PURPOSE. +# gives unlimited permission to copy, distribute and modify it. SHELL = /bin/sh srcdir = . top_srcdir = ../../.. -prefix = /usr +prefix = /usr/X11R6/ exec_prefix = ${prefix} bindir = ${exec_prefix}/bin @@ -55,18 +49,18 @@ POST_INSTALL = true NORMAL_UNINSTALL = true PRE_UNINSTALL = true POST_UNINSTALL = true -host_alias = i486-pc-linux-gnu -host_triplet = i486-pc-linux-gnu +host_alias = i386-unknown-freebsd3.0 +host_triplet = i386-unknown-freebsd3.0 CC = gcc CPP = gcc -E -EMACS = /usr/bin/emacs +EMACS = GIMPTCL = gimptcl JPEG = jpeg -LD = /usr/lib/gcc-lib/i386-linux/egcs-2.90.18/ld +LD = /usr/bin/ld LIBJPEG_LIB = -ljpeg -LIBMPEG_LIB = +LIBMPEG_LIB = -lmpeg LIBPNG_LIB = -lpng -lz -LIBTCL_LIB = -ltcl -ltk +LIBTCL_LIB = -ltcl75 -ltk41 LIBTIFF_LIB = -ltiff LIBTOOL = $(SHELL) $(top_builddir)/libtool LIBXDELTA_LIB = @@ -74,8 +68,8 @@ LIBXPM_LIB = -lXpm LN_S = ln -s MAINT = #M# MAKEINFO = makeinfo -MPEG = -NM = /usr/bin/nm -B +MPEG = mpeg +NM = /usr/bin/nm -p PACKAGE = gimp PNG = png RANLIB = ranlib @@ -111,9 +105,9 @@ default: all $(srcdir)/Makefile.in: #M# Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4) cd $(top_srcdir) && $(AUTOMAKE) --gnu plug-ins/gimptcl/scripts/Makefile -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES) - cd $(top_builddir) \ - && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status +#Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES) +# cd $(top_builddir) \ +# && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status install-pluginlibSCRIPTS: $(pluginlib_SCRIPTS) @@ -145,7 +139,6 @@ subdir = plug-ins/gimptcl/scripts distdir: $(DISTFILES) here=`cd $(top_builddir) && pwd`; \ top_distdir=`cd $(top_distdir) && pwd`; \ - distdir=`cd $(distdir) && pwd`; \ cd $(top_srcdir) \ && $(AUTOMAKE) --include-deps --build-dir=$$here --srcdir-name=$(top_srcdir) --output-dir=$$top_distdir --gnu plug-ins/gimptcl/scripts/Makefile @for file in $(DISTFILES); do \ @@ -179,26 +172,26 @@ installdirs: mostlyclean-generic: - -test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) + test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) clean-generic: - -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) + test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) distclean-generic: - -rm -f Makefile $(DISTCLEANFILES) - -rm -f config.cache config.log stamp-h stamp-h[0-9]* - -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + rm -f Makefile $(DISTCLEANFILES) + rm -f config.cache config.log stamp-h stamp-h[0-9]* + test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) maintainer-clean-generic: - -test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) - -test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) + test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) + test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) mostlyclean: mostlyclean-generic clean: clean-generic mostlyclean distclean: distclean-generic clean - -rm -f config.status - -rm -f libtool + rm -f config.status + rm -f libtool maintainer-clean: maintainer-clean-generic distclean @echo "This command is intended for maintainers to use;" diff --git a/plug-ins/gimptcl/scripts/consolio b/plug-ins/gimptcl/scripts/consolio index c27edae90b..accedaee98 100755 --- a/plug-ins/gimptcl/scripts/consolio +++ b/plug-ins/gimptcl/scripts/consolio @@ -1,33 +1,39 @@ -#!/usr/libexec/gimptcl -# -*-Mode: Tcl;-*- -################################################## +#!/usr/X11R6//libexec/gimptcl +# +## tkcon.tcl +## Enhanced Tk Console, part of the VerTcl system +## +## Originally based off Brent Welch's Tcl Shell Widget +## (from "Practical Programming in Tcl and Tk") +## +## Thanks especially to the following for bug reports & code ideas: +## Steven Wahl , Jan Nijtmans +## Crimmins , Wart +## +## Copyright 1995,1996 Jeffrey Hobbs +## Initiated: Thu Aug 17 15:36:47 PDT 1995 +## +## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/ +## +## source standard_disclaimer.tcl +## source beer_ware.tcl +## # file: consolio.tcl # # This code has been modified by Eric L. Hernes to provide # a console window for use with the Tcl extension to Gimp. # -# This code constructs the console window for an application. It -# can be used by non-unix systems that do not have built-in support -# for shells. -# -# SCCS: @(#) console.tcl 1.28 96/03/07 16:32:14 -# -# Copyright (c) 1995-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. -# # $Id$ # proc gimptcl_query {} { - gimp-install-procedure "gimptcl_consolio" \ + gimp-install-procedure "gimptcl_consolio2" \ "An interactive gimptcl shell" \ "Type commands at the prompt to do stuff" \ "Eric L. Hernes" \ "ELH" \ "1997" \ - "/Xtns/Gimptcl Consolio" \ + "/Xtns/Gimptcl Consolio2" \ "" \ extension \ { @@ -37,423 +43,3509 @@ proc gimptcl_query {} { } proc gimptcl_run {mode} { - tkConsoleInit + global argc argv argv0 tkCon + + set argc 0 + set argv "" + set argv0 "tkconsolio" + + tkConsolioSetup + tkConInit } -proc consexit {args} { - destroy . - return $args -} +proc tkConsolioSetup {} { + global tcl_version tkCon -proc consputs {args} { - switch [llength $args] { - 0 { - set a "\n" - } - 1 { - set a "[lindex $args 0]\n" - } - 2 { - if {[string compare [lindex $args 0] "-nonewline"] == 0} { - set a [lindex $args 1] - } else { - return [eval "orig_puts $args"] + if {$tcl_version>=8.0} { + package require Tk + } elseif {[catch {package require -exact Tk [expr $tcl_version-3.4]}]} { + return -code error \ + "TkCon requires at least the stable version of tcl7.5/tk4.1" + } + + foreach pkg [info loaded {}] { + set file [lindex $pkg 0] + set name [lindex $pkg 1] + if {![catch {set version [package require $name]}]} { + if {[string match {} [package ifneeded $name $version]]} { + package ifneeded $name $version "load [list $file $name]" } } - 3 { - return [orig_puts $args] - } } - .console.t insert end $a - tkTextSetCursor .console.t end + catch {unset file name version} + set tkCon(WWW) [info exists embed_args] } -proc tkConsoleInit {} { - global tcl_platform - frame .console - text .console.t -yscrollcommand ".console.sb set" -setgrid true - scrollbar .console.sb -command ".console.t yview" - pack .console.sb -side right -fill both - pack .console.t -fill both -expand 1 -side left +## tkConInit - inits tkCon +# ARGS: root - widget pathname of the tkCon console root +# title - title for the console root and main (.) windows +# Calls: tkConInitUI +# Outputs: errors found in tkCon resource file +## +proc tkConInit {} { + global auto_path tcl_platform env tcl_pkgPath \ + tkCon argc argv tcl_interactive GimpTclProcs - frame .ctl - button .ctl.exit -text "Exit" -command "destroy ." - label .ctl.currcmd -textvariable GimpPDBCmd - pack .ctl.exit .ctl.currcmd -side left - pack .console .ctl -side top -expand 1 -fill both - tkConsoleBind .console.t + set tcl_interactive 1 - .console.t tag configure stderr -foreground red - .console.t tag configure stdin -foreground blue + if [info exists tkCon(name)] { + set title $tkCon(name) + } else { + tkConMainInit + set title Main + } - focus .console.t - - wm protocol . WM_DELETE_WINDOW { wm withdraw . } - wm title . "The Great Consolio" - flush stdout - .console.t mark set output [.console.t index "end - 1 char"] - tkTextSetCursor .console.t end - .console.t mark set promptEnd insert - .console.t mark gravity promptEnd left - rename "puts" "orig_puts" - rename "consputs" "puts" - rename "exit" "orig_exit" - rename "consexit" "exit" - tkConsolePrompt -} + array set tkCon { + color,blink yellow + color,proc darkgreen + color,prompt brown + color,stdin black + color,stdout blue + color,stderr red -# tkConsoleInvoke -- -# Processes the command line input. If the command is complete it -# is evaled in the main interpreter. Otherwise, the continuation -# prompt is added and more input may be added. -# -# Arguments: -# None. + blinktime 500 + debugPrompt {(level \#$level) debug [history nextid] > } + font fixed + history 32 + dead {} + library {} + lightbrace 1 + lightcmd 1 + autoload {Gimptcl GtclConstant GtclPDB} + maineval {} + nontcl 0 + rcfile .tkconrc + scrollypos right + showmultiple 1 + showmenu 1 + slaveeval {} + subhistory 1 -proc tkConsoleInvoke {args} { - set ranges [.console.t tag ranges input] - set cmd "" - if {$ranges != ""} { - set pos 0 - while {[lindex $ranges $pos] != ""} { - set start [lindex $ranges $pos] - set end [lindex $ranges [incr pos]] - append cmd [.console.t get $start $end] - incr pos - } + exec slave app {} appname {} apptype slave cmd {} cmdbuf {} cmdsave {} + event 1 cols 80 rows 24 deadapp 0 debugging 0 histid 0 + find {} find,case 0 find,reg 0 + errorInfo {} + slavealias { tkcon } + + slaveprocs { alias clear dir dump lremove puts echo tclindex idebug \ + unknown tcl_unknown unalias which observe observe_var auto_execok } + version 0.71 + release {December 1996} + root . + } +# set tkCon(slavealias) [concat $tkCon(slavealias) $GimpTclProcs] + + if $tkCon(WWW) { + set tkCon(prompt1) {[history nextid] % } + } else { + set tkCon(prompt1) {([file tail [pwd]]) [history nextid] % } + } + + ## If there appear to be children of '.', then make sure we use + ## a disassociated toplevel. + if [string compare {} [winfo children .]] { + set tkCon(root) .tkcon + } + + if [string compare unix $tcl_platform(platform)] { + array set tkCon { + font {Courier 12 {}} + rcfile tkcon.cfg } - if {$cmd == ""} { - tkConsolePrompt - } elseif [info complete $cmd] { - .console.t mark set output end - .console.t tag delete input - if {$cmd != ""} { - history add $cmd - catch "uplevel \#0 eval \{$cmd\}" result - if {$result != ""} { - .console.t insert insert "$result\n" - } - tkConsoleHistory reset + } + + if [info exists env(HOME)] { + set tkCon(rcfile) [file join $env(HOME) $tkCon(rcfile)] + } + if 0 { + ## This would get the resource file from the right place + switch $tcl_platform(platform) { + macintosh { + set pref_folder $env(PREF_FOLDER) + cd [file dirname [info script]] + } + windows { set pref_folder $env(WINDIR) } + unix { set pref_folder $env(HOME) } + } + } + + ## Handle command line arguments before sourcing resource file to + ## find if resource file is being specified (let other args pass). + for {set i 0} {$i < $argc} {incr i} { + if [string match \-rcfile [lindex $argv $i]] { + set tkCon(rcfile) [lindex $argv [incr i]] + } + } + + if {!$tkCon(WWW) && [file exists $tkCon(rcfile)]} { + set code [catch [list uplevel \#0 source $tkCon(rcfile)] err] + } + + if [info exists env(TK_CON_LIBRARY)] { + eval lappend auto_path $env(TK_CON_LIBRARY) + } else { + eval lappend auto_path $tkCon(library) + } + + if {![info exists tcl_pkgPath]} { + set dir [file join [file dirname [info nameofexec]] lib] + if [string comp {} [info commands @scope]] { + set dir [file join $dir itcl] + } + catch {source [file join $dir pkgIndex.tcl]} + } + catch {tclPkgUnknown dummy-name dummy-version} + + ## Handle rest of command line arguments after sourcing resource file + ## and slave is created, but before initializing UI or setting packages. + set slaveargs {} + set slavefiles {} + set truth {^(1|yes|true|on)$} + for {set i 0} {$i < $argc} {incr i} { + set arg [lindex $argv $i] + if [regexp -- {-.+} $arg] { + set val [lindex $argv [incr i]] + ## Handle arg based options + switch -- $arg { + -- - -argv { + set argv [concat -- [lrange $argv $i end]] + set argc [llength $argv] + break } - tkConsolePrompt + -main - -e - -eval { append tkCon(maineval) $val\n } + -package - -load { lappend tkCon(autoload) $val } + -slave { append tkCon(slaveeval) $val\n } + -nontcl { set tkCon(nontcl) [regexp -nocase $truth $val] } + -root { set tkCon(root) $val } + -rcfile {} + default { lappend slaveargs $arg; incr i -1 } + } + } elseif {[file isfile $arg]} { + lappend slavefiles $arg } else { - tkConsolePrompt partial + lappend slaveargs $arg } - .console.t yview -pickplace insert -} + } -# tkConsoleHistory -- -# This procedure implements command line history for the -# console. In general is evals the history command in the -# main interpreter to obtain the history. The global variable -# histNum is used to store the current location in the history. -# -# Arguments: -# cmd - Which action to take: prev, next, reset. + ## Create slave executable + if [string comp {} $tkCon(exec)] { + eval tkConInitSlave $tkCon(exec) $slaveargs + } -set histNum 1 -proc tkConsoleHistory {cmd} { - global histNum - - switch $cmd { - prev { - incr histNum -1 - if {$histNum == 0} { - set cmd {history event [expr [history nextid] -1]} - } else { - set cmd "history event $histNum" - } - if {[catch {eval $cmd} cmd]} { - incr histNum - return - } - .console.t delete promptEnd end - .console.t insert promptEnd $cmd {input stdin} - } - next { - incr histNum - if {$histNum == 0} { - set cmd {history event [expr [history nextid] -1]} - } elseif {$histNum > 0} { - set cmd "" - set histNum 1 - } else { - set cmd "history event $histNum" - } - if {$cmd != ""} { - catch {eval $cmd} cmd - } - .console.t delete promptEnd end - .console.t insert promptEnd $cmd {input stdin} - } - reset { - set histNum 1 - } - } -} + ## Attach to the slave, tkConEvalAttached will then be effective + tkConAttach $tkCon(appname) $tkCon(apptype) + tkConInitUI $title -# tkConsolePrompt -- -# This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2 -# exists in the main interpreter it will be called to generate the -# prompt. Otherwise, a hard coded default prompt is printed. -# -# Arguments: -# partial - Flag to specify which prompt to print. - -proc tkConsolePrompt {{partial normal}} { - if {$partial == "normal"} { - set temp [.console.t index "end - 1 char"] - .console.t mark set output end - if [eval "info exists tcl_prompt1"] { - eval "eval \[set tcl_prompt1\]" - } else { - puts -nonewline "% " - } + ## Autoload specified packages in slave + set pkgs [tkConEvalSlave package names] + foreach pkg $tkCon(autoload) { + puts -nonewline "autoloading package \"$pkg\" ... " + if {[lsearch -exact $pkgs $pkg]>-1} { + if [catch {tkConEvalSlave package require $pkg} pkgerr] { + puts stderr "error:\n$pkgerr" + } else { puts "OK" } } else { - set temp [.console.t index output] - .console.t mark set output end - if [eval "info exists tcl_prompt2"] { - eval "eval \[set tcl_prompt2\]" - } else { + puts stderr "error: package does not exist" + } + } + + ## Evaluate maineval in slave + if {[string comp {} $tkCon(maineval)] && + [catch {uplevel \#0 $tkCon(maineval)} merr]} { + puts stderr "error in eval:\n$merr" + } + + ## Source extra command line argument files into slave executable + foreach fn $slavefiles { + puts -nonewline "slave sourcing \"$fn\" ... " + if {[catch {tkConEvalSlave source $fn} fnerr]} { + puts stderr "error:\n$fnerr" + } else { puts "OK" } + } + + ## Evaluate slaveeval in slave + if {[string comp {} $tkCon(slaveeval)] && + [catch {interp eval $tkCon(exec) $tkCon(slaveeval)} serr]} { + puts stderr "error in slave eval:\n$serr" + } + ## Output any error/output that may have been returned from rcfile + if {[info exists code] && [string comp {} $err]} { + if $code { + puts stderr "error in $tkCon(rcfile):\n$err" + } else { + puts stdout "returned from $tkCon(rcfile):\n$err" + } + } + tkConStateCheckpoint [concat $tkCon(name) $tkCon(exec)] slave + tkConStateCheckpoint $tkCon(name) slave +} + +## tkConInitSlave - inits the slave by placing key procs and aliases in it +## It's arg[cv] are based on passed in options, while argv0 is the same as +## the master. tcl_interactive is the same as the master as well. +# ARGS: slave - name of slave to init. If it does not exist, it is created. +# args - args to pass to a slave as argv/argc +## +proc tkConInitSlave {slave args} { + global tkCon argv0 tcl_interactive tcl_library env + if [string match {} $slave] { + return -code error "Don't init the master interpreter, goofball" + } + if ![interp exists $slave] { interp create $slave } + if {[interp eval $slave info command source] == ""} { + $slave alias source tkConSafeSource $slave + $slave alias load tkConSafeLoad $slave + $slave alias open tkConSafeOpen $slave + $slave alias exit tkConExit + $slave alias file file + interp eval $slave [dump var tcl_library env] + interp eval $slave [list source [file join $tcl_library init.tcl]] + } + interp eval $slave {catch {rename puts tcl_puts}} + foreach cmd $tkCon(slaveprocs) { interp eval $slave [dump proc $cmd] } + foreach cmd $tkCon(slavealias) { + $slave alias $cmd $cmd + } + $slave alias exit tkConExit + interp alias $slave ls $slave dir + interp eval $slave set tcl_interactive $tcl_interactive \; \ + set argv0 [list $argv0] \; set argc [llength $args] \; \ + set argv [list $args] \; history keep $tkCon(history) \; { + if {[string match {} [info command bgerror]]} { + proc bgerror err { + global errorInfo + set body [info body bgerror] + rename bgerror {} + if [auto_load bgerror] { return [bgerror $err] } + proc bgerror err $body + tkcon bgerror $err $errorInfo + } + } + } + + foreach pkg [lremove [package names] Tcl] { + foreach v [package versions $pkg] { + interp eval $slave [list package ifneeded $pkg $v \ + [package ifneeded $pkg $v]] + } + } +} + +## tkConInitInterp - inits an interpreter by placing key +## procs and aliases in it. +# ARGS: name - interp name +# type - interp type (slave|interp) +## +proc tkConInitInterp {name type} { + global tkCon + ## Don't allow messing up a local master interpreter + if {[string match slave $type] && \ + [regexp {^([Mm]ain|Slave[0-9]+)$} $name]} return + set old [tkConAttach] + catch { + tkConAttach $name $type + tkConEvalAttached {catch {rename puts tcl_puts}} + foreach cmd $tkCon(slaveprocs) { tkConEvalAttached [dump proc $cmd] } + if [string match slave $type] { + foreach cmd $tkCon(slavealias) { + tkConMain interp alias $name $cmd $tkCon(name) $cmd + } + } else { + set name [tk appname] + foreach cmd $tkCon(slavealias) { + tkConEvalAttached "proc $cmd args { send [list $name] $cmd \$args }" + } + } + ## Catch in case it's a 7.4 (no 'interp alias') interp + tkConEvalAttached {catch {interp alias {} ls {} dir}} + return + } err + eval tkConAttach $old + if [string comp {} $err] { return -code error $err } +} + +## tkConInitUI - inits UI portion (console) of tkCon +## Creates all elements of the console window and sets up the text tags +# ARGS: root - widget pathname of the tkCon console root +# title - title for the console root and main (.) windows +# Calls: tkConInitMenus, tkConPrompt +## +proc tkConInitUI {title} { + global tkCon + + set root $tkCon(root) + if [string match . $root] { set w {} } else { set w [toplevel $root] } + catch {wm withdraw $root} + set tkCon(base) $w + + ## Menus + option add *Menu.font $tkCon(font) widgetDefault + set tkCon(menubar) [frame $w.mbar -relief raised -bd 2] + set tkCon(lastCmd) [label $w.last -textvariable env(GimpPDBCmd) -anchor w] + set tkCon(console) [set con [text $w.text -font $tkCon(font) -wrap char \ + -yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin) \ + -width $tkCon(cols) -height $tkCon(rows)]] + bindtags $con "$con PreCon Console PostCon $root all" + set tkCon(scrolly) [scrollbar $w.sy -takefocus 0 -bd 1 -command "$con yview"] + + tkConInitMenus $tkCon(menubar) $title + tkConBindings + + if $tkCon(showmenu) { + pack $tkCon(menubar) -fill x + pack $tkCon(lastCmd) -fill x + } + pack $w.sy -side $tkCon(scrollypos) -fill y + pack $con -fill both -expand 1 + + tkConPrompt "$title console display active\n" + + foreach col {prompt stdout stderr stdin proc} { + $con tag configure $col -foreground $tkCon(color,$col) + } + $con tag configure blink -background $tkCon(color,blink) + $con tag configure find -background $tkCon(color,blink) + + if ![catch {wm title $root "The Great Consolio: $title"}] { + bind $con { + scan [wm geometry [winfo toplevel %W]] "%%dx%%d" tkCon(cols) tkCon(rows) + } + wm deiconify $root + } + focus -force $tkCon(console) +} + +## tkConEval - evaluates commands input into console window +## This is the first stage of the evaluating commands in the console. +## They need to be broken up into consituent commands (by tkConCmdSep) in +## case a multiple commands were pasted in, then each is eval'ed (by +## tkConEvalCmd) in turn. Any uncompleted command will not be eval'ed. +# ARGS: w - console text widget +# Calls: tkConCmdGet, tkConCmdSep, tkConEvalCmd +## +proc tkConEval {w} { + global tkCon + tkConCmdSep [tkConCmdGet $w] cmds tkCon(cmd) + $w mark set insert end-1c + $w insert end \n + if [llength $cmds] { + foreach cmd $cmds {tkConEvalCmd $w $cmd} + $w insert insert $tkCon(cmd) {} + } elseif {[info complete $tkCon(cmd)] && ![regexp {[^\\]\\$} $tkCon(cmd)]} { + tkConEvalCmd $w $tkCon(cmd) + } + $w see insert +} + +## tkConEvalCmd - evaluates a single command, adding it to history +# ARGS: w - console text widget +# cmd - the command to evaluate +# Calls: tkConPrompt +# Outputs: result of command to stdout (or stderr if error occured) +# Returns: next event number +## +proc tkConEvalCmd {w cmd} { + global tkCon + $w mark set output end + if [string comp {} $cmd] { + set err 0 + if $tkCon(subhistory) { + set ev [tkConEvalSlave history nextid] + incr ev -1 + if {[string match !! $cmd]} { + set err [catch {tkConEvalSlave history event $ev} cmd] + if !$err {$w insert output $cmd\n stdin} + } elseif {[regexp {^!(.+)$} $cmd dummy event]} { + set err [catch {tkConEvalSlave history event $event} cmd] + if !$err {$w insert output $cmd\n stdin} + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} { + if ![set err [catch {tkConEvalSlave history event $ev} cmd]] { + regsub -all -- $old $cmd $new cmd + $w insert output $cmd\n stdin + } + } + } + if $err { + $w insert output $cmd\n stderr + } else { + if [string match {} $tkCon(appname)] { + if [catch {tkConEvalSlave eval $cmd} res] { + set tkCon(errorInfo) [tkConEvalSlave set errorInfo] + set err 1 + } + } else { + if {$tkCon(nontcl) && [string match interp $tkCon(apptype)]} { + if [catch "tkConEvalSend $cmd" res] { + set tkCon(errorInfo) {Non-Tcl errorInfo not available} + set err 1 + } + } else { + if [catch [list tkConEvalAttached $cmd] res] { + if [catch {tkConEvalAttached set errorInfo} err] { + set tkCon(errorInfo) {Error attempting to retrieve errorInfo} + } else { + set tkCon(errorInfo) $err + } + set err 1 + } + } + } + tkConEvalSlave history add $cmd + if $err { + $w insert output $res\n stderr + } elseif {[string comp {} $res]} { + $w insert output $res\n stdout + } + } + } + tkConPrompt + set tkCon(event) [tkConEvalSlave history nextid] +} + +## tkConEvalSlave - evaluates the args in the associated slave +## args should be passed to this procedure like they would be at +## the command line (not like to 'eval'). +# ARGS: args - the command and args to evaluate +## +proc tkConEvalSlave args { + global tkCon + interp eval $tkCon(exec) $args +} + +## tkConEvalOther - evaluate a command in a foreign interp or slave +## without attaching to it. No check for existence is made. +# ARGS: app - interp/slave name +# type - (slave|interp) +## +proc tkConEvalOther {app type args} { + if [string match slave $type] { + if [string match Main $app] { set app {} } + tkConMain interp eval $app $args + } else { + eval send [list $app] $args + } +} + +## tkConEvalSend - sends the args to the attached interpreter +## Varies from 'send' by determining whether attachment is dead +## when an error is received +# ARGS: args - the args to send across +# Returns: the result of the command +## +proc tkConEvalSend args { + global tkCon + if $tkCon(deadapp) { + if {[lsearch -exact [winfo interps] $tkCon(app)]<0} { + return + } else { + set tkCon(appname) [string range $tkCon(appname) 5 end] + set tkCon(deadapp) 0 + tkConPrompt "\n\"$tkCon(app)\" alive\n" [tkConCmdGet $tkCon(console)] + } + } + set code [catch {eval send [list $tkCon(app)] $args} result] + if {$code && [lsearch -exact [winfo interps] $tkCon(app)]<0} { + ## Interpreter disappeared + if {[string compare leave $tkCon(dead)] && \ + ([string match ignore $tkCon(dead)] || \ + [tk_dialog $tkCon(base).dead "Dead Attachment" \ + "\"$tkCon(app)\" appears to have died.\ + \nReturn to primary slave interpreter?" questhead 0 OK No])} { + set tkCon(appname) "DEAD:$tkCon(appname)" + set tkCon(deadapp) 1 + } else { + set err "Attached Tk interpreter \"$tkCon(app)\" died." + tkConAttach {} + set tkCon(deadapp) 0 + tkConEvalSlave set errorInfo $err + } + tkConPrompt \n [tkConCmdGet $tkCon(console)] + } + return -code $code $result +} + +## tkConCmdGet - gets the current command from the console widget +# ARGS: w - console text widget +# Returns: text which compromises current command line +## +proc tkConCmdGet w { + if [string match {} [set ix [$w tag nextrange prompt limit end]]] { + $w tag add stdin limit end-1c + return [$w get limit end-1c] + } +} + +## tkConCmdSep - separates multiple commands into a list and remainder +# ARGS: cmd - (possible) multiple command to separate +# list - varname for the list of commands that were separated. +# rmd - varname of any remainder (like an incomplete final command). +# If there is only one command, it's placed in this var. +# Returns: constituent command info in varnames specified by list & rmd. +## +proc tkConCmdSep {cmd ls rmd} { + upvar $ls cmds $rmd tmp + set tmp {} + set cmds {} + foreach cmd [split [set cmd] \n] { + if [string comp {} $tmp] { + append tmp \n$cmd + } else { + append tmp $cmd + } + if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { + lappend cmds $tmp + set tmp {} + } + } + if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} { + set tmp [lindex $cmds end] + set cmds [lreplace $cmds end end] + } +} + +## tkConPrompt - displays the prompt in the console widget +# ARGS: w - console text widget +# Outputs: prompt (specified in tkCon(prompt1)) to console +## +proc tkConPrompt {{pre {}} {post {}} {prompt {}}} { + global tkCon + set w $tkCon(console) + if [string comp {} $pre] { $w insert end $pre stdout } + set i [$w index end-1c] + if [string comp {} $tkCon(appname)] { + $w insert end ">$tkCon(appname)< " prompt + } + if [string comp {} $prompt] { + $w insert end $prompt prompt + } else { + $w insert end [tkConEvalSlave subst $tkCon(prompt1)] prompt + } + $w mark set output $i + $w mark set insert end + $w mark set limit insert + $w mark gravity limit left + if [string comp {} $post] { $w insert end $post stdin } + $w see end +} + +## FIX - place these in state disabled text widgets. +## tkConAbout - gives about info for tkCon +## +proc tkConAbout {} { + global tkCon + tk_dialog $tkCon(base).about "About TkCon v$tkCon(version)" \ + "Jeffrey Hobbs, Copyright 1995-96\njhobbs@cs.uoregon.edu\ + \nhttp://www.cs.uoregon.edu/~jhobbs/\ + \nRelease Date: v$tkCon(version), $tkCon(release)" questhead 0 OK +} + +## tkConHelp - gives help info for tkCon +## +proc tkConHelp {} { + global tkCon + set page "http://www.cs.uoregon.edu/~jhobbs/work/tkcon/" + set email "jhobbs@cs.uoregon.edu" + if [tk_dialog $tkCon(base).help "Help on TkCon v$tkCon(version)" \ + "Jeffrey Hobbs, $email\nHelp available at:\n$page" \ + questhead 0 OK "Load into Netscape"] { + update + if {[catch {exec netscape -remote "openURL($page)"}] + && [catch {exec netscape $page &}]} { + tk_dialog $tkCon(base).dialog "Couldn't exec Netscape" \ + "Couldn't exec Netscape.\nMake sure it's in your path" \ + warning 0 Bummer + } + } +} + +## tkConInitMenus - inits the menubar and popup for the console +# ARGS: w - console text widget +## +proc tkConInitMenus {w title} { + global tkCon + + if [catch {menu $w.pop -tearoff 0}] { + label $w.label -text "Menus not available in plugin mode" + pack $w.label + return + } + bind [winfo toplevel $w] "tk_popup $w.pop %X %Y" + + pack [menubutton $w.con -text "Console" -un 0 -menu $w.con.m] -side left + $w.pop add cascade -label "Console" -un 0 -menu $w.pop.con + + pack [menubutton $w.edit -text "Edit" -un 0 -menu $w.edit.m] -side left + $w.pop add cascade -label "Edit" -un 0 -menu $w.pop.edit + + pack [menubutton $w.int -text "Interp" -un 0 -menu $w.int.m] -side left + $w.pop add cascade -label "Interp" -un 0 -menu $w.pop.int + + pack [menubutton $w.pref -text "Prefs" -un 0 -menu $w.pref.m] -side left + $w.pop add cascade -label "Prefs" -un 0 -menu $w.pop.pref + + pack [menubutton $w.hist -text "History" -un 0 -menu $w.hist.m] -side left + $w.pop add cascade -label "History" -un 0 -menu $w.pop.hist + + pack [menubutton $w.help -text "Help" -un 0 -menu $w.help.m] -side right + $w.pop add cascade -label "Help" -un 0 -menu $w.pop.help + + ## Console Menu + ## + foreach m [list [menu $w.con.m -disabledfore $tkCon(color,prompt)] \ + [menu $w.pop.con -disabledfore $tkCon(color,prompt)]] { + $m add command -label "$title Console" -state disabled + $m add command -label "New Console" -un 0 -acc Ctrl-N -com tkConNew + $m add command -label "Close Console " -un 0 -acc Ctrl-w -com tkConDestroy + $m add command -label "Clear Console " -un 1 -acc Ctrl-l \ + -com { clear; tkConPrompt } + $m add separator + $m add cascade -label "Attach Console " -un 0 -menu $m.apps + $m add separator + $m add command -label "Quit" -un 0 -acc Ctrl-q -command tkConExit + + ## Attach Console Menu + ## + menu $m.apps -disabledforeground $tkCon(color,prompt) \ + -postcommand "tkConFillAppsMenu $m.apps" + } + + ## Edit Menu + ## + set text $tkCon(console) + foreach m [list [menu $w.edit.m] [menu $w.pop.edit]] { + $m add command -label "Cut" -un 1 -acc Ctrl-x -command "tkConCut $text" + $m add command -label "Copy" -un 1 -acc Ctrl-c -command "tkConCopy $text" + $m add command -label "Paste" -un 0 -acc Ctrl-v -command "tkConPaste $text" + $m add separator + $m add command -label "Find" -un 0 -acc Ctrl-F \ + -command "tkConFindBox $text" + } + + ## Interp Menu + ## + foreach m [list $w.int.m $w.pop.int] { + menu $m -disabledfore $tkCon(color,prompt) -postcom "tkConInterpMenu $m" + } + + ## Prefs Menu + ## + foreach m [list [menu $w.pref.m] [menu $w.pop.pref]] { + $m add checkbutton -label "Brace Highlighting" -var tkCon(lightbrace) + $m add checkbutton -label "Command Highlighting" -var tkCon(lightcmd) + $m add checkbutton -label "History Substitution" -var tkCon(subhistory) + $m add checkbutton -label "Non-Tcl Attachments" -var tkCon(nontcl) + $m add checkbutton -label "Show Multiple Matches" -var tkCon(showmultiple) + $m add checkbutton -label "Show Menubar" -var tkCon(showmenu) \ + -command "if \$tkCon(showmenu) { \ + pack $w -fill x -before $tkCon(lastCmd) \ + } else { pack forget $w }" + $m add cascade -label Scrollbar -un 0 -menu $m.scroll + + ## Scrollbar Menu + ## + set m [menu $m.scroll -tearoff 0] + $m add radio -label "Left" -var tkCon(scrollypos) -value left -command { + pack config $tkCon(scrolly) -side left + } + $m add radio -label "Right" -var tkCon(scrollypos) -value right -command { + pack config $tkCon(scrolly) -side right + } + } + + ## History Menu + ## + foreach m [list $w.hist.m $w.pop.hist] { + menu $m -disabledfore $tkCon(color,prompt) -postcom "tkConHistoryMenu $m" + } + + ## Help Menu + ## + foreach m [list [menu $w.help.m] [menu $w.pop.help]] { + $m add command -label "About " -un 0 -acc Ctrl-A -command tkConAbout + $m add separator + $m add command -label "Help" -un 0 -acc Ctrl-H -command tkConHelp + } +} + +## tkConHistoryMenu - dynamically build the menu for attached interpreters +## +# ARGS: w - menu widget +## +proc tkConHistoryMenu w { + global tkCon + + if ![winfo exists $w] return + set id [tkConEvalSlave history nextid] + if {$tkCon(histid)==$id} return + set tkCon(histid) $id + $w delete 0 end + while {($id>$tkCon(histid)-10) && \ + ![catch {tkConEvalSlave history event [incr id -1]} tmp]} { + set lbl [lindex [split $tmp "\n"] 0] + if {[string len $lbl]>32} { set lbl [string range $tmp 0 30]... } + $w add command -label "$id: $lbl" -command " + $tkCon(console) delete limit end + $tkCon(console) insert limit [list $tmp] + $tkCon(console) see end + tkConEval $tkCon(console) + " + } +} + +## tkConInterpMenu - dynamically build the menu for attached interpreters +## +# ARGS: w - menu widget +## +proc tkConInterpMenu w { + global tkCon + + if ![winfo exists $w] return + set i [tkConAttach] + set app [lindex $i 0] + set type [lindex $i 1] + $w delete 0 end + $w add command -label "[string toup $type]: $app" -state disabled + $w add separator + if {($tkCon(nontcl) && [string match interp $type]) || $tkCon(deadapp)} { + $w add command -state disabled -label "Communication disabled to" + $w add command -state disabled -label "dead or non-Tcl interps" + return + } + + set isnew [tkConEvalAttached expr \[info tclversion\]>7.4] + set hastk [tkConEvalAttached info exists tk_library] + + if 0 { + ## Inspect Cascaded Menu + ## + $w add cascade -label Inspect -un 0 -menu $w.ins + set m $w.ins + if [winfo exists $m] { + $m delete 0 end + } else { + menu $m -tearoff no -disabledfore $tkCon(color,prompt) + } + $m add check -label "Procedures" \ + -command [list tkConInspect $app $type procs] + $m add check -label "Global Vars" \ + -command [list tkConInspect $app $type vars] + if $isnew { + $m add check -label "Interpreters" \ + -command [list tkConInspect $app $type interps] + $m add check -label "Aliases" \ + -command [list tkConInspect $app $type aliases] + } + if $hastk { + $m add separator + $m add check -label "All Widgets" \ + -command [list tkConInspect $app $type widgets] + $m add check -label "Canvas Widgets" \ + -command [list tkConInspect $app $type canvases] + $m add check -label "Menu Widgets" \ + -command [list tkConInspect $app $type menus] + $m add check -label "Text Widgets" \ + -command [list tkConInspect $app $type texts] + if $isnew { + $m add check -label "Images" \ + -command [list tkConInspect $app $type images] + } + } + } + + if $isnew { + ## Packages Cascaded Menu + ## + $w add cascade -label Packages -un 0 -menu $w.pkg + set m $w.pkg + if [winfo exists $m] { $m delete 0 end } else { + menu $m -tearoff no -disabledfore $tkCon(color,prompt) + } + + foreach pkg [tkConEvalAttached [list info loaded {}]] { + set loaded([lindex $pkg 1]) [package provide $pkg] + } + foreach pkg [lremove [tkConEvalAttached package names] Tcl] { + set version [tkConEvalAttached package provide $pkg] + if [string comp {} $version] { + set loaded($pkg) $version + } elseif {![info exists loaded($pkg)]} { + set loadable($pkg) [list package require $pkg] + } + } + foreach pkg [tkConEvalAttached info loaded] { + set pkg [lindex $pkg 1] + if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} { + set loadable($pkg) [list load {} $pkg] + } + } + foreach pkg [array names loadable] { + $m add command -label "Load $pkg ([tkConEvalAttached package version $pkg])" \ + -command "tkConEvalOther [list $app] $type $loadable($pkg)" + } + if {[info exists loaded] && [info exists loadable]} { $m add separator } + foreach pkg [array names loaded] { + $m add command -label "${pkg}$loaded($pkg) Loaded" -state disabled + } + } + + ## Show Last Error + ## + $w add separator + $w add command -label "Show Last Error" \ + -command "tkcon error [list $app] $type" + + ## State Checkpoint/Revert + ## + $w add separator + $w add command -label "Checkpoint State" \ + -command [list tkConStateCheckpoint $app $type] + $w add command -label "Revert State" \ + -command [list tkConStateRevert $app $type] + $w add command -label "View State Change" \ + -command [list tkConStateCompare $app $type] + + ## Init Interp + ## + $w add separator + $w add command -label "Send TkCon Commands" \ + -command [list tkConInitInterp $app $type] +} + +## tkConFillAppsMenu - fill in in the applications sub-menu +## with a list of all the applications that currently exist. +## +proc tkConFillAppsMenu {m} { + global tkCon + + array set interps [set tmp [tkConInterps]] + foreach {i j} $tmp { set tknames($j) {} } + + catch {$m delete 0 last} + set cmd {tkConPrompt \n [tkConCmdGet $tkCon(console)]} + $m add radio -label {None (use local slave) } -var tkCon(app) \ + -value [concat $tkCon(name) $tkCon(exec)] -acc Ctrl-1 \ + -command "tkConAttach {}; $cmd" + $m add separator + $m add command -label "Foreign Tk Interpreters" -state disabled + foreach i [lsort [lremove [winfo interps] [array names tknames]]] { + $m add radio -label $i -var tkCon(app) -value $i \ + -command "tkConAttach [list $i] interp; $cmd" + } + $m add separator + + $m add command -label "TkCon Interpreters" -state disabled + foreach i [lsort [array names interps]] { + if [string match {} $interps($i)] { set interps($i) "no Tk" } + if [regexp {^Slave[0-9]+} $i] { + set opts [list -label "$i ($interps($i))" -var tkCon(app) -value $i \ + -command "tkConAttach [list $i] slave; $cmd"] + if [string match $tkCon(name) $i] { append opts " -acc Ctrl-2" } + eval $m add radio $opts + } else { + set name [concat Main $i] + if [string match Main $name] { + $m add radio -label "$name ($interps($i))" -var tkCon(app) \ + -value Main -acc Ctrl-3 \ + -command "tkConAttach [list $name] slave; $cmd" + } else { + $m add radio -label "$name ($interps($i))" -var tkCon(app) -value $i \ + -command "tkConAttach [list $name] slave; $cmd" + } + } + } +} + +## tkConFindBox - creates minimal dialog interface to tkConFind +# ARGS: w - text widget +# str - optional seed string for tkCon(find) +## +proc tkConFindBox {w {str {}}} { + global tkCon + + set base $tkCon(base).find + if ![winfo exists $base] { + toplevel $base + wm withdraw $base + wm title $base "TkCon Find" + + pack [frame $base.f] -fill x -expand 1 + label $base.f.l -text "Find:" + entry $base.f.e -textvar tkCon(find) + pack [frame $base.opt] -fill x + checkbutton $base.opt.c -text "Case Sensitive" -variable tkCon(find,case) + checkbutton $base.opt.r -text "Use Regexp" -variable tkCon(find,reg) + pack $base.f.l -side left + pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1 + pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x + pack [frame $base.btn] -fill both + button $base.btn.fnd -text "Find" -width 6 + button $base.btn.clr -text "Clear" -width 6 + button $base.btn.dis -text "Dismiss" -width 6 + eval pack [winfo children $base.btn] -padx 4 -pady 2 -side left -fill both + + focus $base.f.e + + bind $base.f.e [list $base.btn.fnd invoke] + bind $base.f.e [list $base.btn.dis invoke] + } + $base.btn.fnd config -command "tkConFind $w \$tkCon(find) \ + -case \$tkCon(find,case) -reg \$tkCon(find,reg)" + $base.btn.clr config -command " + $w tag remove find 1.0 end + set tkCon(find) {} + " + $base.btn.dis config -command " + $w tag remove find 1.0 end + wm withdraw $base + " + if [string comp {} $str] { + set tkCon(find) $str + $base.btn.fnd invoke + } + + if {[string comp normal [wm state $base]]} { + wm deiconify $base + } else { raise $base } + $base.f.e select range 0 end +} + +## tkConFind - searches in text widget $w for $str and highlights it +## If $str is empty, it just deletes any highlighting +# ARGS: w - text widget +# str - string to search for +# -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0 +# -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0 +## +proc tkConFind {w str args} { + $w tag remove find 1.0 end + set truth {^(1|yes|true|on)$} + set opts {} + foreach {key val} $args { + switch -glob -- $key { + -c* { if [regexp -nocase $truth $val] { set case 1 } } + -r* { if [regexp -nocase $truth $val] { lappend opts -regexp } } + default { return -code error "Unknown option $key" } + } + } + if ![info exists case] { lappend opts -nocase } + if [string match {} $str] return + $w mark set findmark 1.0 + while {[string comp {} [set ix [eval $w search $opts -count numc -- \ + [list $str] findmark end]]]} { + $w tag add find $ix ${ix}+${numc}c + $w mark set findmark ${ix}+1c + } + catch {$w see find.first} + return [expr [llength [$w tag ranges find]]/2] +} + +## tkConAttach - called to attach tkCon to an interpreter +# ARGS: an - application name to which tkCon sends commands +# This is either a slave interperter name or tk appname. +# type - (slave|interp) type of interpreter we're attaching to +# slave means it's a TkCon interpreter +# interp means we'll need to 'send' to it. +# Results: tkConEvalAttached is recreated to evaluate in the +# appropriate interpreter +## +proc tkConAttach {{an } {type slave}} { + global tkCon + if [string match $an] { + if [string match {} $tkCon(appname)] { + return [list [concat $tkCon(name) $tkCon(exec)] $tkCon(apptype)] + } else { + return [list $tkCon(appname) $tkCon(apptype)] + } + } + set app - + set path [concat $tkCon(name) $tkCon(exec)] + if [string comp {} $an] { + array set interps [tkConInterps] + if [string match {[Mm]ain} [lindex $an 0]] { set an [lrange $an 1 end] } + if {[string match $path $an]} { + set an {} + set app $path + set type slave + } elseif {[info exists interps($an)]} { + if [string match {} $an] { set an Main; set app Main } + set type slave + } elseif {[interp exists $an]} { + set an [concat $tkCon(name) $an] + set type slave + } elseif {[interp exists [concat $tkCon(exec) $an]]} { + set an [concat $path $an] + set type slave + } elseif {[lsearch [winfo interps] $an] > -1} { + if {[tkConEvalSlave info exists tk_library] + && [string match $an [tkConEvalSlave tk appname]]} { + set an {} + set app $path + set type slave + } elseif {[set i [lsearch [tkConMain set tkCon(interps)] $an]] > -1} { + set an [lindex [tkConMain set tkCon(slaves)] $i] + if [string match {[Mm]ain} $an] { set app Main } + set type slave + } else { + set type interp + } + } else { + return -code error "No known interpreter \"$an\"" + } + } else { + set app $path + } + if [string match - $app] { set app $an } + set tkCon(app) $app + set tkCon(appname) $an + set tkCon(apptype) $type + set tkCon(deadapp) 0 + + ## tkConEvalAttached - evaluates the args in the attached interp + ## args should be passed to this procedure as if they were being + ## passed to the 'eval' procedure. This procedure is dynamic to + ## ensure evaluation occurs in the right interp. + # ARGS: args - the command and args to evaluate + ## + switch $type { + slave { + if [string match {} $an] { + interp alias {} tkConEvalAttached {} tkConEvalSlave eval + } elseif {[string match Main $tkCon(app)]} { + interp alias {} tkConEvalAttached {} tkConMain eval + } elseif {[string match $tkCon(name) $tkCon(app)]} { + interp alias {} tkConEvalAttached {} uplevel \#0 + } else { + interp alias {} tkConEvalAttached {} tkConMain interp eval $tkCon(app) + } + } + interp { + if $tkCon(nontcl) { + interp alias {} tkConEvalAttached {} tkConEvalSlave + } else { + interp alias {} tkConEvalAttached {} tkConEvalSend + } + } + default { + return -code error "[lindex [info level 0] 0] did not specify\ + a valid type: must be slave or interp" + } + } + return +} + +## tkConLoad - sources a file into the console +# ARGS: fn - (optional) filename to source in +# Returns: selected filename ({} if nothing was selected) +## +proc tkConLoad {{fn {}}} { + global tkCon + if {[string match {} $fn] && + ([catch {tk_getOpenFile} fn] || [string match {} $fn])} return + tkConEvalAttached [list source $fn] +} + +## tkConSave - saves the console buffer to a file +## This does not eval in a slave because it's not necessary +# ARGS: w - console text widget +# fn - (optional) filename to save to +## +proc tkConSave {{fn {}}} { + global tkCon + if {[string match {} $fn] && + ([catch {tk_getSaveFile} fn] || [string match {} $fn])} return + if [catch {open $fn w} fid] { + return -code error "Save Error: Unable to open '$fn' for writing\n$fid" + } + puts $fid [$tkCon(console) get 1.0 end-1c] + close $fid +} + +## tkConMainInit +## This is only called for the main interpreter to include certain procs +## that we don't want to include (or rather, just alias) in slave interps. +## +proc tkConMainInit {} { + global tkCon + + if ![info exists tkCon(slaves)] { + array set tkCon [list slave 0 slaves Main name {} interps [tk appname]] + } + interp alias {} tkConMain {} tkConInterpEval Main + interp alias {} tkConSlave {} tkConInterpEval + + ## tkConNew - create new console window + ## Creates a slave interpreter and sources in this script. + ## All other interpreters also get a command to eval function in the + ## new interpreter. + ## + proc tkConNew {} { + global argv0 argc argv tkCon + set tmp [interp create Slave[incr tkCon(slave)]] + lappend tkCon(slaves) $tmp + load {} Tk $tmp + lappend tkCon(interps) [$tmp eval [list tk appname "[tk appname] $tmp"]] + $tmp eval set argc $argc \; set argv [list $argv] \; \ + set argv0 [list $argv0] + $tmp eval [list set tkCon(name) $tmp] + $tmp alias tkConDestroy tkConDestroy $tmp + $tmp alias tkConNew tkConNew + $tmp alias tkConMain tkConInterpEval Main + $tmp alias tkConSlave tkConInterpEval + $tmp alias tkConInterps tkConInterps + $tmp alias tkConStateCheckpoint tkConStateCheckpoint + $tmp alias tkConStateCleanup tkConStateCleanup + $tmp alias tkConStateCompare tkConStateCompare + $tmp alias tkConStateRevert tkConStateRevert + $tmp alias exit tkConExit + $tmp eval [list source $tkCon(SCRIPT)] + return $tmp + } + + ## tkConDestroy - destroy console window + ## This proc should only be called by the main interpreter. If it is + ## called from there, it will ask before exiting TkCon. All others + ## (slaves) will just have their slave interpreter deleted, closing them. + ## + proc tkConDestroy {{slave {}}} { + global tkCon + if [string match {} $slave] { + ## Main interpreter close request + if [tk_dialog $tkCon(base).destroyme {Quit TkCon?} \ + {Closing the Main console will quit TkCon} \ + warning 0 "Don't Quit" "Quit TkCon"] tkConExit + } else { + ## Slave interpreter close request + set name [tkConInterpEval $slave] + set tkCon(interps) [lremove $tkCon(interps) [list $name]] + set tkCon(slaves) [lremove $tkCon(slaves) [list $slave]] + interp delete $slave + } + tkConStateCleanup $slave + } + + ## tkConInterpEval - passes evaluation to another named interpreter + ## If the interpreter is named, but no args are given, it returns the + ## [tk appname] of that interps master (not the associated eval slave). + ## + proc tkConInterpEval {{slave {}} args} { + if [string match {} $slave] { + global tkCon + return $tkCon(slaves) + } elseif {[string match {[Mm]ain} $slave]} { + set slave {} + } + if [string match {} $args] { + return [interp eval $slave tk appname] + } else { + uplevel \#0 [list interp eval $slave $args] + } + } + + proc tkConInterps {{ls {}} {interp {}}} { + if [string match {} $interp] { lappend ls {} [tk appname] } + foreach i [interp slaves $interp] { + if [string comp {} $interp] { set i "$interp $i" } + if [string comp {} [interp eval $i package provide Tk]] { + lappend ls $i [interp eval $i tk appname] + } else { + lappend ls $i {} + } + set ls [tkConInterps $ls $i] + } + return $ls + } + + ## + ## The following state checkpoint/revert procedures are very sketchy + ## and prone to problems. They do not track modifications to currently + ## existing procedures/variables, and they can really screw things up + ## if you load in libraries (especially Tk) between checkpoint and + ## revert. Only with this knowledge in mind should you use these. + ## + + ## tkConStateCheckpoint - checkpoints the current state of the system + ## This allows you to return to this state with tkConStateRevert + # ARGS: + ## + proc tkConStateCheckpoint {app type} { + global tkCon + if {[info exists tkCon($type,$app,cmd)] && + [tk_dialog $tkCon(base).warning "Overwrite Previous State?" \ + "Are you sure you want to lose previously checkpointed\ + state of $type \"$app\"?" questhead 1 "Do It" "Cancel"]} return + set tkCon($type,$app,cmd) [tkConEvalOther $app $type info comm *] + set tkCon($type,$app,var) [tkConEvalOther $app $type info vars *] + return + } + + ## tkConStateCompare - compare two states and output difference + # ARGS: + ## + proc tkConStateCompare {app type {verbose 0}} { + global tkCon + if ![info exists tkCon($type,$app,cmd)] { + return -code error "No previously checkpointed state for $type \"$app\"" + } + set w $tkCon(base).compare + if [winfo exists $w] { + $w.text config -state normal + $w.text delete 1.0 end + } else { + toplevel $w + frame $w.btn + scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview] + text $w.text -font $tkCon(font) -yscrollcommand [list $w.sy set] \ + -height 12 + pack $w.btn -side bottom -fill x + pack $w.sy -side right -fill y + pack $w.text -fill both -expand 1 + button $w.btn.close -text Dismiss -width 11 -command [list destroy $w] + button $w.btn.check -text Recheckpoint -width 11 + button $w.btn.revert -text Revert -width 11 + button $w.btn.expand -text Verbose -width 11 + button $w.btn.update -text Update -width 11 + pack $w.btn.check $w.btn.revert $w.btn.expand $w.btn.update \ + $w.btn.close -side left -fill x -padx 4 -pady 2 -expand 1 + $w.text tag config red -foreground red + } + wm title $w "Compare State: $type [list $app]" + + $w.btn.check config -command "tkConStateCheckpoint [list $app] $type; \ + tkConStateCompare [list $app] $type $verbose" + $w.btn.revert config -command "tkConStateRevert [list $app] $type; \ + tkConStateCompare [list $app] $type $verbose" + $w.btn.update config -command [info level 0] + if $verbose { + $w.btn.expand config -text Brief \ + -command [list tkConStateCompare $app $type 0] + } else { + $w.btn.expand config -text Verbose \ + -command [list tkConStateCompare $app $type 1] + } + ## Don't allow verbose mode unless 'dump' exists in $app + ## We're assuming this is TkCon's dump command + set hasdump [string comp {} [tkConEvalOther $app $type info comm dump]] + if $hasdump { + $w.btn.expand config -state normal + } else { + $w.btn.expand config -state disabled + } + + set cmds [lremove [tkConEvalOther $app $type info comm *] \ + $tkCon($type,$app,cmd)] + set vars [lremove [tkConEvalOther $app $type info vars *] \ + $tkCon($type,$app,var)] + + if {$hasdump && $verbose} { + set cmds [tkConEvalOther $app $type eval dump c -nocomplain $cmds] + set vars [tkConEvalOther $app $type eval dump v -nocomplain $vars] + } + $w.text insert 1.0 "NEW COMMANDS IN \"$app\":\n" red \ + $cmds {} "\n\nNEW VARIABLES IN \"$app\":\n" red $vars {} + + raise $w + $w.text config -state disabled + } + + ## tkConStateRevert - reverts interpreter to previous state + # ARGS: + ## + proc tkConStateRevert {app type} { + global tkCon + if ![info exists tkCon($type,$app,cmd)] { + return -code error "No previously checkpointed state for $type \"$app\"" + } + if {![tk_dialog $tkCon(base).warning "Revert State?" \ + "Are you sure you want to revert the state in $type \"$app\"?" \ + questhead 1 "Do It" "Cancel"]} { + foreach i [lremove [tkConEvalOther $app $type info comm *] \ + $tkCon($type,$app,cmd)] { + catch {tkConEvalOther $app $type rename $i {}} + } + foreach i [lremove [tkConEvalOther $app $type info vars *] \ + $tkCon($type,$app,var)] { + catch {tkConEvalOther $app $type unset $i} + } + } + } + + ## tkConStateCleanup - cleans up state information in master array + # + ## + proc tkConStateCleanup {args} { + global tkCon + if [string match {} $args] { + foreach state [array names tkCon slave,*] { + if ![interp exists [string range $state 6 end]] { unset tkCon($state) } + } + } else { + set app [lindex $args 0] + set type [lindex $args 1] + if [regexp {^(|slave)$} $type] { + foreach state [concat [array names tkCon slave,$app] \ + [array names tkCon "slave,$app *"]] { + if ![interp exists [string range $state 6 end]] {unset tkCon($state)} + } + } else { + catch {unset tkCon($type,$app)} + } + } + } +} + +## tkcon - command that allows control over the console +# ARGS: totally variable, see internal comments +## +proc tkcon {cmd args} { + global tkCon errorInfo + switch -glob -- $cmd { + bg* { + ## 'bgerror' Brings up an error dialog + set errorInfo [lindex $args 1] + bgerror [lindex $args 0] + } + cl* { + ## 'close' Closes the console + tkConDestroy + } + con* { + ## 'console' - passes the args to the text widget of the console. + eval $tkCon(console) $args + } + err* { + ## Outputs stack caused by last error. + if {[llength $args]==2} { + set app [lindex $args 0] + set type [lindex $args 1] + if [catch {tkConEvalOther $app $type set errorInfo} info] { + set info "error getting info from $type $app:\n$info" + } + } else { set info $tkCon(errorInfo) } + if [string match {} $info] { set info {errorInfo empty} } + catch {destroy $tkCon(base).error} + set w [toplevel $tkCon(base).error] + wm title $w "TkCon Last Error" + button $w.close -text Dismiss -command [list destroy $w] + scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview] + text $w.text -font $tkCon(font) -yscrollcommand [list $w.sy set] + pack $w.close -side bottom -fill x + pack $w.sy -side right -fill y + pack $w.text -fill both -expand 1 + $w.text insert 1.0 $info + $w.text config -state disabled + } + fi* { + ## 'find' string + tkConFind $tkCon(console) $args + } + fo* { + ## 'font' ?fontname? - gets/sets the font of the console + if [string comp {} $args] { + return [$tkCon(console) config -font $args] + } else { + return [$tkCon(console) config -font] + } + } + get* { + ## 'gets' a replacement for [gets stdin varname] + ## This forces a complete command to be input though + set old [bind Console ] + bind Console { set tkCon(wait) 0 } + bind Console { set tkCon(wait) 0 } + set w $tkCon(console) + vwait tkCon(wait) + set line [tkConCmdGet $tkCon(console)] + $w insert end \n + while {![info complete $line]} { + vwait tkCon(wait) + set line [tkConCmdGet $tkCon(console)] + $w insert end \n + } + bind Console $old + bind Console $old + if [string match {} $args] { + return $line + } else { + upvar [lindex $args 0] data + set data $line + return [string length $line] + } + } + hid* { + ## 'hide' - hides the console with 'withdraw'. + wm withdraw $tkCon(root) + } + his* { + ## 'history' + set sub {\2} + if [string match -n* $args] { append sub "\n" } + set h [tkConEvalSlave history] + regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h + return $h + } + ico* { + ## 'iconify' - iconifies the console with 'iconify'. + wm iconify $tkCon(root) + } + mas* - eval { + ## 'master' - evals contents in master interpreter + uplevel \#0 $args + } + set { + ## 'set' - set (or get, or unset) simple variables (not whole arrays) + ## from the master console interpreter + ## possible formats: + ## tkcon set + ## tkcon set + ## tkcon set w + ## tkcon set u + ## tkcon set r + if {[llength $args]==5} { + ## This is for use with 'tkcon upvar' and only works with slaves + set var [lindex $args 0] + set i [lindex $args 1] + set var1 [lindex $args 2] + set var2 [lindex $args 3] + if [string compare {} $var2] { append var1 "($var2)" } + set op [lindex $args 4] + switch $op { + u { uplevel \#0 [list unset $var] } + w { + return [uplevel \#0 set \{$var\} [interp eval $i set \{$var1\}]] + } + r { + return [interp eval $i set \{$var1\} [uplevel \#0 set \{$var\}]] + } + } + } + return [uplevel \#0 set $args] + } + sh* - dei* { + ## 'show|deiconify' - deiconifies the console. + wm deiconify $tkCon(root) + raise $tkCon(root) + } + ti* { + ## 'title' ?title? - gets/sets the console's title + if [string comp {} $args] { + return [wm title $tkCon(root) $args] + } else { + return [wm title $tkCon(root)] + } + } + u* { + ## 'upvar' masterVar slaveVar + ## link slave variable slaveVar to the master variable masterVar + ## only works masters<->slave + set masterVar [lindex $args 0] + set slaveVar [lindex $args 1] + if [info exists $masterVar] { + interp eval $tkCon(exec) [list set $myVar [set $masterVar]] + } else { + catch {interp eval $tkCon(exec) [list unset $myVar]} + } + interp eval $tkCon(exec) [list trace variable $myVar rwu \ + [list tkcon set $masterVar $tkCon(exec)]] + return + } + v* { + return $tkCon(version) + } + default { + ## tries to determine if the command exists, otherwise throws error + set new tkCon[string toup [string index $cmd 0]][string range $cmd 1 end] + if [string comp {} [info command $new]] { + uplevel \#0 $new $args + } else { + return -code error "bad option \"$cmd\": must be\ + [join [lsort [list attach close console destroy font hide \ + iconify load main master new save show slave deiconify \ + version title bgerror]] {, }]" + } + } + } +} + +## +## Some procedures to make up for lack of built-in shell commands +## + +## puts +## This allows me to capture all stdout/stderr to the console window +# ARGS: same as usual +# Outputs: the string with a color-coded text tag +## +if ![catch {rename puts tcl_puts}] { + proc puts args { + set len [llength $args] + if {$len==1} { + eval tkcon console insert output $args stdout {\n} stdout + tkcon console see output + } elseif {$len==2 && \ + [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} { + if [string comp $tmp -nonewline] { + eval tkcon console insert output [lreplace $args 0 0] $tmp {\n} $tmp + } else { + eval tkcon console insert output [lreplace $args 0 0] stdout + } + tkcon console see output + } elseif {$len==3 && \ + [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { + if [string comp [lreplace $args 1 2] -nonewline] { + eval tkcon console insert output [lrange $args 1 1] $tmp + } else { + eval tkcon console insert output [lreplace $args 0 1] $tmp + } + tkcon console see output + } else { + global errorCode errorInfo + if [catch "tcl_puts $args" msg] { + regsub tcl_puts $msg puts msg + regsub -all tcl_puts $errorInfo puts errorInfo + error $msg + } + return $msg + } + if $len update + } +} + +## echo +## Relaxes the one string restriction of 'puts' +# ARGS: any number of strings to output to stdout +## +proc echo args { puts [concat $args] } + +## clear - clears the buffer of the console (not the history though) +## This is executed in the parent interpreter +## +proc clear {{pcnt 100}} { + if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { + return -code error \ + "invalid percentage to clear: must be 1-100 (100 default)" + } elseif {$pcnt == 100} { + tkcon console delete 1.0 end + } else { + set tmp [expr $pcnt/100.0*[tkcon console index end]] + tkcon console delete 1.0 "$tmp linestart" + } +} + +## alias - akin to the csh alias command +## If called with no args, then it dumps out all current aliases +## If called with one arg, returns the alias of that arg (or {} if none) +# ARGS: newcmd - (optional) command to bind alias to +# args - command and args being aliased +## +proc alias {{newcmd {}} args} { + if [string match {} $newcmd] { + set res {} + foreach a [interp aliases] { + lappend res [list $a -> [interp alias {} $a]] + } + return [join $res \n] + } elseif {[string match {} $args]} { + interp alias {} $newcmd + } else { + eval interp alias [list {} $newcmd {}] $args + } +} + +## unalias - unaliases an alias'ed command +# ARGS: cmd - command to unbind as an alias +## +proc unalias {cmd} { + interp alias {} $cmd {} +} + +## dump - outputs variables/procedure/widget info in source'able form. +## Accepts glob style pattern matching for the names +# ARGS: type - type of thing to dump: must be variable, procedure, widget +# OPTS: -nocomplain +# don't complain if no vars match something +# -filter pattern +# specifies a glob filter pattern to be used by the variable +# method as an array filter pattern (it filters down for +# nested elements) and in the widget method as a config +# option filter pattern +# -- forcibly ends options recognition +# Returns: the values of the requested items in a 'source'able form +## +proc dump {type args} { + set whine 1 + set code ok + while {[string match -* $args]} { + switch -glob -- [lindex $args 0] { + -n* { set whine 0; set args [lreplace $args 0 0] } + -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] } + -- { set args [lreplace $args 0 0]; break } + default { return -code error "unknown option \"[lindex $args 0]\"" } + } + } + if {$whine && [string match {} $args]} { + return -code error "wrong \# args: [lindex [info level 0] 0]\ + ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?" + } + set res {} + switch -glob -- $type { + c* { + # command + # outpus commands by figuring out, as well as possible, what it is + # this does not attempt to auto-load anything + foreach arg $args { + if [string comp {} [set cmds [info comm $arg]]] { + foreach cmd [lsort $cmds] { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + append res "\#\# ALIAS: $cmd => [interp alias {} $cmd]\n" + } elseif {[string comp {} [info procs $cmd]]} { + if {[catch {dump p -- $cmd} msg] && $whine} { set code error } + append res $msg\n + } else { + append res "\#\# COMMAND: $cmd\n" + } + } + } elseif $whine { + append res "\#\# No known command $arg\n" + set code error + } + } + } + v* { + # variable + # outputs variables value(s), whether array or simple. + if ![info exists fltr] { set fltr * } + foreach arg $args { + if {[string match {} [set vars [uplevel info vars [list $arg]]]]} { + if {[uplevel info exists $arg]} { + set vars $arg + } elseif $whine { + append res "\#\# No known variable $arg\n" + set code error + continue + } else continue + } + foreach var [lsort $vars] { + upvar $var v + if {[array exists v]} { + set nest {} + append res "array set $var \{\n" + foreach i [lsort [array names v $fltr]] { + upvar 0 v\($i\) __ary + if {[array exists __ary]} { + append nest "\#\# NESTED ARRAY ELEMENT: $i\n" + append nest "upvar 0 [list $var\($i\)] __ary;\ + [dump v -filter $fltr __ary]\n" + } else { + append res " [list $i]\t[list $v($i)]\n" + } + } + append res "\}\n$nest" + } else { + append res [list set $var $v]\n + } + } + } + } + p* { + # procedure + foreach arg $args { + if {[string comp {} [set ps [info proc $arg]]] || + ([auto_load $arg] && + [string comp {} [set ps [info proc $arg]]])} { + foreach p [lsort $ps] { + set as {} + foreach a [info args $p] { + if {[info default $p $a tmp]} { + lappend as [list $a $tmp] + } else { + lappend as $a + } + } + append res [list proc $p $as [info body $p]]\n + } + } elseif $whine { + append res "\#\# No known proc $arg\n" + set code error + } + } + } + w* { + # widget + ## The user should have Tk loaded + if [string match {} [info command winfo]] { + return -code error "winfo not present, cannot dump widgets" + } + if ![info exists fltr] { set fltr .* } + foreach arg $args { + if [string comp {} [set ws [info command $arg]]] { + foreach w [lsort $ws] { + if [winfo exists $w] { + if [catch {$w configure} cfg] { + append res "\#\# Widget $w does not support configure method" + set code error + } else { + append res "\#\# [winfo class $w] $w\n$w configure" + foreach c $cfg { + if {[llength $c] != 5} continue + if {[regexp -nocase -- $fltr $c]} { + append res " \\\n\t[list [lindex $c 0] [lindex $c 4]]" + } + } + append res \n + } + } + } + } elseif $whine { + append res "\#\# No known widget $arg\n" + set code error + } + } + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"$type\":\ must be procedure, variable, widget" + } + } + return -code $code [string trimr $res \n] +} + +## idebug - interactive debugger +# ARGS: opt +# +## +proc idebug {opt args} { + global IDEBUG + + if ![info exists IDEBUG(on)] { array set IDEBUG { on 0 id * debugging 0 } } + set level [expr [info level]-1] + switch -glob -- $opt { + on { + if [string comp {} $args] { set IDEBUG(id) $args } + return [set IDEBUG(on) 1] + } + off { return [set IDEBUG(on) 0] } + id { + if [string match {} $args] { + return $IDEBUG(id) + } else { return [set IDEBUG(id) $args] } + } + break { + if {!$IDEBUG(on) || $IDEBUG(debugging) || ([string comp {} $args] \ + && ![string match $IDEBUG(id) $args]) || [info level]<1} return + set IDEBUG(debugging) 1 + puts stderr "idebug at level \#$level: [lindex [info level -1] 0]" + set tkcon [string comp {} [info command tkcon]] + if $tkcon { + tkcon show + tkcon master eval set tkCon(prompt2) \$tkCon(prompt1) + tkcon master eval set tkCon(prompt1) \$tkCon(debugPrompt) + set slave [tkcon set tkCon(exec)] + set event [tkcon set tkCon(event)] + tkcon set tkCon(exec) [tkcon master interp create debugger] + tkcon set tkCon(event) 1 + } + set max $level + while 1 { + set err {} + if $tkcon { + tkcon evalSlave set level $level + tkcon prompt + set line [tkcon gets] + tkcon console mark set output end + } else { + puts -nonewline stderr "(level \#$level) debug > " + gets stdin line + while {![info complete $line]} { puts -nonewline "> " - } - } - flush stdout - .console.t mark set output $temp - tkTextSetCursor .console.t end - .console.t mark set promptEnd insert - .console.t mark gravity promptEnd left -} - -# tkConsoleBind -- -# This procedure first ensures that the default bindings for the Text -# class have been defined. Then certain bindings are overridden for -# the class. -# -# Arguments: -# None. - -proc tkConsoleBind {win} { - bindtags $win "$win Text . all" - - # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. - # Otherwise, if a widget binding for one of these is defined, the - # class binding will also fire and insert the character, - # which is wrong. Ditto for . - - bind $win {# nothing } - bind $win {# nothing} - bind $win {# nothing} - bind $win {# nothing} - bind $win {# nothing} - - bind $win { - tkConsoleInsert %W \t - focus %W - break - } - bind $win { - %W mark set insert {end - 1c} - tkConsoleInsert %W "\n" - tkConsoleInvoke - break - } - bind $win { - if {[%W tag nextrange sel 1.0 end] != ""} { - %W tag remove sel sel.first promptEnd - } else { - if [%W compare insert < promptEnd] { - break - } + append line "\n[gets stdin]" + } } - } - bind $win { - if {[%W tag nextrange sel 1.0 end] != ""} { - %W tag remove sel sel.first promptEnd - } else { - if [%W compare insert <= promptEnd] { - break - } + if [string match {} $line] continue + set key [lindex $line 0] + if ![regexp {^([\#-]?[0-9]+)} [lreplace $line 0 0] lvl] { + set lvl \#$level } + set res {}; set c 0 + switch -- $key { + + { + ## Allow for jumping multiple levels + if {$level < $max} { idebug trace [incr level] $level 0 VERBOSE } + } + - { + ## Allow for jumping multiple levels + if {$level > 1} { idebug trace [incr level -1] $level 0 VERBOSE } + } + . { set c [catch { idebug trace $level $level 0 VERBOSE } res] } + v { set c [catch { idebug show vars $lvl } res] } + V { set c [catch { idebug show vars $lvl VERBOSE } res] } + l { set c [catch { idebug show locals $lvl } res] } + L { set c [catch { idebug show locals $lvl VERBOSE } res] } + g { set c [catch { idebug show globals $lvl } res] } + G { set c [catch { idebug show globals $lvl VERBOSE } res] } + t { set c [catch { idebug trace 1 $max $level } res] } + T { set c [catch { idebug trace 1 $max $level VERBOSE } res] } + b { set c [catch { idebug body $lvl } res] } + o { set res [set IDEBUG(on) [expr !$IDEBUG(on)]] } + h - ? { + puts stderr " + Move down in call stack + - Move up in call stack + . Show current proc name and params + + v Show names of variables currently in scope + V Show names of variables currently in scope with values + l Show names of local (transient) variables + L Show names of local (transient) variables with values + g Show names of declared global variables + G Show names of declared global variables with values + t Show a stack trace + T Show a verbose stack trace + + b Show body of current proc + o Toggle on/off any further debugging + c,q Continue regular execution (Quit debugger) + h,? Print this help + default Evaluate line at current level (\#$level)" + } + c - q break + default { set c [catch {uplevel \#$level $line} res] } + } + if $tkcon { + tkcon set tkCon(event) \ + [tkcon evalSlave eval history add [list $line] \; history nextid] + } + if $c { puts stderr $res } elseif {[string comp {} $res]} { puts $res } + } + set IDEBUG(debugging) 0 + if $tkcon { + tkcon master interp delete debugger + tkcon master eval set tkCon(prompt1) \$tkCon(prompt2) + tkcon set tkCon(exec) $slave + tkcon set tkCon(event) $event + tkcon prompt + } } - foreach left {Control-a Home} { - bind $win <$left> { - if [%W compare insert < promptEnd] { - tkTextSetCursor %W {insert linestart} + bo* { + if [regexp {^([\#-]?[0-9]+)} $args level] { + return [uplevel $level { dump com -no [lindex [info level 0] 0] }] + } + } + t* { + if {[llength $args]<2} return + set min [set max [set lvl $level]] + if ![regexp {^\#?([0-9]+)? ?\#?([0-9]+) ?\#?([0-9]+)? ?(VERBOSE)?} \ + $args junk min max lvl verbose] return + for {set i $max} { + $i>=$min && ![catch {uplevel \#$i info level 0} info] + } {incr i -1} { + if {$i==$lvl} { + puts -nonewline stderr "* \#$i:\t" + } else { + puts -nonewline stderr " \#$i:\t" + } + set name [lindex $info 0] + if {[string comp VERBOSE $verbose] || \ + [string match {} [info procs $name]]} { + puts $info + } else { + puts "proc $name {[info args $name]} { ... }" + set idx 0 + foreach arg [info args $name] { + if [string match args $arg] { + puts "\t$arg = [lrange $info [incr idx] end]"; break } else { - tkTextSetCursor %W promptEnd - } - break - } - } - foreach right {Control-e End} { - bind $win <$right> { - tkTextSetCursor %W {insert lineend} - break - } - } - bind $win { - if [%W compare insert < promptEnd] { - break - } - } - bind $win { - if [%W compare insert < promptEnd] { - %W mark set insert promptEnd - } - } - bind $win { - if [%W compare insert < promptEnd] { - break - } - } - bind $win { - if [%W compare insert < promptEnd] { - break - } - } - bind $win { - if [%W compare insert <= promptEnd] { - break - } - } - bind $win { - if [%W compare insert <= promptEnd] { - break - } - } - foreach prev {Control-p Up} { - bind $win <$prev> { - tkConsoleHistory prev - break - } - } - foreach prev {Control-n Down} { - bind $win <$prev> { - tkConsoleHistory next - break - } - } - bind $win { - if [%W compare insert > promptEnd] { - catch { - %W insert insert [selection get -displayof %W] {input stdin} - %W see insert + puts "\t$arg = [lindex $info [incr idx]]" } + } } - break + } } - bind $win { - catch {tkConsoleInsert %W [selection get -displayof %W]} - break + s* { + #var, local, global + set level \#$level + if ![regexp {^([vgl][^ ]*) ?([\#-]?[0-9]+)? ?(VERBOSE)?} \ + $args junk type level verbose] return + switch -glob -- $type { + v* { set vars [uplevel $level {lsort [info vars]}] } + l* { set vars [uplevel $level {lsort [info locals]}] } + g* { set vars [lremove [uplevel $level {info vars}] \ + [uplevel $level {info locals}]] } + } + if [string match VERBOSE $verbose] { + return [uplevel $level dump var -nocomplain $vars] + } else { + return $vars + } } - bind $win { - tkConsoleInsert %W %A - break + e* - pu* { + if {[llength $opt]==1 && [catch {lindex [info level -1] 0} id]} { + set id [lindex [info level 0] 0] + } else { + set id [lindex $opt 1] + } + if {$IDEBUG(on) && [string match $IDEBUG(id) $id]} { + if [string match e* $opt] { + puts [concat $args] + } else { eval puts $args } + } } - foreach left {Control-b Left} { - bind $win <$left> { - if [%W compare insert == promptEnd] { - break - } - tkTextSetCursor %W insert-1c - break - } - } - foreach right {Control-f Right} { - bind $win <$right> { - tkTextSetCursor %W insert+1c - break - } - } - bind $win { - eval destroy [winfo child .] - source $tk_library/console.tcl - } - foreach copy {F16 Meta-w Control-i} { - bind $win <$copy> { - if {[selection own -displayof %W] == "%W"} { - clipboard clear -displayof %W - catch { - clipboard append -displayof %W [selection get -displayof %W] - } - } - break - } - } - foreach paste {F18 Control-y} { - bind $win <$paste> { - catch { - set clip [selection get -displayof %W -selection CLIPBOARD] - set list [split $clip \n\r] - tkConsoleInsert %W [lindex $list 0] - foreach x [lrange $list 1 end] { - %W mark set insert {end - 1c} - tkConsoleInsert %W "\n" - tkConsoleInvoke - tkConsoleInsert %W $x - } - } - break - } + default { + return -code error "bad [lindex [info level 0] 0] option \"$opt\":\ + must be [join [lsort [list on off id break print body trace \ + show puts echo]] {, }]" } + } } -# tkConsoleInsert -- -# Insert a string into a text at the point of the insertion cursor. -# If there is a selection in the text, and it covers the point of the -# insertion cursor, then delete the selection before inserting. Insertion -# is restricted to the prompt area. +## observe - like trace, but not +# ARGS: opt - option +# name - name of variable or command +## +proc observe {opt name args} { + global tcl_observe + switch -glob -- $opt { + co* { + if [regexp {^(catch|lreplace|set|puts|for|incr|info|uplevel)$} $name] { + return -code error \ + "cannot observe \"$name\": infinite eval loop will occur" + } + set old ${name}@ + while {[string comp {} [info command $old]]} { append old @ } + rename $name $old + set max 4 + regexp {^[0-9]+} $args max + ## idebug trace could be used here + proc $name args " + for {set i \[info level\]; set max \[expr \[info level\]-$max\]} { + \$i>=\$max && !\[catch {uplevel \#\$i info level 0} info\] + } {incr i -1} { + puts -nonewline stderr \" \#\$i:\t\" + puts \$info + } + uplevel \[lreplace \[info level 0\] 0 0 $old\] + " + set tcl_observe($name) $old + } + cd* { + if {[info exists tcl_observe($name)] && [catch { + rename $name {} + rename $tcl_observe($name) $name + unset tcl_observe($name) + } err]} { return -code error $err } + } + ci* { + ## What a useless method... + if [info exists tcl_observe($name)] { + set i $tcl_observe($name) + set res "\"$name\" observes true command \"$i\"" + while {[info exists tcl_observe($i)]} { + append res "\n\"$name\" observes true command \"$i\"" + set i $tcl_observe($name) + } + return $res + } + } + va* - vd* { + set type [lindex $args 0] + set args [lrange $args 1 end] + if ![regexp {^[rwu]} $type type] { + return -code error "bad [lindex [info level 0] 0] $opt type\ + \"$type\": must be read, write or unset" + } + if [string match {} $args] { set args observe_var } + uplevel [list trace $opt $name $type $args] + } + vi* { + uplevel [list trace vinfo $name] + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"[lindex $args 0]\": must be [join [lsort [list procedure \ + pdelete pinfo variable vdelete vinfo]] {, }]" + } + } +} + +## observe_var - auxilary function for observing vars, called by trace +## via observe +# ARGS: name - variable name +# el - array element name, if any +# op - operation type (rwu) +## +proc observe_var {name el op} { + if [string match u $op] { + if [string comp {} $el] { + puts "unset \"$name\($el\)\"" + } else { + puts "unset \"$name\"" + } + } else { + upvar $name $name + if [info exists $name\($el\)] { + puts [dump v $name\($el\)] + } else { + puts [dump v $name] + } + } +} + +## which - tells you where a command is found +# ARGS: cmd - command name +# Returns: where command is found (internal / external / unknown) +## +proc which cmd { + if {[string comp {} [info commands $cmd]] || + ([auto_load $cmd] && [string comp {} [info commands $cmd]])} { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + return "$cmd:\taliased to [alias $cmd]" + } elseif {[string comp {} [info procs $cmd]]} { + return "$cmd:\tinternal proc" + } else { + return "$cmd:\tinternal command" + } + } elseif {[string comp {} [auto_execok $cmd]]} { + return [auto_execok $cmd] + } else { + return -code error "$cmd:\tunknown command" + } +} + +## auto_execpath - tells you where an external command is found +## Only a slight modification from core auto_execok proc +# ARGS: cmd - command name +# Returns: where command is found or {} if not found +## +if {[info tclversion]<7.6} { +if {[string match $tcl_platform(platform) windows]} { + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to a shell builtin or an executable in the +# Windows search path, or "" otherwise. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +# Windows version. +# +# Note that info executable doesn't work under Windows, so we have to +# look for files with .exe, .com, or .bat extensions. Also, the path +# may be in the Path or PATH environment variables, and path +# components are separated with semicolons, not colons as under Unix. +# +proc auto_execok name { + global auto_execs env tcl_platform + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) "" + + if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename + ren rmdir rd time type ver vol} $name] != -1} { + if {[info exists env(COMSPEC)]} { + set comspec $env(COMSPEC) + } elseif {[info exists env(ComSpec)]} { + set comspec $env(ComSpec) + } elseif {$tcl_platform(os) == "Windows NT"} { + set comspec "cmd.exe" + } else { + set comspec "command.com" + } + return [set auto_execs($name) [list $comspec /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext {{} .com .exe .bat} { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) $file] + } + } + return "" + } + + set path "[file dirname [info nameof]];.;" + if {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } elseif {[info exists env(windir)]} { + set windir $env(windir) + } + if {[info exists windir]} { + if {$tcl_platform(os) == "Windows NT"} { + append path "$windir/system32;" + } + append path "$windir/system;$windir;" + } + + if {! [info exists env(PATH)]} { + if [info exists env(Path)] { + append path $env(Path) + } else { + return "" + } + } else { + append path $env(PATH) + } + + foreach dir [split $path {;}] { + if {$dir == ""} { + set dir . + } + foreach ext {{} .com .exe .bat} { + set file [file join $dir ${name}${ext}] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) $file] + } + } + } + return "" +} + +} else { + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to an executable in the path. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +# Unix version. +# +proc auto_execok name { + global auto_execs env + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) "" + if {[llength [file split $name]] != 1} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execs($name) $name + } + return $auto_execs($name) + } + foreach dir [split $env(PATH) :] { + if {$dir == ""} { + set dir . + } + set file [file join $dir $name] + if {[file executable $file] && ![file isdirectory $file]} { + set auto_execs($name) $file + return $file + } + } + return "" +} + +} +} + +## dir - directory list +# ARGS: args - names/glob patterns of directories to list +# OPTS: -all - list hidden files as well (Unix dot files) +# -long - list in full format "permissions size date filename" +# -full - displays / after directories and link paths for links +# Returns: a directory listing +## +proc dir {args} { + array set s { + all 0 full 0 long 0 + 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx + } + while {[string match \-* [lindex $args 0]]} { + set str [lindex $args 0] + set args [lreplace $args 0 0] + switch -glob -- $str { + -a* {set s(all) 1} -f* {set s(full) 1} + -l* {set s(long) 1} -- break + default { + return -code error \ + "unknown option \"$str\", should be one of: -all, -full, -long" + } + } + } + set sep [string trim [file join . .] .] + if [string match {} $args] { set args . } + foreach arg $args { + if {[file isdir $arg]} { + set arg [string trimr $arg $sep]$sep + if $s(all) { + lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]] + } else { + lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]] + } + } else { + lappend out [list [file dirname $arg]$sep \ + [lsort [glob -nocomplain -- $arg]]] + } + } + if $s(long) { + set old [clock scan {1 year ago}] + set fmt "%s%9d %s %s\n" + foreach o $out { + set d [lindex $o 0] + append res $d:\n + foreach f [lindex $o 1] { + file lstat $f st + set f [file tail $f] + if $s(full) { + switch -glob $st(type) { + d* { append f $sep } + l* { append f "@ -> [file readlink $d$sep$f]" } + default { if [file exec $d$sep$f] { append f * } } + } + } + if [string match file $st(type)] { + set mode - + } else { + set mode [string index $st(type) 0] + } + foreach j [split [format %o [expr $st(mode)&0777]] {}] { + append mode $s($j) + } + if {$st(mtime)>$old} { + set cfmt {%b %d %H:%M} + } else { + set cfmt {%b %d %Y} + } + append res [format $fmt $mode $st(size) \ + [clock format $st(mtime) -format $cfmt] $f] + } + append res \n + } + } else { + foreach o $out { + set d [lindex $o 0] + append res $d:\n + set i 0 + foreach f [lindex $o 1] { + if {[string len [file tail $f]] > $i} { + set i [string len [file tail $f]] + } + } + set i [expr $i+2+$s(full)] + ## This gets the number of cols in the TkCon console widget + set j [expr [tkcon master set tkCon(cols)]/$i] + set k 0 + foreach f [lindex $o 1] { + set f [file tail $f] + if $s(full) { + switch -glob [file type $d$sep$f] { + d* { append f $sep } + l* { append f @ } + default { if [file exec $d$sep$f] { append f * } } + } + } + append res [format "%-${i}s" $f] + if {[incr k]%$j == 0} {set res [string trimr $res]\n} + } + append res \n\n + } + } + return [string trimr $res] +} +interp alias {} ls {} dir + +## tclindex - creates the tclIndex file +# OPTS: -ext - extensions to auto index (defaults to *.tcl) +# -pkg - whether to create a pkgIndex.tcl file +# -idx - whether to create a tclIndex file +# ARGS: args - directories to auto index (defaults to pwd) +# Outputs: tclIndex/pkgIndex.tcl file to each directory +## +proc tclindex args { + set truth {^(1|yes|true|on)$}; set pkg 0; set idx 1; + while {[regexp -- {^-[^ ]+} $args opt] && [string comp {} $args]} { + switch -glob -- $opt { + -- { set args [lreplace $args 0 0]; break } + -e* { set ext [lindex $args 1] } + -p* { set pkg [regexp -nocase $truth [lindex $args 1]] } + -i* { set idx [regexp -nocase $truth [lindex $args 1]] } + default { + return -code error "bad option \"$opt\": must be one of\ + [join [lsort [list -- -extension -package -index]] {, }]" + } + set args [lreplace $args 0 1] + } + } + if ![info exists ext] { + set ext {*.tcl} + if $pkg { lappend ext *[info sharedlibextension] } + } + if [string match {} $args] { + if $idx { eval auto_mkindex [list [pwd]] $ext } + if $pkg { eval pkg_mkIndex [list [pwd]] $ext } + } else { + foreach dir $args { + if [file isdir $dir] { + if $idx { eval auto_mkindex [list [pwd]] $ext } + if $pkg { eval pkg_mkIndex [list [pwd]] $ext } + } + } + } +} + +## lremove - remove items from a list +# OPTS: -all remove all instances of each item +# ARGS: l a list to remove items from +# args items to remove +## +proc lremove {args} { + set all 0 + if [string match \-a* [lindex $args 0]] { + set all 1 + set args [lreplace $args 0 0] + } + set l [lindex $args 0] + eval append is [lreplace $args 0 0] + foreach i $is { + if {[set ix [lsearch -exact $l $i]] == -1} continue + set l [lreplace $l $ix $ix] + if $all { + while {[set ix [lsearch -exact $l $i]] != -1} { + set l [lreplace $l $ix $ix] + } + } + } + return $l +} + +## Unknown changed to get output into tkCon window +# unknown: +# Invoked automatically whenever an unknown command is encountered. +# Works through a list of "unknown handlers" that have been registered +# to deal with unknown commands. Extensions can integrate their own +# handlers into the "unknown" facility via "unknown_handle". +# +# If a handler exists that recognizes the command, then it will +# take care of the command action and return a valid result or a +# Tcl error. Otherwise, it should return "-code continue" (=2) +# and responsibility for the command is passed to the next handler. # # Arguments: -# w - The text window in which to insert the string -# s - The string to insert (usually just a single character) +# args - A list whose elements are the words of the original +# command, including the command name. -proc tkConsoleInsert {w s} { - if {$s == ""} { - return +proc unknown args { + global unknown_handler_order unknown_handlers errorInfo errorCode + + # + # Be careful to save error info now, and restore it later + # for each handler. Some handlers generate their own errors + # and disrupt handling. + # + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + + if {![info exists unknown_handler_order] || ![info exists unknown_handlers]} { + set unknown_handlers(tcl) tcl_unknown + set unknown_handler_order tcl } + + foreach handler $unknown_handler_order { + set status [catch {uplevel $unknown_handlers($handler) $args} result] + + if {$status == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code $status -errorcode $errorCode \ + -errorinfo $new $result + + } elseif {$status != 4} { + return -code $status $result + } + + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + } + + set name [lindex $args 0] + return -code error "invalid command name \"$name\"" +} + +# tcl_unknown: +# Invoked when a Tcl command is invoked that doesn't exist in the +# interpreter: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +proc tcl_unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + unset unknown_pending($name) + if ![array size unknown_pending] { unset unknown_pending } + return -code error \ + "self-referential recursion in \"unknown\" for command \"$name\"" + } + ## FIX delete line + set unknown_pending(dummy) dummy + set unknown_pending($name) pending + set ret [catch {auto_load $name} msg] + ## FIX no catch + catch { unset unknown_pending($name) } + if $ret { + return -code $ret -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { unset unknown_pending } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + if {[info level] == 1 && [string match {} [info script]] \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + set new [auto_execok $name] + if {$new != ""} { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + return [uplevel exec [list $new] [lrange $args 1 end]] + #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + ## + ## History substitution moved into tkConEvalCmd + ## + set cmds [info commands $name*] + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } + if {[llength $cmds]} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code continue +} + +proc tkConBindings {} { + global tkCon tcl_platform tk_version + + #----------------------------------------------------------------------- + # Elements of tkPriv that are used in this file: + # + # char - Character position on the line; kept in order + # to allow moving up or down past short lines while + # still remembering the desired position. + # mouseMoved - Non-zero means the mouse has moved a significant + # amount since the button went down (so, for example, + # start dragging out a selection). + # prevPos - Used when moving up or down lines via the keyboard. + # Keeps track of the previous insert position, so + # we can distinguish a series of ups and downs, all + # in a row, from a new up or down. + # selectMode - The style of selection currently underway: + # char, word, or line. + # x, y - Last known mouse coordinates for scanning + # and auto-scanning. + #----------------------------------------------------------------------- + + switch -glob $tcl_platform(platform) { + win* { set tkCon(meta) Alt } + mac* { set tkCon(meta) Command } + default { set tkCon(meta) Meta } + } + + ## <> + bind $tkCon(root) tkConExit + ## <> + bind $tkCon(root) { tkConNew } + ## <> + bind $tkCon(root) { tkConDestroy } + ## <> + bind $tkCon(root) { tkConAbout } + ## <> + bind $tkCon(root) { tkConHelp } + ## <> + bind $tkCon(root) { tkConFindBox $tkCon(console) } + ## <> + bind $tkCon(root) { + tkConAttach {} + tkConPrompt "\n" [tkConCmdGet $tkCon(console)] + } + ## <> + bind $tkCon(root) { + if [string comp {} $tkCon(name)] { + tkConAttach $tkCon(name) + } else { + tkConAttach Main + } + tkConPrompt "\n" [tkConCmdGet $tkCon(console)] + } + ## <> + bind $tkCon(root) { + tkConAttach Main + tkConPrompt "\n" [tkConCmdGet $tkCon(console)] + } + + ## Menu items need null PostCon bindings to avoid the TagProc + ## + foreach ev [bind $tkCon(root)] { + bind PostCon $ev { + # empty + } + } + + # tkConClipboardKeysyms -- + # This procedure is invoked to identify the keys that correspond to + # the "copy", "cut", and "paste" functions for the clipboard. + # + # Arguments: + # copy - Name of the key (keysym name plus modifiers, if any, + # such as "Meta-y") used for the copy operation. + # cut - Name of the key used for the cut operation. + # paste - Name of the key used for the paste operation. + + proc tkConClipboardKeysyms {copy cut paste} { + bind Console <$copy> {tkConCopy %W} + bind Console <$cut> {tkConCut %W} + bind Console <$paste> {tkConPaste %W} + } + + proc tkConCut w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch { + clipboard append -displayof $w [selection get -displayof $w] + if [$w compare sel.first >= limit] {$w delete sel.first sel.last} + } + } + } + proc tkConCopy w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch {clipboard append -displayof $w [selection get -displayof $w]} + } + } + + proc tkConPaste w { + if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] { + if [$w compare insert < limit] {$w mark set insert end} + $w insert insert $tmp + $w see insert + if [string match *\n* $tmp] {tkConEval $w} + } + } + + ## Get all Text bindings into Console except Unix cut/copy/paste + ## and newline insertion + foreach ev [lremove [bind Text] { \ + \ + }] { + bind Console $ev [bind Text $ev] + } + + ## Redefine for Console what we need + ## + if [string compare {} [info command event]] { + event delete <> + tkConClipboardKeysyms + } else { + tkConClipboardKeysyms F16 F20 F18 + tkConClipboardKeysyms Control-c Control-x Control-v + } + + bind Console {catch {tkConInsert %W [selection get -displayof %W]}} + + bind Console {+ catch { - if {[$w compare sel.first <= insert] - && [$w compare sel.last >= insert]} { - $w tag remove sel sel.first promptEnd - $w delete sel.first sel.last + eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last] + %W mark set insert sel.first + } + } + + ## binding editor needed + ## binding for .tkconrc + + ## <> + bind Console { + if [%W compare {insert linestart} != {limit linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W -1] + } else { + if {$tkCon(event) == [tkConEvalSlave history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } + if [catch {tkConEvalSlave history event \ + [incr tkCon(event) -1]} tkCon(tmp)] { + incr tkCon(event) + } else { + %W delete limit end + %W insert limit $tkCon(tmp) + %W see end + } + } + } + ## <> + bind Console { + if [%W compare {insert linestart} != {end-1c linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W 1] + } else { + if {$tkCon(event) < [tkConEvalSlave history nextid]} { + %W delete limit end + if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} { + %W insert limit $tkCon(cmdbuf) + } else { + %W insert limit [tkConEvalSlave history event $tkCon(event)] } + %W see end + } } - if {[$w compare insert < promptEnd]} { - $w mark set insert end + } + ## <> + bind Console { + if [%W compare insert > limit] {tkConExpand %W path} + break + } + ## <> + bind Console { + if [%W compare insert > limit] {tkConExpand %W proc} + } + ## <> + bind Console { + if [%W compare insert > limit] {tkConExpand %W var} + } + ## <> + bind Console { + if [%W compare insert >= limit] { + tkConInsert %W \t } - $w insert insert $s {input stdin} - $w see insert + } + ## <> - no mod + bind Console { + tkConEval %W + } + bind Console [bind Console ] + bind Console { + if {[string comp {} [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= limit]} { + %W delete sel.first sel.last + } elseif {[%W compare insert >= limit]} { + %W delete insert + %W see insert + } + } + bind Console { + if {[string comp {} [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= limit]} { + %W delete sel.first sel.last + } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} { + %W delete insert-1c + %W see insert + } + } + bind Console [bind Console ] + + bind Console { + tkConInsert %W %A + } + + bind Console { + if [%W compare {limit linestart} == {insert linestart}] { + tkTextSetCursor %W limit + } else { + tkTextSetCursor %W {insert linestart} + } + } + bind Console { + if [%W compare insert < limit] break + %W delete insert + } + bind Console { + if [%W compare insert < limit] break + if [%W compare insert == {insert lineend}] { + %W delete insert + } else { + %W delete insert {insert lineend} + } + } + ## <> + bind Console { + ## Clear console buffer, without losing current command line input + set tkCon(tmp) [tkConCmdGet %W] + clear + tkConPrompt {} $tkCon(tmp) + } + ## <> + bind Console { + ## Goto next command in history + if {$tkCon(event) < [tkConEvalSlave history nextid]} { + %W delete limit end + if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} { + %W insert limit $tkCon(cmdbuf) + } else { + %W insert limit [tkConEvalSlave history event $tkCon(event)] + } + %W see end + } + } + ## <> + bind Console { + ## Goto previous command in history + if {$tkCon(event) == [tkConEvalSlave history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } + if [catch {tkConEvalSlave history event \ + [incr tkCon(event) -1]} tkCon(tmp)] { + incr tkCon(event) + } else { + %W delete limit end + %W insert limit $tkCon(tmp) + %W see end + } + } + ## <> + bind Console { + ## Search history reverse + if {$tkCon(event) == [tkConEvalSlave history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } elseif 0 { + ## FIX + ## event ids get confusing (to user) when they 'cancel' a history + ## search. This should reassign the event id properly. + } + set tkCon(tmp1) [string len $tkCon(cmdbuf)] + incr tkCon(tmp1) -1 + while 1 { + if {[catch {tkConEvalSlave history event \ + [incr tkCon(event) -1]} tkCon(tmp)]} { + incr tkCon(event) + break + } elseif {![string comp $tkCon(cmdbuf) \ + [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} { + %W delete limit end + %W insert limit $tkCon(tmp) + break + } + } + %W see end + } + ## <> + bind Console { + ## Search history forward + set tkCon(tmp1) [string len $tkCon(cmdbuf)] + incr tkCon(tmp1) -1 + while {$tkCon(event) < [tkConEvalSlave history nextid]} { + if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} { + %W delete limit end + %W insert limit $tkCon(cmdbuf) + break + } elseif {![catch {tkConEvalSlave history event \ + $tkCon(event)} tkCon(tmp)] + && ![string comp $tkCon(cmdbuf) \ + [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} { + %W delete limit end + %W insert limit $tkCon(tmp) + break + } + } + %W see end + } + ## <> + bind Console { + ## Transpose current and previous chars + if [%W compare insert > limit] { tkTextTranspose %W } + } + ## <> + bind Console { + ## Clear command line (Unix shell staple) + %W delete limit end + } + ## <> + bind Console { + ## Save command buffer (swaps with current command) + set tkCon(tmp) $tkCon(cmdsave) + set tkCon(cmdsave) [tkConCmdGet %W] + if {[string match {} $tkCon(cmdsave)]} { + set tkCon(cmdsave) $tkCon(tmp) + } else { + %W delete limit end-1c + } + tkConInsert %W $tkCon(tmp) + %W see end + } + catch {bind Console { tkTextScrollPages %W -1 }} + catch {bind Console { tkTextScrollPages %W -1 }} + catch {bind Console { tkTextScrollPages %W 1 }} + catch {bind Console { tkTextScrollPages %W 1 }} + bind Console <$tkCon(meta)-d> { + if [%W compare insert >= limit] { + %W delete insert {insert wordend} + } + } + bind Console <$tkCon(meta)-BackSpace> { + if [%W compare {insert -1c wordstart} >= limit] { + %W delete {insert -1c wordstart} insert + } + } + bind Console <$tkCon(meta)-Delete> { + if [%W compare insert >= limit] { + %W delete insert {insert wordend} + } + } + bind Console { + if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \ + && ![catch {selection get -displayof %W} tkCon(tmp)]} { + if [%W compare @%x,%y < limit] { + %W insert end $tkCon(tmp) + } else { + %W insert @%x,%y $tkCon(tmp) + } + if [string match *\n* $tkCon(tmp)] {tkConEval %W} + } + } + + ## + ## End Console bindings + ## + + ## + ## Bindings for doing special things based on certain keys + ## + bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W \( \) limit + } + } + bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W \[ \] limit + } + } + bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W \{ \} limit + } + } + bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchQuote %W limit + } + } + + bind PostCon { + if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W } + } } -# tkConsoleOutput -- -# -# This routine is called directly by ConsolePutsCmd to cause a string -# to be displayed in the console. -# -# Arguments: -# dest - The output tag to be used: either "stderr" or "stdout". -# string - The string to be displayed. - -proc tkConsoleOutput {dest string} { - .console.t insert output $string $dest - .console.t see insert +## tkConTagProc - tags a procedure in the console if it's recognized +## This procedure is not perfect. However, making it perfect wastes +## too much CPU time... Also it should check the existence of a command +## in whatever is the connected slave, not the master interpreter. +## +proc tkConTagProc w { + set i [$w index "insert-1c wordstart"] + set j [$w index "insert-1c wordend"] + if {[string comp {} \ + [tkConEvalAttached info command [list [$w get $i $j]]]]} { + $w tag add proc $i $j + } else { + $w tag remove proc $i $j + } } -# tkConsoleExit -- -# -# This routine is called by ConsoleEventProc when the main window of -# the application is destroyed. -# -# Arguments: -# None. - -proc tkConsoleExit {} { - exit +## tkConMatchPair - blinks a matching pair of characters +## c2 is assumed to be at the text index 'insert'. +## This proc is really loopy and took me an hour to figure out given +## all possible combinations with escaping except for escaped \'s. +## It doesn't take into account possible commenting... Oh well. If +## anyone has something better, I'd like to see/use it. This is really +## only efficient for small contexts. +# ARGS: w - console text widget +# c1 - first char of pair +# c2 - second char of pair +# Calls: tkConBlink +## +proc tkConMatchPair {w c1 c2 {lim 1.0}} { + if [string comp {} [set ix [$w search -back $c1 insert $lim]]] { + while {[string match {\\} [$w get $ix-1c]] && + [string comp {} [set ix [$w search -back $c1 $ix-1c $lim]]]} {} + set i1 insert-1c + while {[string comp {} $ix]} { + set i0 $ix + set j 0 + while {[string comp {} [set i0 [$w search $c2 $i0 $i1]]]} { + append i0 +1c + if {[string match {\\} [$w get $i0-2c]]} continue + incr j + } + if {!$j} break + set i1 $ix + while {$j && [string comp {} [set ix [$w search -back $c1 $ix $lim]]]} { + if {[string match {\\} [$w get $ix-1c]]} continue + incr j -1 + } + } + if [string match {} $ix] { set ix [$w index $lim] } + } else { set ix [$w index $lim] } + tkConBlink $w $ix [$w index insert] } -# now run the gimp main loop -gimp-main +## tkConMatchQuote - blinks between matching quotes. +## Blinks just the quote if it's unmatched, otherwise blinks quoted string +## The quote to match is assumed to be at the text index 'insert'. +# ARGS: w - console text widget +# Calls: tkConBlink +## +proc tkConMatchQuote {w {lim 1.0}} { + set i insert-1c + set j 0 + while {[string comp {} [set i [$w search -back \" $i $lim]]]} { + if {[string match {\\} [$w get $i-1c]]} continue + if {!$j} {set i0 $i} + incr j + } + if [expr $j%2] { + tkConBlink $w $i0 [$w index insert] + } else { + tkConBlink $w [$w index insert-1c] [$w index insert] + } +} + +## tkConBlink - blinks between 2 indices for a specified duration. +# ARGS: w - console text widget +# i1 - start index to blink region +# i2 - end index of blink region +# dur - duration in usecs to blink for +# Outputs: blinks selected characters in $w +## +proc tkConBlink {w i1 i2} { + global tkCon + $w tag add blink $i1 $i2 + after $tkCon(blinktime) $w tag remove blink $i1 $i2 + return +} + + +## tkConInsert +## Insert a string into a text console at the point of the insertion cursor. +## If there is a selection in the text, and it covers the point of the +## insertion cursor, then delete the selection before inserting. +# ARGS: w - text window in which to insert the string +# s - string to insert (usually just a single char) +# Outputs: $s to text widget +## +proc tkConInsert {w s} { + if {[string match {} $s] || [string match disabled [$w cget -state]]} { + return + } + if [$w comp insert < limit] { + $w mark set insert end + } + catch { + if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { + $w delete sel.first sel.last + } + } + $w insert insert $s + $w see insert +} + +## tkConExpand - +# ARGS: w - text widget in which to expand str +# type - type of expansion (path / proc / variable) +# Calls: tkConExpand(Pathname|Procname|Variable) +# Outputs: The string to match is expanded to the longest possible match. +# If tkCon(showmultiple) is non-zero and the user longest match +# equaled the string to expand, then all possible matches are +# output to stdout. Triggers bell if no matches are found. +# Returns: number of matches found +## +proc tkConExpand {w type} { + set exp "\[^\\]\[ \t\n\r\[\{\"\$]" + set tmp [$w search -back -regexp $exp insert-1c limit-1c] + if [string compare {} $tmp] {append tmp +2c} else {set tmp limit} + if [$w compare $tmp >= insert] return + set str [$w get $tmp insert] + switch -glob $type { + pa* { set res [tkConExpandPathname $str] } + pr* { set res [tkConExpandProcname $str] } + v* { set res [tkConExpandVariable $str] } + default {set res {}} + } + set len [llength $res] + if $len { + $w delete $tmp insert + $w insert $tmp [lindex $res 0] + if {$len > 1} { + global tkCon + if {$tkCon(showmultiple) && ![string comp [lindex $res 0] $str]} { + puts stdout [lreplace $res 0 0] + } + } + } else bell + return [incr len -1] +} + +## tkConExpandPathname - expand a file pathname based on $str +## This is based on UNIX file name conventions +# ARGS: str - partial file pathname to expand +# Calls: tkConExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc tkConExpandPathname str { + set pwd [tkConEvalAttached pwd] + if [catch {tkConEvalAttached [list cd [file dirname $str]]} err] { + return -code error $err + } + if [catch {lsort [tkConEvalAttached glob [file tail $str]*]} m] { + set match {} + } else { + if {[llength $m] > 1} { + set tmp [tkConExpandBestMatch $m [file tail $str]] + if [string match ?*/* $str] { + set tmp [file dirname $str]/$tmp + } elseif {[string match /* $str]} { + set tmp /$tmp + } + regsub -all { } $tmp {\\ } tmp + set match [linsert $m 0 $tmp] + } else { + ## This may look goofy, but it handles spaces in path names + eval append match $m + if [file isdir $match] {append match /} + if [string match ?*/* $str] { + set match [file dirname $str]/$match + } elseif {[string match /* $str]} { + set match /$match + } + regsub -all { } $match {\\ } match + ## Why is this one needed and the ones below aren't!! + set match [list $match] + } + } + tkConEvalAttached [list cd $pwd] + return $match +} + +## tkConExpandProcname - expand a tcl proc name based on $str +# ARGS: str - partial proc name to expand +# Calls: tkConExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc tkConExpandProcname str { + set match [tkConEvalAttached info commands $str*] + if {[llength $match] > 1} { + regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + return $match +} + +## tkConExpandVariable - expand a tcl variable name based on $str +# ARGS: str - partial tcl var name to expand +# Calls: tkConExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc tkConExpandVariable str { + if [regexp {([^\(]*)\((.*)} $str junk ary str] { + ## Looks like they're trying to expand an array. + set match [tkConEvalAttached array names $ary $str*] + if {[llength $match] > 1} { + set vars $ary\([tkConExpandBestMatch $match $str] + foreach var $match {lappend vars $ary\($var\)} + return $vars + } else {set match $ary\($match\)} + ## Space transformation avoided for array names. + } else { + set match [tkConEvalAttached info vars $str*] + if {[llength $match] > 1} { + regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + } + return $match +} + +## tkConExpandBestMatch2 - finds the best unique match in a list of names +## Improves upon the speed of the below proc only when $l is small +## or $e is {}. $e is extra for compatibility with proc below. +# ARGS: l - list to find best unique match in +# Returns: longest unique match in the list +## +proc tkConExpandBestMatch2 {l {e {}}} { + set s [lindex $l 0] + if {[llength $l]>1} { + set i [expr [string length $s]-1] + foreach l $l { + while {$i>=0 && [string first $s $l]} { + set s [string range $s 0 [incr i -1]] + } + } + } + return $s +} + +## tkConExpandBestMatch - finds the best unique match in a list of names +## The extra $e in this argument allows us to limit the innermost loop a +## little further. This improves speed as $l becomes large or $e becomes long. +# ARGS: l - list to find best unique match in +# e - currently best known unique match +# Returns: longest unique match in the list +## +proc tkConExpandBestMatch {l {e {}}} { + set ec [lindex $l 0] + if {[llength $l]>1} { + set e [string length $e]; incr e -1 + set ei [string length $ec]; incr ei -1 + foreach l $l { + while {$ei>=$e && [string first $ec $l]} { + set ec [string range $ec 0 [incr ei -1]] + } + } + } + return $ec +} + +# Here is a group of functions that is only used when Tkcon is +# executed in a safe interpreter. It provides safe versions of +# missing functions. For example: +# +# - "tk appname" returns "tkcon.tcl" but cannot be set +# - "toplevel" is equivalent to "frame", only it is automatically +# packed. +# - The "source", "load", "open", "file" and "exit" functions are +# mapped to corresponding functions in the parent interpreter. +# +# Further on, Tk cannot be really loaded. Still the safe "load" +# provedes a speciall case. The Tk can be divided into 4 groups, +# that each has a safe handling procedure. +# +# - "tkConSafeItem" handles commands like "button", "canvas" ...... +# Each of these functions has the window name as first argument. +# - "tkConSafeManage" handles commands like "pack", "place", "grid", +# "winfo", which can have multiple window names as arguments. +# - "tkConSafeWindow" handles all windows, such as ".". For every +# window created, a new alias is formed which also is handled by +# this function. +# - Other (e.g. bind, bindtag, image), which need their own function. +# +## These functions courtesy Jan Nijtmans (nijtmans@nici.kun.nl) +## +if {[string compare [info command tk] tk]} { + proc tk {option args} { + if {![string match app* $option]} { + error "wrong option \"$option\": should be appname" + } + return "tkcon.tcl" + } +} + +if {[string compare [info command toplevel] toplevel]} { + proc toplevel {name args} { + eval frame $name $args + pack $name + } +} + +proc tkConSafeSource {i f} { + set fd [open $f r] + set r [read $fd] + close $fd + if {[catch {interp eval $i $r} msg]} { + error $msg + } +} + +proc tkConSafeOpen {i f {m r}} { + set fd [open $f $m] + interp transfer {} $fd $i + return $fd +} + +proc tkConSafeLoad {i f p} { + global tk_version tk_patchLevel tk_library + if [string compare $p Tk] { + load $f $p $i + } else { + foreach command {button canvas checkbutton entry frame label + listbox message radiobutton scale scrollbar text toplevel} { + $i alias $command tkConSafeItem $i $command + } + $i alias image tkConSafeImage $i + foreach command {pack place grid destroy winfo} { + $i alias $command tkConSafeManage $i $command + } + if [string comp {} [info command event]] { + $i alias event tkConSafeManage $i $command + } + frame .${i}_dot -width 300 -height 300 -relief raised + pack .${i}_dot -side left + $i alias tk tk + $i alias bind tkConSafeBind $i + $i alias bindtags tkConSafeBindtags $i + $i alias . tkConSafeWindow $i {} + foreach var {tk_version tk_patchLevel tk_library} { + $i eval set $var [set $var] + } + $i eval { + package provide Tk $tk_version + if {[lsearch -exact $auto_path $tk_library] < 0} { + lappend auto_path $tk_library + } + } + return "" + } +} + +proc tkConSafeSubst {i a} { + set arg1 "" + foreach {arg value} $a { + if {![string compare $arg -textvariable] || + ![string compare $arg -variable]} { + set newvalue "[list $i] $value" + global $newvalue + if [interp eval $i info exists $value] { + set $newvalue [interp eval $i set $value] + } else { + catch {unset $newvalue} + } + $i eval trace variable $value rwu \{[list tkcon set $newvalue $i]\} + set value $newvalue + } elseif {![string compare $arg -command]} { + set value [list $i eval $value] + } + lappend arg1 $arg $value + } + return $arg1 +} + +proc tkConSafeItem {i command w args} { + set args [tkConSafeSubst $i $args] + set code [catch "$command [list .${i}_dot$w] $args" msg] + $i alias $w tkConSafeWindow $i $w + regsub -all .${i}_dot $msg {} msg + return -code $code $msg +} + +proc tkConSafeManage {i command args} { + set args1 "" + foreach arg $args { + if [string match . $arg] { + set arg .${i}_dot + } elseif [string match .* $arg] { + set arg ".${i}_dot$arg" + } + lappend args1 $arg + } + set code [catch "$command $args1" msg] + regsub -all .${i}_dot $msg {} msg + return -code $code $msg +} + +# +# FIX: this funcion doesn't work yet if the binding starts with "+". +# +proc tkConSafeBind {i w args} { + if [string match . $w] { + set w .${i}_dot + } elseif [string match .* $w] { + set w ".${i}_dot$w" + } + if {[llength $args] > 1} { + set args [list [lindex $args 0] "[list $i] eval [list [lindex $args 1]]"] + } + set code [catch "bind $w $args" msg] + if {[llength $args] <2 && code == 0} { + set msg [lindex $msg 3] + } + return -code $code $msg +} + +proc tkConSafeImage {i option args} { + set code [catch "image $option $args" msg] + if {[string match cr* $option]} { + $i alias $msg $msg + } + return -code $code $msg +} + +proc tkConSafeBindtags {i w {tags {}}} { + if [string match . $w] { + set w .${i}_dot + } elseif [string match .* $w] { + set w ".${i}_dot$w" + } + set newtags {} + foreach tag $tags { + if [string match . $tag] { + lappend newtags .${i}_dot + } elseif [string match .* $tag] { + lappend newtags ".${i}_dot$tag" + } else { + lappend newtags $tag + } + } + if [string match $tags {}] { + set code [catch {bindtags $w} msg] + regsub -all \\.${i}_dot $msg {} msg + } else { + set code [catch {bindtags $w $newtags} msg] + } + return -code $code $msg +} + +proc tkConSafeWindow {i w option args} { + if {[string match conf* $option] && [llength $args] > 1} { + set args [tkConSafeSubst $i $args] + } elseif {[string match itemco* $option] && [llength $args] > 2} { + set args "[list [lindex $args 0]] [tkConSafeSubst $i [lrange $args 1 end]]" + } elseif {[string match cr* $option]} { + if {[llength $args]%2} { + set args "[list [lindex $args 0]] [tkConSafeSubst $i [lrange $args 1 end]]" + } else { + set args [tkConSafeSubst $i $args] + } + } elseif {[string match bi* $option] && [llength $args] > 2} { + set args [list [lindex $args 0] [lindex $args 1] "[list $i] eval [list [lindex $args 2]]"] + } + set code [catch ".${i}_dot$w $option $args" msg] + if {$code} { + regsub -all .${i}_dot $msg {} msg + } elseif {[string match conf* $option] || [string match itemco* $option]} { + if {[llength $args] == 1} { + switch -- $args { + -textvariable - -variable { + set msg "[lrange $msg 0 3] [list [lrange [lindex $msg 4] 1 end]]" + } + -command - updatecommand { + set msg "[lrange $msg 0 3] [list [lindex [lindex $msg 4] 2]]" + } + } + } elseif {[llength $args] == 0} { + set args1 "" + foreach el $msg { + switch -- [lindex $el 0] { + -textvariable - -variable { + set el "[lrange $el 0 3] [list [lrange [lindex $el 4] 1 end]]" + } + -command - updatecommand { + set el "[lrange $el 0 3] [list [lindex [lindex $el 4] 2]]" + } + } + lappend args1 $el + } + set msg $args1 + } + } elseif {[string match cg* $option] || [string match itemcg* $option]} { + switch -- $args { + -textvariable - -variable { + set msg [lrange $msg 1 end] + } + -command - updatecommand { + set msg [lindex $msg 2] + } + } + } elseif [string match bi* $option] { + if {[llength $args] == 2 && $code == 0} { + set msg [lindex $msg 2] + } + } + return -code $code $msg +} + +proc tkConExit {} { + global tkCon + destroy $tkCon(root) +} + +set tkCon(SCRIPT) [info script] + +if {![string compare [interp slave] ""]} { + uplevel \#0 gimptcl_run 1 +} + +## tkConResource - re'source's this script into current console +## Meant primarily for my development of this program. It follows +## links until the ultimate source is found. +## +#if !$tkCon(WWW) { +# while {[string match link [file type $tkCon(SCRIPT)]]} { +# set link [file readlink $tkCon(SCRIPT)] +# if [string match relative [file pathtype $link]] { +# set tkCon(SCRIPT) [file join [file dirname $tkCon(SCRIPT)] $link] +# } else { +# set tkCon(SCRIPT) $link +# } +# } +# catch {unset link} +# if [string match relative [file pathtype $tkCon(SCRIPT)]] { +# set tkCon(SCRIPT) [file join [pwd] $tkCon(SCRIPT)] +# } +# } +# proc tkConResource {} { +# global tkCon +# uplevel \#0 [list source $tkCon(SCRIPT)] +# tkConBindings +# tkConInitSlave $tkCon(exec) +# } diff --git a/plug-ins/gimptcl/scripts/consolio.tcl b/plug-ins/gimptcl/scripts/consolio.tcl index f73234adb9..7f0956d336 100644 --- a/plug-ins/gimptcl/scripts/consolio.tcl +++ b/plug-ins/gimptcl/scripts/consolio.tcl @@ -1,33 +1,39 @@ #!@THEGIMPTCL@ -# -*-Mode: Tcl;-*- -################################################## +# +## tkcon.tcl +## Enhanced Tk Console, part of the VerTcl system +## +## Originally based off Brent Welch's Tcl Shell Widget +## (from "Practical Programming in Tcl and Tk") +## +## Thanks especially to the following for bug reports & code ideas: +## Steven Wahl , Jan Nijtmans +## Crimmins , Wart +## +## Copyright 1995,1996 Jeffrey Hobbs +## Initiated: Thu Aug 17 15:36:47 PDT 1995 +## +## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/ +## +## source standard_disclaimer.tcl +## source beer_ware.tcl +## # file: consolio.tcl # # This code has been modified by Eric L. Hernes to provide # a console window for use with the Tcl extension to Gimp. # -# This code constructs the console window for an application. It -# can be used by non-unix systems that do not have built-in support -# for shells. -# -# SCCS: @(#) console.tcl 1.28 96/03/07 16:32:14 -# -# Copyright (c) 1995-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. -# # $Id$ # proc gimptcl_query {} { - gimp-install-procedure "gimptcl_consolio" \ + gimp-install-procedure "gimptcl_consolio2" \ "An interactive gimptcl shell" \ "Type commands at the prompt to do stuff" \ "Eric L. Hernes" \ "ELH" \ "1997" \ - "/Xtns/Gimptcl Consolio" \ + "/Xtns/Gimptcl Consolio2" \ "" \ extension \ { @@ -37,423 +43,3509 @@ proc gimptcl_query {} { } proc gimptcl_run {mode} { - tkConsoleInit + global argc argv argv0 tkCon + + set argc 0 + set argv "" + set argv0 "tkconsolio" + + tkConsolioSetup + tkConInit } -proc consexit {args} { - destroy . - return $args -} +proc tkConsolioSetup {} { + global tcl_version tkCon -proc consputs {args} { - switch [llength $args] { - 0 { - set a "\n" - } - 1 { - set a "[lindex $args 0]\n" - } - 2 { - if {[string compare [lindex $args 0] "-nonewline"] == 0} { - set a [lindex $args 1] - } else { - return [eval "orig_puts $args"] + if {$tcl_version>=8.0} { + package require Tk + } elseif {[catch {package require -exact Tk [expr $tcl_version-3.4]}]} { + return -code error \ + "TkCon requires at least the stable version of tcl7.5/tk4.1" + } + + foreach pkg [info loaded {}] { + set file [lindex $pkg 0] + set name [lindex $pkg 1] + if {![catch {set version [package require $name]}]} { + if {[string match {} [package ifneeded $name $version]]} { + package ifneeded $name $version "load [list $file $name]" } } - 3 { - return [orig_puts $args] - } } - .console.t insert end $a - tkTextSetCursor .console.t end + catch {unset file name version} + set tkCon(WWW) [info exists embed_args] } -proc tkConsoleInit {} { - global tcl_platform - frame .console - text .console.t -yscrollcommand ".console.sb set" -setgrid true - scrollbar .console.sb -command ".console.t yview" - pack .console.sb -side right -fill both - pack .console.t -fill both -expand 1 -side left +## tkConInit - inits tkCon +# ARGS: root - widget pathname of the tkCon console root +# title - title for the console root and main (.) windows +# Calls: tkConInitUI +# Outputs: errors found in tkCon resource file +## +proc tkConInit {} { + global auto_path tcl_platform env tcl_pkgPath \ + tkCon argc argv tcl_interactive GimpTclProcs - frame .ctl - button .ctl.exit -text "Exit" -command "destroy ." - label .ctl.currcmd -textvariable GimpPDBCmd - pack .ctl.exit .ctl.currcmd -side left - pack .console .ctl -side top -expand 1 -fill both - tkConsoleBind .console.t + set tcl_interactive 1 - .console.t tag configure stderr -foreground red - .console.t tag configure stdin -foreground blue + if [info exists tkCon(name)] { + set title $tkCon(name) + } else { + tkConMainInit + set title Main + } - focus .console.t - - wm protocol . WM_DELETE_WINDOW { wm withdraw . } - wm title . "The Great Consolio" - flush stdout - .console.t mark set output [.console.t index "end - 1 char"] - tkTextSetCursor .console.t end - .console.t mark set promptEnd insert - .console.t mark gravity promptEnd left - rename "puts" "orig_puts" - rename "consputs" "puts" - rename "exit" "orig_exit" - rename "consexit" "exit" - tkConsolePrompt -} + array set tkCon { + color,blink yellow + color,proc darkgreen + color,prompt brown + color,stdin black + color,stdout blue + color,stderr red -# tkConsoleInvoke -- -# Processes the command line input. If the command is complete it -# is evaled in the main interpreter. Otherwise, the continuation -# prompt is added and more input may be added. -# -# Arguments: -# None. + blinktime 500 + debugPrompt {(level \#$level) debug [history nextid] > } + font fixed + history 32 + dead {} + library {} + lightbrace 1 + lightcmd 1 + autoload {Gimptcl GtclConstant GtclPDB} + maineval {} + nontcl 0 + rcfile .tkconrc + scrollypos right + showmultiple 1 + showmenu 1 + slaveeval {} + subhistory 1 -proc tkConsoleInvoke {args} { - set ranges [.console.t tag ranges input] - set cmd "" - if {$ranges != ""} { - set pos 0 - while {[lindex $ranges $pos] != ""} { - set start [lindex $ranges $pos] - set end [lindex $ranges [incr pos]] - append cmd [.console.t get $start $end] - incr pos - } + exec slave app {} appname {} apptype slave cmd {} cmdbuf {} cmdsave {} + event 1 cols 80 rows 24 deadapp 0 debugging 0 histid 0 + find {} find,case 0 find,reg 0 + errorInfo {} + slavealias { tkcon } + + slaveprocs { alias clear dir dump lremove puts echo tclindex idebug \ + unknown tcl_unknown unalias which observe observe_var auto_execok } + version 0.71 + release {December 1996} + root . + } +# set tkCon(slavealias) [concat $tkCon(slavealias) $GimpTclProcs] + + if $tkCon(WWW) { + set tkCon(prompt1) {[history nextid] % } + } else { + set tkCon(prompt1) {([file tail [pwd]]) [history nextid] % } + } + + ## If there appear to be children of '.', then make sure we use + ## a disassociated toplevel. + if [string compare {} [winfo children .]] { + set tkCon(root) .tkcon + } + + if [string compare unix $tcl_platform(platform)] { + array set tkCon { + font {Courier 12 {}} + rcfile tkcon.cfg } - if {$cmd == ""} { - tkConsolePrompt - } elseif [info complete $cmd] { - .console.t mark set output end - .console.t tag delete input - if {$cmd != ""} { - history add $cmd - catch "uplevel \#0 eval \{$cmd\}" result - if {$result != ""} { - .console.t insert insert "$result\n" - } - tkConsoleHistory reset + } + + if [info exists env(HOME)] { + set tkCon(rcfile) [file join $env(HOME) $tkCon(rcfile)] + } + if 0 { + ## This would get the resource file from the right place + switch $tcl_platform(platform) { + macintosh { + set pref_folder $env(PREF_FOLDER) + cd [file dirname [info script]] + } + windows { set pref_folder $env(WINDIR) } + unix { set pref_folder $env(HOME) } + } + } + + ## Handle command line arguments before sourcing resource file to + ## find if resource file is being specified (let other args pass). + for {set i 0} {$i < $argc} {incr i} { + if [string match \-rcfile [lindex $argv $i]] { + set tkCon(rcfile) [lindex $argv [incr i]] + } + } + + if {!$tkCon(WWW) && [file exists $tkCon(rcfile)]} { + set code [catch [list uplevel \#0 source $tkCon(rcfile)] err] + } + + if [info exists env(TK_CON_LIBRARY)] { + eval lappend auto_path $env(TK_CON_LIBRARY) + } else { + eval lappend auto_path $tkCon(library) + } + + if {![info exists tcl_pkgPath]} { + set dir [file join [file dirname [info nameofexec]] lib] + if [string comp {} [info commands @scope]] { + set dir [file join $dir itcl] + } + catch {source [file join $dir pkgIndex.tcl]} + } + catch {tclPkgUnknown dummy-name dummy-version} + + ## Handle rest of command line arguments after sourcing resource file + ## and slave is created, but before initializing UI or setting packages. + set slaveargs {} + set slavefiles {} + set truth {^(1|yes|true|on)$} + for {set i 0} {$i < $argc} {incr i} { + set arg [lindex $argv $i] + if [regexp -- {-.+} $arg] { + set val [lindex $argv [incr i]] + ## Handle arg based options + switch -- $arg { + -- - -argv { + set argv [concat -- [lrange $argv $i end]] + set argc [llength $argv] + break } - tkConsolePrompt + -main - -e - -eval { append tkCon(maineval) $val\n } + -package - -load { lappend tkCon(autoload) $val } + -slave { append tkCon(slaveeval) $val\n } + -nontcl { set tkCon(nontcl) [regexp -nocase $truth $val] } + -root { set tkCon(root) $val } + -rcfile {} + default { lappend slaveargs $arg; incr i -1 } + } + } elseif {[file isfile $arg]} { + lappend slavefiles $arg } else { - tkConsolePrompt partial + lappend slaveargs $arg } - .console.t yview -pickplace insert -} + } -# tkConsoleHistory -- -# This procedure implements command line history for the -# console. In general is evals the history command in the -# main interpreter to obtain the history. The global variable -# histNum is used to store the current location in the history. -# -# Arguments: -# cmd - Which action to take: prev, next, reset. + ## Create slave executable + if [string comp {} $tkCon(exec)] { + eval tkConInitSlave $tkCon(exec) $slaveargs + } -set histNum 1 -proc tkConsoleHistory {cmd} { - global histNum - - switch $cmd { - prev { - incr histNum -1 - if {$histNum == 0} { - set cmd {history event [expr [history nextid] -1]} - } else { - set cmd "history event $histNum" - } - if {[catch {eval $cmd} cmd]} { - incr histNum - return - } - .console.t delete promptEnd end - .console.t insert promptEnd $cmd {input stdin} - } - next { - incr histNum - if {$histNum == 0} { - set cmd {history event [expr [history nextid] -1]} - } elseif {$histNum > 0} { - set cmd "" - set histNum 1 - } else { - set cmd "history event $histNum" - } - if {$cmd != ""} { - catch {eval $cmd} cmd - } - .console.t delete promptEnd end - .console.t insert promptEnd $cmd {input stdin} - } - reset { - set histNum 1 - } - } -} + ## Attach to the slave, tkConEvalAttached will then be effective + tkConAttach $tkCon(appname) $tkCon(apptype) + tkConInitUI $title -# tkConsolePrompt -- -# This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2 -# exists in the main interpreter it will be called to generate the -# prompt. Otherwise, a hard coded default prompt is printed. -# -# Arguments: -# partial - Flag to specify which prompt to print. - -proc tkConsolePrompt {{partial normal}} { - if {$partial == "normal"} { - set temp [.console.t index "end - 1 char"] - .console.t mark set output end - if [eval "info exists tcl_prompt1"] { - eval "eval \[set tcl_prompt1\]" - } else { - puts -nonewline "% " - } + ## Autoload specified packages in slave + set pkgs [tkConEvalSlave package names] + foreach pkg $tkCon(autoload) { + puts -nonewline "autoloading package \"$pkg\" ... " + if {[lsearch -exact $pkgs $pkg]>-1} { + if [catch {tkConEvalSlave package require $pkg} pkgerr] { + puts stderr "error:\n$pkgerr" + } else { puts "OK" } } else { - set temp [.console.t index output] - .console.t mark set output end - if [eval "info exists tcl_prompt2"] { - eval "eval \[set tcl_prompt2\]" - } else { + puts stderr "error: package does not exist" + } + } + + ## Evaluate maineval in slave + if {[string comp {} $tkCon(maineval)] && + [catch {uplevel \#0 $tkCon(maineval)} merr]} { + puts stderr "error in eval:\n$merr" + } + + ## Source extra command line argument files into slave executable + foreach fn $slavefiles { + puts -nonewline "slave sourcing \"$fn\" ... " + if {[catch {tkConEvalSlave source $fn} fnerr]} { + puts stderr "error:\n$fnerr" + } else { puts "OK" } + } + + ## Evaluate slaveeval in slave + if {[string comp {} $tkCon(slaveeval)] && + [catch {interp eval $tkCon(exec) $tkCon(slaveeval)} serr]} { + puts stderr "error in slave eval:\n$serr" + } + ## Output any error/output that may have been returned from rcfile + if {[info exists code] && [string comp {} $err]} { + if $code { + puts stderr "error in $tkCon(rcfile):\n$err" + } else { + puts stdout "returned from $tkCon(rcfile):\n$err" + } + } + tkConStateCheckpoint [concat $tkCon(name) $tkCon(exec)] slave + tkConStateCheckpoint $tkCon(name) slave +} + +## tkConInitSlave - inits the slave by placing key procs and aliases in it +## It's arg[cv] are based on passed in options, while argv0 is the same as +## the master. tcl_interactive is the same as the master as well. +# ARGS: slave - name of slave to init. If it does not exist, it is created. +# args - args to pass to a slave as argv/argc +## +proc tkConInitSlave {slave args} { + global tkCon argv0 tcl_interactive tcl_library env + if [string match {} $slave] { + return -code error "Don't init the master interpreter, goofball" + } + if ![interp exists $slave] { interp create $slave } + if {[interp eval $slave info command source] == ""} { + $slave alias source tkConSafeSource $slave + $slave alias load tkConSafeLoad $slave + $slave alias open tkConSafeOpen $slave + $slave alias exit tkConExit + $slave alias file file + interp eval $slave [dump var tcl_library env] + interp eval $slave [list source [file join $tcl_library init.tcl]] + } + interp eval $slave {catch {rename puts tcl_puts}} + foreach cmd $tkCon(slaveprocs) { interp eval $slave [dump proc $cmd] } + foreach cmd $tkCon(slavealias) { + $slave alias $cmd $cmd + } + $slave alias exit tkConExit + interp alias $slave ls $slave dir + interp eval $slave set tcl_interactive $tcl_interactive \; \ + set argv0 [list $argv0] \; set argc [llength $args] \; \ + set argv [list $args] \; history keep $tkCon(history) \; { + if {[string match {} [info command bgerror]]} { + proc bgerror err { + global errorInfo + set body [info body bgerror] + rename bgerror {} + if [auto_load bgerror] { return [bgerror $err] } + proc bgerror err $body + tkcon bgerror $err $errorInfo + } + } + } + + foreach pkg [lremove [package names] Tcl] { + foreach v [package versions $pkg] { + interp eval $slave [list package ifneeded $pkg $v \ + [package ifneeded $pkg $v]] + } + } +} + +## tkConInitInterp - inits an interpreter by placing key +## procs and aliases in it. +# ARGS: name - interp name +# type - interp type (slave|interp) +## +proc tkConInitInterp {name type} { + global tkCon + ## Don't allow messing up a local master interpreter + if {[string match slave $type] && \ + [regexp {^([Mm]ain|Slave[0-9]+)$} $name]} return + set old [tkConAttach] + catch { + tkConAttach $name $type + tkConEvalAttached {catch {rename puts tcl_puts}} + foreach cmd $tkCon(slaveprocs) { tkConEvalAttached [dump proc $cmd] } + if [string match slave $type] { + foreach cmd $tkCon(slavealias) { + tkConMain interp alias $name $cmd $tkCon(name) $cmd + } + } else { + set name [tk appname] + foreach cmd $tkCon(slavealias) { + tkConEvalAttached "proc $cmd args { send [list $name] $cmd \$args }" + } + } + ## Catch in case it's a 7.4 (no 'interp alias') interp + tkConEvalAttached {catch {interp alias {} ls {} dir}} + return + } err + eval tkConAttach $old + if [string comp {} $err] { return -code error $err } +} + +## tkConInitUI - inits UI portion (console) of tkCon +## Creates all elements of the console window and sets up the text tags +# ARGS: root - widget pathname of the tkCon console root +# title - title for the console root and main (.) windows +# Calls: tkConInitMenus, tkConPrompt +## +proc tkConInitUI {title} { + global tkCon + + set root $tkCon(root) + if [string match . $root] { set w {} } else { set w [toplevel $root] } + catch {wm withdraw $root} + set tkCon(base) $w + + ## Menus + option add *Menu.font $tkCon(font) widgetDefault + set tkCon(menubar) [frame $w.mbar -relief raised -bd 2] + set tkCon(lastCmd) [label $w.last -textvariable env(GimpPDBCmd) -anchor w] + set tkCon(console) [set con [text $w.text -font $tkCon(font) -wrap char \ + -yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin) \ + -width $tkCon(cols) -height $tkCon(rows)]] + bindtags $con "$con PreCon Console PostCon $root all" + set tkCon(scrolly) [scrollbar $w.sy -takefocus 0 -bd 1 -command "$con yview"] + + tkConInitMenus $tkCon(menubar) $title + tkConBindings + + if $tkCon(showmenu) { + pack $tkCon(menubar) -fill x + pack $tkCon(lastCmd) -fill x + } + pack $w.sy -side $tkCon(scrollypos) -fill y + pack $con -fill both -expand 1 + + tkConPrompt "$title console display active\n" + + foreach col {prompt stdout stderr stdin proc} { + $con tag configure $col -foreground $tkCon(color,$col) + } + $con tag configure blink -background $tkCon(color,blink) + $con tag configure find -background $tkCon(color,blink) + + if ![catch {wm title $root "The Great Consolio: $title"}] { + bind $con { + scan [wm geometry [winfo toplevel %W]] "%%dx%%d" tkCon(cols) tkCon(rows) + } + wm deiconify $root + } + focus -force $tkCon(console) +} + +## tkConEval - evaluates commands input into console window +## This is the first stage of the evaluating commands in the console. +## They need to be broken up into consituent commands (by tkConCmdSep) in +## case a multiple commands were pasted in, then each is eval'ed (by +## tkConEvalCmd) in turn. Any uncompleted command will not be eval'ed. +# ARGS: w - console text widget +# Calls: tkConCmdGet, tkConCmdSep, tkConEvalCmd +## +proc tkConEval {w} { + global tkCon + tkConCmdSep [tkConCmdGet $w] cmds tkCon(cmd) + $w mark set insert end-1c + $w insert end \n + if [llength $cmds] { + foreach cmd $cmds {tkConEvalCmd $w $cmd} + $w insert insert $tkCon(cmd) {} + } elseif {[info complete $tkCon(cmd)] && ![regexp {[^\\]\\$} $tkCon(cmd)]} { + tkConEvalCmd $w $tkCon(cmd) + } + $w see insert +} + +## tkConEvalCmd - evaluates a single command, adding it to history +# ARGS: w - console text widget +# cmd - the command to evaluate +# Calls: tkConPrompt +# Outputs: result of command to stdout (or stderr if error occured) +# Returns: next event number +## +proc tkConEvalCmd {w cmd} { + global tkCon + $w mark set output end + if [string comp {} $cmd] { + set err 0 + if $tkCon(subhistory) { + set ev [tkConEvalSlave history nextid] + incr ev -1 + if {[string match !! $cmd]} { + set err [catch {tkConEvalSlave history event $ev} cmd] + if !$err {$w insert output $cmd\n stdin} + } elseif {[regexp {^!(.+)$} $cmd dummy event]} { + set err [catch {tkConEvalSlave history event $event} cmd] + if !$err {$w insert output $cmd\n stdin} + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} { + if ![set err [catch {tkConEvalSlave history event $ev} cmd]] { + regsub -all -- $old $cmd $new cmd + $w insert output $cmd\n stdin + } + } + } + if $err { + $w insert output $cmd\n stderr + } else { + if [string match {} $tkCon(appname)] { + if [catch {tkConEvalSlave eval $cmd} res] { + set tkCon(errorInfo) [tkConEvalSlave set errorInfo] + set err 1 + } + } else { + if {$tkCon(nontcl) && [string match interp $tkCon(apptype)]} { + if [catch "tkConEvalSend $cmd" res] { + set tkCon(errorInfo) {Non-Tcl errorInfo not available} + set err 1 + } + } else { + if [catch [list tkConEvalAttached $cmd] res] { + if [catch {tkConEvalAttached set errorInfo} err] { + set tkCon(errorInfo) {Error attempting to retrieve errorInfo} + } else { + set tkCon(errorInfo) $err + } + set err 1 + } + } + } + tkConEvalSlave history add $cmd + if $err { + $w insert output $res\n stderr + } elseif {[string comp {} $res]} { + $w insert output $res\n stdout + } + } + } + tkConPrompt + set tkCon(event) [tkConEvalSlave history nextid] +} + +## tkConEvalSlave - evaluates the args in the associated slave +## args should be passed to this procedure like they would be at +## the command line (not like to 'eval'). +# ARGS: args - the command and args to evaluate +## +proc tkConEvalSlave args { + global tkCon + interp eval $tkCon(exec) $args +} + +## tkConEvalOther - evaluate a command in a foreign interp or slave +## without attaching to it. No check for existence is made. +# ARGS: app - interp/slave name +# type - (slave|interp) +## +proc tkConEvalOther {app type args} { + if [string match slave $type] { + if [string match Main $app] { set app {} } + tkConMain interp eval $app $args + } else { + eval send [list $app] $args + } +} + +## tkConEvalSend - sends the args to the attached interpreter +## Varies from 'send' by determining whether attachment is dead +## when an error is received +# ARGS: args - the args to send across +# Returns: the result of the command +## +proc tkConEvalSend args { + global tkCon + if $tkCon(deadapp) { + if {[lsearch -exact [winfo interps] $tkCon(app)]<0} { + return + } else { + set tkCon(appname) [string range $tkCon(appname) 5 end] + set tkCon(deadapp) 0 + tkConPrompt "\n\"$tkCon(app)\" alive\n" [tkConCmdGet $tkCon(console)] + } + } + set code [catch {eval send [list $tkCon(app)] $args} result] + if {$code && [lsearch -exact [winfo interps] $tkCon(app)]<0} { + ## Interpreter disappeared + if {[string compare leave $tkCon(dead)] && \ + ([string match ignore $tkCon(dead)] || \ + [tk_dialog $tkCon(base).dead "Dead Attachment" \ + "\"$tkCon(app)\" appears to have died.\ + \nReturn to primary slave interpreter?" questhead 0 OK No])} { + set tkCon(appname) "DEAD:$tkCon(appname)" + set tkCon(deadapp) 1 + } else { + set err "Attached Tk interpreter \"$tkCon(app)\" died." + tkConAttach {} + set tkCon(deadapp) 0 + tkConEvalSlave set errorInfo $err + } + tkConPrompt \n [tkConCmdGet $tkCon(console)] + } + return -code $code $result +} + +## tkConCmdGet - gets the current command from the console widget +# ARGS: w - console text widget +# Returns: text which compromises current command line +## +proc tkConCmdGet w { + if [string match {} [set ix [$w tag nextrange prompt limit end]]] { + $w tag add stdin limit end-1c + return [$w get limit end-1c] + } +} + +## tkConCmdSep - separates multiple commands into a list and remainder +# ARGS: cmd - (possible) multiple command to separate +# list - varname for the list of commands that were separated. +# rmd - varname of any remainder (like an incomplete final command). +# If there is only one command, it's placed in this var. +# Returns: constituent command info in varnames specified by list & rmd. +## +proc tkConCmdSep {cmd ls rmd} { + upvar $ls cmds $rmd tmp + set tmp {} + set cmds {} + foreach cmd [split [set cmd] \n] { + if [string comp {} $tmp] { + append tmp \n$cmd + } else { + append tmp $cmd + } + if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { + lappend cmds $tmp + set tmp {} + } + } + if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} { + set tmp [lindex $cmds end] + set cmds [lreplace $cmds end end] + } +} + +## tkConPrompt - displays the prompt in the console widget +# ARGS: w - console text widget +# Outputs: prompt (specified in tkCon(prompt1)) to console +## +proc tkConPrompt {{pre {}} {post {}} {prompt {}}} { + global tkCon + set w $tkCon(console) + if [string comp {} $pre] { $w insert end $pre stdout } + set i [$w index end-1c] + if [string comp {} $tkCon(appname)] { + $w insert end ">$tkCon(appname)< " prompt + } + if [string comp {} $prompt] { + $w insert end $prompt prompt + } else { + $w insert end [tkConEvalSlave subst $tkCon(prompt1)] prompt + } + $w mark set output $i + $w mark set insert end + $w mark set limit insert + $w mark gravity limit left + if [string comp {} $post] { $w insert end $post stdin } + $w see end +} + +## FIX - place these in state disabled text widgets. +## tkConAbout - gives about info for tkCon +## +proc tkConAbout {} { + global tkCon + tk_dialog $tkCon(base).about "About TkCon v$tkCon(version)" \ + "Jeffrey Hobbs, Copyright 1995-96\njhobbs@cs.uoregon.edu\ + \nhttp://www.cs.uoregon.edu/~jhobbs/\ + \nRelease Date: v$tkCon(version), $tkCon(release)" questhead 0 OK +} + +## tkConHelp - gives help info for tkCon +## +proc tkConHelp {} { + global tkCon + set page "http://www.cs.uoregon.edu/~jhobbs/work/tkcon/" + set email "jhobbs@cs.uoregon.edu" + if [tk_dialog $tkCon(base).help "Help on TkCon v$tkCon(version)" \ + "Jeffrey Hobbs, $email\nHelp available at:\n$page" \ + questhead 0 OK "Load into Netscape"] { + update + if {[catch {exec netscape -remote "openURL($page)"}] + && [catch {exec netscape $page &}]} { + tk_dialog $tkCon(base).dialog "Couldn't exec Netscape" \ + "Couldn't exec Netscape.\nMake sure it's in your path" \ + warning 0 Bummer + } + } +} + +## tkConInitMenus - inits the menubar and popup for the console +# ARGS: w - console text widget +## +proc tkConInitMenus {w title} { + global tkCon + + if [catch {menu $w.pop -tearoff 0}] { + label $w.label -text "Menus not available in plugin mode" + pack $w.label + return + } + bind [winfo toplevel $w] "tk_popup $w.pop %X %Y" + + pack [menubutton $w.con -text "Console" -un 0 -menu $w.con.m] -side left + $w.pop add cascade -label "Console" -un 0 -menu $w.pop.con + + pack [menubutton $w.edit -text "Edit" -un 0 -menu $w.edit.m] -side left + $w.pop add cascade -label "Edit" -un 0 -menu $w.pop.edit + + pack [menubutton $w.int -text "Interp" -un 0 -menu $w.int.m] -side left + $w.pop add cascade -label "Interp" -un 0 -menu $w.pop.int + + pack [menubutton $w.pref -text "Prefs" -un 0 -menu $w.pref.m] -side left + $w.pop add cascade -label "Prefs" -un 0 -menu $w.pop.pref + + pack [menubutton $w.hist -text "History" -un 0 -menu $w.hist.m] -side left + $w.pop add cascade -label "History" -un 0 -menu $w.pop.hist + + pack [menubutton $w.help -text "Help" -un 0 -menu $w.help.m] -side right + $w.pop add cascade -label "Help" -un 0 -menu $w.pop.help + + ## Console Menu + ## + foreach m [list [menu $w.con.m -disabledfore $tkCon(color,prompt)] \ + [menu $w.pop.con -disabledfore $tkCon(color,prompt)]] { + $m add command -label "$title Console" -state disabled + $m add command -label "New Console" -un 0 -acc Ctrl-N -com tkConNew + $m add command -label "Close Console " -un 0 -acc Ctrl-w -com tkConDestroy + $m add command -label "Clear Console " -un 1 -acc Ctrl-l \ + -com { clear; tkConPrompt } + $m add separator + $m add cascade -label "Attach Console " -un 0 -menu $m.apps + $m add separator + $m add command -label "Quit" -un 0 -acc Ctrl-q -command tkConExit + + ## Attach Console Menu + ## + menu $m.apps -disabledforeground $tkCon(color,prompt) \ + -postcommand "tkConFillAppsMenu $m.apps" + } + + ## Edit Menu + ## + set text $tkCon(console) + foreach m [list [menu $w.edit.m] [menu $w.pop.edit]] { + $m add command -label "Cut" -un 1 -acc Ctrl-x -command "tkConCut $text" + $m add command -label "Copy" -un 1 -acc Ctrl-c -command "tkConCopy $text" + $m add command -label "Paste" -un 0 -acc Ctrl-v -command "tkConPaste $text" + $m add separator + $m add command -label "Find" -un 0 -acc Ctrl-F \ + -command "tkConFindBox $text" + } + + ## Interp Menu + ## + foreach m [list $w.int.m $w.pop.int] { + menu $m -disabledfore $tkCon(color,prompt) -postcom "tkConInterpMenu $m" + } + + ## Prefs Menu + ## + foreach m [list [menu $w.pref.m] [menu $w.pop.pref]] { + $m add checkbutton -label "Brace Highlighting" -var tkCon(lightbrace) + $m add checkbutton -label "Command Highlighting" -var tkCon(lightcmd) + $m add checkbutton -label "History Substitution" -var tkCon(subhistory) + $m add checkbutton -label "Non-Tcl Attachments" -var tkCon(nontcl) + $m add checkbutton -label "Show Multiple Matches" -var tkCon(showmultiple) + $m add checkbutton -label "Show Menubar" -var tkCon(showmenu) \ + -command "if \$tkCon(showmenu) { \ + pack $w -fill x -before $tkCon(lastCmd) \ + } else { pack forget $w }" + $m add cascade -label Scrollbar -un 0 -menu $m.scroll + + ## Scrollbar Menu + ## + set m [menu $m.scroll -tearoff 0] + $m add radio -label "Left" -var tkCon(scrollypos) -value left -command { + pack config $tkCon(scrolly) -side left + } + $m add radio -label "Right" -var tkCon(scrollypos) -value right -command { + pack config $tkCon(scrolly) -side right + } + } + + ## History Menu + ## + foreach m [list $w.hist.m $w.pop.hist] { + menu $m -disabledfore $tkCon(color,prompt) -postcom "tkConHistoryMenu $m" + } + + ## Help Menu + ## + foreach m [list [menu $w.help.m] [menu $w.pop.help]] { + $m add command -label "About " -un 0 -acc Ctrl-A -command tkConAbout + $m add separator + $m add command -label "Help" -un 0 -acc Ctrl-H -command tkConHelp + } +} + +## tkConHistoryMenu - dynamically build the menu for attached interpreters +## +# ARGS: w - menu widget +## +proc tkConHistoryMenu w { + global tkCon + + if ![winfo exists $w] return + set id [tkConEvalSlave history nextid] + if {$tkCon(histid)==$id} return + set tkCon(histid) $id + $w delete 0 end + while {($id>$tkCon(histid)-10) && \ + ![catch {tkConEvalSlave history event [incr id -1]} tmp]} { + set lbl [lindex [split $tmp "\n"] 0] + if {[string len $lbl]>32} { set lbl [string range $tmp 0 30]... } + $w add command -label "$id: $lbl" -command " + $tkCon(console) delete limit end + $tkCon(console) insert limit [list $tmp] + $tkCon(console) see end + tkConEval $tkCon(console) + " + } +} + +## tkConInterpMenu - dynamically build the menu for attached interpreters +## +# ARGS: w - menu widget +## +proc tkConInterpMenu w { + global tkCon + + if ![winfo exists $w] return + set i [tkConAttach] + set app [lindex $i 0] + set type [lindex $i 1] + $w delete 0 end + $w add command -label "[string toup $type]: $app" -state disabled + $w add separator + if {($tkCon(nontcl) && [string match interp $type]) || $tkCon(deadapp)} { + $w add command -state disabled -label "Communication disabled to" + $w add command -state disabled -label "dead or non-Tcl interps" + return + } + + set isnew [tkConEvalAttached expr \[info tclversion\]>7.4] + set hastk [tkConEvalAttached info exists tk_library] + + if 0 { + ## Inspect Cascaded Menu + ## + $w add cascade -label Inspect -un 0 -menu $w.ins + set m $w.ins + if [winfo exists $m] { + $m delete 0 end + } else { + menu $m -tearoff no -disabledfore $tkCon(color,prompt) + } + $m add check -label "Procedures" \ + -command [list tkConInspect $app $type procs] + $m add check -label "Global Vars" \ + -command [list tkConInspect $app $type vars] + if $isnew { + $m add check -label "Interpreters" \ + -command [list tkConInspect $app $type interps] + $m add check -label "Aliases" \ + -command [list tkConInspect $app $type aliases] + } + if $hastk { + $m add separator + $m add check -label "All Widgets" \ + -command [list tkConInspect $app $type widgets] + $m add check -label "Canvas Widgets" \ + -command [list tkConInspect $app $type canvases] + $m add check -label "Menu Widgets" \ + -command [list tkConInspect $app $type menus] + $m add check -label "Text Widgets" \ + -command [list tkConInspect $app $type texts] + if $isnew { + $m add check -label "Images" \ + -command [list tkConInspect $app $type images] + } + } + } + + if $isnew { + ## Packages Cascaded Menu + ## + $w add cascade -label Packages -un 0 -menu $w.pkg + set m $w.pkg + if [winfo exists $m] { $m delete 0 end } else { + menu $m -tearoff no -disabledfore $tkCon(color,prompt) + } + + foreach pkg [tkConEvalAttached [list info loaded {}]] { + set loaded([lindex $pkg 1]) [package provide $pkg] + } + foreach pkg [lremove [tkConEvalAttached package names] Tcl] { + set version [tkConEvalAttached package provide $pkg] + if [string comp {} $version] { + set loaded($pkg) $version + } elseif {![info exists loaded($pkg)]} { + set loadable($pkg) [list package require $pkg] + } + } + foreach pkg [tkConEvalAttached info loaded] { + set pkg [lindex $pkg 1] + if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} { + set loadable($pkg) [list load {} $pkg] + } + } + foreach pkg [array names loadable] { + $m add command -label "Load $pkg ([tkConEvalAttached package version $pkg])" \ + -command "tkConEvalOther [list $app] $type $loadable($pkg)" + } + if {[info exists loaded] && [info exists loadable]} { $m add separator } + foreach pkg [array names loaded] { + $m add command -label "${pkg}$loaded($pkg) Loaded" -state disabled + } + } + + ## Show Last Error + ## + $w add separator + $w add command -label "Show Last Error" \ + -command "tkcon error [list $app] $type" + + ## State Checkpoint/Revert + ## + $w add separator + $w add command -label "Checkpoint State" \ + -command [list tkConStateCheckpoint $app $type] + $w add command -label "Revert State" \ + -command [list tkConStateRevert $app $type] + $w add command -label "View State Change" \ + -command [list tkConStateCompare $app $type] + + ## Init Interp + ## + $w add separator + $w add command -label "Send TkCon Commands" \ + -command [list tkConInitInterp $app $type] +} + +## tkConFillAppsMenu - fill in in the applications sub-menu +## with a list of all the applications that currently exist. +## +proc tkConFillAppsMenu {m} { + global tkCon + + array set interps [set tmp [tkConInterps]] + foreach {i j} $tmp { set tknames($j) {} } + + catch {$m delete 0 last} + set cmd {tkConPrompt \n [tkConCmdGet $tkCon(console)]} + $m add radio -label {None (use local slave) } -var tkCon(app) \ + -value [concat $tkCon(name) $tkCon(exec)] -acc Ctrl-1 \ + -command "tkConAttach {}; $cmd" + $m add separator + $m add command -label "Foreign Tk Interpreters" -state disabled + foreach i [lsort [lremove [winfo interps] [array names tknames]]] { + $m add radio -label $i -var tkCon(app) -value $i \ + -command "tkConAttach [list $i] interp; $cmd" + } + $m add separator + + $m add command -label "TkCon Interpreters" -state disabled + foreach i [lsort [array names interps]] { + if [string match {} $interps($i)] { set interps($i) "no Tk" } + if [regexp {^Slave[0-9]+} $i] { + set opts [list -label "$i ($interps($i))" -var tkCon(app) -value $i \ + -command "tkConAttach [list $i] slave; $cmd"] + if [string match $tkCon(name) $i] { append opts " -acc Ctrl-2" } + eval $m add radio $opts + } else { + set name [concat Main $i] + if [string match Main $name] { + $m add radio -label "$name ($interps($i))" -var tkCon(app) \ + -value Main -acc Ctrl-3 \ + -command "tkConAttach [list $name] slave; $cmd" + } else { + $m add radio -label "$name ($interps($i))" -var tkCon(app) -value $i \ + -command "tkConAttach [list $name] slave; $cmd" + } + } + } +} + +## tkConFindBox - creates minimal dialog interface to tkConFind +# ARGS: w - text widget +# str - optional seed string for tkCon(find) +## +proc tkConFindBox {w {str {}}} { + global tkCon + + set base $tkCon(base).find + if ![winfo exists $base] { + toplevel $base + wm withdraw $base + wm title $base "TkCon Find" + + pack [frame $base.f] -fill x -expand 1 + label $base.f.l -text "Find:" + entry $base.f.e -textvar tkCon(find) + pack [frame $base.opt] -fill x + checkbutton $base.opt.c -text "Case Sensitive" -variable tkCon(find,case) + checkbutton $base.opt.r -text "Use Regexp" -variable tkCon(find,reg) + pack $base.f.l -side left + pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1 + pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x + pack [frame $base.btn] -fill both + button $base.btn.fnd -text "Find" -width 6 + button $base.btn.clr -text "Clear" -width 6 + button $base.btn.dis -text "Dismiss" -width 6 + eval pack [winfo children $base.btn] -padx 4 -pady 2 -side left -fill both + + focus $base.f.e + + bind $base.f.e [list $base.btn.fnd invoke] + bind $base.f.e [list $base.btn.dis invoke] + } + $base.btn.fnd config -command "tkConFind $w \$tkCon(find) \ + -case \$tkCon(find,case) -reg \$tkCon(find,reg)" + $base.btn.clr config -command " + $w tag remove find 1.0 end + set tkCon(find) {} + " + $base.btn.dis config -command " + $w tag remove find 1.0 end + wm withdraw $base + " + if [string comp {} $str] { + set tkCon(find) $str + $base.btn.fnd invoke + } + + if {[string comp normal [wm state $base]]} { + wm deiconify $base + } else { raise $base } + $base.f.e select range 0 end +} + +## tkConFind - searches in text widget $w for $str and highlights it +## If $str is empty, it just deletes any highlighting +# ARGS: w - text widget +# str - string to search for +# -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0 +# -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0 +## +proc tkConFind {w str args} { + $w tag remove find 1.0 end + set truth {^(1|yes|true|on)$} + set opts {} + foreach {key val} $args { + switch -glob -- $key { + -c* { if [regexp -nocase $truth $val] { set case 1 } } + -r* { if [regexp -nocase $truth $val] { lappend opts -regexp } } + default { return -code error "Unknown option $key" } + } + } + if ![info exists case] { lappend opts -nocase } + if [string match {} $str] return + $w mark set findmark 1.0 + while {[string comp {} [set ix [eval $w search $opts -count numc -- \ + [list $str] findmark end]]]} { + $w tag add find $ix ${ix}+${numc}c + $w mark set findmark ${ix}+1c + } + catch {$w see find.first} + return [expr [llength [$w tag ranges find]]/2] +} + +## tkConAttach - called to attach tkCon to an interpreter +# ARGS: an - application name to which tkCon sends commands +# This is either a slave interperter name or tk appname. +# type - (slave|interp) type of interpreter we're attaching to +# slave means it's a TkCon interpreter +# interp means we'll need to 'send' to it. +# Results: tkConEvalAttached is recreated to evaluate in the +# appropriate interpreter +## +proc tkConAttach {{an } {type slave}} { + global tkCon + if [string match $an] { + if [string match {} $tkCon(appname)] { + return [list [concat $tkCon(name) $tkCon(exec)] $tkCon(apptype)] + } else { + return [list $tkCon(appname) $tkCon(apptype)] + } + } + set app - + set path [concat $tkCon(name) $tkCon(exec)] + if [string comp {} $an] { + array set interps [tkConInterps] + if [string match {[Mm]ain} [lindex $an 0]] { set an [lrange $an 1 end] } + if {[string match $path $an]} { + set an {} + set app $path + set type slave + } elseif {[info exists interps($an)]} { + if [string match {} $an] { set an Main; set app Main } + set type slave + } elseif {[interp exists $an]} { + set an [concat $tkCon(name) $an] + set type slave + } elseif {[interp exists [concat $tkCon(exec) $an]]} { + set an [concat $path $an] + set type slave + } elseif {[lsearch [winfo interps] $an] > -1} { + if {[tkConEvalSlave info exists tk_library] + && [string match $an [tkConEvalSlave tk appname]]} { + set an {} + set app $path + set type slave + } elseif {[set i [lsearch [tkConMain set tkCon(interps)] $an]] > -1} { + set an [lindex [tkConMain set tkCon(slaves)] $i] + if [string match {[Mm]ain} $an] { set app Main } + set type slave + } else { + set type interp + } + } else { + return -code error "No known interpreter \"$an\"" + } + } else { + set app $path + } + if [string match - $app] { set app $an } + set tkCon(app) $app + set tkCon(appname) $an + set tkCon(apptype) $type + set tkCon(deadapp) 0 + + ## tkConEvalAttached - evaluates the args in the attached interp + ## args should be passed to this procedure as if they were being + ## passed to the 'eval' procedure. This procedure is dynamic to + ## ensure evaluation occurs in the right interp. + # ARGS: args - the command and args to evaluate + ## + switch $type { + slave { + if [string match {} $an] { + interp alias {} tkConEvalAttached {} tkConEvalSlave eval + } elseif {[string match Main $tkCon(app)]} { + interp alias {} tkConEvalAttached {} tkConMain eval + } elseif {[string match $tkCon(name) $tkCon(app)]} { + interp alias {} tkConEvalAttached {} uplevel \#0 + } else { + interp alias {} tkConEvalAttached {} tkConMain interp eval $tkCon(app) + } + } + interp { + if $tkCon(nontcl) { + interp alias {} tkConEvalAttached {} tkConEvalSlave + } else { + interp alias {} tkConEvalAttached {} tkConEvalSend + } + } + default { + return -code error "[lindex [info level 0] 0] did not specify\ + a valid type: must be slave or interp" + } + } + return +} + +## tkConLoad - sources a file into the console +# ARGS: fn - (optional) filename to source in +# Returns: selected filename ({} if nothing was selected) +## +proc tkConLoad {{fn {}}} { + global tkCon + if {[string match {} $fn] && + ([catch {tk_getOpenFile} fn] || [string match {} $fn])} return + tkConEvalAttached [list source $fn] +} + +## tkConSave - saves the console buffer to a file +## This does not eval in a slave because it's not necessary +# ARGS: w - console text widget +# fn - (optional) filename to save to +## +proc tkConSave {{fn {}}} { + global tkCon + if {[string match {} $fn] && + ([catch {tk_getSaveFile} fn] || [string match {} $fn])} return + if [catch {open $fn w} fid] { + return -code error "Save Error: Unable to open '$fn' for writing\n$fid" + } + puts $fid [$tkCon(console) get 1.0 end-1c] + close $fid +} + +## tkConMainInit +## This is only called for the main interpreter to include certain procs +## that we don't want to include (or rather, just alias) in slave interps. +## +proc tkConMainInit {} { + global tkCon + + if ![info exists tkCon(slaves)] { + array set tkCon [list slave 0 slaves Main name {} interps [tk appname]] + } + interp alias {} tkConMain {} tkConInterpEval Main + interp alias {} tkConSlave {} tkConInterpEval + + ## tkConNew - create new console window + ## Creates a slave interpreter and sources in this script. + ## All other interpreters also get a command to eval function in the + ## new interpreter. + ## + proc tkConNew {} { + global argv0 argc argv tkCon + set tmp [interp create Slave[incr tkCon(slave)]] + lappend tkCon(slaves) $tmp + load {} Tk $tmp + lappend tkCon(interps) [$tmp eval [list tk appname "[tk appname] $tmp"]] + $tmp eval set argc $argc \; set argv [list $argv] \; \ + set argv0 [list $argv0] + $tmp eval [list set tkCon(name) $tmp] + $tmp alias tkConDestroy tkConDestroy $tmp + $tmp alias tkConNew tkConNew + $tmp alias tkConMain tkConInterpEval Main + $tmp alias tkConSlave tkConInterpEval + $tmp alias tkConInterps tkConInterps + $tmp alias tkConStateCheckpoint tkConStateCheckpoint + $tmp alias tkConStateCleanup tkConStateCleanup + $tmp alias tkConStateCompare tkConStateCompare + $tmp alias tkConStateRevert tkConStateRevert + $tmp alias exit tkConExit + $tmp eval [list source $tkCon(SCRIPT)] + return $tmp + } + + ## tkConDestroy - destroy console window + ## This proc should only be called by the main interpreter. If it is + ## called from there, it will ask before exiting TkCon. All others + ## (slaves) will just have their slave interpreter deleted, closing them. + ## + proc tkConDestroy {{slave {}}} { + global tkCon + if [string match {} $slave] { + ## Main interpreter close request + if [tk_dialog $tkCon(base).destroyme {Quit TkCon?} \ + {Closing the Main console will quit TkCon} \ + warning 0 "Don't Quit" "Quit TkCon"] tkConExit + } else { + ## Slave interpreter close request + set name [tkConInterpEval $slave] + set tkCon(interps) [lremove $tkCon(interps) [list $name]] + set tkCon(slaves) [lremove $tkCon(slaves) [list $slave]] + interp delete $slave + } + tkConStateCleanup $slave + } + + ## tkConInterpEval - passes evaluation to another named interpreter + ## If the interpreter is named, but no args are given, it returns the + ## [tk appname] of that interps master (not the associated eval slave). + ## + proc tkConInterpEval {{slave {}} args} { + if [string match {} $slave] { + global tkCon + return $tkCon(slaves) + } elseif {[string match {[Mm]ain} $slave]} { + set slave {} + } + if [string match {} $args] { + return [interp eval $slave tk appname] + } else { + uplevel \#0 [list interp eval $slave $args] + } + } + + proc tkConInterps {{ls {}} {interp {}}} { + if [string match {} $interp] { lappend ls {} [tk appname] } + foreach i [interp slaves $interp] { + if [string comp {} $interp] { set i "$interp $i" } + if [string comp {} [interp eval $i package provide Tk]] { + lappend ls $i [interp eval $i tk appname] + } else { + lappend ls $i {} + } + set ls [tkConInterps $ls $i] + } + return $ls + } + + ## + ## The following state checkpoint/revert procedures are very sketchy + ## and prone to problems. They do not track modifications to currently + ## existing procedures/variables, and they can really screw things up + ## if you load in libraries (especially Tk) between checkpoint and + ## revert. Only with this knowledge in mind should you use these. + ## + + ## tkConStateCheckpoint - checkpoints the current state of the system + ## This allows you to return to this state with tkConStateRevert + # ARGS: + ## + proc tkConStateCheckpoint {app type} { + global tkCon + if {[info exists tkCon($type,$app,cmd)] && + [tk_dialog $tkCon(base).warning "Overwrite Previous State?" \ + "Are you sure you want to lose previously checkpointed\ + state of $type \"$app\"?" questhead 1 "Do It" "Cancel"]} return + set tkCon($type,$app,cmd) [tkConEvalOther $app $type info comm *] + set tkCon($type,$app,var) [tkConEvalOther $app $type info vars *] + return + } + + ## tkConStateCompare - compare two states and output difference + # ARGS: + ## + proc tkConStateCompare {app type {verbose 0}} { + global tkCon + if ![info exists tkCon($type,$app,cmd)] { + return -code error "No previously checkpointed state for $type \"$app\"" + } + set w $tkCon(base).compare + if [winfo exists $w] { + $w.text config -state normal + $w.text delete 1.0 end + } else { + toplevel $w + frame $w.btn + scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview] + text $w.text -font $tkCon(font) -yscrollcommand [list $w.sy set] \ + -height 12 + pack $w.btn -side bottom -fill x + pack $w.sy -side right -fill y + pack $w.text -fill both -expand 1 + button $w.btn.close -text Dismiss -width 11 -command [list destroy $w] + button $w.btn.check -text Recheckpoint -width 11 + button $w.btn.revert -text Revert -width 11 + button $w.btn.expand -text Verbose -width 11 + button $w.btn.update -text Update -width 11 + pack $w.btn.check $w.btn.revert $w.btn.expand $w.btn.update \ + $w.btn.close -side left -fill x -padx 4 -pady 2 -expand 1 + $w.text tag config red -foreground red + } + wm title $w "Compare State: $type [list $app]" + + $w.btn.check config -command "tkConStateCheckpoint [list $app] $type; \ + tkConStateCompare [list $app] $type $verbose" + $w.btn.revert config -command "tkConStateRevert [list $app] $type; \ + tkConStateCompare [list $app] $type $verbose" + $w.btn.update config -command [info level 0] + if $verbose { + $w.btn.expand config -text Brief \ + -command [list tkConStateCompare $app $type 0] + } else { + $w.btn.expand config -text Verbose \ + -command [list tkConStateCompare $app $type 1] + } + ## Don't allow verbose mode unless 'dump' exists in $app + ## We're assuming this is TkCon's dump command + set hasdump [string comp {} [tkConEvalOther $app $type info comm dump]] + if $hasdump { + $w.btn.expand config -state normal + } else { + $w.btn.expand config -state disabled + } + + set cmds [lremove [tkConEvalOther $app $type info comm *] \ + $tkCon($type,$app,cmd)] + set vars [lremove [tkConEvalOther $app $type info vars *] \ + $tkCon($type,$app,var)] + + if {$hasdump && $verbose} { + set cmds [tkConEvalOther $app $type eval dump c -nocomplain $cmds] + set vars [tkConEvalOther $app $type eval dump v -nocomplain $vars] + } + $w.text insert 1.0 "NEW COMMANDS IN \"$app\":\n" red \ + $cmds {} "\n\nNEW VARIABLES IN \"$app\":\n" red $vars {} + + raise $w + $w.text config -state disabled + } + + ## tkConStateRevert - reverts interpreter to previous state + # ARGS: + ## + proc tkConStateRevert {app type} { + global tkCon + if ![info exists tkCon($type,$app,cmd)] { + return -code error "No previously checkpointed state for $type \"$app\"" + } + if {![tk_dialog $tkCon(base).warning "Revert State?" \ + "Are you sure you want to revert the state in $type \"$app\"?" \ + questhead 1 "Do It" "Cancel"]} { + foreach i [lremove [tkConEvalOther $app $type info comm *] \ + $tkCon($type,$app,cmd)] { + catch {tkConEvalOther $app $type rename $i {}} + } + foreach i [lremove [tkConEvalOther $app $type info vars *] \ + $tkCon($type,$app,var)] { + catch {tkConEvalOther $app $type unset $i} + } + } + } + + ## tkConStateCleanup - cleans up state information in master array + # + ## + proc tkConStateCleanup {args} { + global tkCon + if [string match {} $args] { + foreach state [array names tkCon slave,*] { + if ![interp exists [string range $state 6 end]] { unset tkCon($state) } + } + } else { + set app [lindex $args 0] + set type [lindex $args 1] + if [regexp {^(|slave)$} $type] { + foreach state [concat [array names tkCon slave,$app] \ + [array names tkCon "slave,$app *"]] { + if ![interp exists [string range $state 6 end]] {unset tkCon($state)} + } + } else { + catch {unset tkCon($type,$app)} + } + } + } +} + +## tkcon - command that allows control over the console +# ARGS: totally variable, see internal comments +## +proc tkcon {cmd args} { + global tkCon errorInfo + switch -glob -- $cmd { + bg* { + ## 'bgerror' Brings up an error dialog + set errorInfo [lindex $args 1] + bgerror [lindex $args 0] + } + cl* { + ## 'close' Closes the console + tkConDestroy + } + con* { + ## 'console' - passes the args to the text widget of the console. + eval $tkCon(console) $args + } + err* { + ## Outputs stack caused by last error. + if {[llength $args]==2} { + set app [lindex $args 0] + set type [lindex $args 1] + if [catch {tkConEvalOther $app $type set errorInfo} info] { + set info "error getting info from $type $app:\n$info" + } + } else { set info $tkCon(errorInfo) } + if [string match {} $info] { set info {errorInfo empty} } + catch {destroy $tkCon(base).error} + set w [toplevel $tkCon(base).error] + wm title $w "TkCon Last Error" + button $w.close -text Dismiss -command [list destroy $w] + scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview] + text $w.text -font $tkCon(font) -yscrollcommand [list $w.sy set] + pack $w.close -side bottom -fill x + pack $w.sy -side right -fill y + pack $w.text -fill both -expand 1 + $w.text insert 1.0 $info + $w.text config -state disabled + } + fi* { + ## 'find' string + tkConFind $tkCon(console) $args + } + fo* { + ## 'font' ?fontname? - gets/sets the font of the console + if [string comp {} $args] { + return [$tkCon(console) config -font $args] + } else { + return [$tkCon(console) config -font] + } + } + get* { + ## 'gets' a replacement for [gets stdin varname] + ## This forces a complete command to be input though + set old [bind Console ] + bind Console { set tkCon(wait) 0 } + bind Console { set tkCon(wait) 0 } + set w $tkCon(console) + vwait tkCon(wait) + set line [tkConCmdGet $tkCon(console)] + $w insert end \n + while {![info complete $line]} { + vwait tkCon(wait) + set line [tkConCmdGet $tkCon(console)] + $w insert end \n + } + bind Console $old + bind Console $old + if [string match {} $args] { + return $line + } else { + upvar [lindex $args 0] data + set data $line + return [string length $line] + } + } + hid* { + ## 'hide' - hides the console with 'withdraw'. + wm withdraw $tkCon(root) + } + his* { + ## 'history' + set sub {\2} + if [string match -n* $args] { append sub "\n" } + set h [tkConEvalSlave history] + regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h + return $h + } + ico* { + ## 'iconify' - iconifies the console with 'iconify'. + wm iconify $tkCon(root) + } + mas* - eval { + ## 'master' - evals contents in master interpreter + uplevel \#0 $args + } + set { + ## 'set' - set (or get, or unset) simple variables (not whole arrays) + ## from the master console interpreter + ## possible formats: + ## tkcon set + ## tkcon set + ## tkcon set w + ## tkcon set u + ## tkcon set r + if {[llength $args]==5} { + ## This is for use with 'tkcon upvar' and only works with slaves + set var [lindex $args 0] + set i [lindex $args 1] + set var1 [lindex $args 2] + set var2 [lindex $args 3] + if [string compare {} $var2] { append var1 "($var2)" } + set op [lindex $args 4] + switch $op { + u { uplevel \#0 [list unset $var] } + w { + return [uplevel \#0 set \{$var\} [interp eval $i set \{$var1\}]] + } + r { + return [interp eval $i set \{$var1\} [uplevel \#0 set \{$var\}]] + } + } + } + return [uplevel \#0 set $args] + } + sh* - dei* { + ## 'show|deiconify' - deiconifies the console. + wm deiconify $tkCon(root) + raise $tkCon(root) + } + ti* { + ## 'title' ?title? - gets/sets the console's title + if [string comp {} $args] { + return [wm title $tkCon(root) $args] + } else { + return [wm title $tkCon(root)] + } + } + u* { + ## 'upvar' masterVar slaveVar + ## link slave variable slaveVar to the master variable masterVar + ## only works masters<->slave + set masterVar [lindex $args 0] + set slaveVar [lindex $args 1] + if [info exists $masterVar] { + interp eval $tkCon(exec) [list set $myVar [set $masterVar]] + } else { + catch {interp eval $tkCon(exec) [list unset $myVar]} + } + interp eval $tkCon(exec) [list trace variable $myVar rwu \ + [list tkcon set $masterVar $tkCon(exec)]] + return + } + v* { + return $tkCon(version) + } + default { + ## tries to determine if the command exists, otherwise throws error + set new tkCon[string toup [string index $cmd 0]][string range $cmd 1 end] + if [string comp {} [info command $new]] { + uplevel \#0 $new $args + } else { + return -code error "bad option \"$cmd\": must be\ + [join [lsort [list attach close console destroy font hide \ + iconify load main master new save show slave deiconify \ + version title bgerror]] {, }]" + } + } + } +} + +## +## Some procedures to make up for lack of built-in shell commands +## + +## puts +## This allows me to capture all stdout/stderr to the console window +# ARGS: same as usual +# Outputs: the string with a color-coded text tag +## +if ![catch {rename puts tcl_puts}] { + proc puts args { + set len [llength $args] + if {$len==1} { + eval tkcon console insert output $args stdout {\n} stdout + tkcon console see output + } elseif {$len==2 && \ + [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} { + if [string comp $tmp -nonewline] { + eval tkcon console insert output [lreplace $args 0 0] $tmp {\n} $tmp + } else { + eval tkcon console insert output [lreplace $args 0 0] stdout + } + tkcon console see output + } elseif {$len==3 && \ + [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { + if [string comp [lreplace $args 1 2] -nonewline] { + eval tkcon console insert output [lrange $args 1 1] $tmp + } else { + eval tkcon console insert output [lreplace $args 0 1] $tmp + } + tkcon console see output + } else { + global errorCode errorInfo + if [catch "tcl_puts $args" msg] { + regsub tcl_puts $msg puts msg + regsub -all tcl_puts $errorInfo puts errorInfo + error $msg + } + return $msg + } + if $len update + } +} + +## echo +## Relaxes the one string restriction of 'puts' +# ARGS: any number of strings to output to stdout +## +proc echo args { puts [concat $args] } + +## clear - clears the buffer of the console (not the history though) +## This is executed in the parent interpreter +## +proc clear {{pcnt 100}} { + if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { + return -code error \ + "invalid percentage to clear: must be 1-100 (100 default)" + } elseif {$pcnt == 100} { + tkcon console delete 1.0 end + } else { + set tmp [expr $pcnt/100.0*[tkcon console index end]] + tkcon console delete 1.0 "$tmp linestart" + } +} + +## alias - akin to the csh alias command +## If called with no args, then it dumps out all current aliases +## If called with one arg, returns the alias of that arg (or {} if none) +# ARGS: newcmd - (optional) command to bind alias to +# args - command and args being aliased +## +proc alias {{newcmd {}} args} { + if [string match {} $newcmd] { + set res {} + foreach a [interp aliases] { + lappend res [list $a -> [interp alias {} $a]] + } + return [join $res \n] + } elseif {[string match {} $args]} { + interp alias {} $newcmd + } else { + eval interp alias [list {} $newcmd {}] $args + } +} + +## unalias - unaliases an alias'ed command +# ARGS: cmd - command to unbind as an alias +## +proc unalias {cmd} { + interp alias {} $cmd {} +} + +## dump - outputs variables/procedure/widget info in source'able form. +## Accepts glob style pattern matching for the names +# ARGS: type - type of thing to dump: must be variable, procedure, widget +# OPTS: -nocomplain +# don't complain if no vars match something +# -filter pattern +# specifies a glob filter pattern to be used by the variable +# method as an array filter pattern (it filters down for +# nested elements) and in the widget method as a config +# option filter pattern +# -- forcibly ends options recognition +# Returns: the values of the requested items in a 'source'able form +## +proc dump {type args} { + set whine 1 + set code ok + while {[string match -* $args]} { + switch -glob -- [lindex $args 0] { + -n* { set whine 0; set args [lreplace $args 0 0] } + -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] } + -- { set args [lreplace $args 0 0]; break } + default { return -code error "unknown option \"[lindex $args 0]\"" } + } + } + if {$whine && [string match {} $args]} { + return -code error "wrong \# args: [lindex [info level 0] 0]\ + ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?" + } + set res {} + switch -glob -- $type { + c* { + # command + # outpus commands by figuring out, as well as possible, what it is + # this does not attempt to auto-load anything + foreach arg $args { + if [string comp {} [set cmds [info comm $arg]]] { + foreach cmd [lsort $cmds] { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + append res "\#\# ALIAS: $cmd => [interp alias {} $cmd]\n" + } elseif {[string comp {} [info procs $cmd]]} { + if {[catch {dump p -- $cmd} msg] && $whine} { set code error } + append res $msg\n + } else { + append res "\#\# COMMAND: $cmd\n" + } + } + } elseif $whine { + append res "\#\# No known command $arg\n" + set code error + } + } + } + v* { + # variable + # outputs variables value(s), whether array or simple. + if ![info exists fltr] { set fltr * } + foreach arg $args { + if {[string match {} [set vars [uplevel info vars [list $arg]]]]} { + if {[uplevel info exists $arg]} { + set vars $arg + } elseif $whine { + append res "\#\# No known variable $arg\n" + set code error + continue + } else continue + } + foreach var [lsort $vars] { + upvar $var v + if {[array exists v]} { + set nest {} + append res "array set $var \{\n" + foreach i [lsort [array names v $fltr]] { + upvar 0 v\($i\) __ary + if {[array exists __ary]} { + append nest "\#\# NESTED ARRAY ELEMENT: $i\n" + append nest "upvar 0 [list $var\($i\)] __ary;\ + [dump v -filter $fltr __ary]\n" + } else { + append res " [list $i]\t[list $v($i)]\n" + } + } + append res "\}\n$nest" + } else { + append res [list set $var $v]\n + } + } + } + } + p* { + # procedure + foreach arg $args { + if {[string comp {} [set ps [info proc $arg]]] || + ([auto_load $arg] && + [string comp {} [set ps [info proc $arg]]])} { + foreach p [lsort $ps] { + set as {} + foreach a [info args $p] { + if {[info default $p $a tmp]} { + lappend as [list $a $tmp] + } else { + lappend as $a + } + } + append res [list proc $p $as [info body $p]]\n + } + } elseif $whine { + append res "\#\# No known proc $arg\n" + set code error + } + } + } + w* { + # widget + ## The user should have Tk loaded + if [string match {} [info command winfo]] { + return -code error "winfo not present, cannot dump widgets" + } + if ![info exists fltr] { set fltr .* } + foreach arg $args { + if [string comp {} [set ws [info command $arg]]] { + foreach w [lsort $ws] { + if [winfo exists $w] { + if [catch {$w configure} cfg] { + append res "\#\# Widget $w does not support configure method" + set code error + } else { + append res "\#\# [winfo class $w] $w\n$w configure" + foreach c $cfg { + if {[llength $c] != 5} continue + if {[regexp -nocase -- $fltr $c]} { + append res " \\\n\t[list [lindex $c 0] [lindex $c 4]]" + } + } + append res \n + } + } + } + } elseif $whine { + append res "\#\# No known widget $arg\n" + set code error + } + } + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"$type\":\ must be procedure, variable, widget" + } + } + return -code $code [string trimr $res \n] +} + +## idebug - interactive debugger +# ARGS: opt +# +## +proc idebug {opt args} { + global IDEBUG + + if ![info exists IDEBUG(on)] { array set IDEBUG { on 0 id * debugging 0 } } + set level [expr [info level]-1] + switch -glob -- $opt { + on { + if [string comp {} $args] { set IDEBUG(id) $args } + return [set IDEBUG(on) 1] + } + off { return [set IDEBUG(on) 0] } + id { + if [string match {} $args] { + return $IDEBUG(id) + } else { return [set IDEBUG(id) $args] } + } + break { + if {!$IDEBUG(on) || $IDEBUG(debugging) || ([string comp {} $args] \ + && ![string match $IDEBUG(id) $args]) || [info level]<1} return + set IDEBUG(debugging) 1 + puts stderr "idebug at level \#$level: [lindex [info level -1] 0]" + set tkcon [string comp {} [info command tkcon]] + if $tkcon { + tkcon show + tkcon master eval set tkCon(prompt2) \$tkCon(prompt1) + tkcon master eval set tkCon(prompt1) \$tkCon(debugPrompt) + set slave [tkcon set tkCon(exec)] + set event [tkcon set tkCon(event)] + tkcon set tkCon(exec) [tkcon master interp create debugger] + tkcon set tkCon(event) 1 + } + set max $level + while 1 { + set err {} + if $tkcon { + tkcon evalSlave set level $level + tkcon prompt + set line [tkcon gets] + tkcon console mark set output end + } else { + puts -nonewline stderr "(level \#$level) debug > " + gets stdin line + while {![info complete $line]} { puts -nonewline "> " - } - } - flush stdout - .console.t mark set output $temp - tkTextSetCursor .console.t end - .console.t mark set promptEnd insert - .console.t mark gravity promptEnd left -} - -# tkConsoleBind -- -# This procedure first ensures that the default bindings for the Text -# class have been defined. Then certain bindings are overridden for -# the class. -# -# Arguments: -# None. - -proc tkConsoleBind {win} { - bindtags $win "$win Text . all" - - # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. - # Otherwise, if a widget binding for one of these is defined, the - # class binding will also fire and insert the character, - # which is wrong. Ditto for . - - bind $win {# nothing } - bind $win {# nothing} - bind $win {# nothing} - bind $win {# nothing} - bind $win {# nothing} - - bind $win { - tkConsoleInsert %W \t - focus %W - break - } - bind $win { - %W mark set insert {end - 1c} - tkConsoleInsert %W "\n" - tkConsoleInvoke - break - } - bind $win { - if {[%W tag nextrange sel 1.0 end] != ""} { - %W tag remove sel sel.first promptEnd - } else { - if [%W compare insert < promptEnd] { - break - } + append line "\n[gets stdin]" + } } - } - bind $win { - if {[%W tag nextrange sel 1.0 end] != ""} { - %W tag remove sel sel.first promptEnd - } else { - if [%W compare insert <= promptEnd] { - break - } + if [string match {} $line] continue + set key [lindex $line 0] + if ![regexp {^([\#-]?[0-9]+)} [lreplace $line 0 0] lvl] { + set lvl \#$level } + set res {}; set c 0 + switch -- $key { + + { + ## Allow for jumping multiple levels + if {$level < $max} { idebug trace [incr level] $level 0 VERBOSE } + } + - { + ## Allow for jumping multiple levels + if {$level > 1} { idebug trace [incr level -1] $level 0 VERBOSE } + } + . { set c [catch { idebug trace $level $level 0 VERBOSE } res] } + v { set c [catch { idebug show vars $lvl } res] } + V { set c [catch { idebug show vars $lvl VERBOSE } res] } + l { set c [catch { idebug show locals $lvl } res] } + L { set c [catch { idebug show locals $lvl VERBOSE } res] } + g { set c [catch { idebug show globals $lvl } res] } + G { set c [catch { idebug show globals $lvl VERBOSE } res] } + t { set c [catch { idebug trace 1 $max $level } res] } + T { set c [catch { idebug trace 1 $max $level VERBOSE } res] } + b { set c [catch { idebug body $lvl } res] } + o { set res [set IDEBUG(on) [expr !$IDEBUG(on)]] } + h - ? { + puts stderr " + Move down in call stack + - Move up in call stack + . Show current proc name and params + + v Show names of variables currently in scope + V Show names of variables currently in scope with values + l Show names of local (transient) variables + L Show names of local (transient) variables with values + g Show names of declared global variables + G Show names of declared global variables with values + t Show a stack trace + T Show a verbose stack trace + + b Show body of current proc + o Toggle on/off any further debugging + c,q Continue regular execution (Quit debugger) + h,? Print this help + default Evaluate line at current level (\#$level)" + } + c - q break + default { set c [catch {uplevel \#$level $line} res] } + } + if $tkcon { + tkcon set tkCon(event) \ + [tkcon evalSlave eval history add [list $line] \; history nextid] + } + if $c { puts stderr $res } elseif {[string comp {} $res]} { puts $res } + } + set IDEBUG(debugging) 0 + if $tkcon { + tkcon master interp delete debugger + tkcon master eval set tkCon(prompt1) \$tkCon(prompt2) + tkcon set tkCon(exec) $slave + tkcon set tkCon(event) $event + tkcon prompt + } } - foreach left {Control-a Home} { - bind $win <$left> { - if [%W compare insert < promptEnd] { - tkTextSetCursor %W {insert linestart} + bo* { + if [regexp {^([\#-]?[0-9]+)} $args level] { + return [uplevel $level { dump com -no [lindex [info level 0] 0] }] + } + } + t* { + if {[llength $args]<2} return + set min [set max [set lvl $level]] + if ![regexp {^\#?([0-9]+)? ?\#?([0-9]+) ?\#?([0-9]+)? ?(VERBOSE)?} \ + $args junk min max lvl verbose] return + for {set i $max} { + $i>=$min && ![catch {uplevel \#$i info level 0} info] + } {incr i -1} { + if {$i==$lvl} { + puts -nonewline stderr "* \#$i:\t" + } else { + puts -nonewline stderr " \#$i:\t" + } + set name [lindex $info 0] + if {[string comp VERBOSE $verbose] || \ + [string match {} [info procs $name]]} { + puts $info + } else { + puts "proc $name {[info args $name]} { ... }" + set idx 0 + foreach arg [info args $name] { + if [string match args $arg] { + puts "\t$arg = [lrange $info [incr idx] end]"; break } else { - tkTextSetCursor %W promptEnd - } - break - } - } - foreach right {Control-e End} { - bind $win <$right> { - tkTextSetCursor %W {insert lineend} - break - } - } - bind $win { - if [%W compare insert < promptEnd] { - break - } - } - bind $win { - if [%W compare insert < promptEnd] { - %W mark set insert promptEnd - } - } - bind $win { - if [%W compare insert < promptEnd] { - break - } - } - bind $win { - if [%W compare insert < promptEnd] { - break - } - } - bind $win { - if [%W compare insert <= promptEnd] { - break - } - } - bind $win { - if [%W compare insert <= promptEnd] { - break - } - } - foreach prev {Control-p Up} { - bind $win <$prev> { - tkConsoleHistory prev - break - } - } - foreach prev {Control-n Down} { - bind $win <$prev> { - tkConsoleHistory next - break - } - } - bind $win { - if [%W compare insert > promptEnd] { - catch { - %W insert insert [selection get -displayof %W] {input stdin} - %W see insert + puts "\t$arg = [lindex $info [incr idx]]" } + } } - break + } } - bind $win { - catch {tkConsoleInsert %W [selection get -displayof %W]} - break + s* { + #var, local, global + set level \#$level + if ![regexp {^([vgl][^ ]*) ?([\#-]?[0-9]+)? ?(VERBOSE)?} \ + $args junk type level verbose] return + switch -glob -- $type { + v* { set vars [uplevel $level {lsort [info vars]}] } + l* { set vars [uplevel $level {lsort [info locals]}] } + g* { set vars [lremove [uplevel $level {info vars}] \ + [uplevel $level {info locals}]] } + } + if [string match VERBOSE $verbose] { + return [uplevel $level dump var -nocomplain $vars] + } else { + return $vars + } } - bind $win { - tkConsoleInsert %W %A - break + e* - pu* { + if {[llength $opt]==1 && [catch {lindex [info level -1] 0} id]} { + set id [lindex [info level 0] 0] + } else { + set id [lindex $opt 1] + } + if {$IDEBUG(on) && [string match $IDEBUG(id) $id]} { + if [string match e* $opt] { + puts [concat $args] + } else { eval puts $args } + } } - foreach left {Control-b Left} { - bind $win <$left> { - if [%W compare insert == promptEnd] { - break - } - tkTextSetCursor %W insert-1c - break - } - } - foreach right {Control-f Right} { - bind $win <$right> { - tkTextSetCursor %W insert+1c - break - } - } - bind $win { - eval destroy [winfo child .] - source $tk_library/console.tcl - } - foreach copy {F16 Meta-w Control-i} { - bind $win <$copy> { - if {[selection own -displayof %W] == "%W"} { - clipboard clear -displayof %W - catch { - clipboard append -displayof %W [selection get -displayof %W] - } - } - break - } - } - foreach paste {F18 Control-y} { - bind $win <$paste> { - catch { - set clip [selection get -displayof %W -selection CLIPBOARD] - set list [split $clip \n\r] - tkConsoleInsert %W [lindex $list 0] - foreach x [lrange $list 1 end] { - %W mark set insert {end - 1c} - tkConsoleInsert %W "\n" - tkConsoleInvoke - tkConsoleInsert %W $x - } - } - break - } + default { + return -code error "bad [lindex [info level 0] 0] option \"$opt\":\ + must be [join [lsort [list on off id break print body trace \ + show puts echo]] {, }]" } + } } -# tkConsoleInsert -- -# Insert a string into a text at the point of the insertion cursor. -# If there is a selection in the text, and it covers the point of the -# insertion cursor, then delete the selection before inserting. Insertion -# is restricted to the prompt area. +## observe - like trace, but not +# ARGS: opt - option +# name - name of variable or command +## +proc observe {opt name args} { + global tcl_observe + switch -glob -- $opt { + co* { + if [regexp {^(catch|lreplace|set|puts|for|incr|info|uplevel)$} $name] { + return -code error \ + "cannot observe \"$name\": infinite eval loop will occur" + } + set old ${name}@ + while {[string comp {} [info command $old]]} { append old @ } + rename $name $old + set max 4 + regexp {^[0-9]+} $args max + ## idebug trace could be used here + proc $name args " + for {set i \[info level\]; set max \[expr \[info level\]-$max\]} { + \$i>=\$max && !\[catch {uplevel \#\$i info level 0} info\] + } {incr i -1} { + puts -nonewline stderr \" \#\$i:\t\" + puts \$info + } + uplevel \[lreplace \[info level 0\] 0 0 $old\] + " + set tcl_observe($name) $old + } + cd* { + if {[info exists tcl_observe($name)] && [catch { + rename $name {} + rename $tcl_observe($name) $name + unset tcl_observe($name) + } err]} { return -code error $err } + } + ci* { + ## What a useless method... + if [info exists tcl_observe($name)] { + set i $tcl_observe($name) + set res "\"$name\" observes true command \"$i\"" + while {[info exists tcl_observe($i)]} { + append res "\n\"$name\" observes true command \"$i\"" + set i $tcl_observe($name) + } + return $res + } + } + va* - vd* { + set type [lindex $args 0] + set args [lrange $args 1 end] + if ![regexp {^[rwu]} $type type] { + return -code error "bad [lindex [info level 0] 0] $opt type\ + \"$type\": must be read, write or unset" + } + if [string match {} $args] { set args observe_var } + uplevel [list trace $opt $name $type $args] + } + vi* { + uplevel [list trace vinfo $name] + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"[lindex $args 0]\": must be [join [lsort [list procedure \ + pdelete pinfo variable vdelete vinfo]] {, }]" + } + } +} + +## observe_var - auxilary function for observing vars, called by trace +## via observe +# ARGS: name - variable name +# el - array element name, if any +# op - operation type (rwu) +## +proc observe_var {name el op} { + if [string match u $op] { + if [string comp {} $el] { + puts "unset \"$name\($el\)\"" + } else { + puts "unset \"$name\"" + } + } else { + upvar $name $name + if [info exists $name\($el\)] { + puts [dump v $name\($el\)] + } else { + puts [dump v $name] + } + } +} + +## which - tells you where a command is found +# ARGS: cmd - command name +# Returns: where command is found (internal / external / unknown) +## +proc which cmd { + if {[string comp {} [info commands $cmd]] || + ([auto_load $cmd] && [string comp {} [info commands $cmd]])} { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + return "$cmd:\taliased to [alias $cmd]" + } elseif {[string comp {} [info procs $cmd]]} { + return "$cmd:\tinternal proc" + } else { + return "$cmd:\tinternal command" + } + } elseif {[string comp {} [auto_execok $cmd]]} { + return [auto_execok $cmd] + } else { + return -code error "$cmd:\tunknown command" + } +} + +## auto_execpath - tells you where an external command is found +## Only a slight modification from core auto_execok proc +# ARGS: cmd - command name +# Returns: where command is found or {} if not found +## +if {[info tclversion]<7.6} { +if {[string match $tcl_platform(platform) windows]} { + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to a shell builtin or an executable in the +# Windows search path, or "" otherwise. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +# Windows version. +# +# Note that info executable doesn't work under Windows, so we have to +# look for files with .exe, .com, or .bat extensions. Also, the path +# may be in the Path or PATH environment variables, and path +# components are separated with semicolons, not colons as under Unix. +# +proc auto_execok name { + global auto_execs env tcl_platform + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) "" + + if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename + ren rmdir rd time type ver vol} $name] != -1} { + if {[info exists env(COMSPEC)]} { + set comspec $env(COMSPEC) + } elseif {[info exists env(ComSpec)]} { + set comspec $env(ComSpec) + } elseif {$tcl_platform(os) == "Windows NT"} { + set comspec "cmd.exe" + } else { + set comspec "command.com" + } + return [set auto_execs($name) [list $comspec /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext {{} .com .exe .bat} { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) $file] + } + } + return "" + } + + set path "[file dirname [info nameof]];.;" + if {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } elseif {[info exists env(windir)]} { + set windir $env(windir) + } + if {[info exists windir]} { + if {$tcl_platform(os) == "Windows NT"} { + append path "$windir/system32;" + } + append path "$windir/system;$windir;" + } + + if {! [info exists env(PATH)]} { + if [info exists env(Path)] { + append path $env(Path) + } else { + return "" + } + } else { + append path $env(PATH) + } + + foreach dir [split $path {;}] { + if {$dir == ""} { + set dir . + } + foreach ext {{} .com .exe .bat} { + set file [file join $dir ${name}${ext}] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) $file] + } + } + } + return "" +} + +} else { + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to an executable in the path. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +# Unix version. +# +proc auto_execok name { + global auto_execs env + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) "" + if {[llength [file split $name]] != 1} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execs($name) $name + } + return $auto_execs($name) + } + foreach dir [split $env(PATH) :] { + if {$dir == ""} { + set dir . + } + set file [file join $dir $name] + if {[file executable $file] && ![file isdirectory $file]} { + set auto_execs($name) $file + return $file + } + } + return "" +} + +} +} + +## dir - directory list +# ARGS: args - names/glob patterns of directories to list +# OPTS: -all - list hidden files as well (Unix dot files) +# -long - list in full format "permissions size date filename" +# -full - displays / after directories and link paths for links +# Returns: a directory listing +## +proc dir {args} { + array set s { + all 0 full 0 long 0 + 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx + } + while {[string match \-* [lindex $args 0]]} { + set str [lindex $args 0] + set args [lreplace $args 0 0] + switch -glob -- $str { + -a* {set s(all) 1} -f* {set s(full) 1} + -l* {set s(long) 1} -- break + default { + return -code error \ + "unknown option \"$str\", should be one of: -all, -full, -long" + } + } + } + set sep [string trim [file join . .] .] + if [string match {} $args] { set args . } + foreach arg $args { + if {[file isdir $arg]} { + set arg [string trimr $arg $sep]$sep + if $s(all) { + lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]] + } else { + lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]] + } + } else { + lappend out [list [file dirname $arg]$sep \ + [lsort [glob -nocomplain -- $arg]]] + } + } + if $s(long) { + set old [clock scan {1 year ago}] + set fmt "%s%9d %s %s\n" + foreach o $out { + set d [lindex $o 0] + append res $d:\n + foreach f [lindex $o 1] { + file lstat $f st + set f [file tail $f] + if $s(full) { + switch -glob $st(type) { + d* { append f $sep } + l* { append f "@ -> [file readlink $d$sep$f]" } + default { if [file exec $d$sep$f] { append f * } } + } + } + if [string match file $st(type)] { + set mode - + } else { + set mode [string index $st(type) 0] + } + foreach j [split [format %o [expr $st(mode)&0777]] {}] { + append mode $s($j) + } + if {$st(mtime)>$old} { + set cfmt {%b %d %H:%M} + } else { + set cfmt {%b %d %Y} + } + append res [format $fmt $mode $st(size) \ + [clock format $st(mtime) -format $cfmt] $f] + } + append res \n + } + } else { + foreach o $out { + set d [lindex $o 0] + append res $d:\n + set i 0 + foreach f [lindex $o 1] { + if {[string len [file tail $f]] > $i} { + set i [string len [file tail $f]] + } + } + set i [expr $i+2+$s(full)] + ## This gets the number of cols in the TkCon console widget + set j [expr [tkcon master set tkCon(cols)]/$i] + set k 0 + foreach f [lindex $o 1] { + set f [file tail $f] + if $s(full) { + switch -glob [file type $d$sep$f] { + d* { append f $sep } + l* { append f @ } + default { if [file exec $d$sep$f] { append f * } } + } + } + append res [format "%-${i}s" $f] + if {[incr k]%$j == 0} {set res [string trimr $res]\n} + } + append res \n\n + } + } + return [string trimr $res] +} +interp alias {} ls {} dir + +## tclindex - creates the tclIndex file +# OPTS: -ext - extensions to auto index (defaults to *.tcl) +# -pkg - whether to create a pkgIndex.tcl file +# -idx - whether to create a tclIndex file +# ARGS: args - directories to auto index (defaults to pwd) +# Outputs: tclIndex/pkgIndex.tcl file to each directory +## +proc tclindex args { + set truth {^(1|yes|true|on)$}; set pkg 0; set idx 1; + while {[regexp -- {^-[^ ]+} $args opt] && [string comp {} $args]} { + switch -glob -- $opt { + -- { set args [lreplace $args 0 0]; break } + -e* { set ext [lindex $args 1] } + -p* { set pkg [regexp -nocase $truth [lindex $args 1]] } + -i* { set idx [regexp -nocase $truth [lindex $args 1]] } + default { + return -code error "bad option \"$opt\": must be one of\ + [join [lsort [list -- -extension -package -index]] {, }]" + } + set args [lreplace $args 0 1] + } + } + if ![info exists ext] { + set ext {*.tcl} + if $pkg { lappend ext *[info sharedlibextension] } + } + if [string match {} $args] { + if $idx { eval auto_mkindex [list [pwd]] $ext } + if $pkg { eval pkg_mkIndex [list [pwd]] $ext } + } else { + foreach dir $args { + if [file isdir $dir] { + if $idx { eval auto_mkindex [list [pwd]] $ext } + if $pkg { eval pkg_mkIndex [list [pwd]] $ext } + } + } + } +} + +## lremove - remove items from a list +# OPTS: -all remove all instances of each item +# ARGS: l a list to remove items from +# args items to remove +## +proc lremove {args} { + set all 0 + if [string match \-a* [lindex $args 0]] { + set all 1 + set args [lreplace $args 0 0] + } + set l [lindex $args 0] + eval append is [lreplace $args 0 0] + foreach i $is { + if {[set ix [lsearch -exact $l $i]] == -1} continue + set l [lreplace $l $ix $ix] + if $all { + while {[set ix [lsearch -exact $l $i]] != -1} { + set l [lreplace $l $ix $ix] + } + } + } + return $l +} + +## Unknown changed to get output into tkCon window +# unknown: +# Invoked automatically whenever an unknown command is encountered. +# Works through a list of "unknown handlers" that have been registered +# to deal with unknown commands. Extensions can integrate their own +# handlers into the "unknown" facility via "unknown_handle". +# +# If a handler exists that recognizes the command, then it will +# take care of the command action and return a valid result or a +# Tcl error. Otherwise, it should return "-code continue" (=2) +# and responsibility for the command is passed to the next handler. # # Arguments: -# w - The text window in which to insert the string -# s - The string to insert (usually just a single character) +# args - A list whose elements are the words of the original +# command, including the command name. -proc tkConsoleInsert {w s} { - if {$s == ""} { - return +proc unknown args { + global unknown_handler_order unknown_handlers errorInfo errorCode + + # + # Be careful to save error info now, and restore it later + # for each handler. Some handlers generate their own errors + # and disrupt handling. + # + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + + if {![info exists unknown_handler_order] || ![info exists unknown_handlers]} { + set unknown_handlers(tcl) tcl_unknown + set unknown_handler_order tcl } + + foreach handler $unknown_handler_order { + set status [catch {uplevel $unknown_handlers($handler) $args} result] + + if {$status == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code $status -errorcode $errorCode \ + -errorinfo $new $result + + } elseif {$status != 4} { + return -code $status $result + } + + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + } + + set name [lindex $args 0] + return -code error "invalid command name \"$name\"" +} + +# tcl_unknown: +# Invoked when a Tcl command is invoked that doesn't exist in the +# interpreter: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +proc tcl_unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + unset unknown_pending($name) + if ![array size unknown_pending] { unset unknown_pending } + return -code error \ + "self-referential recursion in \"unknown\" for command \"$name\"" + } + ## FIX delete line + set unknown_pending(dummy) dummy + set unknown_pending($name) pending + set ret [catch {auto_load $name} msg] + ## FIX no catch + catch { unset unknown_pending($name) } + if $ret { + return -code $ret -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { unset unknown_pending } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + if {[info level] == 1 && [string match {} [info script]] \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + set new [auto_execok $name] + if {$new != ""} { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + return [uplevel exec [list $new] [lrange $args 1 end]] + #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + ## + ## History substitution moved into tkConEvalCmd + ## + set cmds [info commands $name*] + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } + if {[llength $cmds]} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code continue +} + +proc tkConBindings {} { + global tkCon tcl_platform tk_version + + #----------------------------------------------------------------------- + # Elements of tkPriv that are used in this file: + # + # char - Character position on the line; kept in order + # to allow moving up or down past short lines while + # still remembering the desired position. + # mouseMoved - Non-zero means the mouse has moved a significant + # amount since the button went down (so, for example, + # start dragging out a selection). + # prevPos - Used when moving up or down lines via the keyboard. + # Keeps track of the previous insert position, so + # we can distinguish a series of ups and downs, all + # in a row, from a new up or down. + # selectMode - The style of selection currently underway: + # char, word, or line. + # x, y - Last known mouse coordinates for scanning + # and auto-scanning. + #----------------------------------------------------------------------- + + switch -glob $tcl_platform(platform) { + win* { set tkCon(meta) Alt } + mac* { set tkCon(meta) Command } + default { set tkCon(meta) Meta } + } + + ## <> + bind $tkCon(root) tkConExit + ## <> + bind $tkCon(root) { tkConNew } + ## <> + bind $tkCon(root) { tkConDestroy } + ## <> + bind $tkCon(root) { tkConAbout } + ## <> + bind $tkCon(root) { tkConHelp } + ## <> + bind $tkCon(root) { tkConFindBox $tkCon(console) } + ## <> + bind $tkCon(root) { + tkConAttach {} + tkConPrompt "\n" [tkConCmdGet $tkCon(console)] + } + ## <> + bind $tkCon(root) { + if [string comp {} $tkCon(name)] { + tkConAttach $tkCon(name) + } else { + tkConAttach Main + } + tkConPrompt "\n" [tkConCmdGet $tkCon(console)] + } + ## <> + bind $tkCon(root) { + tkConAttach Main + tkConPrompt "\n" [tkConCmdGet $tkCon(console)] + } + + ## Menu items need null PostCon bindings to avoid the TagProc + ## + foreach ev [bind $tkCon(root)] { + bind PostCon $ev { + # empty + } + } + + # tkConClipboardKeysyms -- + # This procedure is invoked to identify the keys that correspond to + # the "copy", "cut", and "paste" functions for the clipboard. + # + # Arguments: + # copy - Name of the key (keysym name plus modifiers, if any, + # such as "Meta-y") used for the copy operation. + # cut - Name of the key used for the cut operation. + # paste - Name of the key used for the paste operation. + + proc tkConClipboardKeysyms {copy cut paste} { + bind Console <$copy> {tkConCopy %W} + bind Console <$cut> {tkConCut %W} + bind Console <$paste> {tkConPaste %W} + } + + proc tkConCut w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch { + clipboard append -displayof $w [selection get -displayof $w] + if [$w compare sel.first >= limit] {$w delete sel.first sel.last} + } + } + } + proc tkConCopy w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch {clipboard append -displayof $w [selection get -displayof $w]} + } + } + + proc tkConPaste w { + if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] { + if [$w compare insert < limit] {$w mark set insert end} + $w insert insert $tmp + $w see insert + if [string match *\n* $tmp] {tkConEval $w} + } + } + + ## Get all Text bindings into Console except Unix cut/copy/paste + ## and newline insertion + foreach ev [lremove [bind Text] { \ + \ + }] { + bind Console $ev [bind Text $ev] + } + + ## Redefine for Console what we need + ## + if [string compare {} [info command event]] { + event delete <> + tkConClipboardKeysyms + } else { + tkConClipboardKeysyms F16 F20 F18 + tkConClipboardKeysyms Control-c Control-x Control-v + } + + bind Console {catch {tkConInsert %W [selection get -displayof %W]}} + + bind Console {+ catch { - if {[$w compare sel.first <= insert] - && [$w compare sel.last >= insert]} { - $w tag remove sel sel.first promptEnd - $w delete sel.first sel.last + eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last] + %W mark set insert sel.first + } + } + + ## binding editor needed + ## binding for .tkconrc + + ## <> + bind Console { + if [%W compare {insert linestart} != {limit linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W -1] + } else { + if {$tkCon(event) == [tkConEvalSlave history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } + if [catch {tkConEvalSlave history event \ + [incr tkCon(event) -1]} tkCon(tmp)] { + incr tkCon(event) + } else { + %W delete limit end + %W insert limit $tkCon(tmp) + %W see end + } + } + } + ## <> + bind Console { + if [%W compare {insert linestart} != {end-1c linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W 1] + } else { + if {$tkCon(event) < [tkConEvalSlave history nextid]} { + %W delete limit end + if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} { + %W insert limit $tkCon(cmdbuf) + } else { + %W insert limit [tkConEvalSlave history event $tkCon(event)] } + %W see end + } } - if {[$w compare insert < promptEnd]} { - $w mark set insert end + } + ## <> + bind Console { + if [%W compare insert > limit] {tkConExpand %W path} + break + } + ## <> + bind Console { + if [%W compare insert > limit] {tkConExpand %W proc} + } + ## <> + bind Console { + if [%W compare insert > limit] {tkConExpand %W var} + } + ## <> + bind Console { + if [%W compare insert >= limit] { + tkConInsert %W \t } - $w insert insert $s {input stdin} - $w see insert + } + ## <> - no mod + bind Console { + tkConEval %W + } + bind Console [bind Console ] + bind Console { + if {[string comp {} [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= limit]} { + %W delete sel.first sel.last + } elseif {[%W compare insert >= limit]} { + %W delete insert + %W see insert + } + } + bind Console { + if {[string comp {} [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= limit]} { + %W delete sel.first sel.last + } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} { + %W delete insert-1c + %W see insert + } + } + bind Console [bind Console ] + + bind Console { + tkConInsert %W %A + } + + bind Console { + if [%W compare {limit linestart} == {insert linestart}] { + tkTextSetCursor %W limit + } else { + tkTextSetCursor %W {insert linestart} + } + } + bind Console { + if [%W compare insert < limit] break + %W delete insert + } + bind Console { + if [%W compare insert < limit] break + if [%W compare insert == {insert lineend}] { + %W delete insert + } else { + %W delete insert {insert lineend} + } + } + ## <> + bind Console { + ## Clear console buffer, without losing current command line input + set tkCon(tmp) [tkConCmdGet %W] + clear + tkConPrompt {} $tkCon(tmp) + } + ## <> + bind Console { + ## Goto next command in history + if {$tkCon(event) < [tkConEvalSlave history nextid]} { + %W delete limit end + if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} { + %W insert limit $tkCon(cmdbuf) + } else { + %W insert limit [tkConEvalSlave history event $tkCon(event)] + } + %W see end + } + } + ## <> + bind Console { + ## Goto previous command in history + if {$tkCon(event) == [tkConEvalSlave history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } + if [catch {tkConEvalSlave history event \ + [incr tkCon(event) -1]} tkCon(tmp)] { + incr tkCon(event) + } else { + %W delete limit end + %W insert limit $tkCon(tmp) + %W see end + } + } + ## <> + bind Console { + ## Search history reverse + if {$tkCon(event) == [tkConEvalSlave history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } elseif 0 { + ## FIX + ## event ids get confusing (to user) when they 'cancel' a history + ## search. This should reassign the event id properly. + } + set tkCon(tmp1) [string len $tkCon(cmdbuf)] + incr tkCon(tmp1) -1 + while 1 { + if {[catch {tkConEvalSlave history event \ + [incr tkCon(event) -1]} tkCon(tmp)]} { + incr tkCon(event) + break + } elseif {![string comp $tkCon(cmdbuf) \ + [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} { + %W delete limit end + %W insert limit $tkCon(tmp) + break + } + } + %W see end + } + ## <> + bind Console { + ## Search history forward + set tkCon(tmp1) [string len $tkCon(cmdbuf)] + incr tkCon(tmp1) -1 + while {$tkCon(event) < [tkConEvalSlave history nextid]} { + if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} { + %W delete limit end + %W insert limit $tkCon(cmdbuf) + break + } elseif {![catch {tkConEvalSlave history event \ + $tkCon(event)} tkCon(tmp)] + && ![string comp $tkCon(cmdbuf) \ + [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} { + %W delete limit end + %W insert limit $tkCon(tmp) + break + } + } + %W see end + } + ## <> + bind Console { + ## Transpose current and previous chars + if [%W compare insert > limit] { tkTextTranspose %W } + } + ## <> + bind Console { + ## Clear command line (Unix shell staple) + %W delete limit end + } + ## <> + bind Console { + ## Save command buffer (swaps with current command) + set tkCon(tmp) $tkCon(cmdsave) + set tkCon(cmdsave) [tkConCmdGet %W] + if {[string match {} $tkCon(cmdsave)]} { + set tkCon(cmdsave) $tkCon(tmp) + } else { + %W delete limit end-1c + } + tkConInsert %W $tkCon(tmp) + %W see end + } + catch {bind Console { tkTextScrollPages %W -1 }} + catch {bind Console { tkTextScrollPages %W -1 }} + catch {bind Console { tkTextScrollPages %W 1 }} + catch {bind Console { tkTextScrollPages %W 1 }} + bind Console <$tkCon(meta)-d> { + if [%W compare insert >= limit] { + %W delete insert {insert wordend} + } + } + bind Console <$tkCon(meta)-BackSpace> { + if [%W compare {insert -1c wordstart} >= limit] { + %W delete {insert -1c wordstart} insert + } + } + bind Console <$tkCon(meta)-Delete> { + if [%W compare insert >= limit] { + %W delete insert {insert wordend} + } + } + bind Console { + if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \ + && ![catch {selection get -displayof %W} tkCon(tmp)]} { + if [%W compare @%x,%y < limit] { + %W insert end $tkCon(tmp) + } else { + %W insert @%x,%y $tkCon(tmp) + } + if [string match *\n* $tkCon(tmp)] {tkConEval %W} + } + } + + ## + ## End Console bindings + ## + + ## + ## Bindings for doing special things based on certain keys + ## + bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W \( \) limit + } + } + bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W \[ \] limit + } + } + bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W \{ \} limit + } + } + bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchQuote %W limit + } + } + + bind PostCon { + if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W } + } } -# tkConsoleOutput -- -# -# This routine is called directly by ConsolePutsCmd to cause a string -# to be displayed in the console. -# -# Arguments: -# dest - The output tag to be used: either "stderr" or "stdout". -# string - The string to be displayed. - -proc tkConsoleOutput {dest string} { - .console.t insert output $string $dest - .console.t see insert +## tkConTagProc - tags a procedure in the console if it's recognized +## This procedure is not perfect. However, making it perfect wastes +## too much CPU time... Also it should check the existence of a command +## in whatever is the connected slave, not the master interpreter. +## +proc tkConTagProc w { + set i [$w index "insert-1c wordstart"] + set j [$w index "insert-1c wordend"] + if {[string comp {} \ + [tkConEvalAttached info command [list [$w get $i $j]]]]} { + $w tag add proc $i $j + } else { + $w tag remove proc $i $j + } } -# tkConsoleExit -- -# -# This routine is called by ConsoleEventProc when the main window of -# the application is destroyed. -# -# Arguments: -# None. - -proc tkConsoleExit {} { - exit +## tkConMatchPair - blinks a matching pair of characters +## c2 is assumed to be at the text index 'insert'. +## This proc is really loopy and took me an hour to figure out given +## all possible combinations with escaping except for escaped \'s. +## It doesn't take into account possible commenting... Oh well. If +## anyone has something better, I'd like to see/use it. This is really +## only efficient for small contexts. +# ARGS: w - console text widget +# c1 - first char of pair +# c2 - second char of pair +# Calls: tkConBlink +## +proc tkConMatchPair {w c1 c2 {lim 1.0}} { + if [string comp {} [set ix [$w search -back $c1 insert $lim]]] { + while {[string match {\\} [$w get $ix-1c]] && + [string comp {} [set ix [$w search -back $c1 $ix-1c $lim]]]} {} + set i1 insert-1c + while {[string comp {} $ix]} { + set i0 $ix + set j 0 + while {[string comp {} [set i0 [$w search $c2 $i0 $i1]]]} { + append i0 +1c + if {[string match {\\} [$w get $i0-2c]]} continue + incr j + } + if {!$j} break + set i1 $ix + while {$j && [string comp {} [set ix [$w search -back $c1 $ix $lim]]]} { + if {[string match {\\} [$w get $ix-1c]]} continue + incr j -1 + } + } + if [string match {} $ix] { set ix [$w index $lim] } + } else { set ix [$w index $lim] } + tkConBlink $w $ix [$w index insert] } -# now run the gimp main loop -gimp-main +## tkConMatchQuote - blinks between matching quotes. +## Blinks just the quote if it's unmatched, otherwise blinks quoted string +## The quote to match is assumed to be at the text index 'insert'. +# ARGS: w - console text widget +# Calls: tkConBlink +## +proc tkConMatchQuote {w {lim 1.0}} { + set i insert-1c + set j 0 + while {[string comp {} [set i [$w search -back \" $i $lim]]]} { + if {[string match {\\} [$w get $i-1c]]} continue + if {!$j} {set i0 $i} + incr j + } + if [expr $j%2] { + tkConBlink $w $i0 [$w index insert] + } else { + tkConBlink $w [$w index insert-1c] [$w index insert] + } +} + +## tkConBlink - blinks between 2 indices for a specified duration. +# ARGS: w - console text widget +# i1 - start index to blink region +# i2 - end index of blink region +# dur - duration in usecs to blink for +# Outputs: blinks selected characters in $w +## +proc tkConBlink {w i1 i2} { + global tkCon + $w tag add blink $i1 $i2 + after $tkCon(blinktime) $w tag remove blink $i1 $i2 + return +} + + +## tkConInsert +## Insert a string into a text console at the point of the insertion cursor. +## If there is a selection in the text, and it covers the point of the +## insertion cursor, then delete the selection before inserting. +# ARGS: w - text window in which to insert the string +# s - string to insert (usually just a single char) +# Outputs: $s to text widget +## +proc tkConInsert {w s} { + if {[string match {} $s] || [string match disabled [$w cget -state]]} { + return + } + if [$w comp insert < limit] { + $w mark set insert end + } + catch { + if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { + $w delete sel.first sel.last + } + } + $w insert insert $s + $w see insert +} + +## tkConExpand - +# ARGS: w - text widget in which to expand str +# type - type of expansion (path / proc / variable) +# Calls: tkConExpand(Pathname|Procname|Variable) +# Outputs: The string to match is expanded to the longest possible match. +# If tkCon(showmultiple) is non-zero and the user longest match +# equaled the string to expand, then all possible matches are +# output to stdout. Triggers bell if no matches are found. +# Returns: number of matches found +## +proc tkConExpand {w type} { + set exp "\[^\\]\[ \t\n\r\[\{\"\$]" + set tmp [$w search -back -regexp $exp insert-1c limit-1c] + if [string compare {} $tmp] {append tmp +2c} else {set tmp limit} + if [$w compare $tmp >= insert] return + set str [$w get $tmp insert] + switch -glob $type { + pa* { set res [tkConExpandPathname $str] } + pr* { set res [tkConExpandProcname $str] } + v* { set res [tkConExpandVariable $str] } + default {set res {}} + } + set len [llength $res] + if $len { + $w delete $tmp insert + $w insert $tmp [lindex $res 0] + if {$len > 1} { + global tkCon + if {$tkCon(showmultiple) && ![string comp [lindex $res 0] $str]} { + puts stdout [lreplace $res 0 0] + } + } + } else bell + return [incr len -1] +} + +## tkConExpandPathname - expand a file pathname based on $str +## This is based on UNIX file name conventions +# ARGS: str - partial file pathname to expand +# Calls: tkConExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc tkConExpandPathname str { + set pwd [tkConEvalAttached pwd] + if [catch {tkConEvalAttached [list cd [file dirname $str]]} err] { + return -code error $err + } + if [catch {lsort [tkConEvalAttached glob [file tail $str]*]} m] { + set match {} + } else { + if {[llength $m] > 1} { + set tmp [tkConExpandBestMatch $m [file tail $str]] + if [string match ?*/* $str] { + set tmp [file dirname $str]/$tmp + } elseif {[string match /* $str]} { + set tmp /$tmp + } + regsub -all { } $tmp {\\ } tmp + set match [linsert $m 0 $tmp] + } else { + ## This may look goofy, but it handles spaces in path names + eval append match $m + if [file isdir $match] {append match /} + if [string match ?*/* $str] { + set match [file dirname $str]/$match + } elseif {[string match /* $str]} { + set match /$match + } + regsub -all { } $match {\\ } match + ## Why is this one needed and the ones below aren't!! + set match [list $match] + } + } + tkConEvalAttached [list cd $pwd] + return $match +} + +## tkConExpandProcname - expand a tcl proc name based on $str +# ARGS: str - partial proc name to expand +# Calls: tkConExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc tkConExpandProcname str { + set match [tkConEvalAttached info commands $str*] + if {[llength $match] > 1} { + regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + return $match +} + +## tkConExpandVariable - expand a tcl variable name based on $str +# ARGS: str - partial tcl var name to expand +# Calls: tkConExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc tkConExpandVariable str { + if [regexp {([^\(]*)\((.*)} $str junk ary str] { + ## Looks like they're trying to expand an array. + set match [tkConEvalAttached array names $ary $str*] + if {[llength $match] > 1} { + set vars $ary\([tkConExpandBestMatch $match $str] + foreach var $match {lappend vars $ary\($var\)} + return $vars + } else {set match $ary\($match\)} + ## Space transformation avoided for array names. + } else { + set match [tkConEvalAttached info vars $str*] + if {[llength $match] > 1} { + regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + } + return $match +} + +## tkConExpandBestMatch2 - finds the best unique match in a list of names +## Improves upon the speed of the below proc only when $l is small +## or $e is {}. $e is extra for compatibility with proc below. +# ARGS: l - list to find best unique match in +# Returns: longest unique match in the list +## +proc tkConExpandBestMatch2 {l {e {}}} { + set s [lindex $l 0] + if {[llength $l]>1} { + set i [expr [string length $s]-1] + foreach l $l { + while {$i>=0 && [string first $s $l]} { + set s [string range $s 0 [incr i -1]] + } + } + } + return $s +} + +## tkConExpandBestMatch - finds the best unique match in a list of names +## The extra $e in this argument allows us to limit the innermost loop a +## little further. This improves speed as $l becomes large or $e becomes long. +# ARGS: l - list to find best unique match in +# e - currently best known unique match +# Returns: longest unique match in the list +## +proc tkConExpandBestMatch {l {e {}}} { + set ec [lindex $l 0] + if {[llength $l]>1} { + set e [string length $e]; incr e -1 + set ei [string length $ec]; incr ei -1 + foreach l $l { + while {$ei>=$e && [string first $ec $l]} { + set ec [string range $ec 0 [incr ei -1]] + } + } + } + return $ec +} + +# Here is a group of functions that is only used when Tkcon is +# executed in a safe interpreter. It provides safe versions of +# missing functions. For example: +# +# - "tk appname" returns "tkcon.tcl" but cannot be set +# - "toplevel" is equivalent to "frame", only it is automatically +# packed. +# - The "source", "load", "open", "file" and "exit" functions are +# mapped to corresponding functions in the parent interpreter. +# +# Further on, Tk cannot be really loaded. Still the safe "load" +# provedes a speciall case. The Tk can be divided into 4 groups, +# that each has a safe handling procedure. +# +# - "tkConSafeItem" handles commands like "button", "canvas" ...... +# Each of these functions has the window name as first argument. +# - "tkConSafeManage" handles commands like "pack", "place", "grid", +# "winfo", which can have multiple window names as arguments. +# - "tkConSafeWindow" handles all windows, such as ".". For every +# window created, a new alias is formed which also is handled by +# this function. +# - Other (e.g. bind, bindtag, image), which need their own function. +# +## These functions courtesy Jan Nijtmans (nijtmans@nici.kun.nl) +## +if {[string compare [info command tk] tk]} { + proc tk {option args} { + if {![string match app* $option]} { + error "wrong option \"$option\": should be appname" + } + return "tkcon.tcl" + } +} + +if {[string compare [info command toplevel] toplevel]} { + proc toplevel {name args} { + eval frame $name $args + pack $name + } +} + +proc tkConSafeSource {i f} { + set fd [open $f r] + set r [read $fd] + close $fd + if {[catch {interp eval $i $r} msg]} { + error $msg + } +} + +proc tkConSafeOpen {i f {m r}} { + set fd [open $f $m] + interp transfer {} $fd $i + return $fd +} + +proc tkConSafeLoad {i f p} { + global tk_version tk_patchLevel tk_library + if [string compare $p Tk] { + load $f $p $i + } else { + foreach command {button canvas checkbutton entry frame label + listbox message radiobutton scale scrollbar text toplevel} { + $i alias $command tkConSafeItem $i $command + } + $i alias image tkConSafeImage $i + foreach command {pack place grid destroy winfo} { + $i alias $command tkConSafeManage $i $command + } + if [string comp {} [info command event]] { + $i alias event tkConSafeManage $i $command + } + frame .${i}_dot -width 300 -height 300 -relief raised + pack .${i}_dot -side left + $i alias tk tk + $i alias bind tkConSafeBind $i + $i alias bindtags tkConSafeBindtags $i + $i alias . tkConSafeWindow $i {} + foreach var {tk_version tk_patchLevel tk_library} { + $i eval set $var [set $var] + } + $i eval { + package provide Tk $tk_version + if {[lsearch -exact $auto_path $tk_library] < 0} { + lappend auto_path $tk_library + } + } + return "" + } +} + +proc tkConSafeSubst {i a} { + set arg1 "" + foreach {arg value} $a { + if {![string compare $arg -textvariable] || + ![string compare $arg -variable]} { + set newvalue "[list $i] $value" + global $newvalue + if [interp eval $i info exists $value] { + set $newvalue [interp eval $i set $value] + } else { + catch {unset $newvalue} + } + $i eval trace variable $value rwu \{[list tkcon set $newvalue $i]\} + set value $newvalue + } elseif {![string compare $arg -command]} { + set value [list $i eval $value] + } + lappend arg1 $arg $value + } + return $arg1 +} + +proc tkConSafeItem {i command w args} { + set args [tkConSafeSubst $i $args] + set code [catch "$command [list .${i}_dot$w] $args" msg] + $i alias $w tkConSafeWindow $i $w + regsub -all .${i}_dot $msg {} msg + return -code $code $msg +} + +proc tkConSafeManage {i command args} { + set args1 "" + foreach arg $args { + if [string match . $arg] { + set arg .${i}_dot + } elseif [string match .* $arg] { + set arg ".${i}_dot$arg" + } + lappend args1 $arg + } + set code [catch "$command $args1" msg] + regsub -all .${i}_dot $msg {} msg + return -code $code $msg +} + +# +# FIX: this funcion doesn't work yet if the binding starts with "+". +# +proc tkConSafeBind {i w args} { + if [string match . $w] { + set w .${i}_dot + } elseif [string match .* $w] { + set w ".${i}_dot$w" + } + if {[llength $args] > 1} { + set args [list [lindex $args 0] "[list $i] eval [list [lindex $args 1]]"] + } + set code [catch "bind $w $args" msg] + if {[llength $args] <2 && code == 0} { + set msg [lindex $msg 3] + } + return -code $code $msg +} + +proc tkConSafeImage {i option args} { + set code [catch "image $option $args" msg] + if {[string match cr* $option]} { + $i alias $msg $msg + } + return -code $code $msg +} + +proc tkConSafeBindtags {i w {tags {}}} { + if [string match . $w] { + set w .${i}_dot + } elseif [string match .* $w] { + set w ".${i}_dot$w" + } + set newtags {} + foreach tag $tags { + if [string match . $tag] { + lappend newtags .${i}_dot + } elseif [string match .* $tag] { + lappend newtags ".${i}_dot$tag" + } else { + lappend newtags $tag + } + } + if [string match $tags {}] { + set code [catch {bindtags $w} msg] + regsub -all \\.${i}_dot $msg {} msg + } else { + set code [catch {bindtags $w $newtags} msg] + } + return -code $code $msg +} + +proc tkConSafeWindow {i w option args} { + if {[string match conf* $option] && [llength $args] > 1} { + set args [tkConSafeSubst $i $args] + } elseif {[string match itemco* $option] && [llength $args] > 2} { + set args "[list [lindex $args 0]] [tkConSafeSubst $i [lrange $args 1 end]]" + } elseif {[string match cr* $option]} { + if {[llength $args]%2} { + set args "[list [lindex $args 0]] [tkConSafeSubst $i [lrange $args 1 end]]" + } else { + set args [tkConSafeSubst $i $args] + } + } elseif {[string match bi* $option] && [llength $args] > 2} { + set args [list [lindex $args 0] [lindex $args 1] "[list $i] eval [list [lindex $args 2]]"] + } + set code [catch ".${i}_dot$w $option $args" msg] + if {$code} { + regsub -all .${i}_dot $msg {} msg + } elseif {[string match conf* $option] || [string match itemco* $option]} { + if {[llength $args] == 1} { + switch -- $args { + -textvariable - -variable { + set msg "[lrange $msg 0 3] [list [lrange [lindex $msg 4] 1 end]]" + } + -command - updatecommand { + set msg "[lrange $msg 0 3] [list [lindex [lindex $msg 4] 2]]" + } + } + } elseif {[llength $args] == 0} { + set args1 "" + foreach el $msg { + switch -- [lindex $el 0] { + -textvariable - -variable { + set el "[lrange $el 0 3] [list [lrange [lindex $el 4] 1 end]]" + } + -command - updatecommand { + set el "[lrange $el 0 3] [list [lindex [lindex $el 4] 2]]" + } + } + lappend args1 $el + } + set msg $args1 + } + } elseif {[string match cg* $option] || [string match itemcg* $option]} { + switch -- $args { + -textvariable - -variable { + set msg [lrange $msg 1 end] + } + -command - updatecommand { + set msg [lindex $msg 2] + } + } + } elseif [string match bi* $option] { + if {[llength $args] == 2 && $code == 0} { + set msg [lindex $msg 2] + } + } + return -code $code $msg +} + +proc tkConExit {} { + global tkCon + destroy $tkCon(root) +} + +set tkCon(SCRIPT) [info script] + +if {![string compare [interp slave] ""]} { + uplevel \#0 gimptcl_run 1 +} + +## tkConResource - re'source's this script into current console +## Meant primarily for my development of this program. It follows +## links until the ultimate source is found. +## +#if !$tkCon(WWW) { +# while {[string match link [file type $tkCon(SCRIPT)]]} { +# set link [file readlink $tkCon(SCRIPT)] +# if [string match relative [file pathtype $link]] { +# set tkCon(SCRIPT) [file join [file dirname $tkCon(SCRIPT)] $link] +# } else { +# set tkCon(SCRIPT) $link +# } +# } +# catch {unset link} +# if [string match relative [file pathtype $tkCon(SCRIPT)]] { +# set tkCon(SCRIPT) [file join [pwd] $tkCon(SCRIPT)] +# } +# } +# proc tkConResource {} { +# global tkCon +# uplevel \#0 [list source $tkCon(SCRIPT)] +# tkConBindings +# tkConInitSlave $tkCon(exec) +# } diff --git a/plug-ins/gimptcl/scripts/license.terms-consolio b/plug-ins/gimptcl/scripts/license.terms-consolio deleted file mode 100644 index 3dcd816f4a..0000000000 --- a/plug-ins/gimptcl/scripts/license.terms-consolio +++ /dev/null @@ -1,32 +0,0 @@ -This software is copyrighted by the Regents of the University of -California, Sun Microsystems, Inc., and other parties. The following -terms apply to all files associated with the software unless explicitly -disclaimed in individual files. - -The authors hereby grant permission to use, copy, modify, distribute, -and license this software and its documentation for any purpose, provided -that existing copyright notices are retained in all copies and that this -notice is included verbatim in any distributions. No written agreement, -license, or royalty fee is required for any of the authorized uses. -Modifications to this software may be copyrighted by their authors -and need not follow the licensing terms described here, provided that -the new terms are clearly indicated on the first page of each file where -they apply. - -IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY -FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY -DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. - -THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE -IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE -NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR -MODIFICATIONS. - -RESTRICTED RIGHTS: Use, duplication or disclosure by the government -is subject to the restrictions as set forth in subparagraph (c) (1) (ii) -of the Rights in Technical Data and Computer Software Clause as DFARS -252.227-7013 and FAR 52.227-19. diff --git a/plug-ins/gimptcl/scripts/pdb_help b/plug-ins/gimptcl/scripts/pdb_help index 9a62691b6f..e3dc4cbfde 100755 --- a/plug-ins/gimptcl/scripts/pdb_help +++ b/plug-ins/gimptcl/scripts/pdb_help @@ -1,4 +1,4 @@ -#!/usr/libexec/gimptcl +#!/usr/X11R6//libexec/gimptcl # -*-Mode: Tcl;-*- ################################################## # file: pdb-help.tcl @@ -273,3 +273,7 @@ proc pdb-help-init {} { show_proc "pdb_help" } + +if {![string compare [interp slave] ""]} { + uplevel \#0 gimptcl_run 1 +} diff --git a/plug-ins/gimptcl/scripts/pdb_help.tcl b/plug-ins/gimptcl/scripts/pdb_help.tcl index 17ca4090e6..99c1fd0e2c 100644 --- a/plug-ins/gimptcl/scripts/pdb_help.tcl +++ b/plug-ins/gimptcl/scripts/pdb_help.tcl @@ -273,3 +273,7 @@ proc pdb-help-init {} { show_proc "pdb_help" } + +if {![string compare [interp slave] ""]} { + uplevel \#0 gimptcl_run 1 +}