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

Last change on this file since 15567 was 15567, checked in by rme, 8 years ago

In build-ide, just warn about classes found in the interfaces that
aren't found by the runtime. (This situation will occur on pre-10.8
systems.) This will probably cause user confusion, but at least
(require 'cocoa-application) will work without having to continue from
the break manually.

See ticket:1047.

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