X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/ad82b992bbbd8ae5eb4c4352939704929f56cdc8..07c53b50741b6684d3d3ef5177a92861fbaec14c:/admin/archive-contents.el diff --git a/admin/archive-contents.el b/admin/archive-contents.el index acfe34dba..b63f4cdaf 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-2014 Free Software Foundation, Inc +;; Copyright (C) 2011-2015 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))) @@ -531,6 +531,7 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (cond ((member file '("." ".." "elpa.rss" "index.html" "archive-contents"))) ((string-match "\\.html\\'" file)) + ((string-match "\\.sig\\'" file)) ((string-match "-readme\\.txt\\'" file) (let ((name (substring file 0 (match-beginning 0)))) (puthash name (gethash name packages) packages))) @@ -561,37 +562,46 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (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) - "Cleanup packages not registered in the 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) + (let ((default-directory emacs-repo-root)) + (message "Running git pull in %S" default-directory) + (call-process "git" nil t nil "pull") + 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. +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). + nil) ((member dir '("." "..")) nil) ((assoc dir externals-list) nil) ((file-directory-p (expand-file-name (format "%s/.git" dir))) @@ -605,10 +615,19 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (progn (delete-directory dir 'recursive t) (message "Deleted all of %s" dir)) (message "Keeping leftover unclean %s:\n%s" dir status)))) - ((not (zerop (call-process "git" nil nil nil - "ls-files" "--error-unmatch" dir))) - (message "Deleted untracked package %s" dir) - (delete-directory dir 'recursive t)))))) + ;; Check if `dir' is under version control. + ((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." @@ -638,9 +657,9 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." "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)) @@ -649,14 +668,18 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (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)) @@ -671,12 +694,12 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (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)))))) @@ -698,36 +721,38 @@ Rename DIR/ to PKG-VERS/, and return the descriptor." (pcase file-pattern ((pred (stringp)) (cons file-pattern "")) (`(,file ,dest . ,_) (cons file dest)) - (t (error "Unrecognized file format for package %s: %S" + (_ (error "Unrecognized file format for package %s: %S" name file-pattern)))) (if (stringp file-patterns) ;; 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 () + "Remove non-package directories and fetch external packages." (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