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

Last change on this file since 12183 was 12183, checked in by mikel, 11 years ago

swank load removed
pref UI changed to reflect swank listener instead of swank
swank listener disabled until load-order bugs are resolved

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.