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

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

Remove a stale comment (the init file loads in the initial listener thread.)

When starting up a standalone application, try to start and connect
to "AltConsole?.app", if that application bundle can be found in this
application bundle's Resources subdirectory.

File size: 8.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
66;;; Support for saving a stand-alone IDE
67
68
69(defclass cocoa-application (application)
70  ())
71
72(defmethod ccl::application-error ((a cocoa-application) condition error-pointer)
73  (ccl::break-loop-handle-error condition error-pointer))
74
75
76(defmethod ccl::application-init-file ((a cocoa-application))
77  '("home:ccl-init" "home:\\.ccl-init"))
78
79;;; If we're launched via the Finder, the only argument we'll
80;;; get is of the form -psnXXXXXX.  That's meaningless to us;
81;;; it's easier to pretend that we didn't get any arguments.
82;;; (If it seems like some of this needs to be thought out a
83;;; bit better ... I'd tend to agree.)
84(defmethod ccl::parse-application-arguments ((a cocoa-application))
85  (values nil nil nil nil))
86
87
88(defmethod toplevel-function ((a cocoa-application) init-file)
89  (declare (ignore init-file))
90  (when (< #&NSAppKitVersionNumber 824)
91    (#_NSLog #@"This application requires features introduced in OSX 10.4.")
92    (#_ _exit -1))
93  (setq *standalone-cocoa-ide* t)
94  ;; It's probably reasonable to do this here: it's not really IDE-specific
95  (try-connecting-to-altconsole)
96  ;; TODO: to avoid confusion, should now reset *cocoa-application-path* to
97  ;; actual bundle path where started up.
98  (start-cocoa-application))
99
100
101
102
103(defun build-ide (bundle-path)
104  (setq bundle-path (ensure-directory-pathname bundle-path))
105
106  ;; The bundle is expected to exist, we'll just add the executable into it.
107  (assert (probe-file bundle-path))
108
109  ;; Wait until we're sure that the Cocoa event loop has started.
110  (wait-on-semaphore *cocoa-application-finished-launching*)
111
112  (require :easygui)
113
114  (ccl::maybe-map-objc-classes t)
115  (let* ((missing ()))
116    (ccl::do-interface-dirs (d)
117      (ccl::cdb-enumerate-keys
118       (ccl::db-objc-classes d)
119       (lambda (name)
120         (let* ((class (ccl::lookup-objc-class name nil)))
121           (unless (ccl::objc-class-id  class) (push name missing))))))
122    (when missing
123      (break "ObjC classes ~{~&~a~} are declared but not defined." missing)))
124
125  (ccl::touch bundle-path)
126
127  (let ((image-file (make-pathname :name (ccl::standard-kernel-name) :type nil :version nil
128                                   :defaults (merge-pathnames ";Contents;MacOS;" bundle-path))))
129    (format *error-output* "~2%Saving application to ~a~2%" (truename bundle-path))
130    (force-output *error-output*)
131    (ensure-directories-exist image-file)
132    (save-application image-file
133                      :prepend-kernel t
134                      :application-class 'cocoa-application)))
135
136;;; If we're running as a standalone .app, try to see if a bundle named
137;;; AltConsole.app exists in our PlugIns directory.  If so, execute
138;;; that bundle'es executable file, with its standard input/output/error
139;;; descriptors connected to one end of a socketpair, and connect t
140;;; descriptors 0,1,and 2 to the socket on the other end.
141
142(defun try-connecting-to-altconsole ()
143  (with-autorelease-pool
144      (let* ((main-bundle (#/mainBundle ns:ns-bundle))
145             (resource-path (#/resourcePath main-bundle)))
146        (block exit
147          (when (%null-ptr-p resource-path)
148            (return-from exit nil))
149          (let* ((altconsole-bundle
150                  (make-instance ns:ns-bundle
151                                 :with-path
152                                 (#/stringByAppendingPathComponent:
153                                  resource-path
154                                  #@"AltConsole.app"))))
155            (when (%null-ptr-p altconsole-bundle)
156              (return-from exit nil))
157            (let* ((executable-path (#/executablePath altconsole-bundle)))
158              (when (%null-ptr-p executable-path)
159                (return-from exit nil))
160              (let* ((nbytes (1+ (#/lengthOfBytesUsingEncoding:
161                                  executable-path
162                                  #$NSUTF8StringEncoding))))
163                (%stack-block ((c-executable-path nbytes))
164                  (unless (#/getCString:maxLength:encoding:
165                           executable-path
166                           c-executable-path
167                           nbytes
168                           #$NSUTF8StringEncoding)
169                    (return-from exit nil))
170                  (rletz ((argv (:array :address 2))
171                          (envp (:array :address 1))
172                          (sockets (:array :int 2)))
173                    (setf (paref argv (:array :address) 0) c-executable-path)
174                    (unless (eql 0 (#_socketpair #$AF_UNIX #$SOCK_STREAM 0 sockets))
175                      (return-from exit nil))
176                    (let* ((parent-socket (paref sockets (:array :int) 0))
177                           (child-socket (paref sockets (:array :int) 1))
178                           (pid (#_fork)))
179                      (case pid
180                        (-1
181                         ;; Fork failed
182                         (#_close parent-socket)
183                         (#_close child-socket)
184                         (return-from exit nil))
185                        (0
186                         ;; This runs in the child.
187                         (#_close parent-socket)
188                         (#_dup2 child-socket 0)
189                         (#_dup2 child-socket 1)
190                         (#_dup2 child-socket 2)
191                         (#_execve c-executable-path
192                                   argv
193                                   envp)
194                         ;; If the #_exec fails, there isn't
195                         ;; much to do or say about it.
196                         (#__exit 1))
197                        (t
198                         ;; We're the parent.
199                         (#_close child-socket)
200                         (when (eq t (ccl::check-pid pid))
201                           (#_dup2 parent-socket 0)
202                           (#_dup2 parent-socket 1)
203                           (#_dup2 parent-socket 2)
204                           pid)))))))))))))
205                     
206                   
207             
208;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
209
210
211(start-cocoa-application)
Note: See TracBrowser for help on using the repository browser.