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

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

Cocotron conditionalization.

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