Newer
Older
(call-next-method)))
;;;; -----------------------------------------------------------------
;;;; Windows shortcut support. Based on:
;;;;
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
;;;; -----------------------------------------------------------------
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
(defun read-null-terminated-string (s)
(with-output-to-string (out)
(loop
for code = (read-byte s)
until (zerop code)
do (write-char (code-char code) out))))
(defun read-little-endian (s &optional (bytes 4))
(let ((result 0))
(loop
for i from 0 below bytes
do
(setf result (logior result (ash (read-byte s) (* 8 i)))))
(defun parse-file-location-info (s)
(let ((start (file-position s))
(total-length (read-little-endian s))
(end-of-header (read-little-endian s))
(fli-flags (read-little-endian s))
(local-volume-offset (read-little-endian s))
(local-offset (read-little-endian s))
(network-volume-offset (read-little-endian s))
(remaining-offset (read-little-endian s)))
(declare (ignore total-length end-of-header local-volume-offset))
(unless (zerop fli-flags)
(cond
((logbitp 0 fli-flags)
(file-position s (+ start local-offset)))
((logbitp 1 fli-flags)
(file-position s (+ start
network-volume-offset
#x14))))
(concatenate 'string
(read-null-terminated-string s)
(progn
(file-position s (+ start remaining-offset))
(read-null-terminated-string s))))))
(defun parse-windows-shortcut (pathname)
(with-open-file (s pathname :element-type '(unsigned-byte 8))
(handler-case
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
(when (and (= (read-little-endian s) *link-initial-dword*)
(let ((header (make-array (length *link-guid*))))
(read-sequence header s)
(equalp header *link-guid*)))
(let ((flags (read-little-endian s)))
(file-position s 76) ;skip rest of header
(when (logbitp 0 flags)
;; skip shell item id list
(let ((length (read-little-endian s 2)))
(file-position s (+ length (file-position s)))))
(cond
((logbitp 1 flags)
(parse-file-location-info s))
(t
(when (logbitp 2 flags)
;; skip description string
(let ((length (read-little-endian s 2)))
(file-position s (+ length (file-position s)))))
(when (logbitp 3 flags)
;; finally, our pathname
(let* ((length (read-little-endian s 2))
(buffer (make-array length)))
(read-sequence buffer s)
(map 'string #'code-char buffer)))))))
Francois-Rene Rideau
committed
;;;; -----------------------------------------------------------------
;;;; SBCL hook into REQUIRE
;;;;
#+sbcl
(progn
(defun module-provide-asdf (name)

Daniel Barlow
committed
(handler-bind ((style-warning #'muffle-warning))
(let* ((*verbose-out* (make-broadcast-stream))
(system (asdf:find-system name nil)))
(when system
(asdf:operate 'asdf:load-op name)
t))))
(defun contrib-sysdef-search (system)
Francois-Rene Rideau
committed
(let ((home (getenv "SBCL_HOME")))
(let* ((name (coerce-name system))
(home (truename home))
(contrib (merge-pathnames
(make-pathname :directory `(:relative ,name)
:name name
:type "asd"
:case :local
:version :newest)
home)))
(probe-file contrib)))))
Francois-Rene Rideau
committed
'(let ((home (getenv "SBCL_HOME")))
(merge-pathnames "site-systems/" (truename home))))

Daniel Barlow
committed
'(merge-pathnames ".sbcl/systems/"
(user-homedir-pathname))
(pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
(pushnew 'contrib-sysdef-search *system-definition-search-functions*))
Francois-Rene Rideau
committed
;;;; -----------------------------------------------------------------
;;;; TODO: Read Configuration.
;;;; See https://bugs.launchpad.net/asdf/+bug/485918
Francois-Rene Rideau
committed
;;;; TODO: add protocols for re-searching a loaded system in the registry,
;;;; for invalidating registry entries, etc.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
(pushnew 'sysdef-source-registry-search *system-definition-search-functions*)
;; Using ack 1.2 exclusions
(defvar *default-exclusions*
'(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
"_sgbak" "autom4te.cache" "cover_db" "_build"))
(defun default-registry ()
())
(defvar *source-registry* ())
(defun source-registry ()
(car *source-registry*))
(defun (setf source-registry) (x)
(setf *source-registry* (list x)))
(defun source-registry-initialized-p ()
(and *source-registry* t))
(defun clear-source-registry ()
"Undoes any initialization of the source registry.
You might want to call that before you dump an image that would be resumed
with a different configuration, so the configuration would be re-read then."
;; TODO: in the future, have a hook that clients will use to clear any cache
;; that depends on this configuration.
(setf *source-registry* '())
(values))
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
(defun sysdef-source-registry-search (system)
(ensure-source-registry)
(let ((name (coerce-name system)))
(block nil
(dolist (dir (source-registry))
(let ((defaults (eval dir)))
(when defaults
(cond ((directory-pathname-p defaults)
(let ((file (and defaults
(make-pathname
:defaults defaults :version :newest
:name name :type "asd" :case :local)))
#+(and (or win32 windows) (not :clisp))
(shortcut (make-pathname
:defaults defaults :version :newest
:name name :type "asd.lnk" :case :local)))
(when (and file (probe-file file))
(return file))
#+(and (or win32 windows) (not :clisp))
(when (probe-file shortcut)
(let ((target (parse-windows-shortcut shortcut)))
(when target
(return (pathname target))))))))))))))
Francois-Rene Rideau
committed
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
(defun read-file-forms (file)
(with-open-file (in file)
(loop :with eof = (list nil)
:for form = (read in nil eof)
:until (eq form eof)
:collect form)))
(defun validate-source-registry-directive (directive)
(or
(destructuring-bind (kw &rest rest) directive
(case kw
((:include :directory :tree)
(and (length=n-p rest 1)
(typep (car rest) '(or pathname string))))
((:exclude)
(every #'stringp rest))
((:default-registry :inherit-configuration :ignore-inherited-configuration)
(null rest))))
(error "Invalid directive ~S~%" directive)))
(defun validate-source-registry-form (form)
(unless (and (consp form) (eq (car form) :source-registry))
(error "Error: Form is not a source registry ~S~%" form))
(loop :with inherit = 0
:for directive :in (cdr form) :do
(unless (consp directive)
(error "invalid directive ~S" directive))
(when (member (car directive)
'(:inherit-configuration :ignore-inherited-configuration))
(incf inherit))
(validate-source-registry-directive directive)
:finally
(unless (= inherit 1)
(error "One and only one of :inherit-configuration or :ignore-inherited-configuration is required")))
form)
(defun validate-source-registry-file (file)
(let ((forms (read-file-forms file)))
(unless (length=n-p forms 1)
(error "Only and only one form allowed for source registry. Got: ~S~%" forms))
(validate-source-registry-form (car forms))))
(defun parse-source-registry-string (string)
(cond
((or (null string) (equal string ""))
Francois-Rene Rideau
committed
'(:source-registry :inherit-configuration))
((not (stringp string))
(error "environment string isn't: ~S" string))
((eql (char string 0) #\()
(validate-source-registry-form (read-from-string string)))
(t
Francois-Rene Rideau
committed
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
:with inherit = nil
:with directives = ()
:with start = 0
:with end = (length string)
:for i = (or (position #\: string :start start) end) :do
(let ((s (subseq string start i)))
(cond
((equal "" s) ; empty element
nil)
((equal "!" s) ; inherit
(when inherit
(error "only one inherited configuration allowed: ~S" string))
(setf inherit t)
(push '(:inherit-configuration) directives))
((ends-with s "//")
(push `(:tree ,(subseq s 0 (1- (length s)))) directives))
(t
(push `(:directory ,s) directives)))
(setf start (1+ i))
(when (>= start end)
(unless inherit
(push '(:ignore-inherited-configuration) directives))
(return `(:source-registry ,(nreverse directives)))))))))
(defun collect-asd-subdirectories (directory &key (exclude *default-exclusions*) collect)
(let* ((files (directory (merge-pathnames #P"**/*.asd" directory)
#+sbcl #+sbcl :resolve-symlinks nil
#+clisp #+clisp :circle t))
Francois-Rene Rideau
committed
(dirs (remove-duplicates (mapcar #'pathname-sans-name+type files) :test #'equal)))
(loop
:for dir :in dirs
Francois-Rene Rideau
committed
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
:unless (loop :for x :in exclude
:thereis (find x (pathname-directory dir) :test #'equal))
:do (funcall collect dir))))
(defparameter *default-source-registries*
'(process-environment-source-registry
process-user-source-registry
process-system-source-registry
process-default-source-registry))
(defun source-registry-under (directory)
(merge-pathnames "common-lisp/source-registry.conf" directory))
(defun user-source-registry-pathname ()
(source-registry-under (merge-pathnames ".config/" (user-homedir-pathname))))
(defun system-source-registry-pathname ()
(source-registry-under "/etc/"))
(defun process-environment-source-registry (&key inherit collect)
(process-source-registry (getenv "CL_SOURCE_REGISTRY")
:inherit inherit :collect collect))
(defun process-user-source-registry (&key inherit collect)
(process-source-registry (user-source-registry-pathname)
:inherit inherit :collect collect))
(defun process-system-source-registry (&key inherit collect)
(process-source-registry (system-source-registry-pathname)
:inherit inherit :collect collect))
(defun process-default-source-registry (&key inherit collect)
(declare (ignore inherit collect))
nil)
Francois-Rene Rideau
committed
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
(defgeneric process-source-registry (spec &key inherit collect))
(defmethod process-source-registry ((pathname pathname) &key inherit collect)
(if (probe-file pathname)
(process-source-registry (validate-source-registry-file pathname)
:inherit inherit :collect collect)
(inherit-source-registry inherit :collect collect)))
(defmethod process-source-registry ((string string) &key inherit collect)
(process-source-registry (parse-source-registry-string string)
:inherit inherit :collect collect))
(defmethod process-source-registry ((x null) &key inherit collect)
(inherit-source-registry inherit :collect collect))
(defun make-collector ()
(let ((acc ()))
(values (lambda (x) (push x acc))
(lambda () (reverse acc)))))
(defmethod process-source-registry ((form cons) &key inherit collect)
(multiple-value-bind (collect result)
(if collect
(values collect (constantly nil))
(make-collector))
(let ((*default-exclusions* *default-exclusions*))
(dolist (directive (cdr (validate-source-registry-form form)))
(process-source-registry-directive directive :inherit inherit :collect collect)))
(funcall result)))
(defun inherit-source-registry (inherit &key collect)
(when inherit
(funcall (first inherit) :collect collect :inherit (rest inherit))))
(defun process-source-registry-directive (directive &key inherit collect)
(destructuring-bind (kw &rest rest) directive
(ecase kw
((:include)
(destructuring-bind (pathname) rest
(process-source-registry (pathname pathname) :inherit inherit :collect collect)))
((:directory)
(destructuring-bind (pathname) rest
(funcall collect (ensure-directory-pathname pathname))))
((:tree)
(destructuring-bind (pathname) rest
(collect-asd-subdirectories pathname :collect collect)))
((:default-registry)
(default-registry))
((:inherit-configuration)
(inherit-source-registry inherit :collect collect))
((:ignore-inherited-configuration)
nil))))
;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
(defun initialize-source-registry ()
Francois-Rene Rideau
committed
(setf (source-registry)
(inherit-source-registry *default-source-registries*)))
;; checks an initial variable to see whether the state is initialized
;; or cleared. In the former case, return current configuration; in
;; the latter, initialize. ASDF will call this function at the start
;; of (asdf:find-system).
(defun ensure-source-registry ()
(if (source-registry-initialized-p)
(source-registry)
(initialize-source-registry)))
Francois-Rene Rideau
committed
;;;; -------------------------------------------------------------------------
;;;; Cleanups after hot-upgrade.
;;;; Things to do in case we're upgrading from a previous version of ASDF.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;;
;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
Francois-Rene Rideau
committed
(eval-when (:compile-toplevel :load-toplevel :execute)
#+ecl ;; Support upgrade from before ECL went to 1.369
(when (fboundp 'compile-op-system-p)
(defmethod compile-op-system-p ((op compile-op))
(getf :system-p (compile-op-flags op)))))
Francois-Rene Rideau
committed
;;;; -----------------------------------------------------------------
;;;; Done!
(when *load-verbose*
(asdf-message ";; ASDF, revision ~a" *asdf-revision*))
Francois-Rene Rideau
committed
(pushnew :asdf *features*)
Francois-Rene Rideau
committed
(provide :asdf)
;;;; The End.