;;; 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 <monnier@iro.umontreal.ca>
(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")
"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"))
(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 "<p>Home page: <a href=%S>%s</a></p>\n"
url (archive--quote url)))
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)
(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."
(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
(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))
(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))
(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))))))
;; 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 ()
(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