+(defconst archive--emacs-git-url "git://git.sv.gnu.org/emacs.git")
+
+(defun archive--sync-emacs-repo ()
+ "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)))
+ (let ((status
+ (with-temp-buffer
+ (let ((default-directory (file-name-as-directory
+ (expand-file-name dir))))
+ (call-process "git" nil t nil "status" "--porcelain")
+ (buffer-string)))))
+ (if (zerop (length status))
+ (progn (delete-directory dir 'recursive t)
+ (message "Deleted all of %s" dir))
+ (message "Keeping leftover unclean %s:\n%s" dir status))))
+ ;; 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."
+ (let ((default-directory (expand-file-name "packages/")))
+ (cond ((not (file-exists-p name))
+ (let* ((branch (concat "externals/" name))
+ (output
+ (with-temp-buffer
+ ;; FIXME: Use git-new-workdir!
+ (call-process "git" nil t nil "clone"
+ "--reference" ".." "--single-branch"
+ "--branch" branch
+ archive--elpa-git-url name)
+ (buffer-string))))
+ (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))))))))
+
+(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-link-file
+ (source dest emacs-repo-root package-root exclude-regexp)
+ "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))
+ (absolute-core-file-name
+ (expand-file-name source emacs-repo-root))
+ (directory (file-name-directory absolute-package-file-name)))
+ (unless (file-directory-p directory)
+ (make-directory directory t))
+ (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-link-directory
+ (source dest emacs-repo-root package-root exclude-regexp)
+ "Link directory files from SOURCE to DEST ensuring subdirectories."
+ (let ((stack (list source))
+ (base source)
+ (absolute-source))
+ (while stack
+ (setq source (pop stack)
+ absolute-source (expand-file-name source emacs-repo-root))
+ (if (file-directory-p absolute-source)
+ (dolist (file (directory-files absolute-source))
+ (unless (member file (list "." ".."))
+ (push (concat (file-name-as-directory source) file) stack)))
+ (let* ((base (file-name-as-directory base))
+ (source-sans-base (substring source (length base)))
+ (package-file-name
+ (if (archive--core-package-empty-dest-p dest)
+ ;; 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-link-file
+ source package-file-name
+ emacs-repo-root package-root exclude-regexp))))))
+
+(defun archive--core-package-sync (definition)
+ "Sync core package from DEFINITION."
+ (pcase-let*
+ ((`(,name . (:core ,file-patterns :excludes ,excludes)) definition)
+ (emacs-repo-root (expand-file-name "emacs"))
+ (package-root (expand-file-name name "packages"))
+ (default-directory package-root)
+ (exclude-regexp
+ (mapconcat #'identity
+ (mapcar #'wildcard-to-regexp
+ (append '("*.elc" "*~") excludes nil))
+ "\\|"))
+ (file-patterns
+ (mapcar
+ (lambda (file-pattern)
+ (pcase file-pattern
+ ((pred (stringp)) (cons file-pattern ""))
+ (`(,file ,dest . ,_) (cons file dest))
+ (_ (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 "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-link-directory
+ file dest emacs-repo-root package-root exclude-regexp)
+ (archive--core-package-link-file
+ file dest emacs-repo-root package-root exclude-regexp))))))