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

Last change on this file since 12141 was 12141, checked in by gb, 11 years ago

Don't return GUI-ish break options string if we're on the AppKit? thread.
(Probably should have some other way to determine whether or not they're
appropriate.)

DON'T REQUIRE SWANK. Aside from other reasons for not wanting to do this,
doing so seems to clobber one or more of *TERMINAL-IO* or *STANDARD-OUTPUT*
in the initial thread. (Feel free to change this back if this doesn't affect
you or if you need to be able to load swank early; it did affect me, and
we should spend more time than I did trying to understand and fix the
clobbering.)

If we're running standalone, assume that we don't have interactive terminal
io, unless fd 0 is attached to something other than /dev/null. If we can
connect to AltConsole?, then that's a (primitive) kind of interactive terminal
i/o device (as may be swank or similar things someday.)

Note that if/when establishing a swank connection provides a stream that
the appkit thread can interact with, we may want to reset that thread so
that appropriate error handling behavior is used.

File size: 10.7 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#+no
94(eval-when (:compile-toplevel :load-toplevel :execute)
95    (require :swank))
96
97(defmethod toplevel-function ((a cocoa-application) init-file)
98  (declare (ignore init-file))
99  (when (< #&NSAppKitVersionNumber 824)
100    (#_NSLog #@"This application requires features introduced in OSX 10.4.")
101    (#_ _exit -1))
102  (setq *standalone-cocoa-ide* t)
103  (with-slots  (have-interactive-terminal-io) ccl::*current-process*
104    (when (and (eql (nth-value 4 (ccl::%stat "/dev/null"))
105                    (nth-value 4 (ccl::%fstat 0)))
106             ;; Should compare st_dev, too
107             )
108      (setq have-interactive-terminal-io nil)
109      ;; It's probably reasonable to do this here: it's not really IDE-specific
110      #+no
111      (try-starting-swank)
112      (when (try-connecting-to-altconsole)
113        (setq have-interactive-terminal-io t)))
114    ;; TODO: to avoid confusion, should now reset *cocoa-application-path* to
115    ;; actual bundle path where started up.
116    (start-cocoa-application)))
117
118
119
120
121  (defun build-ide (bundle-path)
122    (setq bundle-path (ensure-directory-pathname bundle-path))
123
124    ;; The bundle is expected to exist, we'll just add the executable into it.
125    (assert (probe-file bundle-path))
126
127    ;; Wait until we're sure that the Cocoa event loop has started.
128    (wait-on-semaphore *cocoa-application-finished-launching*)
129
130    (require :easygui)
131
132    (ccl::maybe-map-objc-classes t)
133    (let* ((missing ()))
134      (ccl::do-interface-dirs (d)
135        (ccl::cdb-enumerate-keys
136         (ccl::db-objc-classes d)
137         (lambda (name)
138           (let* ((class (ccl::lookup-objc-class name nil)))
139             (unless (ccl::objc-class-id  class) (push name missing))))))
140      (when missing
141        (break "ObjC classes ~{~&~a~} are declared but not defined." missing)))
142
143    (ccl::touch bundle-path)
144
145    (let ((image-file (make-pathname :name (ccl::standard-kernel-name) :type nil :version nil
146                                     :defaults (merge-pathnames ";Contents;MacOS;" bundle-path))))
147      (format *error-output* "~2%Saving application to ~a~2%" (truename bundle-path))
148      (force-output *error-output*)
149      (ensure-directories-exist image-file)
150      (save-application image-file
151                        :prepend-kernel t
152                        :application-class 'cocoa-application)))
153
154;;; If we're running as a standalone .app, try to see if a bundle named
155;;; AltConsole.app exists in our Resources directory.  If so, execute
156;;; that bundle'es executable file, with its standard input/output/error
157;;; descriptors connected to one end of a socketpair, and connect
158;;; lisp's *TERMINAL-IO* and C's stdin/stdout/stderr to the other end
159;;; of the socket.
160
161(defun try-connecting-to-altconsole ()
162  (with-autorelease-pool
163      (let* ((main-bundle (#/mainBundle ns:ns-bundle))
164             (resource-path (#/resourcePath main-bundle)))
165        (block exit
166          (when (%null-ptr-p resource-path)
167            (return-from exit nil))
168          (let* ((altconsole-bundle
169                  (make-instance ns:ns-bundle
170                                 :with-path
171                                 (#/stringByAppendingPathComponent:
172                                  resource-path
173                                  #@"AltConsole.app"))))
174            (when (%null-ptr-p altconsole-bundle)
175              (return-from exit nil))
176            (let* ((executable-path (#/executablePath altconsole-bundle)))
177              (when (%null-ptr-p executable-path)
178                (return-from exit nil))
179              (let* ((nbytes (1+ (#/lengthOfBytesUsingEncoding:
180                                  executable-path
181                                  #$NSUTF8StringEncoding))))
182                (%stack-block ((c-executable-path nbytes))
183                  (unless (#/getCString:maxLength:encoding:
184                           executable-path
185                           c-executable-path
186                           nbytes
187                           #$NSUTF8StringEncoding)
188                    (return-from exit nil))
189                  (rletz ((argv (:array :address 2))
190                          (envp (:array :address 1))
191                          (sockets (:array :int 2)))
192                    (setf (paref argv (:array :address) 0) c-executable-path)
193                    (unless (eql 0 (#_socketpair #$AF_UNIX #$SOCK_STREAM 0 sockets))
194                      (return-from exit nil))
195                    (let* ((parent-socket (paref sockets (:array :int) 0))
196                           (child-socket (paref sockets (:array :int) 1))
197                           (pid (#_fork)))
198                      (case pid
199                        (-1
200                         ;; Fork failed
201                         (#_close parent-socket)
202                         (#_close child-socket)
203                         (return-from exit nil))
204                        (0
205                         ;; This runs in the child.
206                         (#_close parent-socket)
207                         (#_dup2 child-socket 0)
208                         (#_dup2 child-socket 1)
209                         (#_dup2 child-socket 2)
210                         (#_execve c-executable-path
211                                   argv
212                                   envp)
213                         ;; If the #_exec fails, there isn't
214                         ;; much to do or say about it.
215                         (#__exit 1))
216                        (t
217                         ;; We're the parent.
218                         (#_close child-socket)
219                         (when (eq t (ccl::check-pid pid))
220                           (flet ((set-lisp-stream-fd (stream fd)
221                                    (setf (ccl::ioblock-device (ccl::stream-ioblock stream t))
222                                          fd)))
223                             (ff-call (ccl::%kernel-import target::kernel-import-open-debug-output)
224                                      :int parent-socket
225                                      :int)
226                             (#_dup2 parent-socket 0)
227                             (set-lisp-stream-fd ccl::*stdin* parent-socket)
228                             (set-lisp-stream-fd ccl::*stdout* parent-socket))
229                           ;; Ensure that output to the stream ccl::*stdout* -
230                           ;; which is connected to fd 1 - is flushed periodically
231                           ;; by the housekeeping task.  (ccl::*stdout* is
232                           ;; typically the output side of the two-way stream
233                           ;; which is the global/static value of *TERMINAL-IO*;
234                           ;; many standard streams are synonym streams to
235                           ;; *TERMINAL-IO*.
236                           (ccl::add-auto-flush-stream ccl::*stdout*)
237                           pid)))))))))))))
238                     
239                   
240             
241;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
242
243
244(start-cocoa-application)
Note: See TracBrowser for help on using the repository browser.