[clim-desktop-cvs] CVS clim-desktop

[thenriksen]

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