Browse files

pass back-end objects instead of classes to with-tk, toplevel-tk

  • Loading branch information...
1 parent 15ff730 commit 0208b903b6d5971f30db390768726535d08f708a @marijnh committed Mar 14, 2009
Showing with 15 additions and 19 deletions.
  1. +12 −12 base.lisp
  2. +1 −4 test.lisp
  3. +2 −3 wish.lisp
@@ -123,18 +123,18 @@
;; Running a Tk instance
-(defun start-tk (&optional class)
- (cond (class (make-instance class))
- ((find-class 'ffi-tk)
- (handler-case (make-instance 'ffi-tk)
- (error (e) (warn "Failed to start FFI back-end: ~a" (princ-to-string e))
- (make-instance 'wish-tk))))
- (t (make-instance 'wish-tk))))
-(defmacro with-tk ((&optional class) &body body)
- `(let ((*tk* (start-tk ,class)))
+(defun start-tk (&optional back-end)
+ (or back-end
+ (if (find-class 'ffi-tk)
+ (handler-case (make-instance 'ffi-tk)
+ (error (e) (warn "Failed to start FFI back-end: ~a" (princ-to-string e))
+ (make-instance 'wish-tk)))
+ (make-instance 'wish-tk))))
+(defmacro with-tk ((&optional back-end) &body body)
+ `(let ((*tk* (start-tk ,back-end)))
(unwind-protect (progn ,@body)
-(defun toplevel-tk (&optional class)
- (setf *tk* (start-tk class)))
+(defun toplevel-tk (&optional back-end)
+ (setf *tk* (start-tk back-end)))
@@ -1,10 +1,7 @@
(in-package :cl-tk)
-(defmacro with-random-tk (&body body)
- `(with-tk ((if (zerop (random 2)) 'wish-tk 'ffi-tk)) ,@body))
(defun test-button ()
- (with-random-tk
+ (with-tk ()
(let ((stop nil))
(tcl "ttk::button" ".b" :text "Exit ☻" :command (event-handler* (setf stop t)))
(tcl "pack .b")
@@ -44,15 +44,14 @@
(tcl-error "Could not start wish process.")))
-(defparameter *wish-binary* "wish")
(defclass wish-tk (tk)
((stream :reader @stream)
+ (binary :initarg :binary :initform "wish" :reader @binary)
(queue :initform () :accessor @queue)
(alive :initform t :accessor @alive)))
(defmethod initialize-instance :after ((tk wish-tk) &key &allow-other-keys)
- (setf (slot-value tk 'stream) (wish-stream *wish-binary*))
+ (setf (slot-value tk 'stream) (wish-stream (@binary tk)))
(tcl-send tk "package require Tk 8.5" nil)
(tcl-send tk "proc _esc {s} {format {\"%s\"} [regsub -all {\"} [regsub -all {\\\\} $s {\\\\\\\\}] {\\\"}]}" nil)
(tcl-send tk "proc _lst {type args} {puts \"(:$type\"; foreach arg $args {puts \" [_esc $arg]\"}; puts \")\\n\"; flush stdout}" nil)

0 comments on commit 0208b90

Please sign in to comment.