Newer
Older
(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
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
(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
;;;; -----------------------------------------------------------------
;;;; Source Registry Configuration, by Francois-Rene Rideau
;;;; See README.source-registry and https://bugs.launchpad.net/asdf/+bug/485918
(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."
(setf *source-registry* '())
(values))
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
(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
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
(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
: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
Francois-Rene Rideau
committed
((equal "" s) ; empty element: inherit
Francois-Rene Rideau
committed
(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
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
: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
(defgeneric process-source-registry (spec &key inherit collect))
Francois-Rene Rideau
committed
(defmethod process-source-registry ((pathname pathname) &key
(inherit *default-source-registries*)
collect)
Francois-Rene Rideau
committed
(if (probe-file pathname)
(process-source-registry (validate-source-registry-file pathname)
:inherit inherit :collect collect)
(inherit-source-registry inherit :collect collect)))
Francois-Rene Rideau
committed
(defmethod process-source-registry ((string string) &key
(inherit *default-source-registries*)
collect)
Francois-Rene Rideau
committed
(process-source-registry (parse-source-registry-string string)
:inherit inherit :collect collect))
Francois-Rene Rideau
committed
(defmethod process-source-registry ((x null) &key
(inherit *default-source-registries*)
collect)
Francois-Rene Rideau
committed
(inherit-source-registry inherit :collect collect))
(defun make-collector ()
(let ((acc ()))
(values (lambda (x) (push x acc))
(lambda () (reverse acc)))))
Francois-Rene Rideau
committed
(defmethod process-source-registry ((form cons) &key
(inherit *default-source-registries*)
collect)
Francois-Rene Rideau
committed
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
(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)))
((:exclude)
(setf *default-exclusions* rest))
Francois-Rene Rideau
committed
((: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.