[cells-cvs] CVS Celtk

[fgoenninger]

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

Modified Files:
	entry.lisp 
Log Message:
Changed/added: text widget: new slot eval-text. Defaults to t.
If nil then upon setting the model value of the text widget the
new valiue will be scanned for "dangerous" characters.
These are: [Ê]Ê{Ê}
Reason: Tcl evaluates text in brackets as commands. This may be
dangerous. If any such dangerous character is found it is replaced
by a Space character in order to not change the length of the text.

--- /project/cells/cvsroot/Celtk/entry.lisp	2006/05/24 20:38:54	1.9
+++ /project/cells/cvsroot/Celtk/entry.lisp	2006/05/27 22:28:01	1.10
@@ -68,7 +68,9 @@
       (tk-format `(:variable ,self) "set ~a ~s" (^path) new-value))))
 
 (deftk text-widget (widget)
-  ((modified :initarg :modified :accessor modified :initform nil))
+  ((modified :initarg :modified :accessor modified :initform nil)
+   (eval-text :initarg :eval-text :accessor eval-text :initform (c-in t)
+	      :documentation "Set to nil if you want to make sure text entries do not get evaluated. If set to nil the /dangerous charachters/ will be replaced by space char."))
   (:tk-spec text
     -background -borderwidth -cursor
     -exportselection (tkfont -font) -foreground
@@ -102,8 +104,25 @@
   (trc nil "md-value output" self new-value)
   (with-integrity (:client `(:variable ,self))
     (tk-format-now "~a delete 1.0 end" (^path))
-    (when (plusp (length new-value))
-      (tk-format-now "~a insert end ~s" (^path) new-value))))
+    (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)))))
+
+;; frgo, 2006-05-27:
+;; replace-dangeorous-chars is meant to replace characters in a
+;; sequence that would start/end evaluation in Tcl land.
+(defun replace-dangerous-chars (seq &optional (dangerous-chars "[]{}"))
+  (assert (stringp seq))
+  (let ((result seq))
+    (loop for pos from 0 to (1- (length result))
+      do
+      (let ((c (char result pos)))
+        (if (find c dangerous-chars)
+	 (setf (char result pos) #\Space))))
+    (values result)))
 
 ;;;(defvar +tk-keysym-table+
 ;;;  (let ((ht (make-hash-table :test 'string=)))
@@ -116,7 +135,7 @@
 ;;;          finally (return ht)))))
 
  (defun tk-translate-keysym (keysym$)
-  (if (= 1 (length keysym$))
+   (if (= 1 (length keysym$))
       (schar keysym$ 0)
     (intern (string-upcase keysym$))
     #+nah (gethash keysym$ +tk-keysym-table+)))
\ No newline at end of file