Loading clpm/bundle.lisp +5 −4 Original line number Original line Diff line number Diff line Loading @@ -85,10 +85,11 @@ the lock file if necessary." (sync-source s)))) (sync-source s)))) ;; Map all update systems to their projects. ;; Map all update systems to their projects. (dolist (system update-systems) (dolist (system update-systems) (when-let* ((system-release (find system (context-system-releases lockfile) (when-let* ((release-cons (find-if (lambda (x) :key (compose #'system-name #'system-release-system) (member system x :test #'equal)) :test #'equal)) (context-system-releases lockfile) (release (system-release-release system-release)) :key #'cdr)) (release (car release-cons)) (project-name (project-name (release-project release)))) (project-name (project-name (release-project release)))) (pushnew project-name update-projects :test #'equal))) (pushnew project-name update-projects :test #'equal))) ;; Nuke the lockfile's requirements so that we pick up deletions ;; Nuke the lockfile's requirements so that we pick up deletions Loading clpm/clpi.lisp +7 −4 Original line number Original line Diff line number Diff line Loading @@ -76,10 +76,13 @@ (let* ((missing-system-spec (groveler-dependency-missing-system c)) (let* ((missing-system-spec (groveler-dependency-missing-system c)) (missing-req (convert-asd-system-spec-to-req missing-system-spec)) (missing-req (convert-asd-system-spec-to-req missing-system-spec)) (missing-system-name (requirement-name missing-req)) (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) (context-system-releases clpmfile) :test #'equal :key #'cdr)) :key (compose #'system-name #'system-release-system)))) (matching-sr (when matching-cons (release-system-release (car matching-cons) missing-system-name)))) (when (and matching-sr (when (and matching-sr (system-release-satisfies-version-spec-p (system-release-satisfies-version-spec-p matching-sr matching-sr Loading clpm/context.lisp +27 −16 Original line number Original line Diff line number Diff line Loading @@ -83,7 +83,12 @@ pathname (if this is an anonymous context).") (system-releases (system-releases :initform nil :initform nil :initarg :system-releases :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 (:documentation "Represents a snapshot of a context. Includes sources, the releases installed "Represents a snapshot of a context. Includes sources, the releases installed in the context, the requirements that gave rise to those releases, etc. Contexts 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)) :requirements (copy-list (context-requirements context)) :reverse-dependencies (copy-alist (context-reverse-dependencies context)) :reverse-dependencies (copy-alist (context-reverse-dependencies context)) :user-sources (copy-list (context-user-sources 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) (defun global-context-pathname (name) (clpm-data-pathname (list "contexts" 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)) (let* ((context (get-context context)) (system-releases (context-system-releases context))) (system-releases (context-system-releases context))) (remove-duplicates (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))) :test #'equal))) (defun context-installed-systems (context) (defun context-installed-systems (context) (let* ((context (get-context context)) (let* ((context (get-context context)) (system-releases (context-system-releases context))) (system-releases (context-system-releases context))) (mapcar #'system-release-system system-releases))) (mappend #'cdr system-releases))) (defun context-visible-primary-system-names (context) (defun context-visible-primary-system-names (context) (let* ((context (get-context context)) (let* ((context (get-context context)) (releases (context-releases 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-files (remove-duplicates (mapcar #'system-release-system-file system-releases))) (system-file-directories (remove-duplicates (mapcar (compose #'uiop:pathname-directory-pathname (system-file-directories (remove-duplicates (mapcar (compose #'uiop:pathname-directory-pathname #'system-file-absolute-asd-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) (defun context-find-system-asd-pathname (context system-name) (when-let* ((context (get-context context)) (when-let* ((context (get-context context)) (system-release (find system-name (context-system-releases context) (system-release-cons (find-if (lambda (x) :key (compose #'system-name #'system-release-system) (member system-name x :test 'equal)) :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))) (system-release-absolute-asd-pathname system-release))) (defun context-write-asdf-files (context) (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 (push release (context-releases context)) (context-releases context)) (dolist (system-name systems) (dolist (system-name systems) (push (release-system-release release system-name) (push system-name (context-system-releases context)))))) (assoc-value (context-system-releases context) release)))))) (defmethod process-form (context (section (eql :reverse-dependencies)) form)) (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< (dolist (release (sort (copy-list (context-releases context)) #'string< :key (compose #'project-name #'release-project))) :key (compose #'project-name #'release-project))) (format stream "~S~%" (format stream "~S~%" (context-release-to-form release (remove-if-not (lambda (x) (context-release-to-form release (assoc-value (context-system-releases context) (eql x release)) release)))) (context-system-releases context) :key #'system-release-release)))) (terpri stream) (terpri stream) (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) ,(list* (requirement-type-keyword req) (requirement-to-plist 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)) `(,(project-name (release-project release)) :version ,(release-version release) :version ,(release-version release) :source ,(source-name (release-source 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) (defun context-reverse-deps-to-form (release-and-reverse-deps) (destructuring-bind (release . reverse-deps) release-and-reverse-deps (destructuring-bind (release . reverse-deps) release-and-reverse-deps Loading clpm/resolve.lisp +4 −1 Original line number Original line Diff line number Diff line Loading @@ -114,5 +114,8 @@ the requirements." (setf (context-reverse-dependencies out-context) (setf (context-reverse-dependencies out-context) (sort (copy-alist (node-activated-releases final-node)) (sort (copy-alist (node-activated-releases final-node)) #'string< :key (compose #'project-name #'release-project #'car))) #'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))) out-context))) clpm/update.lisp +5 −4 Original line number Original line Diff line number Diff line Loading @@ -27,10 +27,11 @@ (with-context (context (copy-context orig-context)) (with-context (context (copy-context orig-context)) ;; Map all systems to their corresponding projects. ;; Map all systems to their corresponding projects. (dolist (system update-systems) (dolist (system update-systems) (when-let* ((system-release (find system (context-system-releases orig-context) (when-let* ((release-cons (find-if (lambda (x) :key (compose #'system-name #'system-release-system) (member system x :test #'equal)) :test #'equal)) (context-system-releases orig-context) (release (system-release-release system-release)) :key #'cdr)) (release (car release-cons)) (project-name (project-name (release-project release)))) (project-name (project-name (release-project release)))) (pushnew project-name update-projects :test #'equal))) (pushnew project-name update-projects :test #'equal))) Loading Loading
clpm/bundle.lisp +5 −4 Original line number Original line Diff line number Diff line Loading @@ -85,10 +85,11 @@ the lock file if necessary." (sync-source s)))) (sync-source s)))) ;; Map all update systems to their projects. ;; Map all update systems to their projects. (dolist (system update-systems) (dolist (system update-systems) (when-let* ((system-release (find system (context-system-releases lockfile) (when-let* ((release-cons (find-if (lambda (x) :key (compose #'system-name #'system-release-system) (member system x :test #'equal)) :test #'equal)) (context-system-releases lockfile) (release (system-release-release system-release)) :key #'cdr)) (release (car release-cons)) (project-name (project-name (release-project release)))) (project-name (project-name (release-project release)))) (pushnew project-name update-projects :test #'equal))) (pushnew project-name update-projects :test #'equal))) ;; Nuke the lockfile's requirements so that we pick up deletions ;; Nuke the lockfile's requirements so that we pick up deletions Loading
clpm/clpi.lisp +7 −4 Original line number Original line Diff line number Diff line Loading @@ -76,10 +76,13 @@ (let* ((missing-system-spec (groveler-dependency-missing-system c)) (let* ((missing-system-spec (groveler-dependency-missing-system c)) (missing-req (convert-asd-system-spec-to-req missing-system-spec)) (missing-req (convert-asd-system-spec-to-req missing-system-spec)) (missing-system-name (requirement-name missing-req)) (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) (context-system-releases clpmfile) :test #'equal :key #'cdr)) :key (compose #'system-name #'system-release-system)))) (matching-sr (when matching-cons (release-system-release (car matching-cons) missing-system-name)))) (when (and matching-sr (when (and matching-sr (system-release-satisfies-version-spec-p (system-release-satisfies-version-spec-p matching-sr matching-sr Loading
clpm/context.lisp +27 −16 Original line number Original line Diff line number Diff line Loading @@ -83,7 +83,12 @@ pathname (if this is an anonymous context).") (system-releases (system-releases :initform nil :initform nil :initarg :system-releases :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 (:documentation "Represents a snapshot of a context. Includes sources, the releases installed "Represents a snapshot of a context. Includes sources, the releases installed in the context, the requirements that gave rise to those releases, etc. Contexts 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)) :requirements (copy-list (context-requirements context)) :reverse-dependencies (copy-alist (context-reverse-dependencies context)) :reverse-dependencies (copy-alist (context-reverse-dependencies context)) :user-sources (copy-list (context-user-sources 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) (defun global-context-pathname (name) (clpm-data-pathname (list "contexts" 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)) (let* ((context (get-context context)) (system-releases (context-system-releases context))) (system-releases (context-system-releases context))) (remove-duplicates (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))) :test #'equal))) (defun context-installed-systems (context) (defun context-installed-systems (context) (let* ((context (get-context context)) (let* ((context (get-context context)) (system-releases (context-system-releases context))) (system-releases (context-system-releases context))) (mapcar #'system-release-system system-releases))) (mappend #'cdr system-releases))) (defun context-visible-primary-system-names (context) (defun context-visible-primary-system-names (context) (let* ((context (get-context context)) (let* ((context (get-context context)) (releases (context-releases 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-files (remove-duplicates (mapcar #'system-release-system-file system-releases))) (system-file-directories (remove-duplicates (mapcar (compose #'uiop:pathname-directory-pathname (system-file-directories (remove-duplicates (mapcar (compose #'uiop:pathname-directory-pathname #'system-file-absolute-asd-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) (defun context-find-system-asd-pathname (context system-name) (when-let* ((context (get-context context)) (when-let* ((context (get-context context)) (system-release (find system-name (context-system-releases context) (system-release-cons (find-if (lambda (x) :key (compose #'system-name #'system-release-system) (member system-name x :test 'equal)) :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))) (system-release-absolute-asd-pathname system-release))) (defun context-write-asdf-files (context) (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 (push release (context-releases context)) (context-releases context)) (dolist (system-name systems) (dolist (system-name systems) (push (release-system-release release system-name) (push system-name (context-system-releases context)))))) (assoc-value (context-system-releases context) release)))))) (defmethod process-form (context (section (eql :reverse-dependencies)) form)) (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< (dolist (release (sort (copy-list (context-releases context)) #'string< :key (compose #'project-name #'release-project))) :key (compose #'project-name #'release-project))) (format stream "~S~%" (format stream "~S~%" (context-release-to-form release (remove-if-not (lambda (x) (context-release-to-form release (assoc-value (context-system-releases context) (eql x release)) release)))) (context-system-releases context) :key #'system-release-release)))) (terpri stream) (terpri stream) (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) ,(list* (requirement-type-keyword req) (requirement-to-plist 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)) `(,(project-name (release-project release)) :version ,(release-version release) :version ,(release-version release) :source ,(source-name (release-source 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) (defun context-reverse-deps-to-form (release-and-reverse-deps) (destructuring-bind (release . reverse-deps) release-and-reverse-deps (destructuring-bind (release . reverse-deps) release-and-reverse-deps Loading
clpm/resolve.lisp +4 −1 Original line number Original line Diff line number Diff line Loading @@ -114,5 +114,8 @@ the requirements." (setf (context-reverse-dependencies out-context) (setf (context-reverse-dependencies out-context) (sort (copy-alist (node-activated-releases final-node)) (sort (copy-alist (node-activated-releases final-node)) #'string< :key (compose #'project-name #'release-project #'car))) #'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))) out-context)))
clpm/update.lisp +5 −4 Original line number Original line Diff line number Diff line Loading @@ -27,10 +27,11 @@ (with-context (context (copy-context orig-context)) (with-context (context (copy-context orig-context)) ;; Map all systems to their corresponding projects. ;; Map all systems to their corresponding projects. (dolist (system update-systems) (dolist (system update-systems) (when-let* ((system-release (find system (context-system-releases orig-context) (when-let* ((release-cons (find-if (lambda (x) :key (compose #'system-name #'system-release-system) (member system x :test #'equal)) :test #'equal)) (context-system-releases orig-context) (release (system-release-release system-release)) :key #'cdr)) (release (car release-cons)) (project-name (project-name (release-project release)))) (project-name (project-name (release-project release)))) (pushnew project-name update-projects :test #'equal))) (pushnew project-name update-projects :test #'equal))) Loading