Make externals directory removal safer

[gnu-emacs-elpa] / admin / archive-contents.el

diff --git a/admin/archive-contents.el b/admin/archive-contents.el
index 74e473ea84d8e87e67ee2d5acc04710b9d51b3be..2181aba8ef459d9865caf8df408e4e9a8ede5faf 100755 (executable)
--- a/admin/archive-contents.el
+++ b/admin/archive-contents.el
@@ -207,8 +207,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"))
@@ -588,6 +589,17 @@ Rename DIR/ to PKG-VERS/, and return the descriptor."
                     "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
@@ -614,8 +626,15 @@ version control nor listed in EXTERNALS-LIST."
        ;; 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))))))
+        ;; 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."
@@ -645,9 +664,9 @@ version control nor listed in EXTERNALS-LIST."
   "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 +675,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 +701,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 +734,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 ()