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

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

Added user preferences to control whether the swank server starts up at launch, and on which port. Added lots of error checking and handling around that whole process.

File size: 14.0 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 ()
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                                nil))))
99           (start-swank-pref (and defaults (#/valueForKey: defaults #@"startSwankServer")))
100           (start-swank? (cond
101                           ;; the user default is not initialized
102                           ((or (null start-swank-pref)
103                                (%null-ptr-p start-swank-pref)) nil)
104                           ;; examine the user default
105                           ((typep start-swank-pref 'ns:ns-number) 
106                            (case (#/intValue start-swank-pref)
107                              ;; don't start swank
108                              (0 nil)
109                              ;; start swank
110                              (1 t)
111                              ;; the user default value is incomprehensible
112                              (otherwise (progn
113                                           (format t "~%ERROR: Unrecognized value in user preference 'startSwankServer': ~S"
114                                                   start-swank-pref)
115                                           nil))))
116                           ;; the user default value is incomprehensible
117                           (t (progn
118                                (format t "~%ERROR: Unrecognized value type in user preference 'startSwankServer': ~S"
119                                        start-swank-pref)
120                                nil))))
121           (swank-port-pref (and defaults (#/valueForKey: defaults #@"swankPort")))
122           (swank-port (cond
123                         ;; the user default is not initialized
124                         ((or (null swank-port-pref)
125                              (%null-ptr-p swank-port-pref)) nil)
126                         ;; examine the user default
127                         ((typep swank-port-pref 'ns:ns-string) 
128                          (handler-case (let* ((port-str (lisp-string-from-nsstring swank-port-pref))
129                                               (port (parse-integer port-str :junk-allowed nil)))
130                                          (or port *default-gui-swank-port*))
131                            ;; parsing the port number failed
132                            (ccl::parse-integer-not-integer-string (c)
133                              (setf *ccl-swank-active-p* nil)
134                              (format t "~%Error starting swank server; the swank-port user preference is not a valid port number: ~S~%"
135                                      port-str)
136                              nil)))
137                         ;; the user default value is incomprehensible
138                         (t (progn
139                              (format t "~%ERROR: Unrecognized value type in user preference 'swankPort': ~S"
140                                      swank-port-pref)
141                              nil)))))
142      (if (and start-swank? swank-port)
143          ;; try to start the swank server
144          (handler-case (progn
145                          (swank:create-server :port swank-port :dont-close t)
146                          (setf *ccl-swank-active-p* t)
147                          (setf *active-gui-swank-port* swank-port)
148                          swank-port)
149            ;; swank server creation failed
150            (serious-condition (c)
151              (setf *ccl-swank-active-p* nil)
152              (setf *active-gui-swank-port* nil)
153              (format t "~%Error starting swank server: ~A~%" c)
154              nil))
155          ;; don't try to start the swank server
156          (progn
157            (setf *ccl-swank-active-p* nil)
158            (setf *active-gui-swank-port* nil)
159            nil)))
160    (force-output)))
161
162(defmethod toplevel-function ((a cocoa-application) init-file)
163  (declare (ignore init-file))
164  (when (< #&NSAppKitVersionNumber 824)
165    (#_NSLog #@"This application requires features introduced in OSX 10.4.")
166    (#_ _exit -1))
167  (setq *standalone-cocoa-ide* t)
168  ;; It's probably reasonable to do this here: it's not really IDE-specific
169  (try-starting-swank)
170  (try-connecting-to-altconsole)
171  ;; TODO: to avoid confusion, should now reset *cocoa-application-path* to
172  ;; actual bundle path where started up.
173  (start-cocoa-application))
174
175
176
177
178(defun build-ide (bundle-path)
179  (setq bundle-path (ensure-directory-pathname bundle-path))
180
181  ;; The bundle is expected to exist, we'll just add the executable into it.
182  (assert (probe-file bundle-path))
183
184  ;; Wait until we're sure that the Cocoa event loop has started.
185  (wait-on-semaphore *cocoa-application-finished-launching*)
186
187  (require :easygui)
188
189  (ccl::maybe-map-objc-classes t)
190  (let* ((missing ()))
191    (ccl::do-interface-dirs (d)
192      (ccl::cdb-enumerate-keys
193       (ccl::db-objc-classes d)
194       (lambda (name)
195         (let* ((class (ccl::lookup-objc-class name nil)))
196           (unless (ccl::objc-class-id  class) (push name missing))))))
197    (when missing
198      (break "ObjC classes ~{~&~a~} are declared but not defined." missing)))
199
200  (ccl::touch bundle-path)
201
202  (let ((image-file (make-pathname :name (ccl::standard-kernel-name) :type nil :version nil
203                                   :defaults (merge-pathnames ";Contents;MacOS;" bundle-path))))
204    (format *error-output* "~2%Saving application to ~a~2%" (truename bundle-path))
205    (force-output *error-output*)
206    (ensure-directories-exist image-file)
207    (save-application image-file
208                      :prepend-kernel t
209                      :application-class 'cocoa-application)))
210
211;;; If we're running as a standalone .app, try to see if a bundle named
212;;; AltConsole.app exists in our Resources directory.  If so, execute
213;;; that bundle'es executable file, with its standard input/output/error
214;;; descriptors connected to one end of a socketpair, and connect
215;;; lisp's *TERMINAL-IO* and C's stdin/stdout/stderr to the other end
216;;; of the socket.
217
218(defun try-connecting-to-altconsole ()
219  (with-autorelease-pool
220      (let* ((main-bundle (#/mainBundle ns:ns-bundle))
221             (resource-path (#/resourcePath main-bundle)))
222        (block exit
223          (when (%null-ptr-p resource-path)
224            (return-from exit nil))
225          (let* ((altconsole-bundle
226                  (make-instance ns:ns-bundle
227                                 :with-path
228                                 (#/stringByAppendingPathComponent:
229                                  resource-path
230                                  #@"AltConsole.app"))))
231            (when (%null-ptr-p altconsole-bundle)
232              (return-from exit nil))
233            (let* ((executable-path (#/executablePath altconsole-bundle)))
234              (when (%null-ptr-p executable-path)
235                (return-from exit nil))
236              (let* ((nbytes (1+ (#/lengthOfBytesUsingEncoding:
237                                  executable-path
238                                  #$NSUTF8StringEncoding))))
239                (%stack-block ((c-executable-path nbytes))
240                  (unless (#/getCString:maxLength:encoding:
241                           executable-path
242                           c-executable-path
243                           nbytes
244                           #$NSUTF8StringEncoding)
245                    (return-from exit nil))
246                  (rletz ((argv (:array :address 2))
247                          (envp (:array :address 1))
248                          (sockets (:array :int 2)))
249                    (setf (paref argv (:array :address) 0) c-executable-path)
250                    (unless (eql 0 (#_socketpair #$AF_UNIX #$SOCK_STREAM 0 sockets))
251                      (return-from exit nil))
252                    (let* ((parent-socket (paref sockets (:array :int) 0))
253                           (child-socket (paref sockets (:array :int) 1))
254                           (pid (#_fork)))
255                      (case pid
256                        (-1
257                         ;; Fork failed
258                         (#_close parent-socket)
259                         (#_close child-socket)
260                         (return-from exit nil))
261                        (0
262                         ;; This runs in the child.
263                         (#_close parent-socket)
264                         (#_dup2 child-socket 0)
265                         (#_dup2 child-socket 1)
266                         (#_dup2 child-socket 2)
267                         (#_execve c-executable-path
268                                   argv
269                                   envp)
270                         ;; If the #_exec fails, there isn't
271                         ;; much to do or say about it.
272                         (#__exit 1))
273                        (t
274                         ;; We're the parent.
275                         (#_close child-socket)
276                         (when (eq t (ccl::check-pid pid))
277                           (flet ((set-lisp-stream-fd (stream fd)
278                                    (setf (ccl::ioblock-device (ccl::stream-ioblock stream t))
279                                          fd)))
280                             (ff-call (ccl::%kernel-import target::kernel-import-open-debug-output)
281                                      :int parent-socket
282                                      :int)
283                             (#_dup2 parent-socket 0)
284                             (set-lisp-stream-fd ccl::*stdin* parent-socket)
285                             (set-lisp-stream-fd ccl::*stdout* parent-socket))
286                           ;; Ensure that output to the stream ccl::*stdout* -
287                           ;; which is connected to fd 1 - is flushed periodically
288                           ;; by the housekeeping task.  (ccl::*stdout* is
289                           ;; typically the output side of the two-way stream
290                           ;; which is the global/static value of *TERMINAL-IO*;
291                           ;; many standard streams are synonym streams to
292                           ;; *TERMINAL-IO*.
293                           (ccl::add-auto-flush-stream ccl::*stdout*)
294                           pid)))))))))))))
295                     
296                   
297             
298;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
299
300
301(start-cocoa-application)
Note: See TracBrowser for help on using the repository browser.