[ltk-user] patch for unescaped values
Jason Miller
jason at milr.com
Mon Oct 14 19:32:10 UTC 2013
In general this in a format string is a code-smell:
"{~A}"
it nearly always means that a value isn't properly escaped. Note that
even (format-wish "{~A}" (tkescape foo)) will fail for a string that
ends with a backslash.
I'm pretty sure that I can come up with code to break every single
change I made. I used my own escape function as a format specifier just
because I find it clearer and less error-prone to have all the escaping
in the format string. with tkescape2, you need to surrond the
corresponding ~a with dquotes (e.g. (format-wish "\"~a\"" (tkescape2
foo)) is correct but (format-wish "~a" (tkescape foo) and (format-wish
"\"~a\"" foo) are both wrong)
I found this originally in the setf for text, and the setf for
listboxes. When I found the same bug in two places I figured it was a
good idea to look for more.
-Jason
-------------- next part --------------
Index: ltk.lisp
===================================================================
--- ltk.lisp (revision 265)
+++ ltk.lisp (working copy)
@@ -1115,6 +1115,29 @@
(make-array (length string) :element-type 'character
:initial-contents string :adjustable t :fill-pointer t))
+;; This works by the following algorithm:
+;; 1) Replace all backslaskes with \x5c
+;; 2) Replace all { with \{
+;; 3) Replace all } with #\}
+;; 4) Generate a tcl command that performs backslash substitution on it
+(defun esc (stream string &rest modifiers)
+ "Creates a tcl command-substitution that will fully reproduce the
+ lisp string"
+ (declare (ignore modifiers))
+ (when (not (stringp string))
+ (setf string (format nil "~a" string)))
+ (progn
+ (write-string "[subst -nocommands -novariables {" stream)
+ (loop for char across string
+ do (case char
+ (#\\
+ (write-string "\\x5c" stream))
+ ((#\{ #\})
+ (write-char #\\ stream)
+ (write-char char stream))
+ (t (write-char char stream))))
+ (write-string "} ]" stream)))
+
;; Much faster version. For one test run it takes 2 seconds, where the
;; other implementation requires 38 minutes.
(defun tkescape (text)
@@ -1397,7 +1420,7 @@
(disabledforeground disabledforeground "~@[ -disabledforeground ~(~a~)~]" disabledforeground "")
(elementborderwidth elementborderwidth "~@[ -elementborderwidth ~(~a~)~]" elementborderwidth "")
(exportselection exportselection "~@[ -exportselection ~(~a~)~]" exportselection "")
- (font font "~@[ -font {~a}~]" font "font to use to display text on the widget")
+ (font font "~@[ -font ~/ltk:esc/~]" font "font to use to display text on the widget")
(foreground foreground "~@[ -foreground ~(~a~)~]" foreground "foreground color of the widget")
(format format "~@[ -format ~(~a~)~]" format "")
(from from "~@[ -from ~(~a~)~]" from "")
@@ -1500,7 +1523,7 @@
(value value "~@[ -value ~(~a~)~]" value "")
(value-radio-button nil "~@[ -value ~(~a~)~]" (radio-button-value widget)
"value for the radio button group to take, when the button is selected")
- (values values "~@[ -values {~{{~a}~^ ~}}~]" values "")
+ (values values "~@[ -values [list ~{~/ltk:esc/~^ ~}]~]" values "")
(variable variable "~@[ -variable ~(~a~)~]" variable "name of the variable associated with the widget")
(variable-radio-button nil "~@[ -variable ~(~a~)~]" (radio-button-variable widget)
"name of the radio button group the button shall belong to as a string")
@@ -1798,7 +1821,7 @@
(read-data))
(defun clipboard-append (txt)
- (format-wish "clipboard append {~a}" txt))
+ (format-wish "clipboard append ~/ltk:esc/" txt))
;; around - initializer
@@ -1924,7 +1947,7 @@
(defgeneric (setf value) (widget val))
(defmethod (setf value) (val (v tkvariable))
- (format-wish "global ~a; set ~a {~a}" (name v) (name v) val)
+ (format-wish "global ~a; set ~a ~/ltk:esc/" (name v) (name v) val)
val)
(defclass tktextvariable ()
@@ -1975,7 +1998,7 @@
(setf (slot-value m 'widget-path) (create-path (master m) (name m))))
(format-wish "menu ~A -tearoff ~a" (widget-path m) tearoff)
(when (master m)
- (format-wish "~A add cascade -label {~A} -menu ~a~@[ -underline ~a ~]"
+ (format-wish "~A add cascade -label ~/ltk:esc/ -menu ~a~@[ -underline ~a ~]"
(widget-path (master m)) (text m) (widget-path m) underline)))
(defun make-menu(menu text &key underline name (tearoff 0))
@@ -2008,7 +2031,7 @@
(defmethod initialize-instance :after ((m menubutton) &key command underline accelerator state)
(when command
(add-callback (name m) command))
- (format-wish "~A add command -label {~A} -command {callback ~A}~@[ -underline ~a ~]~@[ -accelerator {~a} ~]~@[ -state ~(~a~)~]"
+ (format-wish "~A add command -label ~/ltk:esc/ -command {callback ~A}~@[ -underline ~a ~]~@[ -accelerator ~/ltk:esc/ ~]~@[ -state ~(~a~)~]"
(widget-path (master m)) (text m) (name m) underline accelerator state))
(defun make-menubutton(menu text command &key underline accelerator state)
@@ -2022,7 +2045,7 @@
(defmethod initialize-instance :after ((m menucheckbutton) &key)
(when (command m)
(add-callback (name m) (command m)))
- (format-wish "~A add checkbutton -label {~A} -variable ~a ~@[ -command {callback ~a}~]"
+ (format-wish "~A add checkbutton -label ~/ltk:esc/ -variable ~a ~@[ -command {callback ~a}~]"
(widget-path (master m)) (text m) (name m) (and (command m) (name m))))
(defmethod value ((cb menucheckbutton))
@@ -2043,7 +2066,7 @@
(unless (group m)
(setf (group m)
(name m)))
- (format-wish "~A add radiobutton -label {~A} -value ~a -variable ~a ~@[ -command {callback ~a}~]"
+ (format-wish "~A add radiobutton -label ~/ltk:esc/ -value ~a -variable ~a ~@[ -command {callback ~a}~]"
(widget-path (master m)) (text m) (name m) (group m)
(and (command m) (name m))))
@@ -2153,7 +2176,7 @@
#-:tk84
(defmethod (setf options) (values (combobox combobox))
- (format-wish "~a configure -values {~{ \{~a\}~}}" (widget-path combobox) values))
+ (format-wish "~a configure -values [list ~{~/ltk:esc/ ~}]" (widget-path combobox) values))
;; text entry widget
@@ -2213,7 +2236,7 @@
(defwrapper labelframe (widget) () "ttk::labelframe")
(defmethod (setf text) :after (val (l labelframe))
- (format-wish "~a configure -text {~a}" (widget-path l) val)
+ (format-wish "~a configure -text ~/ltk:esc/" (widget-path l) val)
val)
;;; panedwindow widget
@@ -2288,8 +2311,8 @@
(defmethod listbox-append ((l listbox) values)
"append values (which may be a list) to the list box"
(if (listp values)
- (format-wish "~a insert end ~{ \{~a\}~}" (widget-path l) values)
- (format-wish "~a insert end \{~a\}" (widget-path l) values))
+ (format-wish "~a insert end ~{ ~/ltk:esc/~}" (widget-path l) values)
+ (format-wish "~a insert end ~/ltk:esc/" (widget-path l) values))
l)
(defgeneric listbox-get-selection (l))
@@ -2322,8 +2345,8 @@
(defgeneric listbox-insert (l index values))
(defmethod listbox-insert ((l listbox) index values)
(if (listp values)
- (format-wish "~a insert ~a ~{ \{~a\}~}" (widget-path l) index values)
- (format-wish "~a insert ~a \{~a\}" (widget-path l) index values))
+ (format-wish "~a insert ~a ~{ ~/ltk:esc/~}" (widget-path l) index values)
+ (format-wish "~a insert ~a ~/ltk:esc/" (widget-path l) index values))
l)
(defgeneric listbox-configure (l i &rest options))
@@ -2377,11 +2400,11 @@
(defgeneric notebook-add (nb widget &rest options))
(defmethod notebook-add ((nb notebook) (w widget) &rest options)
- (format-wish "~a add ~a ~{-~(~a~) {~a}~}" (widget-path nb) (widget-path w) options))
+ (format-wish "~a add ~a ~{-~(~a~) ~/ltk:esc/~}" (widget-path nb) (widget-path w) options))
(defgeneric notebook-tab (nb widget option value))
(defmethod notebook-tab ((nb notebook) (w widget) option value)
- (format-wish "~a tab ~a -~(~a~) {~a}" (widget-path nb)
+ (format-wish "~a tab ~a -~(~a~) ~/ltk:esc/" (widget-path nb)
(widget-path w) option value))
(defgeneric notebook-forget (nb widget))
@@ -2728,11 +2751,11 @@
item)
(defmethod (setf text) (val (item treeitem))
- (format-wish "~a item ~a -text {~A}" (widget-path (tree item)) (name item) val)
+ (format-wish "~a item ~a -text ~/ltk:esc/" (widget-path (tree item)) (name item) val)
val)
(defmethod (setf image) (val (item treeitem))
- (format-wish "~a item ~a -image {~A}" (widget-path (tree item)) (name item) val)
+ (format-wish "~a item ~a -image ~/ltk:esc/" (widget-path (tree item)) (name item) val)
val)
(defmethod see ((tv treeview) (item treeitem))
@@ -2755,16 +2778,16 @@
(defgeneric column-configure (tree column option value &rest rest))
(defmethod column-configure ((tree treeview) column option value &rest rest)
- (format-wish "~a column ~a -~(~a~) {~a}~{ -~(~a~) {~(~a~)}~}" (widget-path tree) column
+ (format-wish "~a column ~a -~(~a~) ~/ltk:esc/~{ -~(~a~) {~(~a~)}~}" (widget-path tree) column
option value rest))
(defgeneric treeview-delete (tree items))
(defmethod treeview-delete ((tree treeview) item)
- (format-wish "~a delete {~a}" (widget-path tree) item))
+ (format-wish "~a delete ~/ltk:esc/" (widget-path tree) item))
(defmethod treeview-delete ((tree treeview) (item treeitem))
(setf (items tree) (remove item (items tree)))
- (format-wish "~a delete {~a}" (widget-path tree) (name item)))
+ (format-wish "~a delete ~/ltk:esc/" (widget-path tree) (name item)))
(defmethod treeview-delete ((tree treeview) (items cons))
(format-wish "~a delete {~{~a~^ ~}}" (widget-path tree) items))
@@ -2817,9 +2840,9 @@
(string= arg "")))
(format stream "{}"))
((listp arg)
- (format stream "{~{~/ltk::tk-princ/~^ ~}}" (mapcar #'tkescape arg)))
+ (format stream "[list ~{~/ltk::tk-princ/~^ ~}]" arg))
(t
- (format stream "~a" (tkescape arg)))))
+ (format stream "~/ltk:esc/" arg))))
(defun treeview-insert (tree &rest options
&key (parent "{}") (index "end") (id (create-name)) &allow-other-keys)
@@ -2898,7 +2921,7 @@
(defgeneric treeview-set-selection (w items))
(defmethod treeview-set-selection ((tv treeview) items)
- (format-wish "~a selection set {~{~a ~}}" (widget-path tv) (mapcar #'name items)))
+ (format-wish "~a selection set [list ~{~/ltk:esc/ ~}]" (widget-path tv) (mapcar #'name items)))
@@ -3229,13 +3252,13 @@
(args))
((eq itemtype :text)
- (format stream "~a create text ~a ~a -anchor nw -text {~a} "
- cpath (number) (number) (tkescape (arg)))
+ (format stream "~a create text ~a ~a -anchor nw -text \"~a\" "
+ cpath (number) (number) (tkescape2 (arg)))
(args))
((eq itemtype :ctext)
- (format stream "~a create text ~a ~a -anchor n -text {~a} "
- cpath (number) (number) (tkescape (arg)))
+ (format stream "~a create text ~a ~a -anchor n -text \"~a\" "
+ cpath (number) (number) (tkescape2 (arg)))
(args))
))))
@@ -3268,7 +3291,7 @@
(make-instance class :canvas canvas :handle handle))))))
(defun create-text (canvas x y text)
- (format-wish "senddata [~a create text ~a ~a -anchor nw -text {~a}]" (widget-path canvas)
+ (format-wish "senddata [~a create text ~a ~a -anchor nw -text ~/ltk:esc/]" (widget-path canvas)
(tk-number x) (tk-number y)
text)
(read-data))
@@ -3410,13 +3433,13 @@
(read-data))
(defmethod (setf text) (val (text text))
- (format-wish "~A delete 0.0 end;~A insert end {~A}" (widget-path text) (widget-path text) val)
+ (format-wish "~A delete 0.0 end;~A insert end ~/ltk:esc/" (widget-path text) (widget-path text) val)
val)
(defgeneric save-text (txt filename))
(defmethod save-text ((txt text) filename)
"save the content of the text widget into the file <filename>"
- (format-wish "set file [open {~a} \"w\"];puts $file [~a get 1.0 end];close $file;puts \"asdf\"" filename (widget-path txt))
+ (format-wish "set file [open ~/ltk:esc/ \"w\"];puts $file [~a get 1.0 end];close $file;puts \"asdf\"" filename (widget-path txt))
(read-line (wish-stream *wish*))
txt)
@@ -3424,7 +3447,7 @@
(defmethod load-text((txt text) filename)
"load the content of the file <filename>"
; (format-wish "set file [open {~a} \"r\"];~a delete 1.0 end;~a insert end [read $file];close $file;puts \"asdf\"" filename (widget-path txt) (widget-path txt))
- (format-wish "set file [open {~a} \"r\"];~a delete 1.0 end;~a insert end [read $file];close $file;puts \"(:DATA asdf)\"" filename (widget-path txt) (widget-path txt))
+ (format-wish "set file [open ~/ltk:esc/ \"r\"];~a delete 1.0 end;~a insert end [read $file];close $file;puts \"(:DATA asdf)\"" filename (widget-path txt) (widget-path txt))
(read-data))
;;; photo image object
@@ -3452,7 +3475,7 @@
(defgeneric image-load (p filename))
(defmethod image-load((p photo-image) filename)
;(format t "loading file ~a~&" filename)
- (send-wish (format nil "~A read {~A} -shrink" (name p) filename))
+ (send-wish (format nil "~A read ~/ltk:esc/ -shrink" (name p) filename))
p)
(defgeneric ishow (p name))
@@ -3531,17 +3554,17 @@
(defgeneric grid-columnconfigure (widget c o v))
(defmethod grid-columnconfigure (widget column option value)
- (format-wish "grid columnconfigure ~a ~a -~(~a~) {~a}" (widget-path widget) column option value)
+ (format-wish "grid columnconfigure ~a ~a -~(~a~) ~/ltk:esc/" (widget-path widget) column option value)
widget)
(defgeneric grid-rowconfigure (widget r o v))
(defmethod grid-rowconfigure (widget row option value)
- (format-wish "grid rowconfigure ~a ~a -~(~a~) {~a}" (widget-path widget) row option value)
+ (format-wish "grid rowconfigure ~a ~a -~(~a~) ~/ltk:esc/" (widget-path widget) row option value)
widget)
(defgeneric grid-configure (widget o v))
(defmethod grid-configure (widget option value)
- (format-wish "grid configure ~a -~(~a~) {~a}" (widget-path widget) option value)
+ (format-wish "grid configure ~a -~(~a~) ~/ltk:esc/" (widget-path widget) option value)
widget)
(defgeneric grid-forget (widget))
@@ -3568,7 +3591,7 @@
(defmethod configure ((item menuentry) option value &rest others)
(let ((path (widget-path (master item))))
- (format-wish "~A entryconfigure [~A index {~A}]~{ -~(~a~) {~/ltk::down/}~}"
+ (format-wish "~A entryconfigure [~A index ~/ltk:esc/]~{ -~(~a~) {~/ltk::down/}~}"
path
path
(text item)
@@ -3591,7 +3614,7 @@
;;; for tkobjects, the name of the widget is taken
(defmethod configure (widget option (value tkobject) &rest others)
- (format-wish "~A configure -~(~A~) {~A} ~{ -~(~a~) {~(~a~)}~}" (widget-path widget) option (widget-path value) others)
+ (format-wish "~A configure -~(~A~) ~/ltk:esc/ ~{ -~(~a~) {~(~a~)}~}" (widget-path widget) option (widget-path value) others)
widget)
(defgeneric cget (widget option))
@@ -3619,7 +3642,7 @@
(defgeneric itemconfigure (widget item option value))
(defmethod itemconfigure ((widget canvas) item option value)
- (format-wish "~A itemconfigure ~A -~(~A~) {~A}" (widget-path widget) item option
+ (format-wish "~A itemconfigure ~A -~(~A~) ~/ltk:esc/" (widget-path widget) item option
(if (stringp value) ;; There may be values that need to be passed as
value ;; unmodified strings, so do not downcase strings
(format nil "~(~a~)" value))) ;; if its not a string, print it downcased
@@ -3628,7 +3651,7 @@
;;; for tkobjects, the name of the widget is taken
(defmethod itemconfigure ((widget canvas) item option (value tkobject))
- (format-wish "~A itemconfigure ~A -~(~A~) {~A}" (widget-path widget) item option (widget-path value))
+ (format-wish "~A itemconfigure ~A -~(~A~) ~/ltk:esc/" (widget-path widget) item option (widget-path value))
widget)
(defgeneric itemlower (w i &optional below))
@@ -3707,7 +3730,7 @@
(defgeneric wm-title (widget title))
(defmethod wm-title ((w widget) title)
- (format-wish "wm title ~a {~a}" (widget-path w) title)
+ (format-wish "wm title ~a ~/ltk:esc/" (widget-path w) title)
w)
#-:tk84
@@ -3937,7 +3960,7 @@
;;; Dialog functions
(defun choose-color (&key parent title initialcolor )
- (format-wish "senddatastring [tk_chooseColor ~@[ -parent ~A~]~@[ -title {~A}~]~@[ -initialcolor {~A}~]]" (when parent (widget-path parent)) title initialcolor)
+ (format-wish "senddatastring [tk_chooseColor ~@[ -parent ~A~]~@[ -title ~/ltk:esc/~]~@[ -initialcolor ~/ltk:esc/~]]" (when parent (widget-path parent)) title initialcolor)
(read-data))
(defun get-open-file (&key (filetypes '(("All Files" "*")))
@@ -3945,21 +3968,21 @@
multiple parent title)
(let ((files
(with-output-to-string (s)
- (format s "{")
+ (format s "[list ")
(dolist (type filetypes)
(let ((name (first type))
(wildcard (second type)))
- (format s "{{~a} {~a}} " name wildcard)))
- (format s "}"))))
+ (format s "[list ~/ltk:esc/ ~/ltk:esc/ ] " name wildcard)))
+ (format s " ]"))))
(if multiple
(format-wish "senddatastrings [tk_getOpenFile ~
- -filetypes ~a ~@[ -initialdir {~a}~] -multiple 1 ~
- ~@[ -parent ~a~] ~@[ -title {~a}~]]"
+ -filetypes ~a ~@[ -initialdir ~/ltk:esc/~] -multiple 1 ~
+ ~@[ -parent ~a~] ~@[ -title ~/ltk:esc/~]]"
files initialdir
(and parent (widget-path parent)) title)
(format-wish "senddatastring [tk_getOpenFile ~
- -filetypes ~a ~@[ -initialdir {~a}~] ~
- ~@[ -parent ~a~] ~@[ -title {~a}~]]"
+ -filetypes ~a ~@[ -initialdir ~/ltk:esc/~] ~
+ ~@[ -parent ~a~] ~@[ -title ~/ltk:esc/~]]"
files initialdir
(and parent (widget-path parent)) title))
(read-data)))
@@ -3967,18 +3990,18 @@
(defun get-save-file (&key (filetypes '(("All Files" "*"))))
(let ((files
(with-output-to-string (s)
- (format s "{")
+ (format s "[list ")
(dolist (type filetypes)
(let ((name (first type))
(wildcard (second type)))
- (format s "{{~a} {~a}} " name wildcard)))
- (format s "}"))))
+ (format s "[list ~/ltk:esc/ ~/ltk:esc/ ] " name wildcard)))
+ (format s " ]"))))
(format-wish "senddatastring [tk_getSaveFile -filetypes ~a]" files)
(read-data)))
(defun choose-directory (&key (initialdir (namestring *default-pathname-defaults*))
parent title mustexist)
- (format-wish "senddatastring [tk_chooseDirectory ~@[ -initialdir \"~a\"~]~@[ -parent ~a ~]~@[ -title {~a}~]~@[ -mustexist ~a~]]" (tkescape2 initialdir) (and parent (widget-path parent)) title (and mustexist 1))
+ (format-wish "senddatastring [tk_chooseDirectory ~@[ -initialdir \"~a\"~]~@[ -parent ~a ~]~@[ -title ~/ltk:esc/~]~@[ -mustexist ~a~]]" (tkescape2 initialdir) (and parent (widget-path parent)) title (and mustexist 1))
(read-data))
(defvar *mb-icons* (list "error" "info" "question" "warning")
@@ -3987,7 +4010,7 @@
;;; see make-string-output-string/get-output-stream-string
(defun message-box (message title type icon &key parent)
;;; tk_messageBox function
- (format-wish "senddatastring [tk_messageBox -message \"~a\" -title {~a} -type ~(~a~) -icon ~(~a~)~@[ -parent ~a~]]" (tkescape2 message) title type icon (and parent (widget-path parent)))
+ (format-wish "senddatastring [tk_messageBox -message \"~a\" -title ~/ltk:esc/ -type ~(~a~) -icon ~(~a~)~@[ -parent ~a~]]" (tkescape2 message) title type icon (and parent (widget-path parent)))
(read-keyword))
@@ -4053,7 +4076,7 @@
(t
(let* ((name (create-name)))
(add-callback name (second tree))
- (send-wish (format nil "~A add command -label {~A} -command {puts -nonewline {(\"~A\")};flush $server}" widget-path (first tree) name))
+ (send-wish (format nil "~A add command -label ~/ltk:esc/ -command {puts -nonewline {(\"~A\")};flush $server}" widget-path (first tree) name))
))))
(defun create-menu2 (menutree)
More information about the ltk-user
mailing list