Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv12631

Modified Files: clim-launcher.lisp Log Message: Added support for launching applications to the Listener.

--- /project/clim-desktop/cvsroot/clim-desktop/clim-launcher.lisp 2006/03/30 10:33:55 1.2 +++ /project/clim-desktop/cvsroot/clim-desktop/clim-launcher.lisp 2006/06/06 13:46:58 1.3 @@ -4,8 +4,6 @@ ;;(asdf:oos 'asdf:load-op :clim-listener) ;;(asdf:oos 'asdf:load-op :climacs)

- - (in-package :clim-launcher)

(define-application-frame launcher () @@ -39,9 +37,9 @@ (define-launcher-command com-launch-app ((appl 'clim-app)) - ;; SBCL doesn't keep dynamic bindings from the parent thread when - ;; invoking a new thread, so we'll have to create the threads and - ;; the bindings ourselves. + ;; KLUDGE: SBCL doesn't keep dynamic bindings from the parent thread + ;; when invoking a new thread, so we'll have to create the threads + ;; and the bindings ourselves. (flet ((run () (let #+sbcl ((sb-ext:*invoke-debugger-hook* #'clim-debugger:debugger) (*debugger-hook* #'clim-debugger:debugger)) @@ -80,4 +78,71 @@ (defun start () "Start the CLIM Launcher program." #+:cmucl (multiprocessing::startup-idle-and-top-level-loops) - (run-frame-top-level (make-application-frame 'clim-launcher::launcher))) \ No newline at end of file + (run-frame-top-level (make-application-frame 'clim-launcher::launcher))) + +;; Get some support for launching apps into the CLIM Listener: + +(defmethod display-commands ((frame clim-listener::listener) stream) + (loop for app being the hash-values of *apps* + do (present app 'clim-app :stream stream))) + +(define-command (com-list-applications + :name t + :command-table clim-listener::show-commands + :menu t) + () + (display-commands *application-frame* (frame-standard-output *application-frame*))) + +(define-command (com-launch-application + :name t + :command-table clim-listener::lisp-commands + :menu t) + ((appl 'clim-app)) + ;; KLUDGE: SBCL doesn't inherit local dynamic bindings from the + ;; parent thread, so we'll have to create the threads and the + ;; bindings ourselves. + (flet ((run () + (let #+sbcl ((sb-ext:*invoke-debugger-hook* #'clim-debugger:debugger) + (*debugger-hook* #'clim-debugger:debugger)) + #-sbcl nil + (funcall (entry appl))))) + (clim-sys:make-process #'run :name (name appl)))) + +(define-presentation-to-command-translator launch-application-translator + (clim-app com-launch-application clim-listener::lisp-commands + :gesture :select + :documentation "Launch Application") + (object) + (list object)) + +(define-presentation-to-command-translator edit-application-translator + (clim-app climacs-gui::com-edit-function-definition clim-listener::lisp-commands + :gesture :edit + :tester ((object presentation) + (declare (ignore presentation)) + (symbolp (entry object))) + :documentation "Edit Application") + (object) + (list (entry object))) + +(define-presentation-method accept + ((type clim-app) stream view &key (default nil defaultp) + (default-type type)) + (multiple-value-bind (object success string) + (complete-input stream + (lambda (so-far action) + (complete-from-possibilities + so-far + (loop for val being the hash-values of *apps* + collecting val) + '() + :action action + :name-key #'name + :value-key #'identity)) + :partial-completers '(#\Space) + :allow-any-input t) + (cond (success + (values object type)) + ((and (zerop (length string)) defaultp) + (values default default-type)) + (t (values string 'string))))) \ No newline at end of file