Loading clpm/bundle.lisp +5 −4 Original line number Diff line number Diff line Loading @@ -85,10 +85,11 @@ the lock file if necessary." (sync-source s)))) ;; Map all update systems to their projects. (dolist (system update-systems) (when-let* ((system-release (find system (context-system-releases lockfile) :key (compose #'system-name #'system-release-system) :test #'equal)) (release (system-release-release system-release)) (when-let* ((release-cons (find-if (lambda (x) (member system x :test #'equal)) (context-system-releases lockfile) :key #'cdr)) (release (car release-cons)) (project-name (project-name (release-project release)))) (pushnew project-name update-projects :test #'equal))) ;; Nuke the lockfile's requirements so that we pick up deletions Loading clpm/clpi.lisp +7 −4 Original line number Diff line number Diff line Loading @@ -76,10 +76,13 @@ (let* ((missing-system-spec (groveler-dependency-missing-system c)) (missing-req (convert-asd-system-spec-to-req missing-system-spec)) (missing-system-name (requirement-name missing-req)) (matching-sr (find missing-system-name (matching-cons (find-if (lambda (x) (member missing-system-name x :test #'equal)) (context-system-releases clpmfile) :test #'equal :key (compose #'system-name #'system-release-system)))) :key #'cdr)) (matching-sr (when matching-cons (release-system-release (car matching-cons) missing-system-name)))) (when (and matching-sr (system-release-satisfies-version-spec-p matching-sr Loading clpm/context.lisp +27 −16 Original line number Diff line number Diff line Loading @@ -83,7 +83,12 @@ pathname (if this is an anonymous context).") (system-releases :initform nil :initarg :system-releases :accessor context-system-releases)) :accessor context-system-releases :documentation "An alist mapping release objects to strings naming the systems installed as part of the release. SYSTEM-RELEASE objects must *not* be used here, because they are not guaranteed to be constructable when the context is read (e.g., in the case of VCS repos where commits have been deleted).")) (:documentation "Represents a snapshot of a context. Includes sources, the releases installed in the context, the requirements that gave rise to those releases, etc. Contexts Loading Loading @@ -128,7 +133,7 @@ can be named, global contexts, or anonymous.")) :requirements (copy-list (context-requirements context)) :reverse-dependencies (copy-alist (context-reverse-dependencies context)) :user-sources (copy-list (context-user-sources context)) :system-releases (copy-list (context-system-releases context)))) :system-releases (copy-tree (context-system-releases context)))) (defun global-context-pathname (name) (clpm-data-pathname (list "contexts" name))) Loading Loading @@ -229,18 +234,24 @@ in place with the same name. Return the new requirement if it was modified." (let* ((context (get-context context)) (system-releases (context-system-releases context))) (remove-duplicates (mapcar (compose #'asdf:primary-system-name #'system-name #'system-release-system) system-releases) (mappend (lambda (x) (mapcar #'asdf:primary-system-name (cdr x))) system-releases) :test #'equal))) (defun context-installed-systems (context) (let* ((context (get-context context)) (system-releases (context-system-releases context))) (mapcar #'system-release-system system-releases))) (mappend #'cdr system-releases))) (defun context-visible-primary-system-names (context) (let* ((context (get-context context)) (releases (context-releases context)) (system-releases (context-system-releases context)) (system-release-alist (context-system-releases context)) (system-releases (mappend (lambda (x) (mapcar (lambda (system-name) (release-system-release (car x) system-name)) (cdr x))) system-release-alist)) (system-files (remove-duplicates (mapcar #'system-release-system-file system-releases))) (system-file-directories (remove-duplicates (mapcar (compose #'uiop:pathname-directory-pathname #'system-file-absolute-asd-pathname) Loading Loading @@ -283,9 +294,11 @@ in place with the same name. Return the new requirement if it was modified." (defun context-find-system-asd-pathname (context system-name) (when-let* ((context (get-context context)) (system-release (find system-name (context-system-releases context) :key (compose #'system-name #'system-release-system) :test #'equal))) (system-release-cons (find-if (lambda (x) (member system-name x :test 'equal)) (context-system-releases context) :key #'cdr)) (system-release (release-system-release (car system-release-cons) system-name))) (system-release-absolute-asd-pathname system-release))) (defun context-write-asdf-files (context) Loading Loading @@ -433,8 +446,8 @@ in place with the same name. Return the new requirement if it was modified." (push release (context-releases context)) (dolist (system-name systems) (push (release-system-release release system-name) (context-system-releases context)))))) (push system-name (assoc-value (context-system-releases context) release)))))) (defmethod process-form (context (section (eql :reverse-dependencies)) form)) Loading Loading @@ -541,10 +554,8 @@ in place with the same name. Return the new requirement if it was modified." (dolist (release (sort (copy-list (context-releases context)) #'string< :key (compose #'project-name #'release-project))) (format stream "~S~%" (context-release-to-form release (remove-if-not (lambda (x) (eql x release)) (context-system-releases context) :key #'system-release-release)))) (context-release-to-form release (assoc-value (context-system-releases context) release)))) (terpri stream) (terpri stream) Loading @@ -570,11 +581,11 @@ in place with the same name. Return the new requirement if it was modified." ,(list* (requirement-type-keyword req) (requirement-to-plist req))))) (defun context-release-to-form (release system-releases) (defun context-release-to-form (release system-names) `(,(project-name (release-project release)) :version ,(release-version release) :source ,(source-name (release-source release)) :systems ,(mapcar (compose #'system-name #'system-release-system) system-releases))) :systems ,system-names)) (defun context-reverse-deps-to-form (release-and-reverse-deps) (destructuring-bind (release . reverse-deps) release-and-reverse-deps Loading clpm/resolve.lisp +4 −1 Original line number Diff line number Diff line Loading @@ -114,5 +114,8 @@ the requirements." (setf (context-reverse-dependencies out-context) (sort (copy-alist (node-activated-releases final-node)) #'string< :key (compose #'project-name #'release-project #'car))) (setf (context-system-releases out-context) (node-activated-system-releases final-node)) (setf (context-system-releases out-context) nil) (dolist (sr (node-activated-system-releases final-node)) (push (system-name (system-release-system sr)) (assoc-value (context-system-releases out-context) (system-release-release sr)))) out-context))) clpm/update.lisp +5 −4 Original line number Diff line number Diff line Loading @@ -27,10 +27,11 @@ (with-context (context (copy-context orig-context)) ;; Map all systems to their corresponding projects. (dolist (system update-systems) (when-let* ((system-release (find system (context-system-releases orig-context) :key (compose #'system-name #'system-release-system) :test #'equal)) (release (system-release-release system-release)) (when-let* ((release-cons (find-if (lambda (x) (member system x :test #'equal)) (context-system-releases orig-context) :key #'cdr)) (release (car release-cons)) (project-name (project-name (release-project release)))) (pushnew project-name update-projects :test #'equal))) Loading Loading
clpm/bundle.lisp +5 −4 Original line number Diff line number Diff line Loading @@ -85,10 +85,11 @@ the lock file if necessary." (sync-source s)))) ;; Map all update systems to their projects. (dolist (system update-systems) (when-let* ((system-release (find system (context-system-releases lockfile) :key (compose #'system-name #'system-release-system) :test #'equal)) (release (system-release-release system-release)) (when-let* ((release-cons (find-if (lambda (x) (member system x :test #'equal)) (context-system-releases lockfile) :key #'cdr)) (release (car release-cons)) (project-name (project-name (release-project release)))) (pushnew project-name update-projects :test #'equal))) ;; Nuke the lockfile's requirements so that we pick up deletions Loading
clpm/clpi.lisp +7 −4 Original line number Diff line number Diff line Loading @@ -76,10 +76,13 @@ (let* ((missing-system-spec (groveler-dependency-missing-system c)) (missing-req (convert-asd-system-spec-to-req missing-system-spec)) (missing-system-name (requirement-name missing-req)) (matching-sr (find missing-system-name (matching-cons (find-if (lambda (x) (member missing-system-name x :test #'equal)) (context-system-releases clpmfile) :test #'equal :key (compose #'system-name #'system-release-system)))) :key #'cdr)) (matching-sr (when matching-cons (release-system-release (car matching-cons) missing-system-name)))) (when (and matching-sr (system-release-satisfies-version-spec-p matching-sr Loading
clpm/context.lisp +27 −16 Original line number Diff line number Diff line Loading @@ -83,7 +83,12 @@ pathname (if this is an anonymous context).") (system-releases :initform nil :initarg :system-releases :accessor context-system-releases)) :accessor context-system-releases :documentation "An alist mapping release objects to strings naming the systems installed as part of the release. SYSTEM-RELEASE objects must *not* be used here, because they are not guaranteed to be constructable when the context is read (e.g., in the case of VCS repos where commits have been deleted).")) (:documentation "Represents a snapshot of a context. Includes sources, the releases installed in the context, the requirements that gave rise to those releases, etc. Contexts Loading Loading @@ -128,7 +133,7 @@ can be named, global contexts, or anonymous.")) :requirements (copy-list (context-requirements context)) :reverse-dependencies (copy-alist (context-reverse-dependencies context)) :user-sources (copy-list (context-user-sources context)) :system-releases (copy-list (context-system-releases context)))) :system-releases (copy-tree (context-system-releases context)))) (defun global-context-pathname (name) (clpm-data-pathname (list "contexts" name))) Loading Loading @@ -229,18 +234,24 @@ in place with the same name. Return the new requirement if it was modified." (let* ((context (get-context context)) (system-releases (context-system-releases context))) (remove-duplicates (mapcar (compose #'asdf:primary-system-name #'system-name #'system-release-system) system-releases) (mappend (lambda (x) (mapcar #'asdf:primary-system-name (cdr x))) system-releases) :test #'equal))) (defun context-installed-systems (context) (let* ((context (get-context context)) (system-releases (context-system-releases context))) (mapcar #'system-release-system system-releases))) (mappend #'cdr system-releases))) (defun context-visible-primary-system-names (context) (let* ((context (get-context context)) (releases (context-releases context)) (system-releases (context-system-releases context)) (system-release-alist (context-system-releases context)) (system-releases (mappend (lambda (x) (mapcar (lambda (system-name) (release-system-release (car x) system-name)) (cdr x))) system-release-alist)) (system-files (remove-duplicates (mapcar #'system-release-system-file system-releases))) (system-file-directories (remove-duplicates (mapcar (compose #'uiop:pathname-directory-pathname #'system-file-absolute-asd-pathname) Loading Loading @@ -283,9 +294,11 @@ in place with the same name. Return the new requirement if it was modified." (defun context-find-system-asd-pathname (context system-name) (when-let* ((context (get-context context)) (system-release (find system-name (context-system-releases context) :key (compose #'system-name #'system-release-system) :test #'equal))) (system-release-cons (find-if (lambda (x) (member system-name x :test 'equal)) (context-system-releases context) :key #'cdr)) (system-release (release-system-release (car system-release-cons) system-name))) (system-release-absolute-asd-pathname system-release))) (defun context-write-asdf-files (context) Loading Loading @@ -433,8 +446,8 @@ in place with the same name. Return the new requirement if it was modified." (push release (context-releases context)) (dolist (system-name systems) (push (release-system-release release system-name) (context-system-releases context)))))) (push system-name (assoc-value (context-system-releases context) release)))))) (defmethod process-form (context (section (eql :reverse-dependencies)) form)) Loading Loading @@ -541,10 +554,8 @@ in place with the same name. Return the new requirement if it was modified." (dolist (release (sort (copy-list (context-releases context)) #'string< :key (compose #'project-name #'release-project))) (format stream "~S~%" (context-release-to-form release (remove-if-not (lambda (x) (eql x release)) (context-system-releases context) :key #'system-release-release)))) (context-release-to-form release (assoc-value (context-system-releases context) release)))) (terpri stream) (terpri stream) Loading @@ -570,11 +581,11 @@ in place with the same name. Return the new requirement if it was modified." ,(list* (requirement-type-keyword req) (requirement-to-plist req))))) (defun context-release-to-form (release system-releases) (defun context-release-to-form (release system-names) `(,(project-name (release-project release)) :version ,(release-version release) :source ,(source-name (release-source release)) :systems ,(mapcar (compose #'system-name #'system-release-system) system-releases))) :systems ,system-names)) (defun context-reverse-deps-to-form (release-and-reverse-deps) (destructuring-bind (release . reverse-deps) release-and-reverse-deps Loading
clpm/resolve.lisp +4 −1 Original line number Diff line number Diff line Loading @@ -114,5 +114,8 @@ the requirements." (setf (context-reverse-dependencies out-context) (sort (copy-alist (node-activated-releases final-node)) #'string< :key (compose #'project-name #'release-project #'car))) (setf (context-system-releases out-context) (node-activated-system-releases final-node)) (setf (context-system-releases out-context) nil) (dolist (sr (node-activated-system-releases final-node)) (push (system-name (system-release-system sr)) (assoc-value (context-system-releases out-context) (system-release-release sr)))) out-context)))
clpm/update.lisp +5 −4 Original line number Diff line number Diff line Loading @@ -27,10 +27,11 @@ (with-context (context (copy-context orig-context)) ;; Map all systems to their corresponding projects. (dolist (system update-systems) (when-let* ((system-release (find system (context-system-releases orig-context) :key (compose #'system-name #'system-release-system) :test #'equal)) (release (system-release-release system-release)) (when-let* ((release-cons (find-if (lambda (x) (member system x :test #'equal)) (context-system-releases orig-context) :key #'cdr)) (release (car release-cons)) (project-name (project-name (release-project release)))) (pushnew project-name update-projects :test #'equal))) Loading