#| This software is Copyright (c) 2003, 2004, 2005, 2006 Peter Herth Portions Copyright (c) 2005 Thomas F. Burdick Portions Copyright (c) 2006 Cadence Design Systems The authors grant you the rights to distribute and use this software as governed by the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. |# #| All tk commads as of version 8.4 with support information. "-" means not supported by purpose (look comment), "x" means supported, though some options may not be supported. command supported comment bell x bind x bindtags modifly the tag list of a widget that describes which events it gets bitmap - see image button x canvas x checkbutton x clipboard x (canvas get missing... tricky...) colors - constants only console - only on some platforms cursors x destroy x entry x event create and manage virtual events focus x focus management functions font frame x grab grid x image x keysyms - constants only label x labelframe x listbox x loadTk - lower x menu x menubutton x message x option - options - only helpfile pack x panedwindow x photo x place x geometry manager using coordinates radiobutton x raise x scale x scrollbar x selection send spinbox x text x tk tk_bisque - only for tk backwards compatibility tk_chooseColor tk_chooseDirectory tk_dialog tk_focusFollowsMouse tk_focusNext tk_focusPrev tk_getOpenFile x tk_getSaveFile x tk_menuSetFocus - tk_messageBox x tk_optionMenu tk_popup tk_setPalette - tk_textCopy tk_textCut tk_textPaste tkerror - tkvars - tkwait toplevel x winfo x wm x support of all config args as keywords to make-instance: bitmap button x canvas x checkbutton x entry x frame x image label x labelframe x listbox x menu menubutton message panedwindow x photo radiobutton x scale x scrollbar x spinbox x text x toplevel x |# (defpackage :ltk (:use :common-lisp #+(or :cmu :scl) :ext #+:sbcl :sb-ext ) (:export #:ltktest #:*ltk-version* #:*cursors* #:*debug-tk* #:*break-mainloop* #:*exit-mainloop* #:*init-wish-hook* #:*mb-icons* #:*tk* #:*wish* #:wish-stream #:*wish-args* #:*wish-pathname* #:*default-ltk-debugger* #:add-pane #:add-separator #:after #:after-cancel #:after-idle #:append-text #:append-newline #:ask-okcancel #:ask-yesno #:background #:bbox #:bell #:bind #:button #:calc-scroll-region #:canvas #:canvas-line #:canvas-oval #:canvas-polygon #:canvas-rectangle #:canvas-text #:canvas-image #:canvas-arc #:canvas-bbox #:canvasx #:canvasy #:cget #:check-button #:choose-color #:choose-directory #:clear-text #:clear #:clipboard-append #:clipboard-clear #:clipboard-get #:command #:coords #:configure #:create-arc #:create-bitmap #:create-image #:create-line #:create-line* #:create-menu2 #:create-oval #:create-polygon #:create-rectangle #:create-text #:create-window #:debug-setting-keys #:defargs #:deiconify #:destroy #:do-execute #:do-msg #:entry #:entry-select #:exit-wish #:event #:event-x #:event-y #:event-keycode #:event-char #:event-mouse-button #:event-root-x #:event-root-y #:focus #:force-focus #:forget-pane #:format-wish #:frame #:geometry #:get-open-file #:get-save-file #:grab #:grab-release #:grid #:grid-columnconfigure #:grid-configure #:grid-forget #:grid-rowconfigure #:iconify #:iconwindow #:image-load #:image-setpixel #:cursor-index #:input-box #:insert-object #:interior #:itembind #:itemconfigure #:itemdelete #:itemmove #:itemlower #:itemraise #:label #:labelframe #:listbox #:listbox-append #:listbox-clear #:listbox-configure #:listbox-get-selection #:listbox-nearest #:listbox-select #:load-text #:lower #:mainloop #:make-items #:make-canvas #:make-frame #:make-image #:make-label #:make-menu #:make-menubar #:make-menubutton #:make-scrollbar #:make-scrolled-canvas #:make-text #:make-toplevel #:make-line #:make-oval #:make-polygon #:make-rectangle #:master #:maxsize #:menu #:menubar #:menubutton #:menucheckbutton #:menu-delete #:menuradiobutton #:message #:message-box #:minsize #:move #:move-all #:normalize #:on-close #:on-focus #:pack #:pack-forget #:pack-propagate #:paned-window #:photo-image #:place #:place-forget #:popup #:postscript #:process-events #:radio-button #:raise #:read-event #:save-text #:scale #:screen-height #:screen-height-mm #:screen-mouse #:screen-mouse-x #:screen-mouse-y #:screen-width #:screen-width-mm #:scrollbar #:scrolled-canvas #:scrolled-frame #:scrolled-listbox #:scrolled-text #:scrollregion #:search-all-text #:search-next-text #:see #:send-wish #:set-coords #:set-coords* #:set-focus-next #:set-geometry #:set-geometry-wh #:set-geometry-xy #:set-wm-overrideredirect #:spinbox #:start-wish #:tag-bind #:tag-configure #:text #:textbox #:tkobject #:toplevel #:value #:widget #:widget-path #:window-height #:window-id #:window-width #:window-x #:window-y #:make-ltk-connection #:widget-class-name #:with-ltk #:call-with-ltk #:with-modal-toplevel #:with-remote-ltk #:with-widgets #:withdraw #:wm-title #:wm-state )) (defpackage :ltk-user (:use :common-lisp :ltk)) (in-package :ltk) ;communication with wish ;;; this ist the only function to adapted to other lisps (defun do-execute (program args &optional (wt nil)) "execute program with args a list containing the arguments passed to the program if wt is non-nil, the function will wait for the execution of the program to return. returns a two way stream connected to stdin/stdout of the program" #+:clisp (declare (ignore wt)) (let ((fullstring program)) (dolist (a args) (setf fullstring (concatenate 'string fullstring " " a))) #+(or :cmu :scl) (let ((proc (run-program program args :input :stream :output :stream :wait wt #+scl :external-format #+scl :utf-8))) (unless proc (error "Cannot create process.")) (make-two-way-stream (ext:process-output proc) (ext:process-input proc)) ) #+:clisp (let ((proc (ext:run-program program :arguments args :input :stream :output :stream :wait t))) (unless proc (error "Cannot create process.")) proc ) #+:sbcl (let ((proc (sb-ext:run-program program args :input :stream :output :stream :wait wt :search t))) (unless proc (error "Cannot create process.")) #+:ext-8859-1 (make-two-way-stream (sb-sys:make-fd-stream (sb-sys:fd-stream-fd (process-output proc)) :input t :external-format :iso-8859-1) (sb-sys:make-fd-stream (sb-sys:fd-stream-fd (process-input proc)) :output t :external-format :iso-8859-1)) #-:ext-8859-1 (make-two-way-stream (process-output proc) (process-input proc)) ) #+:lispworks (system:open-pipe fullstring :direction :io) #+:allegro (let ((proc (excl:run-shell-command #+:mswindows fullstring #-:mswindows (apply #'vector program program args) :input :stream :output :stream :wait wt))) (unless proc (error "Cannot create process.")) proc ) #+:ecl(ext:run-program program args :input :stream :output :stream :error :output) #+:openmcl (let ((proc (ccl:run-program program args :input :stream :output :stream :wait wt))) (unless proc (error "Cannot create process.")) (make-two-way-stream (ccl:external-process-output-stream proc) (ccl:external-process-input-stream proc))) )) (defvar *ltk-version* "0.91") ;;; global var for holding the communication stream (defstruct (ltk-connection (:constructor make-ltk-connection ()) (:conc-name #:wish-)) (stream nil) (callbacks (make-hash-table :test #'equal)) (after-ids (make-hash-table :test #'equal)) (counter 1) (after-counter 1) (event-queue nil) ;; This is should be a function that takes a thunk, and calls it in ;; an environment with some condition handling in place. It is what ;; allows the user to specify error-handling in START-WISH, and have ;; it take place inside of MAINLOOP. (call-with-condition-handlers-function (lambda (f) (funcall f))) ;; This is only used to support SERVE-EVENT. (input-handler nil)) (defmacro with-ltk-handlers (() &body body) `(funcall (wish-call-with-condition-handlers-function *wish*) (lambda () ,@body))) ;;; global connection information (eval-when (:compile-toplevel :load-toplevel :execute) (setf (documentation 'make-ltk-connection 'function) "Create a new LTK-CONNECTION object. This represents a connection to a specific wish. You can maintain connections to several distinct wish processes by binding *WISH* to the one you desire to communicate with, and using LTK functions within that dynamic scope.")) (define-condition ltk-error (simple-error) ()) (defun ltk-error (format &rest args) (error 'ltk-error :format-control format :format-arguments args)) (defvar *wish* (make-ltk-connection) "The current connection to an inferior wish.") (defvar *wish-connections* () "Connections pushed aside by invoking the NEW-WISH restart in START-WISH.") ;;; verbosity of debug messages, if true, then all communication ;;; with tk is echoed to stdout (defvar *debug-tk* nil) (defvar *trace-tk* nil) (defvar *wish-pathname* #+freebsd "wish8.4" #-freebsd "wish") (defvar *wish-args* '("-name" "LTK")) (defvar *init-wish-hook* nil) (defun dbg (fmt &rest args) (when *debug-tk* (apply #'format t fmt args) (finish-output))) ;;; setup of wish ;;; put any tcl function definitions needed for running ltk here (defun init-wish () ;; print string readable, escaping all " and \ ;; proc esc {s} {puts "\"[regsub {"} [regsub {\\} $s {\\\\}] {\"}]\""} ;(send-wish "proc esc {s} {puts \"\\\"[regsub -all {\"} [regsub -all {\\\\} $s {\\\\\\\\}] {\\\"}]\\\"\"} ") ;(send-wish "proc escape {s} {return [regsub -all {\"} [regsub -all {\\\\} $s {\\\\\\\\}] {\\\"}]} ") (send-wish "package require Tk") (send-wish "proc escape {s} {regsub -all {\\\\} $s {\\\\\\\\} s1;regsub -all {\"} $s1 {\\\"} s2;return $s2}") ;;; proc senddata {s} {puts "(data \"[regsub {"} [regsub {\\} $s {\\\\}] {\"}]\")"} (send-wish "proc senddata {s} {puts \"(:data [escape $s])\";flush stdout}") (send-wish "proc senddatastring {s} {puts \"(:data \\\"[escape $s]\\\")\";flush stdout} ") (send-wish "proc senddatastrings {strings} { puts \"(:data (\" foreach s $strings { puts \"\\\"[escape $s]\\\"\" } puts \"))\";flush stdout} ") (send-wish "proc to_keyword {s} { if {[string index $s 0] == \"-\"} { return \":[string range $s 1 [string length $s]]\" } {return \":$s\"}}") (send-wish "proc sendpropertylist {l} { set pos 0 set ll [llength $l] puts \"(:data (\" while {$pos < $ll} { puts \" [to_keyword [lindex $l $pos]] \" set pos [expr $pos + 1] puts \" [lindex $l $pos] \" set pos [expr $pos + 1] } puts \"))\" }") (send-wish "proc searchall {widget pattern} { set l [string length $pattern] set result [$widget search $pattern 1.0] set previous 0 while {$result > $previous} { $widget tag add sel $result $result+${l}chars set previous $result set result [$widget search $pattern $result+${l}chars] } }") (send-wish "proc searchnext {widget pattern} { set l [string length $pattern] set result [$widget search $pattern insert] if {$result > 0} { $widget tag remove sel 1.0 end $widget tag add sel $result $result+${l}chars $widget mark set insert $result+${l}chars $widget see insert } }") ;;; proc sendevent {s} {puts "(event \"[regsub {"} [regsub {\\} $s {\\\\}] {\"}]\")"} ;(send-wish "proc sendevent {s x y keycode char width height root_x root_y} {puts \"(:event \\\"$s\\\" $x $y $keycode $char $width $height $root_x $root_y)\"} ") (send-wish "proc sendevent {s x y keycode char width height root_x root_y mouse_button} {puts \"(:event \\\"$s\\\" $x $y $keycode $char $width $height $root_x $root_y $mouse_button)\"} ") ;;; proc callback {s} {puts "(callback \"[regsub {"} [regsub {\\} $s {\\\\}] {\"}]\")"} ;;; callback structure: (:callback "widgetname") ;; for non-parameter callbacks ;;; (:callback "widgetname" val) ;; wideget returns non-string value ;;; (:callback "widgetname" "string") ;; widget returns string value (send-wish "proc callback {s} {puts \"(:callback \\\"$s\\\")\";flush stdout} ") (send-wish "proc callbackval {s val} {puts \"(:callback \\\"$s\\\" $val)\"} ") (send-wish "proc callbackstring {s val} {puts \"(:callback \\\"$s\\\" \\\"[escape $val]\\\")\"} ") (dolist (fun *init-wish-hook*) ; run init hook funktions (funcall fun))) ;;; start wish and set (wish-stream *wish*) (defun start-wish (&rest keys &key handle-errors handle-warnings (debugger t) stream) (declare (ignore handle-errors handle-warnings debugger)) ;; open subprocess (if (null (wish-stream *wish*)) (progn (setf (wish-stream *wish*) (or stream (do-execute *wish-pathname* *wish-args*)) (wish-call-with-condition-handlers-function *wish*) (apply #'make-condition-handler-function keys)) ;; perform tcl initialisations (with-ltk-handlers () (init-wish))) ;; By default, we don't automatically create a new connection, because the ;; user may have simply been careless and doesn't want to push the old ;; connection aside. The NEW-WISH restart makes it easy to start another. (restart-case (ltk-error "There is already an inferior wish.") (new-wish () :report "Create an additional inferior wish." (push *wish* *wish-connections*) (setf *wish* (make-ltk-connection)) (apply #'start-wish keys))))) ;;; CMUCL, SCL, and SBCL, use a two-way-stream and the constituent ;;; streams need to be closed. (defun close-process-stream (stream) "Close a 'stream open by 'do-execute." (when *debug-tk* (format t "Closing wish stream: ~S~%" stream)) (ignore-errors (close stream)) #+(or :cmu :scl :sbcl) (when (typep stream 'two-way-stream) (close (two-way-stream-input-stream stream) :abort t) (close (two-way-stream-output-stream stream) :abort t)) nil) (defun exit-wish () (with-ltk-handlers () (let ((stream (wish-stream *wish*))) (when stream (remove-input-handler) (when (open-stream-p stream) (ignore-errors (send-wish "exit"))) (close-process-stream stream)) (setf (wish-stream *wish*) nil) #+:allegro (system:reap-os-subprocess) (setf *wish-connections* (remove *wish* *wish-connections*))) nil)) ;;; send a string to wish (defun send-wish (text) (declare (string text) (optimize (speed 3))) (when *debug-tk* (format t "~A~%" text) (finish-output)) (let ((*print-pretty* nil) (stream (wish-stream *wish*))) (declare (stream stream)) (handler-bind ((stream-error (lambda (e) (when *debug-tk* (format t "Error sending command to wish: ~A" e) (finish-output)) (ignore-errors (close stream)) (exit-wish)))) (format stream "~A~%" text) (finish-output stream)))) (defmacro format-wish (control &rest args) "format 'args using 'control as control string to wish" (let ((stream (gensym))) `(progn (when *debug-tk* (format t ,control ,@args) (format t "~%") (finish-output)) (let ((*print-pretty* nil) (,stream (wish-stream *wish*))) (declare (type stream ,stream)) ;(optimize (speed 3))) (format ,stream ,control ,@args) (format ,stream "~%") (finish-output ,stream)) nil))) ;; differences: ;; cmucl/sbcl READ expressions only if there is one more character in the stream, if ;; it is a whitespace its discarded. Lispworks READs the expression as soon as it can ;; be fully read from the stream - no character is discarded ;; so I am printing an additional space after every READable expression printed from tcl, ;; this has to be eaten for read-line from the stream in lispworks (which returns the line ;; ending character, cmucl/sbcl don't) (defun read-all(stream) (declare (stream stream) (inline read-char-no-hang)) (let ((c (read-char-no-hang stream nil nil)) (s (make-array 256 :adjustable t :element-type 'character :fill-pointer 0))) (loop while c do (vector-push-extend c s) (setf c (read-char-no-hang stream nil nil))) (coerce s 'simple-string))) ;;; read from wish (defun read-wish () "Reads from wish. If the next thing in the stream is looks like a lisp-list read it as such, otherwise read one line as a string." ;; FIXME: The problem here is that wish sends us error-messages on the same ;; stream that we use for our own communication. It would be good if we could ;; get the error-messages (that are presumably written to stderr) onto a separate ;; stream. The current workaround is based on the observation that wish error ;; messages always seem to end on a newline, but this may not always be so. ;; ;; READ-ALL would be a bad idea anyways, as in that case we could accidentally ;; snarf a real message from the stream as well, if it immediately followed ;; an error message. (let ((*read-eval* nil) (*package* (find-package :ltk)) (stream (wish-stream *wish*))) (if (eql #\( (peek-char t stream nil)) (read stream nil) (read-line stream nil)))) (defun can-read (stream) "return t, if there is something to READ on the stream" (declare (stream stream) (inline read-char-no-hang unread-char)) (let ((c (read-char-no-hang stream))) (loop while (and c (member c '(#\Newline #\Return #\Space))) do (setf c (read-char-no-hang stream))) (when c (unread-char c stream) t))) (defun read-event (&key (blocking t) (no-event-value nil)) "read the next event from wish, return the event or nil, if there is no event to read and blocking is set to nil" (or (pop (wish-event-queue *wish*)) (if (or blocking (can-read (wish-stream *wish*))) (read-preserving-whitespace (wish-stream *wish*) nil nil) no-event-value))) (defun read-data () "Read data from wish. Non-data events are postponed, bogus messages (eg. +error-strings) are ignored." (loop for data = (read-wish) when (listp data) do (cond ((eq (first data) :data) (dbg "read-data: ~s~%" data) (return (second data))) (t (dbg "postponing event: ~s~%" data) (setf (wish-event-queue *wish*) (append (wish-event-queue *wish*) (list data))))) else do (dbg "read-data error: ~a~%" data))) (defun read-keyword () (let ((string (read-data))) (when (> (length string) 0) (values (intern #-scl (string-upcase string) #+scl (if (eq ext:*case-mode* :upper) (string-upcase string) (string-downcase string)) :keyword))))) ;;; sanitizing strings: lisp -> tcl (format (wish-stream *wish*) "{~a}" string) ;;; in string escaped : {} mit \{ bzw \} und \ mit \\ (defun make-adjustable-string (&optional (string "")) (make-array (length string) :element-type 'character :initial-contents string :adjustable t :fill-pointer t)) ;; Much faster version. For one test run it takes 2 seconds, where the ;; other implementation requires 38 minutes. (defun tkescape (text) (unless (stringp text) (setf text (format nil "~a" text))) (loop with result = (make-adjustable-string) for c across text do (when (member c '(#\\ #\$ #\[ #\] #\{ #\} #\")) (vector-push-extend #\\ result)) (vector-push-extend c result) finally (return result))) ;; basic tk object (defclass tkobject () ((name :accessor name :initarg :name :initform nil) ) (:documentation "Base class for every Tk object")) ;; basic class for all widgets (defclass widget(tkobject) ((master :accessor master :initarg :master :initform nil) ;; parent widget or nil (widget-path :initarg :path :initform nil :accessor %widget-path) ;; pathname to refer to the widget (init-command :accessor init-command :initform nil :initarg :init-command) ) (:documentation "Base class for all widget types")) ;; creating of the tk widget after creating the clos object (defmethod initialize-instance :after ((w widget) &key) (unless (name w) ; generate name if not given (setf (name w) (create-name)))) (defvar *tk* (make-instance 'widget :name "." :path ".") "dummy widget to access the tk root object") ;;; tcl -> lisp: puts "$x" mit \ und " escaped ;;; puts [regsub {"} [regsub {\\} $x {\\\\}] {\"}] ;;; call to convert untility (defun convert(from to) (close-process-stream (do-execute "convert" (list from to) t))) ;;; table used for callback every callback consists of a name of a widget and ;;; a function to call (defun add-callback (sym fun) "create a callback sym is the name to use for storage, fun is the function to call" (when *debug-tk* (format t "add-callback (~A ~A)~%" sym fun)) (setf (gethash sym (wish-callbacks *wish*)) fun)) (defun remove-callback (sym) (when *debug-tk* (format t "remove-callback (~A)~%" sym)) (setf (gethash sym (wish-callbacks *wish*)) nil)) (defun callback (sym arg) "perform the call of the function associated with sym and the args arg" (let ((fun (gethash sym (wish-callbacks *wish*)))) (when fun (apply fun arg)))) (defun after (time fun) "after