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

Last change on this file since 12641 was 12641, checked in by gb, 12 years ago

Conditionalize for Cocotron: get the platform-specific bundle
subdirectory right, don't try to load EasyGUI for now (contains
some Mac-specific code that needs to be conditionalized), don't
try to call CCL::TOUCH on directories (not necessary in Cocotron,
and doesn't seem to work in Windows ...)

File size: 10.9 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    #-cocotron                          ;needs conditionalization
132    (require :easygui)
133
134    (ccl::maybe-map-objc-classes t)
135    (let* ((missing ()))
136      (ccl::do-interface-dirs (d)
137        (ccl::cdb-enumerate-keys
138         (ccl::db-objc-classes d)
139         (lambda (name)
140           (let* ((class (ccl::lookup-objc-class name nil)))
141             (unless (ccl::objc-class-id  class) (push name missing))))))
142      (when missing
143        (break "ObjC classes ~{~&~a~} are declared but not defined." missing)))
144
145    #-cocotron
146    (ccl::touch bundle-path)
147
148    (let ((image-file (make-pathname :name (ccl::standard-kernel-name) :type nil :version nil
149                                     :defaults (merge-pathnames (format nil";Contents;~a;" #+darwin-target "MacOS" #+cocotron "Windows")  bundle-path))))
150      (format *error-output* "~2%Saving application to ~a~2%" (truename bundle-path))
151      (force-output *error-output*)
152      (ensure-directories-exist image-file)
153      (save-application image-file
154                        :prepend-kernel t
155                        :application-class 'cocoa-application)))
156
157;;; If we're running as a standalone .app, try to see if a bundle named
158;;; AltConsole.app exists in our Resources directory.  If so, execute
159;;; that bundle'es executable file, with its standard input/output/error
160;;; descriptors connected to one end of a socketpair, and connect
161;;; lisp's *TERMINAL-IO* and C's stdin/stdout/stderr to the other end
162;;; of the socket.
163
164(defun try-connecting-to-altconsole ()
165  #-cocotron
166  (with-autorelease-pool
167      (let* ((main-bundle (#/mainBundle ns:ns-bundle))
168             (resource-path (#/resourcePath main-bundle)))
169        (block exit
170          (when (%null-ptr-p resource-path)
171            (return-from exit nil))
172          (let* ((altconsole-bundle
173                  (make-instance ns:ns-bundle
174                                 :with-path
175                                 (#/stringByAppendingPathComponent:
176                                  resource-path
177                                  #@"AltConsole.app"))))
178            (when (%null-ptr-p altconsole-bundle)
179              (return-from exit nil))
180            (let* ((executable-path (#/executablePath altconsole-bundle)))
181              (when (%null-ptr-p executable-path)
182                (return-from exit nil))
183              (let* ((nbytes (1+ (#/lengthOfBytesUsingEncoding:
184                                  executable-path
185                                  #$NSUTF8StringEncoding))))
186                (%stack-block ((c-executable-path nbytes))
187                  (unless (#/getCString:maxLength:encoding:
188                           executable-path
189                           c-executable-path
190                           nbytes
191                           #$NSUTF8StringEncoding)
192                    (return-from exit nil))
193                  (rletz ((argv (:array :address 2))
194                          (envp (:array :address 1))
195                          (sockets (:array :int 2)))
196                    (setf (paref argv (:array :address) 0) c-executable-path)
197                    (unless (eql 0 (#_socketpair #$AF_UNIX #$SOCK_STREAM 0 sockets))
198                      (return-from exit nil))
199                    (let* ((parent-socket (paref sockets (:array :int) 0))
200                           (child-socket (paref sockets (:array :int) 1))
201                           (pid (#_fork)))
202                      (case pid
203                        (-1
204                         ;; Fork failed
205                         (#_close parent-socket)
206                         (#_close child-socket)
207                         (return-from exit nil))
208                        (0
209                         ;; This runs in the child.
210                         (#_close parent-socket)
211                         (#_dup2 child-socket 0)
212                         (#_dup2 child-socket 1)
213                         (#_dup2 child-socket 2)
214                         (#_execve c-executable-path
215                                   argv
216                                   envp)
217                         ;; If the #_exec fails, there isn't
218                         ;; much to do or say about it.
219                         (#__exit 1))
220                        (t
221                         ;; We're the parent.
222                         (#_close child-socket)
223                         (when (eq t (ccl::check-pid pid))
224                           (flet ((set-lisp-stream-fd (stream fd)
225                                    (setf (ccl::ioblock-device (ccl::stream-ioblock stream t))
226                                          fd)))
227                             (ff-call (ccl::%kernel-import target::kernel-import-open-debug-output)
228                                      :int parent-socket
229                                      :int)
230                             (#_dup2 parent-socket 0)
231                             (set-lisp-stream-fd ccl::*stdin* parent-socket)
232                             (set-lisp-stream-fd ccl::*stdout* parent-socket))
233                           ;; Ensure that output to the stream ccl::*stdout* -
234                           ;; which is connected to fd 1 - is flushed periodically
235                           ;; by the housekeeping task.  (ccl::*stdout* is
236                           ;; typically the output side of the two-way stream
237                           ;; which is the global/static value of *TERMINAL-IO*;
238                           ;; many standard streams are synonym streams to
239                           ;; *TERMINAL-IO*.
240                           (ccl::add-auto-flush-stream ccl::*stdout*)
241                           pid)))))))))))))
242                     
243                   
244             
245;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
246
247
248(start-cocoa-application)
Note: See TracBrowser for help on using the repository browser.