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

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

In build-ide, don't bother checking whether all the classes in the
interfaces are found in the runtime. Even warning about it is
pointless: of course older systems will be missing certain classes
found in interfaces built from a newer system.

What's the user supposed to do about such a warning, anyway? Install
Mountain Lion? Now if we got referral commissions, that might be
diferent. I can see it now: "Warning! I see that you are running a
version of Mac OS X that does not include the NSPopover class. Don't
you yearn to make popovers pop up over everything? Don't miss out on
notifying the user of matters both mundane and extraordinary with
notifications displayed in Notification Center via the
new-for-Mountain-Lion NSUserNotificationCenter! Go to the Mac App
Store and upgrade to the latest OS X release today!"

See ticket:1047.

File size: 12.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 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  #-cocotron
128  (ccl::touch bundle-path)
129  (let ((kernel-file (make-pathname :name (ccl::standard-kernel-name) 
130                                    :type nil 
131                                    :version nil 
132                                    :defaults (merge-pathnames 
133                                               #+darwin-target
134                                               ";Contents;MacOS;"
135                                               #+cocotron
136                                               ";Contents;Windows;"
137                                               bundle-path))) 
138        (image-file (make-pathname :name (ccl::standard-kernel-name) 
139                                   :type "image" 
140                                   :version nil 
141                                   :defaults (merge-pathnames 
142                                              ";Contents;Resources;ccl;" 
143                                              bundle-path)))) 
144    (format *error-output* "~2%Saving application to ~a~2%" (truename bundle-path))
145    (force-output *error-output*)
146    (ensure-directories-exist image-file)
147    (ccl:copy-file (ccl::kernel-path) kernel-file :if-exists :supersede 
148                   :preserve-attributes t)
149    (save-application image-file
150                      :application-class 'cocoa-ide
151                      #+windows-target #+windows-target
152                      :application-type :gui)))
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 the kernel's dbgout 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          #-windows-target
169          (let* ((altconsole-bundle
170                  (make-instance ns:ns-bundle
171                                 :with-path
172                                 (#/stringByAppendingPathComponent:
173                                  resource-path
174                                  #@"AltConsole.app"))))
175            (when (%null-ptr-p altconsole-bundle)
176              (return-from exit nil))
177            (let* ((executable-path (#/executablePath altconsole-bundle)))
178              (when (%null-ptr-p executable-path)
179                (return-from exit nil))
180              (let* ((nbytes (1+ (#/lengthOfBytesUsingEncoding:
181                                  executable-path
182                                  #$NSUTF8StringEncoding))))
183                (%stack-block ((c-executable-path nbytes))
184                  (unless (#/getCString:maxLength:encoding:
185                           executable-path
186                           c-executable-path
187                           nbytes
188                           #$NSUTF8StringEncoding)
189                    (return-from exit nil))
190                  (rletz ((argv (:array :address 2))
191                          (envp (:array :address 1))
192                          (sockets (:array :int 2)))
193                    (setf (paref argv (:array :address) 0) c-executable-path)
194                    (unless (eql 0 (#_socketpair #$AF_UNIX #$SOCK_STREAM 0 sockets))
195                      (return-from exit nil))
196                    (let* ((parent-socket (paref sockets (:array :int) 0))
197                           (child-socket (paref sockets (:array :int) 1))
198                           (pid (#_fork)))
199                      (case pid
200                        (-1
201                         ;; Fork failed
202                         (#_close parent-socket)
203                         (#_close child-socket)
204                         (return-from exit nil))
205                        (0
206                         ;; This runs in the child.
207                         (#_close parent-socket)
208                         (#_dup2 child-socket 0)
209                         (#_dup2 child-socket 1)
210                         (#_dup2 child-socket 2)
211                         (#_execve c-executable-path
212                                   argv
213                                   envp)
214                         ;; If the #_exec fails, there isn't
215                         ;; much to do or say about it.
216                         (#__exit 1))
217                        (t
218                         ;; We're the parent.
219                         (#_close child-socket)
220                         (when (eq t (ccl::check-pid pid))
221                           (flet ((set-lisp-stream-fd (stream fd)
222                                    (setf (ccl::ioblock-device (ccl::stream-ioblock stream t))
223                                          fd)))
224                             (ff-call (ccl::%kernel-import target::kernel-import-open-debug-output)
225                                      :int parent-socket
226                                      :int)
227                             (#_dup2 parent-socket 0)
228                             (set-lisp-stream-fd ccl::*stdin* parent-socket)
229                             (set-lisp-stream-fd ccl::*stdout* parent-socket))
230                           ;; Ensure that output to the stream ccl::*stdout* -
231                           ;; which is connected to fd 1 - is flushed periodically
232                           ;; by the housekeeping task.  (ccl::*stdout* is
233                           ;; typically the output side of the two-way stream
234                           ;; which is the global/static value of *TERMINAL-IO*;
235                           ;; many standard streams are synonym streams to
236                           ;; *TERMINAL-IO*.
237                           (ccl::add-auto-flush-stream ccl::*stdout*)
238                           pid)))))))))
239          #+windows-target
240          (let* ((executable-path (#/stringByAppendingPathComponent:
241                                  resource-path
242                                  #@"WaltConsole.exe")))
243            (unless (#/isExecutableFileAtPath:
244                     (#/defaultManager ns:ns-file-manager)
245                     executable-path)
246              (return-from exit nil))
247            (multiple-value-bind (child-in parent-out) (ccl::pipe)
248              (multiple-value-bind (parent-in child-out) (ccl::pipe)
249                (cond ((ccl::create-windows-process child-in child-out child-out (lisp-string-from-nsstring executable-path) nil)
250                       (#_CloseHandle (ccl::%int-to-ptr child-in))
251                       (#_CloseHandle (ccl::%int-to-ptr child-out))
252                       (let* ((in-fd (#__open_osfhandle parent-in #$_O_RDONLY))
253                              (out-fd (#__open_osfhandle parent-out 0)))
254                         (#_SetStdHandle #$STD_INPUT_HANDLE (%int-to-ptr parent-in))
255                         (#__dup2 in-fd 0) ; Thank god the namespace isn't polluted.
256                         (ff-call (ccl::%kernel-import target::kernel-import-open-debug-output)
257                                  :int out-fd
258                                  :int)                         
259                         (flet ((set-lisp-stream-handle (stream handle)
260                                    (setf (ccl::ioblock-device (ccl::stream-ioblock stream t))
261                                          handle)))
262                           (set-lisp-stream-handle ccl::*stdin* parent-in)
263                           (set-lisp-stream-handle ccl::*stdout* parent-out)
264                           (ccl::add-auto-flush-stream ccl::*stdout*)
265                           t)))))))))))
266                     
267                   
268             
269;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
270
271
272;;(start-cocoa-ide)
Note: See TracBrowser for help on using the repository browser.