source: trunk/source/cocoa-ide/start.lisp @ 12115

Last change on this file since 12115 was 12115, checked in by mikel, 11 years ago

Added a "Start Now" button to the preferences pane for the swank server, so that now we can start the Swank server from the preference pane without having to restart CCL, and without necessarily enabling it to start up at launch.

File size: 14.4 KB
Line 
1(in-package "GUI")
2
3(defparameter *standalone-cocoa-ide* nil)
4
5(if (< #&NSAppKitVersionNumber 824)
6    (error "This application requires features introduced in OSX 10.4."))
7
8(def-cocoa-default  *ccl-directory* :string "" nil
9                    #+no #'(lambda (old new)
10                             (when (equal new "") (setq new nil))
11                             (unless (and new (equal old new))
12                               (init-interfaces-root)
13                               (ccl::replace-base-translation
14                                "ccl:"
15                                (or new (find-ccl-directory))))))
16
17;; If there are interfaces inside the bundle, use those rather than the ones
18;; in CCL:, since they're more likely to be valid.  CCL: could be some random
19;; old sources we're just using for meta-.
20(defun init-interfaces-root ()
21  (let* ((subpath (ccl::cdb-subdirectory-path))
22         (path (pathname-directory (ccl::ccl-directory))))
23    (when (and *standalone-cocoa-ide*
24               (equalp (last path 2) '("Contents" "MacOS")))
25      (setq path (butlast path))
26      (when (or (probe-file (make-pathname :directory (append path subpath)))
27                (probe-file (make-pathname :directory (append (setq path `(,@path "Resources")) subpath))))
28        (setq ccl::*interfaces-root* (make-pathname :directory path))))))
29
30(defun find-ccl-directory ()
31  (let* ((path (ccl::ccl-directory))
32         (dir (pathname-directory path)))
33    (if (equalp (last dir 2) '("Contents" "MacOS"))
34        (make-pathname :directory (butlast dir 3))
35        path)))
36
37
38(defmethod ccl::ui-object-do-operation ((o ns:ns-application)
39                                        operation
40                                        &rest args)
41  (declare (ignore operation args))
42  ;; Do nothing.  Would it be better to warn and/or log this ?
43  )
44
45(defmethod ccl::ui-object-do-operation ((o ns:ns-application)
46                                        (operation (eql :note-current-package))
47                                        &rest args)
48  (ui-object-note-package o (car args)))
49
50(defmethod ccl::ui-object-do-operation ((o ns:ns-application)
51                                        (operation (eql :eval-selection))
52                                        &rest args)
53  (ui-object-eval-selection o (car args)))
54
55(defmethod ccl::ui-object-do-operation ((o ns:ns-application)
56                                        (operation (eql :enter-backtrace-context))
57                                        &rest args)
58  (ui-object-enter-backtrace-context o (car args)))
59
60(defmethod ccl::ui-object-do-operation ((o ns:ns-application)
61                                        (operation (eql :exit-backtrace-context))
62                                        &rest args)
63  (ui-object-exit-backtrace-context o (car args)))
64
65
66;;; Support for saving a stand-alone IDE
67
68
69(defclass cocoa-application (application)
70  ())
71
72(defmethod ccl::application-error ((a cocoa-application) condition error-pointer)
73  (ccl::break-loop-handle-error condition error-pointer))
74
75
76(defmethod ccl::application-init-file ((a cocoa-application))
77  '("home:ccl-init" "home:\\.ccl-init"))
78
79;;; If we're launched via the Finder, the only argument we'll
80;;; get is of the form -psnXXXXXX.  That's meaningless to us;
81;;; it's easier to pretend that we didn't get any arguments.
82;;; (If it seems like some of this needs to be thought out a
83;;; bit better ... I'd tend to agree.)
84(defmethod ccl::parse-application-arguments ((a cocoa-application))
85  (values nil nil nil nil))
86
87(eval-when (:compile-toplevel :load-toplevel :execute)
88    (require :swank))
89
90(defun try-starting-swank (&key (force nil))
91  (unless *ccl-swank-active-p*
92    ;; try to determine the user preferences concerning the swank port number
93    ;; and whether the swank server should be started. If the user says start
94    ;; it, and we can determine a valid port for it, start it up
95    (let* ((defaults (handler-case (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))
96                       (serious-condition (c) 
97                         (progn (format t "~%ERROR: Unable to get preferences from the Shared User Defaults Controller")
98                                (force-output)
99                                nil))))
100           (start-swank-pref (and defaults (#/valueForKey: defaults #@"startSwankServer")))
101           (start-swank? (cond
102                           ;; force is true, so we don't care about the user pref
103                           (force t)
104                           ;; the user default is not initialized
105                           ((or (null start-swank-pref)
106                                (%null-ptr-p start-swank-pref)) nil)
107                           ;; examine the user default
108                           ((typep start-swank-pref 'ns:ns-number) 
109                            (case (#/intValue start-swank-pref)
110                              ;; don't start swank
111                              (0 nil)
112                              ;; start swank
113                              (1 t)
114                              ;; the user default value is incomprehensible
115                              (otherwise (progn
116                                           (format t "~%ERROR: Unrecognized value in user preference 'startSwankServer': ~S"
117                                                   start-swank-pref)
118                                           (force-output)
119                                           nil))))
120                           ;; the user default value is incomprehensible
121                           (t (progn
122                                (format t "~%ERROR: Unrecognized value type in user preference 'startSwankServer': ~S"
123                                        start-swank-pref)
124                                (force-output)
125                                nil))))
126           (swank-port-pref (and defaults (#/valueForKey: defaults #@"swankPort")))
127           (swank-port (cond
128                         ;; the user default is not initialized
129                         ((or (null swank-port-pref)
130                              (%null-ptr-p swank-port-pref)) nil)
131                         ;; examine the user default
132                         ((typep swank-port-pref 'ns:ns-string) 
133                          (handler-case (let* ((port-str (lisp-string-from-nsstring swank-port-pref))
134                                               (port (parse-integer port-str :junk-allowed nil)))
135                                          (or port *default-gui-swank-port*))
136                            ;; parsing the port number failed
137                            (ccl::parse-integer-not-integer-string (c)
138                              (setf *ccl-swank-active-p* nil)
139                              (format t "~%Error starting swank server; the swank-port user preference is not a valid port number: ~S~%"
140                                      port-str)
141                              (force-output)
142                              nil)))
143                         ;; the user default value is incomprehensible
144                         (t (progn
145                              (format t "~%ERROR: Unrecognized value type in user preference 'swankPort': ~S"
146                                      swank-port-pref)
147                              (force-output)
148                              nil)))))
149      (if (and start-swank? swank-port)
150          ;; try to start the swank server
151          (handler-case (progn
152                          (swank:create-server :port swank-port :dont-close t)
153                          (setf *ccl-swank-active-p* t)
154                          (setf *active-gui-swank-port* swank-port)
155                          swank-port)
156            ;; swank server creation failed
157            (serious-condition (c)
158              (setf *ccl-swank-active-p* nil)
159              (setf *active-gui-swank-port* nil)
160              (format t "~%Error starting swank server: ~A~%" c)
161              (force-output)
162              nil))
163          ;; don't try to start the swank server
164          (progn
165            (setf *ccl-swank-active-p* nil)
166            (setf *active-gui-swank-port* nil)
167            nil)))))
168
169(defmethod toplevel-function ((a cocoa-application) init-file)
170  (declare (ignore init-file))
171  (when (< #&NSAppKitVersionNumber 824)
172    (#_NSLog #@"This application requires features introduced in OSX 10.4.")
173    (#_ _exit -1))
174  (setq *standalone-cocoa-ide* t)
175  ;; It's probably reasonable to do this here: it's not really IDE-specific
176  (try-starting-swank)
177  (try-connecting-to-altconsole)
178  ;; TODO: to avoid confusion, should now reset *cocoa-application-path* to
179  ;; actual bundle path where started up.
180  (start-cocoa-application))
181
182
183
184
185(defun build-ide (bundle-path)
186  (setq bundle-path (ensure-directory-pathname bundle-path))
187
188  ;; The bundle is expected to exist, we'll just add the executable into it.
189  (assert (probe-file bundle-path))
190
191  ;; Wait until we're sure that the Cocoa event loop has started.
192  (wait-on-semaphore *cocoa-application-finished-launching*)
193
194  (require :easygui)
195
196  (ccl::maybe-map-objc-classes t)
197  (let* ((missing ()))
198    (ccl::do-interface-dirs (d)
199      (ccl::cdb-enumerate-keys
200       (ccl::db-objc-classes d)
201       (lambda (name)
202         (let* ((class (ccl::lookup-objc-class name nil)))
203           (unless (ccl::objc-class-id  class) (push name missing))))))
204    (when missing
205      (break "ObjC classes ~{~&~a~} are declared but not defined." missing)))
206
207  (ccl::touch bundle-path)
208
209  (let ((image-file (make-pathname :name (ccl::standard-kernel-name) :type nil :version nil
210                                   :defaults (merge-pathnames ";Contents;MacOS;" bundle-path))))
211    (format *error-output* "~2%Saving application to ~a~2%" (truename bundle-path))
212    (force-output *error-output*)
213    (ensure-directories-exist image-file)
214    (save-application image-file
215                      :prepend-kernel t
216                      :application-class 'cocoa-application)))
217
218;;; If we're running as a standalone .app, try to see if a bundle named
219;;; AltConsole.app exists in our Resources directory.  If so, execute
220;;; that bundle'es executable file, with its standard input/output/error
221;;; descriptors connected to one end of a socketpair, and connect
222;;; lisp's *TERMINAL-IO* and C's stdin/stdout/stderr to the other end
223;;; of the socket.
224
225(defun try-connecting-to-altconsole ()
226  (with-autorelease-pool
227      (let* ((main-bundle (#/mainBundle ns:ns-bundle))
228             (resource-path (#/resourcePath main-bundle)))
229        (block exit
230          (when (%null-ptr-p resource-path)
231            (return-from exit nil))
232          (let* ((altconsole-bundle
233                  (make-instance ns:ns-bundle
234                                 :with-path
235                                 (#/stringByAppendingPathComponent:
236                                  resource-path
237                                  #@"AltConsole.app"))))
238            (when (%null-ptr-p altconsole-bundle)
239              (return-from exit nil))
240            (let* ((executable-path (#/executablePath altconsole-bundle)))
241              (when (%null-ptr-p executable-path)
242                (return-from exit nil))
243              (let* ((nbytes (1+ (#/lengthOfBytesUsingEncoding:
244                                  executable-path
245                                  #$NSUTF8StringEncoding))))
246                (%stack-block ((c-executable-path nbytes))
247                  (unless (#/getCString:maxLength:encoding:
248                           executable-path
249                           c-executable-path
250                           nbytes
251                           #$NSUTF8StringEncoding)
252                    (return-from exit nil))
253                  (rletz ((argv (:array :address 2))
254                          (envp (:array :address 1))
255                          (sockets (:array :int 2)))
256                    (setf (paref argv (:array :address) 0) c-executable-path)
257                    (unless (eql 0 (#_socketpair #$AF_UNIX #$SOCK_STREAM 0 sockets))
258                      (return-from exit nil))
259                    (let* ((parent-socket (paref sockets (:array :int) 0))
260                           (child-socket (paref sockets (:array :int) 1))
261                           (pid (#_fork)))
262                      (case pid
263                        (-1
264                         ;; Fork failed
265                         (#_close parent-socket)
266                         (#_close child-socket)
267                         (return-from exit nil))
268                        (0
269                         ;; This runs in the child.
270                         (#_close parent-socket)
271                         (#_dup2 child-socket 0)
272                         (#_dup2 child-socket 1)
273                         (#_dup2 child-socket 2)
274                         (#_execve c-executable-path
275                                   argv
276                                   envp)
277                         ;; If the #_exec fails, there isn't
278                         ;; much to do or say about it.
279                         (#__exit 1))
280                        (t
281                         ;; We're the parent.
282                         (#_close child-socket)
283                         (when (eq t (ccl::check-pid pid))
284                           (flet ((set-lisp-stream-fd (stream fd)
285                                    (setf (ccl::ioblock-device (ccl::stream-ioblock stream t))
286                                          fd)))
287                             (ff-call (ccl::%kernel-import target::kernel-import-open-debug-output)
288                                      :int parent-socket
289                                      :int)
290                             (#_dup2 parent-socket 0)
291                             (set-lisp-stream-fd ccl::*stdin* parent-socket)
292                             (set-lisp-stream-fd ccl::*stdout* parent-socket))
293                           ;; Ensure that output to the stream ccl::*stdout* -
294                           ;; which is connected to fd 1 - is flushed periodically
295                           ;; by the housekeeping task.  (ccl::*stdout* is
296                           ;; typically the output side of the two-way stream
297                           ;; which is the global/static value of *TERMINAL-IO*;
298                           ;; many standard streams are synonym streams to
299                           ;; *TERMINAL-IO*.
300                           (ccl::add-auto-flush-stream ccl::*stdout*)
301                           pid)))))))))))))
302                     
303                   
304             
305;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
306
307
308(start-cocoa-application)
Note: See TracBrowser for help on using the repository browser.