X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/6f7aa2669e1f2fdda4269b31fa44fb41cf01a8cf..f4df1681254dae0cf5ba65eeacc8a9c93f316af2:/admin/archive-contents.el diff --git a/admin/archive-contents.el b/admin/archive-contents.el index 74e473ea8..37b582d53 100755 --- a/admin/archive-contents.el +++ b/admin/archive-contents.el @@ -1,6 +1,6 @@ ;;; archive-contents.el --- Auto-generate an Emacs Lisp package archive. -*- lexical-binding:t -*- -;; Copyright (C) 2011-2015 Free Software Foundation, Inc +;; Copyright (C) 2011-2016 Free Software Foundation, Inc ;; Author: Stefan Monnier @@ -179,7 +179,6 @@ PKG is the name of the package and DIR is the directory where it is." (error "Can't parse first line of %s" mainfile) ;; Grab the other fields, which are not mandatory. (let* ((description (match-string 1)) - (pv ) (version (or (lm-header "package-version") (lm-header "version") @@ -207,8 +206,9 @@ PKG is the name of the package and DIR is the directory where it is." "Deploy the contents of DIR into the archive as a simple package. Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and return the descriptor." ;; Write DIR/foo.el to foo-VERS.el and delete DIR - (rename-file (expand-file-name (concat pkg ".el") dir) - (concat pkg "-" vers ".el")) + (let ((src (expand-file-name (concat pkg ".el") dir))) + (funcall (if (file-symlink-p src) #'copy-file #'rename-file) + src (concat pkg "-" vers ".el"))) ;; Add the content of the ChangeLog. (let ((cl (expand-file-name "ChangeLog" dir))) (with-current-buffer (find-file-noselect (concat pkg "-" vers ".el")) @@ -420,7 +420,7 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (replace-regexp-in-string "<" "<" (replace-regexp-in-string "&" "&" txt))) -(defun archive--insert-repolinks (name srcdir mainsrcfile url) +(defun archive--insert-repolinks (name srcdir _mainsrcfile url) (when url (insert (format "

Home page: %s

\n" url (archive--quote url))) @@ -556,47 +556,57 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." packages) (archive--html-make-index archive-contents))) +(defun archive--pull (dirname) + (let ((default-directory (file-name-as-directory + (expand-file-name dirname)))) + (with-temp-buffer + (message "Running git pull in %S" default-directory) + (call-process "git" nil t nil "pull") + (message "Updated %s:\n%s" dirname (buffer-string))))) + ;;; Maintain external packages. (defconst archive--elpa-git-url "git://git.sv.gnu.org/emacs/elpa") (defconst archive--emacs-git-url "git://git.sv.gnu.org/emacs.git") (defun archive--sync-emacs-repo () - "Clone and sync Emacs repository." - (let ((reference (expand-file-name - (or (getenv "EMACS_CLONE_REFERENCE") "../emacs/master"))) - (emacs-repo-root (expand-file-name "emacs"))) - (when (and (file-exists-p emacs-repo-root) - (not (file-exists-p - (expand-file-name "README" emacs-repo-root)))) - (message "Cleaning stalled Emacs clone: %s" emacs-repo-root) - (delete-directory emacs-repo-root t)) - (cond ((file-exists-p emacs-repo-root) - (let ((default-directory emacs-repo-root)) - (message "Running git pull in %S" default-directory) - (call-process "git" nil t nil "pull"))) - ((file-exists-p reference) - (message "Emacs repository reference found: %s" reference) - (call-process - "git" nil t nil - "clone" archive--emacs-git-url - "--reference" reference - emacs-repo-root)) - (t - (error - (concat "Emacs repository not found at: %s\n" - "Point EMACS_CLONE_REFERENCE environment variable to an " - "existing checkout.") reference))))) - -(defun archive--cleanup-packages (externals-list) + "Sync Emacs repository, if applicable. +Return non-nil if there's an \"emacs\" repository present." + ;; Support for :core packages is important for elpa.gnu.org, but for other + ;; cases such as "in-place installation", it's rather secondary since + ;; those users can just as well use a development version of Emacs to get + ;; those packages. + ;; So make the handling of :core packages depend on whether or not the user + ;; has setup a clone of Emacs under the "emacs" subdirectory. + (let ((emacs-repo-root (expand-file-name "emacs"))) + (if (not (file-directory-p emacs-repo-root)) + (progn (message "No \"emacs\" subdir: will skip :core packages") + nil) + (archive--pull emacs-repo-root) + t))) + +(defun archive--find-non-trivial-file (dir) + (catch 'found-important-file + (dolist (file (directory-files-recursively dir ".*")) + (unless (or (member file '("." "..")) + (string-match "\\.elc\\'" file) + (string-match "-autoloads.el\\'" file) + (string-match "-pkg.el\\'" file) + (file-symlink-p file)) + (throw 'found-important-file file))) + nil)) + +(defun archive--cleanup-packages (externals-list with-core) "Remove subdirectories of `packages/' that do not correspond to known packages. This is any subdirectory inside `packages/' that's not under -version control nor listed in EXTERNALS-LIST." +version control nor listed in EXTERNALS-LIST. +If WITH-CORE is non-nil, it means we manage :core packages as well." (let ((default-directory (expand-file-name "packages/"))) (dolist (dir (directory-files ".")) (cond ((or (not (file-directory-p dir)) (file-symlink-p dir)) - ;; We only add/remove plain directories in elpa/packages (not symlinks). + ;; We only add/remove plain directories in elpa/packages (not + ;; symlinks). nil) ((member dir '("." "..")) nil) ((assoc dir externals-list) nil) @@ -612,10 +622,19 @@ version control nor listed in EXTERNALS-LIST." (message "Deleted all of %s" dir)) (message "Keeping leftover unclean %s:\n%s" dir status)))) ;; Check if `dir' is under version control. - ((not (zerop (call-process "git" nil nil nil - "ls-files" "--error-unmatch" dir))) - (message "Deleted untracked package %s" dir) - (delete-directory dir 'recursive t)))))) + ((and with-core + (not (zerop (call-process "git" nil nil nil + "ls-files" "--error-unmatch" dir)))) + ;; Not under version control. Check if it only contains + ;; symlinks and generated files, in which case it is probably + ;; a leftover :core package that can safely be deleted. + ;; (let ((file (archive--find-non-trivial-file dir))) + ;; (if file + ;; (message "Keeping %s for non-trivial file \"%s\"" dir file) + ;; (progn + ;; (message "Deleted untracked package %s" dir) + ;; (delete-directory dir 'recursive t)))) + ))))) (defun archive--external-package-sync (name) "Sync external package named NAME." @@ -624,7 +643,7 @@ version control nor listed in EXTERNALS-LIST." (let* ((branch (concat "externals/" name)) (output (with-temp-buffer - ;; FIXME: Use git-new-workdir! + ;; FIXME: Use `git worktree'! (call-process "git" nil t nil "clone" "--reference" ".." "--single-branch" "--branch" branch @@ -633,21 +652,15 @@ version control nor listed in EXTERNALS-LIST." (message "Cloning branch %s:\n%s" name output))) ((not (file-directory-p (concat name "/.git"))) (message "%s is in the way of an external, please remove!" name)) - (t - (let ((default-directory (file-name-as-directory - (expand-file-name name)))) - (with-temp-buffer - (message "Running git pull in %S" default-directory) - (call-process "git" nil t nil "pull") - (message "Updated %s:%s" name (buffer-string)))))))) + (t (archive--pull name))))) (defun archive--core-package-empty-dest-p (dest) "Return non-nil if DEST is an empty variant." (member dest (list "" "." nil))) -(defun archive--core-package-copy-file +(defun archive--core-package-link-file (source dest emacs-repo-root package-root exclude-regexp) - "Copy file from SOURCE to DEST ensuring subdirectories." + "Link file from SOURCE to DEST ensuring subdirectories." (unless (string-match-p exclude-regexp source) (let* ((absolute-package-file-name (expand-file-name dest package-root)) @@ -656,14 +669,18 @@ version control nor listed in EXTERNALS-LIST." (directory (file-name-directory absolute-package-file-name))) (unless (file-directory-p directory) (make-directory directory t)) - (copy-file absolute-core-file-name absolute-package-file-name)) + (condition-case nil + (make-symbolic-link absolute-core-file-name + absolute-package-file-name t) + (file-error + (copy-file absolute-core-file-name absolute-package-file-name)))) (message " %s -> %s" source (if (archive--core-package-empty-dest-p dest) (file-name-nondirectory source) dest)))) -(defun archive--core-package-copy-directory +(defun archive--core-package-link-directory (source dest emacs-repo-root package-root exclude-regexp) - "Copy directory files from SOURCE to DEST ensuring subdirectories." + "Link directory files from SOURCE to DEST ensuring subdirectories." (let ((stack (list source)) (base source) (absolute-source)) @@ -678,12 +695,12 @@ version control nor listed in EXTERNALS-LIST." (source-sans-base (substring source (length base))) (package-file-name (if (archive--core-package-empty-dest-p dest) - ;; Copy to root with it's original filename. + ;; Link to root with its original filename. source-sans-base (concat ;; Prepend the destination, allowing for directory rename. (file-name-as-directory dest) source-sans-base)))) - (archive--core-package-copy-file + (archive--core-package-link-file source package-file-name emacs-repo-root package-root exclude-regexp)))))) @@ -711,16 +728,16 @@ version control nor listed in EXTERNALS-LIST." ;; Files may be just a string, normalize. (list file-patterns) file-patterns)))) - (message "Copying files for package: %s" name) + (message "Linking files for package: %s" name) (when (file-directory-p package-root) (delete-directory package-root t)) (make-directory package-root t) (dolist (file-pattern file-patterns) (pcase-let* ((`(,file . ,dest) file-pattern)) (if (file-directory-p (expand-file-name file emacs-repo-root)) - (archive--core-package-copy-directory + (archive--core-package-link-directory file dest emacs-repo-root package-root exclude-regexp) - (archive--core-package-copy-file + (archive--core-package-link-file file dest emacs-repo-root package-root exclude-regexp)))))) (defun archive-add/remove/update-externals () @@ -728,14 +745,15 @@ version control nor listed in EXTERNALS-LIST." (let ((externals-list (with-current-buffer (find-file-noselect "externals-list") (read (buffer-string))))) - (archive--cleanup-packages externals-list) - (archive--sync-emacs-repo) - (pcase-dolist ((and definition `(,name ,kind ,_url)) externals-list) - (pcase kind - (`:subtree nil) ;Nothing to do. - (`:external (archive--external-package-sync name)) - (`:core (archive--core-package-sync definition)) - (_ (message "Unknown external package kind `%S' for %s" kind name)))))) + (let ((with-core (archive--sync-emacs-repo))) + (archive--cleanup-packages externals-list with-core) + (pcase-dolist ((and definition `(,name ,kind ,_url)) externals-list) + (pcase kind + (`:subtree nil) ;Nothing to do. + (`:external (archive--external-package-sync name)) + (`:core (when with-core (archive--core-package-sync definition))) + (_ (message "Unknown external package kind `%S' for %s" + kind name))))))) (provide 'archive-contents) ;;; archive-contents.el ends here