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

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

added a bunch of the server-side request-handling code for the swank-listener.

switched the swank loader back on (but made sure swank isn't loaded unless the user default says it should be)

File size: 12.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(defmethod ccl::ui-object-do-operation ((o ns:ns-application) (operation (eql :break-options-string)) &rest args)
66  (unless (typep ccl::*current-process* 'appkit-process)
67    (destructuring-bind (continuablep) args
68      (if continuablep
69        "~&> Type cmd-/ to continue, cmd-/ to abort, cmd-\\ for a list of available restarts."
70        "~&> Type cmd-. to abort, cmd-\\ for a list of available restarts.~%"))))
71
72;;; Support for saving a stand-alone IDE
73
74
75(defclass cocoa-application (application)
76  ())
77
78(defmethod ccl::application-error ((a cocoa-application) condition error-pointer)
79  (ccl::break-loop-handle-error condition error-pointer))
80
81
82(defmethod ccl::application-init-file ((a cocoa-application))
83  '("home:ccl-init" "home:\\.ccl-init"))
84
85;;; If we're launched via the Finder, the only argument we'll
86;;; get is of the form -psnXXXXXX.  That's meaningless to us;
87;;; it's easier to pretend that we didn't get any arguments.
88;;; (If it seems like some of this needs to be thought out a
89;;; bit better ... I'd tend to agree.)
90(defmethod ccl::parse-application-arguments ((a cocoa-application))
91  (values nil nil nil nil))
92
93;;; preference-start-swank? 
94;;; returns the current value of the "Start swank server?" user
95;;; preference
96(defun preference-start-swank? ()
97  (let* ((defaults (handler-case (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))
98                     (serious-condition (c) 
99                       (progn (log-debug "~%ERROR: Unable to get preferences from the Shared User Defaults Controller")
100                              nil))))
101         (start-swank-pref (if (and defaults (not (%null-ptr-p defaults))) 
102                               (#/valueForKey: defaults #@"startSwankServer")         
103                               nil)))
104    (cond
105      ;; the user default is not initialized
106      ((or (null start-swank-pref)
107           (%null-ptr-p start-swank-pref)) nil)
108      ;; examine the user default
109      ;; intValue works on NSNumber or NSString
110      ;; BUG? if a string value is not a valid representation of an integer,
111      ;;      intValue returns 0, which means any non-numeric string will have the
112      ;;      same effect as "0"
113      ((or (typep start-swank-pref 'ns:ns-number)
114           (typep start-swank-pref 'ns:ns-string))
115       (case (#/intValue start-swank-pref)
116         ;; don't start swank
117         (0 nil)
118         ;; start swank
119         (1 t)
120         ;; the user default value is incomprehensible
121         (otherwise (progn
122                      (log-debug "~%ERROR: Unrecognized value in user preference 'startSwankServer': ~S"
123                                 start-swank-pref)
124                      nil))))
125      ;; the user default value is incomprehensible
126      (t (progn
127           (log-debug "~%ERROR: Unrecognized value type in user preference 'startSwankServer': ~S"
128                      start-swank-pref)
129           nil)))))
130
131(defmethod toplevel-function ((a cocoa-application) init-file)
132  (declare (ignore init-file))
133  (when (< #&NSAppKitVersionNumber 824)
134    (#_NSLog #@"This application requires features introduced in OSX 10.4.")
135    (#_ _exit -1))
136  (setq *standalone-cocoa-ide* t)
137  (when (preference-start-swank?)
138        (require :swank)
139        (try-starting-swank))
140  (with-slots  (have-interactive-terminal-io) ccl::*current-process*
141    (when (and (eql (nth-value 4 (ccl::%stat "/dev/null"))
142                    (nth-value 4 (ccl::%fstat 0)))
143             ;; Should compare st_dev, too
144             )
145      (setq have-interactive-terminal-io nil)
146     
147      ;; It's probably reasonable to do this here: it's not really IDE-specific
148      (when (try-connecting-to-altconsole)
149        (setq have-interactive-terminal-io t)))
150    ;; TODO: to avoid confusion, should now reset *cocoa-application-path* to
151    ;; actual bundle path where started up.
152    (start-cocoa-application)))
153
154
155
156
157  (Defun build-ide (bundle-path)
158    (setq bundle-path (ensure-directory-pathname bundle-path))
159
160    ;; The bundle is expected to exist, we'll just add the executable into it.
161    (assert (probe-file bundle-path))
162
163    ;; Wait until we're sure that the Cocoa event loop has started.
164    (wait-on-semaphore *cocoa-application-finished-launching*)
165
166    (require :easygui)
167
168    (ccl::maybe-map-objc-classes t)
169    (let* ((missing ()))
170      (ccl::do-interface-dirs (d)
171        (ccl::cdb-enumerate-keys
172         (ccl::db-objc-classes d)
173         (lambda (name)
174           (let* ((class (ccl::lookup-objc-class name nil)))
175             (unless (ccl::objc-class-id  class) (push name missing))))))
176      (when missing
177        (break "ObjC classes ~{~&~a~} are declared but not defined." missing)))
178
179    (ccl::touch bundle-path)
180
181    (let ((image-file (make-pathname :name (ccl::standard-kernel-name) :type nil :version nil
182                                     :defaults (merge-pathnames ";Contents;MacOS;" bundle-path))))
183      (format *error-output* "~2%Saving application to ~a~2%" (truename bundle-path))
184      (force-output *error-output*)
185      (ensure-directories-exist image-file)
186      (save-application image-file
187                        :prepend-kernel t
188                        :application-class 'cocoa-application)))
189
190;;; If we're running as a standalone .app, try to see if a bundle named
191;;; AltConsole.app exists in our Resources directory.  If so, execute
192;;; that bundle'es executable file, with its standard input/output/error
193;;; descriptors connected to one end of a socketpair, and connect
194;;; lisp's *TERMINAL-IO* and C's stdin/stdout/stderr to the other end
195;;; of the socket.
196
197(defun try-connecting-to-altconsole ()
198  (with-autorelease-pool
199      (let* ((main-bundle (#/mainBundle ns:ns-bundle))
200             (resource-path (#/resourcePath main-bundle)))
201        (block exit
202          (when (%null-ptr-p resource-path)
203            (return-from exit nil))
204          (let* ((altconsole-bundle
205                  (make-instance ns:ns-bundle
206                                 :with-path
207                                 (#/stringByAppendingPathComponent:
208                                  resource-path
209                                  #@"AltConsole.app"))))
210            (when (%null-ptr-p altconsole-bundle)
211              (return-from exit nil))
212            (let* ((executable-path (#/executablePath altconsole-bundle)))
213              (when (%null-ptr-p executable-path)
214                (return-from exit nil))
215              (let* ((nbytes (1+ (#/lengthOfBytesUsingEncoding:
216                                  executable-path
217                                  #$NSUTF8StringEncoding))))
218                (%stack-block ((c-executable-path nbytes))
219                  (unless (#/getCString:maxLength:encoding:
220                           executable-path
221                           c-executable-path
222                           nbytes
223                           #$NSUTF8StringEncoding)
224                    (return-from exit nil))
225                  (rletz ((argv (:array :address 2))
226                          (envp (:array :address 1))
227                          (sockets (:array :int 2)))
228                    (setf (paref argv (:array :address) 0) c-executable-path)
229                    (unless (eql 0 (#_socketpair #$AF_UNIX #$SOCK_STREAM 0 sockets))
230                      (return-from exit nil))
231                    (let* ((parent-socket (paref sockets (:array :int) 0))
232                           (child-socket (paref sockets (:array :int) 1))
233                           (pid (#_fork)))
234                      (case pid
235                        (-1
236                         ;; Fork failed
237                         (#_close parent-socket)
238                         (#_close child-socket)
239                         (return-from exit nil))
240                        (0
241                         ;; This runs in the child.
242                         (#_close parent-socket)
243                         (#_dup2 child-socket 0)
244                         (#_dup2 child-socket 1)
245                         (#_dup2 child-socket 2)
246                         (#_execve c-executable-path
247                                   argv
248                                   envp)
249                         ;; If the #_exec fails, there isn't
250                         ;; much to do or say about it.
251                         (#__exit 1))
252                        (t
253                         ;; We're the parent.
254                         (#_close child-socket)
255                         (when (eq t (ccl::check-pid pid))
256                           (flet ((set-lisp-stream-fd (stream fd)
257                                    (setf (ccl::ioblock-device (ccl::stream-ioblock stream t))
258                                          fd)))
259                             (ff-call (ccl::%kernel-import target::kernel-import-open-debug-output)
260                                      :int parent-socket
261                                      :int)
262                             (#_dup2 parent-socket 0)
263                             (set-lisp-stream-fd ccl::*stdin* parent-socket)
264                             (set-lisp-stream-fd ccl::*stdout* parent-socket))
265                           ;; Ensure that output to the stream ccl::*stdout* -
266                           ;; which is connected to fd 1 - is flushed periodically
267                           ;; by the housekeeping task.  (ccl::*stdout* is
268                           ;; typically the output side of the two-way stream
269                           ;; which is the global/static value of *TERMINAL-IO*;
270                           ;; many standard streams are synonym streams to
271                           ;; *TERMINAL-IO*.
272                           (ccl::add-auto-flush-stream ccl::*stdout*)
273                           pid)))))))))))))
274                     
275                   
276             
277;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
278
279
280(start-cocoa-application)
Note: See TracBrowser for help on using the repository browser.