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

Last change on this file since 12266 was 12266, checked in by rme, 11 years ago

fix typo in break options message

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