+(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--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)
+ "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."
+ (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.
+ ((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))))))