#| This software is Copyright (c) 2003, 2004, 2005, 2006 Peter Herth Parts Copyright (c) 2005 Thomas F. Burdick Parts Copyright (c) Cadence Design Systems, GmbH Peter Herth grants 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 #+:cmu :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-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" "PANE-CONFIGURE" "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" "SEE" "SEND-WISH" "SET-COORDS" "SET-COORDS*" "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-REMOTE-LTK" "WITH-WIDGETS" "WITHDRAW" "WM-TITLE" )) (defpackage :ltk-user (:use :common-lisp :ltk)) (in-package :ltk) (defun dbg (fmt &rest args) (apply #'format t fmt args) (finish-output)) ;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))) #+:cmu (let ((proc (run-program program args :input :stream :output :stream :wait wt))) (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) #+:gcl(si: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.881") ;;; 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* t) (defvar *trace-tk* t) (defvar *wish-pathname* #+freebsd "wish8.4" #-freebsd "wish") (defvar *wish-args* '("-name" "LTK")) (defvar *init-wish-hook* nil) ;;; 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 "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} ") ;;; 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))))) (defun exit-wish () (with-ltk-handlers () (when (wish-stream *wish*) (remove-input-handler) (when (open-stream-p (wish-stream *wish*)) (send-wish "exit")) (close (wish-stream *wish*)) (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) (when *debug-tk* (format t "~A~%" text) (finish-output)) (handler-bind ((stream-error (lambda (e) (when *debug-tk* (format t "Error sending command to wish: ~A" e) (finish-output)) (close (wish-stream *wish*)) (exit-wish)))) (format (wish-stream *wish*) "~A~%" text) (finish-output (wish-stream *wish*)))) (defun format-wish (control &rest args) "format args using control as control string to wish" (when *debug-tk* (apply #'format t control args) (format t "~%") (finish-output)) (apply #'format (wish-stream *wish*) control args) (format (wish-stream *wish*) "~%") (finish-output (wish-stream *wish*))) ;; 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) (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() (let ((*read-eval* nil) (*package* (find-package :ltk))) (read (wish-stream *wish*) nil nil))) (defun can-read (stream) "return t, if there is something to READ on the stream" (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" (let ((d (read-wish))) (if (listp d) ; paranoia check when we do not read a list eg. error messages from wish (progn (loop while (not (equal (first d) :data)) do (setf (wish-event-queue *wish*) (append (wish-event-queue *wish*) (list d))) ;;(format t "postponing event: ~a ~%" d) (finish-output) (setf d (read-wish))) ;(format t "readdata: ~s~%" d) (finish-output) (second d)) (format t "read-data:~a~a~%" d (read-all (wish-stream *wish*)))))) (defun read-keyword () (let ((string (read-data))) (when (> (length string) 0) (values (intern (string-upcase string) :keyword))))) ;;; sanitizing strings: lisp -> tcl (format (wish-stream *wish*) "{~a}" string) ;;; in string escaped : {} mit \{ bzw \} und \ mit \\ (defun replace-char (txt char with) (let ((pos (search char txt))) (loop while pos do (progn ;;(dbg "txt: ~a -> " txt) (setf txt (concatenate 'string (subseq txt 0 pos) with (subseq txt (1+ pos)))) ;;(dbg " ~a~&" txt) (setf pos (search char txt :start2 (+ pos (length with))))))) txt) (defun tkescape (txt) (setf txt (format nil "~a" txt)) (replace-char (replace-char (replace-char (replace-char (replace-char txt "\\" "\\\\") "$" "\\$") "[" "\\[") "]" "\\]") "\"" "\\\"")) ;;; tcl -> lisp: puts "$x" mit \ und " escaped ;;; puts [regsub {"} [regsub {\\} $x {\\\\}] {\"}] ;;; call to convert untility (defun convert(from to) (close (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