source: release/1.2/source/tools/asdf-install/digitool.lisp @ 9219

Last change on this file since 9219 was 9219, checked in by gb, 11 years ago

synch from trunk

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.4 KB
Line 
1;;; -*- package: asdf-install; -*-
2;;;
3;;; Digitool-specific bootstrapping
4;;;
5;;; 2004-01-18 james.anderson@setf.de additions for MCL
6;;; 2008-01-22 added exit-code checks to call-system
7
8(in-package #:asdf-install)
9
10#+:digitool
11(let ((getenv-fn 0)
12      (setenv-fn 0)
13      (unsetenv-fn 0)
14      (popen-fn 0)
15      (pclose-fn 0)
16      (fread-fn 0)
17      (feof-fn 0))
18  (ccl::with-cfstrs ((framework "System.framework"))
19    (let ((err 0)
20          (baseURL nil)
21          (bundleURL nil)
22          (bundle nil))
23      (ccl::rlet ((folder :fsref))
24        ;; Find the folder holding the bundle
25        (setf err (ccl::require-trap traps::_FSFindFolder
26                                     (ccl::require-trap-constant traps::$kOnAppropriateDisk)
27                                     (ccl::require-trap-constant traps::$kFrameworksFolderType)
28                                     t folder))
29        ;; if everything's cool, make a URL for it
30        (when (zerop err)
31          (setf baseURL (ccl::require-trap traps::_CFURLCreateFromFSRef (ccl::%null-ptr) folder)))
32        (if (ccl::%null-ptr-p baseURL)
33          (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr))))
34      ;; if everything's cool, make a URL for the bundle
35      (when (zerop err)
36        (setf bundleURL (ccl::require-trap traps::_CFURLCreateCopyAppendingPathComponent (ccl::%null-ptr) baseURL framework nil))
37        (if (ccl::%null-ptr-p bundleURL)
38          (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr))))
39      ;; if everything's cool, create it
40      (when (zerop err)
41        (setf bundle (ccl::require-trap traps::_CFBundleCreate (ccl::%null-ptr) bundleURL))
42        (if (ccl::%null-ptr-p bundle)
43          (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr))))
44      ;; if everything's cool, load it
45      (when (zerop err)
46        (if (not (ccl::require-trap traps::_CFBundleLoadExecutable bundle))
47          (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr))))
48      ;; if there's an error, but we've got a pointer, free it and clear result
49      (when (and (not (zerop err)) (not (ccl::%null-ptr-p bundle)))
50        (ccl::require-trap traps::_CFRelease bundle)
51        (setf bundle nil))
52      ;; free the URLs if here non-null
53      (when (not (ccl::%null-ptr-p bundleURL))
54        (ccl::require-trap traps::_CFRelease bundleURL))
55      (when (not (ccl::%null-ptr-p baseURL))
56        (ccl::require-trap traps::_CFRelease baseURL))
57      (cond (bundle
58             ;; extract the necessary function id's
59             (flet ((get-addr (name)
60                      (ccl::with-cfstrs ((c-name name))
61                        (let* ((addr (ccl::require-trap traps::_CFBundleGetFunctionPointerForName bundle c-name)))
62                          (when (ccl::%null-ptr-p addr)
63                            (error "Couldn't resolve address of foreign function ~s" name))
64                          (ccl::rlet ((buf :long))
65                            (setf (ccl::%get-ptr buf) addr)
66                            (ash (ccl::%get-signed-long buf) -2))))))
67               (setf getenv-fn (get-addr "getenv"))
68               (setf setenv-fn (get-addr "setenv"))
69               (setf unsetenv-fn (get-addr "unsetenv"))
70               (setf popen-fn (get-addr "popen"))
71               (setf pclose-fn (get-addr "pclose"))
72               (setf fread-fn (get-addr "fread"))
73               (setf feof-fn (get-addr "feof")))
74             (ccl::require-trap traps::_CFRelease bundle)
75             (setf bundle nil))
76            (t
77             (error "can't resolve core framework entry points.")))))
78 
79  (defun ccl::getenv (variable-name)
80    (ccl::with-cstrs ((c-variable-name variable-name))
81      (let* ((env-ptr (ccl::%null-ptr)))
82        (declare (dynamic-extent env-ptr))
83        (ccl::%setf-macptr env-ptr (ccl::ppc-ff-call getenv-fn
84                                                     :address c-variable-name
85                                                     :address))
86        (unless (ccl::%null-ptr-p env-ptr)
87          (ccl::%get-cstring env-ptr)))))
88
89  (defun ccl::setenv (variable-name variable-value)
90    (ccl::with-cstrs ((c-variable-name variable-name)
91                      (c-variable-value variable-value))
92      (ccl::ppc-ff-call setenv-fn
93                        :address c-variable-name
94                        :address c-variable-value
95                        :signed-fullword 1
96                        :signed-fullword)))
97
98  (defun ccl::unsetenv (variable-name)
99    (ccl::with-cstrs ((c-variable-name variable-name))
100      (ccl::ppc-ff-call unsetenv-fn
101                        :address c-variable-name
102                        :void)))
103 
104  (labels ((fread (fp buffer length)
105             (ccl::ppc-ff-call fread-fn
106                               :address buffer
107                               :unsigned-fullword 1
108                               :unsigned-fullword length
109                               :address fp
110                               :signed-fullword))
111           (feof-p (fp)
112             (not (zerop (ccl::ppc-ff-call feof-fn
113                                           :address fp
114                                           :signed-fullword))))
115           (popen (command)
116             (ccl::with-cstrs  ((read "r")
117                                (cmd command))
118               (ccl::ppc-ff-call popen-fn
119                                 :address cmd
120                                 :address read
121                                 :address)))
122           (pclose (fp)
123             (ccl::ppc-ff-call pclose-fn
124                               :address fp
125                               :signed-fullword))
126           
127           (fread-decoded (fp io-buffer io-buffer-length string-buffer script)
128             (cond ((feof-p fp)
129                    (values nil string-buffer))
130                   (t
131                    (let ((io-count (fread fp io-buffer io-buffer-length)))
132                      (cond ((and io-count (plusp io-count))
133                             (if script
134                               (multiple-value-bind (chars fatp) (ccl::pointer-char-length io-buffer io-count script)
135                                 (cond ((not fatp)
136                                        (ccl::%copy-ptr-to-ivector io-buffer 0 string-buffer 0 io-count))
137                                       (t
138                                        (unless (>= (length string-buffer) chars)
139                                          (setf string-buffer (make-string chars :element-type 'base-character)))
140                                        (ccl::pointer-to-string-in-script io-buffer string-buffer io-count script)
141                                        (setf io-count chars))))
142                               (ccl::%copy-ptr-to-ivector io-buffer 0 string-buffer 0 io-count))
143                             (values io-count string-buffer))
144                            (t
145                             (values 0 string-buffer))))))))
146   
147    (defun ccl::call-system (command)
148      (let* ((script (ccl::default-script nil))
149             (table (ccl::get-char-byte-table script))
150             (result (make-array 128 :element-type 'character :adjustable t :fill-pointer 0))
151             (string-buffer (unless table (make-string 512 :element-type 'base-character)))
152             (io-count 0)
153             (fp (popen command))
154             (exit-code 0))
155        (unless (ccl::%null-ptr-p fp)
156          (unwind-protect
157            (ccl::%stack-block ((io-buffer 512))
158              (loop (multiple-value-setq (io-count string-buffer)
159                      (fread-decoded fp io-buffer 512 string-buffer (when table script)))
160                    (unless io-count (return))
161                    (let ((char #\null))
162                      (dotimes (i io-count)
163                        (case (setf char (schar string-buffer i))
164                          ((#\return #\linefeed) (setf char #\newline)))
165                        (vector-push-extend char result)))))
166            (setf exit-code (pclose fp))
167            (setf fp nil))
168          (if (zerop exit-code)
169            (values result 0)
170            (values nil exit-code result)))))
171   
172    ;; need a function to avoid both the reader macro and the compiler
173    (setf (symbol-function '%new-ptr) #'ccl::%new-ptr) 
174   
175    (defclass popen-input-stream (ccl::input-stream)
176      ((io-buffer :initform nil)
177       (fp :initform nil )
178       (string-buffer :initform nil)
179       (length :initform 0)
180       (index :initform 0)
181       (script :initarg :script :initform (ccl::default-script nil)))
182      (:default-initargs :direction :input))
183   
184    (defmethod initialize-instance :after ((instance popen-input-stream) &key command)
185      (with-slots (io-buffer string-buffer fp script) instance
186        (setf fp (popen command)
187              io-buffer (%new-ptr 512 nil)
188              string-buffer (make-string 512 :element-type 'base-character))
189        (when script (unless (ccl::get-char-byte-table script) (setf script nil)))))
190   
191    (defmethod ccl::stream-close ((stream popen-input-stream))
192      (declare (ignore abort))
193      (with-slots (io-buffer string-buffer fp ccl::direction) stream
194        (when (and fp (not (ccl::%null-ptr-p fp)))
195          (pclose fp)
196          (setf fp nil)
197          (setf ccl::direction :closed)
198          (ccl::disposeptr io-buffer)
199          (setf io-buffer nil))))
200   
201    (defmethod stream-element-type ((stream popen-input-stream))
202      'character)
203   
204    (defmethod ccl::stream-tyi ((stream popen-input-stream))
205      ;; despite the decoding provisions, unix input comes with linefeeds
206      ;; and i don't know what decoding one would need.
207      (with-slots (io-buffer fp string-buffer length index script) stream
208        (when fp
209          (when (>= index length)
210            (multiple-value-setq (length string-buffer)
211              (fread-decoded fp io-buffer 512 string-buffer script))
212            (unless (and length (plusp length))
213              (setf length -1)
214              (return-from ccl::stream-tyi nil))
215            (setf index 0))
216          (let ((char (schar string-buffer index)))
217            (incf index)
218            (case char
219              ((#\return #\linefeed) #\newline)
220              (t char))))))
221   
222    (defmethod ccl::stream-untyi ((stream popen-input-stream) char)
223      (with-slots (string-buffer length index) stream
224        (unless (and (plusp index) (eql char (schar (decf index) string-buffer)))
225          (error "invalid tyi character: ~s." char))
226        char))
227
228    (defmethod ccl::stream-eofp ((stream popen-input-stream))
229      (with-slots (length) stream
230        (minusp length)))))
Note: See TracBrowser for help on using the repository browser.