[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Sun May 28 15:34:28 UTC 2006
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
More information about the Cells-cvs
mailing list