Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv19640

Modified Files: CELTK.lpr Celtk.lisp demos.lisp entry.lisp fileevent.lisp tk-structs.lisp Log Message: Suppress Tcl evaluation of entry and text fields; look for more of these to surface

--- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/27 06:04:22 1.13 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/05/28 15:34:27 1.14 @@ -104,7 +104,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::test-fileevent + :on-initialization 'celtk::tk-test :on-restart 'do-default-restart)

;; End of Project Definition --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/25 15:41:32 1.25 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/28 15:34:27 1.26 @@ -124,6 +124,8 @@ "]" "\]") """ "\""))

+(tkescape "[exit]") + (defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) (let* ((*print-circle* nil) @@ -131,10 +133,10 @@ ; ; --- debug stuff --------------------------------- ; - (let ((yes '( "destroy")) + (let ((yes '( "insert")) (no '())) (declare (ignorable yes no)) - (when nil #+not (and (find-if (lambda (s) (search s tk$)) yes) + (when (and (find-if (lambda (s) (search s tk$)) yes) (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) (assert *tki*) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/25 07:12:59 1.19 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/28 15:34:27 1.20 @@ -20,11 +20,11 @@

(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window - ;;'one-button-window + 'one-button-window ;;'ltktest-cells-inside ;;'menu-button-test ;;'spinbox-test - 'lotsa-widgets + ;;'lotsa-widgets ;; Now in Gears project 'gears-demo ))

@@ -33,22 +33,22 @@ (:default-initargs :kids (c? (the-kids (mk-menubar - :kids (c? (the-kids - (mk-menu-entry-cascade-ex (:label "File") - (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) - (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) + :kids (c? (the-kids + (mk-menu-entry-cascade-ex (:label "File") + (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) + (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) (mk-frame-stack :packing (c?pack-self) :kids (c? (the-kids (mk-text-widget :id :my-text - :md-value (c?n "hello, world") + :md-value (c?n "[bzbzbzbz]") :height 8 :width 25) - ;;; (make-instance 'entry - ;;; :id :entree - ;;; :fm-parent *parent* - ;;; :md-value (c-in "Boots")) + (make-instance 'entry + :id :entree + :fm-parent *parent* + :md-value (c-in "Boots")) ;;; (make-instance 'button ;;; :fm-parent *parent* ;;; :text "read" --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/27 22:28:01 1.10 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/28 15:34:27 1.11 @@ -48,7 +48,7 @@ (tcl-get-string (xsv user-data xe)))) ;; assuming write op, but data field shows that (let ((new-value (tcl-get-var *tki* (^path) - (var-flags :TCL_NAMESPACE_ONLY)))) + (var-flags :TCL-NAMESPACE-ONLY)))) (unless (string= new-value (^md-value)) (setf (^md-value) new-value))))))))

@@ -65,7 +65,7 @@ (when new-value (unless (string= new-value old-value) (trc nil "md-value output" self new-value) - (tk-format `(:variable ,self) "set ~a ~s" (^path) new-value)))) + (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY)))))

(deftk text-widget (widget) ((modified :initarg :modified :accessor modified :initform nil) @@ -104,12 +104,8 @@ (trc nil "md-value output" self new-value) (with-integrity (:client `(:variable ,self)) (tk-format-now "~a delete 1.0 end" (^path)) - (let ((value nil)) - (when (plusp (length new-value)) - (if (not (^eval-text)) - (setq value (replace-dangerous-chars new-value)) - (setq value new-value)) - (tk-format-now "~a insert end ~s" (^path) value))))) + (when (plusp (length new-value)) + (tk-format-now "~a insert end {~a}" (^path) new-value)))) ;; kt060528: simple {} seems to block evaluation

;; frgo, 2006-05-27: ;; replace-dangeorous-chars is meant to replace characters in a @@ -123,6 +119,7 @@ (if (find c dangerous-chars) (setf (char result pos) #\Space)))) (values result))) +>>>>>>> 1.10

;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/27 22:25:18 1.3 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/05/28 15:34:27 1.4 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.3 2006/05/27 22:25:18 fgoenninger Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.4 2006/05/28 15:34:27 ktilton Exp $ ;;; ---------------------------------------------------------------------------

;;; =========================================================================== @@ -352,7 +352,7 @@ (interp :pointer) (argc :int) (argv :pointer)) - (declare (ignorable clientData argc interp)) + (declare (ignore clientData argc interp)) (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^read-fn)) @@ -364,7 +364,7 @@ (interp :pointer) (argc :int) (argv :pointer)) - (declare (ignorable clientData argc interp)) + (declare (ignore clientData argc interp)) (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^write-fn)) @@ -376,7 +376,8 @@ (interp :pointer) (argc :int) (argv :pointer)) - (declare (ignorable clientData interp argc)) + (declare (ignore clientData interp argc)) + (trc "eof!!!!!") (let* ((path (foreign-string-to-lisp (mem-aref argv :pointer 1))) (self (gethash path (dictionary *tkw*)))) (bwhen (fn (^eof-fn)) @@ -466,7 +467,7 @@ :eval-text nil)) (mk-fileevent :id :fileevent-test :read-fn 'read-from-pipe - :iostream (open "/Users/frgo/tmp/frgo-test" + :iostream (open "/0dev/hw.txt" ;;; Adapt here !!! ^^^^^^^^^^^^^^^^^^^^^^^^^^^ :direction :input))))))

@@ -475,3 +476,6 @@ (trc "-----------------------------------------------------------------------------") (test-window 'fileevent-test-window) (trc "-----------------------------------------------------------------------------")) + +#+test +(test-window 'fileevent-test-window) \ No newline at end of file --- /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/24 20:38:54 1.2 +++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2006/05/28 15:34:27 1.3 @@ -132,23 +132,23 @@ (:tcl-all-events -3))

(defcenum tcl-variable-related-flag - "Flags passed to getvar, setvar, tracevar, etc" - (:TCL_GLOBAL_ONLY 1) - (:TCL_NAMESPACE_ONLY 2) - (:TCL_APPEND_VALUE 4) - (:TCL_LIST_ELEMENT 8) - (:TCL_TRACE_READS #x10) - (:TCL_TRACE_WRITES #x20) - (:TCL_TRACE_UNSETS #x40) - (:TCL_TRACE_DESTROYED #x80) - (:TCL_INTERP_DESTROYED #x100) - (:TCL_LEAVE_ERR_MSG #x200) - (:TCL_TRACE_ARRAY #x800) - ;; Required to support old variable/vdelete/vinfo traces */ - (:TCL_TRACE_OLD_STYLE #x1000) - ;; Indicate the semantics of the result of a trace */ - (:TCL_TRACE_RESULT_DYNAMIC #x8000) - (:TCL_TRACE_RESULT_OBJECT #x10000)) + "flags passed to getvar, setvar, tracevar, etc" + (:tcl-global-only 1) + (:tcl-namespace-only 2) + (:tcl-append-value 4) + (:tcl-list-element 8) + (:tcl-trace-reads #x10) + (:tcl-trace-writes #x20) + (:tcl-trace-unsets #x40) + (:tcl-trace-destroyed #x80) + (:tcl-interp-destroyed #x100) + (:tcl-leave-err-msg #x200) + (:tcl-trace-array #x800) + ;; required to support old variable/vdelete/vinfo traces */ + (:tcl-trace-old-style #x1000) + ;; indicate the semantics of the result of a trace */ + (:tcl-trace-result-dynamic #x8000) + (:tcl-trace-result-object #x10000))

(defun var-flags (&rest kws) (apply '+ (loop for kw in kws