code.delx.au - gnu-emacs-elpa/blob - admin/archive-contents.el

   1 ;;; archive-contents.el --- Auto-generate an Emacs Lisp package archive.  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2011, 2012, 2013  Free Software Foundation, Inc
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;;; Code:
  23
  24 (eval-when-compile (require 'cl))
  25 (require 'lisp-mnt)
  26 (require 'package)
  27 (require 'pcase)
  28
  29 (defconst archive-contents-subdirectory-regexp
  30   "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)")
  31
  32 (defconst archive-re-no-dot "\\`\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
  33   "Regular expression matching all files except \".\" and \"..\".")
  34
  35 (defun archive--version-to-list (vers)
  36   (when vers
  37     (let ((l (version-to-list vers)))
  38       ;; Signal an error for things like "1.02" which is parsed as "1.2".
  39       (assert (equal vers (package-version-join l)))
  40       l)))
  41
  42 (defun archive--convert-require (elt)
  43   (list (car elt)
  44         (archive--version-to-list (car (cdr elt)))))
  45
  46 (defun archive--strip-rcs-id (str)
  47   "Strip RCS version ID from the version string STR.
  48 If the result looks like a dotted numeric version, return it.
  49 Otherwise return nil."
  50   (when str
  51     (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
  52       (setq str (substring str (match-end 0))))
  53     (condition-case nil
  54         (if (archive--version-to-list str)
  55             str)
  56       (error nil))))
  57
  58 (defun archive--delete-elc-files (dir &optional only-orphans)
  59   "Recursively delete all .elc files in DIR.
  60 Delete backup files also."
  61   (dolist (f (directory-files dir t archive-re-no-dot))
  62     (cond ((file-directory-p f)
  63            (archive--delete-elc-files f))
  64           ((or (and (string-match "\\.elc\\'" f)
  65                     (not (and only-orphans
  66                               (file-readable-p (replace-match ".el" t t f)))))
  67                (backup-file-name-p f))
  68            (delete-file f)))))
  69
  70 (defun batch-make-archive ()
  71   "Process package content directories and generate the archive-contents file."
  72   (let ((packages '(1))) ; format-version.
  73     (dolist (dir (directory-files default-directory nil archive-re-no-dot))
  74       (condition-case v
  75           (if (not (file-directory-p dir))
  76               (message "Skipping non-package file %s" dir)
  77             (let* ((pkg (file-name-nondirectory dir))
  78                    (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir))
  79                    simple-p)
  80               ;; Omit autoloads and .elc files from the package.
  81               (if (file-exists-p autoloads-file)
  82                   (delete-file autoloads-file))
  83               (archive--delete-elc-files dir)
  84               ;; Test whether this is a simple or multi-file package.
  85               (setq simple-p (archive--simple-package-p dir pkg))
  86               (push (if (car simple-p)
  87                         (apply #'archive--process-simple-package
  88                                dir pkg (cdr simple-p))
  89                       (if simple-p
  90                           (apply #'archive--write-pkg-file
  91                                  dir pkg (cdr simple-p)))
  92                       (archive--process-multi-file-package dir pkg))
  93                     packages)))
  94         ((debug error) (error "Error in %s: %S" dir v))))
  95     (with-temp-buffer
  96       (pp (nreverse packages) (current-buffer))
  97       (write-region nil nil "archive-contents"))))
  98
  99 (defconst archive--revno-re "[0-9a-f]+")
 100
 101 (defun archive-prepare-packages (srcdir)
 102   "Prepare the `packages' directory inside the Git checkout.
 103 Expects to be called from within the `packages' directory.
 104 \"Prepare\" here is for subsequent construction of the packages and archive,
 105 so it is meant to refresh any generated files we may need.
 106 Currently only refreshes the ChangeLog files."
 107   (setq srcdir (file-name-as-directory (expand-file-name srcdir)))
 108   (let* ((wit ".changelog-witness")
 109          (prevno (with-temp-buffer
 110                    (ignore-errors (insert-file-contents wit))
 111                    (if (looking-at (concat archive--revno-re "$"))
 112                        (match-string 0)
 113                      (error "Can't find previous revision name"))))
 114          (new-revno
 115           (or (with-temp-buffer
 116                 (let ((default-directory srcdir))
 117                   (call-process "git" nil '(t) nil "rev-parse" "HEAD")
 118                   (goto-char (point-min))
 119                   (when (looking-at (concat archive--revno-re "$"))
 120                     (match-string 0))))
 121               (error "Couldn't find the current revision's name")))
 122          (pkgs '()))
 123     (unless (equal prevno new-revno)
 124       (with-temp-buffer
 125         (let ((default-directory srcdir))
 126           (unless (zerop (call-process "git" nil '(t) nil "diff"
 127                                        "--dirstat=cumulative,0"
 128                                        prevno))
 129             (error "Error signaled by git diff --dirstat %d" prevno)))
 130         (goto-char (point-min))
 131         (while (re-search-forward "^[ \t.0-9%]* packages/\\([-[:alnum:]]+\\)/$"
 132                                   nil t)
 133           (push (match-string 1) pkgs))))
 134     (let ((default-directory (expand-file-name "packages/")))
 135       (dolist (pkg pkgs)
 136         (condition-case v
 137             (if (file-directory-p pkg)
 138                 (archive--make-changelog pkg (expand-file-name "packages/"
 139                                                                srcdir)))
 140           (error (message "Error: %S" v)))))
 141     (write-region new-revno nil wit nil 'quiet)
 142     ;; Also update the ChangeLog of external packages.
 143     (let ((default-directory (expand-file-name "packages/")))
 144       (dolist (dir (directory-files "."))
 145         (and (not (member dir '("." "..")))
 146              (file-directory-p dir)
 147              (let ((index (expand-file-name
 148                            (concat "packages/" dir "/.git/index")
 149                            srcdir))
 150                    (cl (expand-file-name "ChangeLog" dir)))
 151                (and (file-exists-p index)
 152                     (or (not (file-exists-p cl))
 153                         (file-newer-than-file-p index cl))))
 154              (archive--make-changelog
 155               dir (expand-file-name "packages/" srcdir)))))
 156     ))
 157
 158 (defun archive--simple-package-p (dir pkg)
 159   "Test whether DIR contains a simple package named PKG.
 160 Return a list (SIMPLE VERSION DESCRIPTION REQ), where
 161 SIMPLE is non-nil if the package is indeed simple;
 162 VERSION is the version string of the simple package;
 163 DESCRIPTION is the brief description of the package;
 164 REQ is a list of requirements.
 165 Otherwise, return nil."
 166   (let* ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir))
 167          (mainfile (expand-file-name (concat pkg ".el") dir))
 168          (files (directory-files dir nil "\\.el\\'")))
 169     (setq files (delete (concat pkg "-pkg.el") files))
 170     (setq files (delete (concat pkg "-autoloads.el") files))
 171     (cond
 172      ((and (not (file-exists-p pkg-file))
 173            (file-exists-p mainfile))
 174       (with-temp-buffer
 175         (insert-file-contents mainfile)
 176         (goto-char (point-min))
 177         (if (not (looking-at ";;;.*---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$"))
 178             (error "Can't parse first line of %s" mainfile)
 179           ;; Grab the other fields, which are not mandatory.
 180           (let* ((description (match-string 1))
 181                  (version
 182                   (or (archive--strip-rcs-id (lm-header "package-version"))
 183                       (archive--strip-rcs-id (lm-header "version"))
 184                       (error "Missing `version' header")))
 185                  (requires-str (lm-header "package-requires"))
 186                  (pt (lm-header "package-type"))
 187                  (simple (if pt (equal pt "simple") (= (length files) 1)))
 188                  (req
 189                   (if requires-str
 190                       (mapcar 'archive--convert-require
 191                               (car (read-from-string requires-str))))))
 192             (list simple version description req)))))
 193      ((not (file-exists-p pkg-file))
 194       (error "Can find single file nor package desc file in %s" dir)))))
 195
 196 (defun archive--process-simple-package (dir pkg vers desc req)
 197   "Deploy the contents of DIR into the archive as a simple package.
 198 Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and return the descriptor."
 199   ;; Write DIR/foo.el to foo-VERS.el and delete DIR
 200   (rename-file (expand-file-name (concat pkg ".el") dir)
 201                (concat pkg "-" vers ".el"))
 202   ;; Add the content of the ChangeLog.
 203   (let ((cl (expand-file-name "ChangeLog" dir)))
 204     (with-current-buffer (find-file-noselect (concat pkg "-" vers ".el"))
 205       (goto-char (point-max))
 206       (re-search-backward "^;;;.*ends here")
 207       (re-search-backward "^(provide")
 208       (skip-chars-backward " \t\n")
 209       (insert "\n\n;;;; ChangeLog:\n\n")
 210       (let* ((start (point))
 211              (end (copy-marker start t)))
 212         (insert-file-contents cl)
 213         (goto-char end)
 214         (unless (bolp) (insert "\n"))
 215         (while (progn (forward-line -1) (>= (point) start))
 216           (insert ";; ")))
 217       (set (make-local-variable 'backup-inhibited) t)
 218       (basic-save-buffer)               ;Less chatty than save-buffer.
 219       (kill-buffer)))
 220   (delete-directory dir t)
 221   (cons (intern pkg) (vector (archive--version-to-list vers)
 222                              req desc 'single)))
 223
 224 (defun archive--make-changelog (dir srcdir)
 225   "Export Git log info of DIR into a ChangeLog file."
 226   (message "Refreshing ChangeLog in %S" dir)
 227   (let ((default-directory (file-name-as-directory (expand-file-name dir))))
 228     (with-temp-buffer
 229       (set-buffer-multibyte nil)
 230       (let ((coding-system-for-read 'binary)
 231             (coding-system-for-write 'binary))
 232         (if (file-readable-p "ChangeLog") (insert-file-contents "ChangeLog"))
 233         (let ((old-md5 (md5 (current-buffer))))
 234           (erase-buffer)
 235           (let ((default-directory
 236                   (file-name-as-directory (expand-file-name dir srcdir))))
 237             (call-process "git" nil (current-buffer) nil
 238                           "log" "--date=short"
 239                           "--format=%cd  %aN  <%ae>%n%n%w(80,8,8)%B%n"
 240                           "."))
 241           (tabify (point-min) (point-max))
 242           (goto-char (point-min))
 243           (while (re-search-forward "\n\n\n+" nil t)
 244             (replace-match "\n\n"))
 245           (if (equal old-md5 (md5 (current-buffer)))
 246               (message "ChangeLog's md5 unchanged for %S" dir)
 247             (write-region (point-min) (point-max) "ChangeLog" nil 'quiet)))))))
 248
 249 (defun archive--process-multi-file-package (dir pkg)
 250   "Deploy the contents of DIR into the archive as a multi-file package.
 251 Rename DIR/ to PKG-VERS/, and return the descriptor."
 252   (let* ((exp (archive--multi-file-package-def dir pkg))
 253          (vers (nth 2 exp))
 254          (req-exp (nth 4 exp))
 255          (req (mapcar 'archive--convert-require
 256                       (if (eq 'quote (car-safe req-exp)) (nth 1 req-exp)
 257                         (when req-exp
 258                           (error "REQ should be a quoted constant: %S"
 259                                  req-exp))))))
 260     (unless (equal (nth 1 exp) pkg)
 261       (error (format "Package name %s doesn't match file name %s"
 262                      (nth 1 exp) pkg)))
 263     (rename-file dir (concat pkg "-" vers))
 264     (cons (intern pkg) (vector (archive--version-to-list vers)
 265                                req (nth 3 exp) 'tar))))
 266
 267 (defun archive--multi-file-package-def (dir pkg)
 268   "Return the `define-package' form in the file DIR/PKG-pkg.el."
 269   (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)))
 270     (with-temp-buffer
 271       (unless (file-exists-p pkg-file)
 272         (error "File not found: %s" pkg-file))
 273       (insert-file-contents pkg-file)
 274       (goto-char (point-min))
 275       (read (current-buffer)))))
 276
 277 (defun archive--refresh-pkg-file ()
 278   (let* ((dir (directory-file-name default-directory))
 279          (pkg (file-name-nondirectory dir))
 280          (simple-p (archive--simple-package-p dir pkg)))
 281     (if simple-p
 282         (progn
 283           ;; (message "Refreshing pkg description of %s" pkg)
 284           (apply 'archive--write-pkg-file dir pkg (cdr simple-p)))
 285       ;; (message "Not refreshing pkg description of %s" pkg)
 286       )))
 287
 288 (defun archive--write-pkg-file (pkg-dir name version desc requires &rest ignored)
 289   (let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
 290         (print-level nil)
 291         (print-quoted t)
 292         (print-length nil))
 293     (write-region
 294      (concat (format ";; Generated package description from %s.el\n"
 295                      name)
 296              (prin1-to-string
 297               (list 'define-package
 298                     name
 299                     version
 300                     desc
 301                     (list 'quote
 302                           ;; Turn version lists into string form.
 303                           (mapcar
 304                            (lambda (elt)
 305                              (list (car elt)
 306                                    (package-version-join (cadr elt))))
 307                            requires))))
 308              "\n")
 309      nil
 310      pkg-file)))
 311
 312 ;;; Make the HTML pages for online browsing.
 313
 314 (defun archive--html-header (title)
 315   (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">
 316 <html>
 317 <head>
 318   <title>%s</title>
 319   <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
 320 </head>
 321 <body>
 322 <h1 align=\"center\">%s</h1>\n"
 323           title title))
 324
 325 (defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.
 326   (setq bytes (/ bytes 1024.0))
 327   (let ((units '(;; "B"
 328                  "kB" "MB" "GB" "TB")))
 329     (while (>= bytes 1024)
 330       (setq bytes (/ bytes 1024.0))
 331       (setq units (cdr units)))
 332     (cond
 333      ;; ((integerp bytes) (format "%4d%s" bytes (car units)))
 334      ((>= bytes 100) (format "%4.0f%s" bytes (car units)))
 335      ((>= bytes 10) (format "%4.1f%s" bytes (car units)))
 336      (t (format "%4.2f%s" bytes (car units))))))
 337
 338 (defun archive--get-prop (prop name srcdir mainsrcfile)
 339   (let ((kprop (intern (format ":%s" (downcase prop)))))
 340     (or
 341      (let ((pkgdescfile (expand-file-name (format "%s-pkg.el" name)
 342                                           srcdir)))
 343        (when (file-readable-p pkgdescfile)
 344          (with-temp-buffer
 345            (insert-file-contents pkgdescfile)
 346            (let ((desc (read (current-buffer))))
 347              (plist-get (cdr desc) kprop)))))
 348      (when (file-readable-p mainsrcfile)
 349        (with-temp-buffer
 350          (insert-file-contents mainsrcfile)
 351          (lm-header prop))))))
 352
 353 (defun archive--get-section (hsection fsection srcdir mainsrcfile)
 354   (when (consp fsection)
 355     (while (cdr-safe fsection)
 356       (setq fsection
 357             (if (file-readable-p (expand-file-name (car fsection) srcdir))
 358                 (car fsection)
 359               (cdr fsection))))
 360     (when (consp fsection) (setq fsection (car fsection))))
 361   (cond
 362    ((file-readable-p (expand-file-name fsection srcdir))
 363     (with-temp-buffer
 364       (insert-file-contents (expand-file-name fsection srcdir))
 365       (buffer-string)))
 366    ((file-readable-p mainsrcfile)
 367     (with-temp-buffer
 368       (insert-file-contents mainsrcfile)
 369       (let ((start (lm-section-start hsection)))
 370         (when start
 371           (insert
 372            (prog1
 373                (buffer-substring start (lm-section-end hsection))
 374              (erase-buffer)))
 375           (emacs-lisp-mode)
 376           (goto-char (point-min))
 377           (delete-region (point) (line-beginning-position 2))
 378           (uncomment-region (point-min) (point-max))
 379           (when (looking-at "^\\([ \t]*\n\\)+")
 380             (replace-match ""))
 381           (goto-char (point-max))
 382           (skip-chars-backward " \t\n")
 383           (delete-region (point) (point-max))
 384           (buffer-string)))))))
 385
 386 (defun archive--quote (txt)
 387   (replace-regexp-in-string "<" "&lt;"
 388                             (replace-regexp-in-string "&" "&amp;" txt)))
 389
 390 (defun archive--insert-repolinks (name srcdir mainsrcfile)
 391   (let ((url (archive--get-prop "URL" name srcdir mainsrcfile)))
 392     (if url
 393         (insert (format "<p>Origin: <a href=%S>%s</a></p>\n"
 394                         url (archive--quote url)))
 395       (let* ((externals
 396               (with-temp-buffer
 397                 (insert-file-contents
 398                  (expand-file-name "../../../elpa/externals-list" srcdir))
 399                 (read (current-buffer))))
 400              (external (eq :external (nth 1 (assoc name externals))))
 401              (git-sv "http://git.savannah.gnu.org/")
 402              (urls (if external
 403                        '("cgit/emacs/elpa.git/?h=externals/"
 404                          "gitweb/?p=emacs/elpa.git;a=shortlog;h=refs/heads/externals/")
 405                      '("cgit/emacs/elpa.git/tree/packages/"
 406                        "gitweb/?p=emacs/elpa.git;a=tree;f=packages/"))))
 407         (insert (format
 408                  (concat "<p>Browse repository: <a href=%S>%s</a>"
 409                          " or <a href=%S>%s</a></p>\n")
 410                  (concat git-sv (nth 0 urls) name)
 411                  'CGit
 412                  (concat git-sv (nth 1 urls) name)
 413                  'Gitweb))))))
 414
 415 (defun archive--html-make-pkg (pkg files)
 416   (let* ((name (symbol-name (car pkg)))
 417          (latest (package-version-join (aref (cdr pkg) 0)))
 418          (srcdir (expand-file-name name "../../build/packages"))
 419          (mainsrcfile (expand-file-name (format "%s.el" name) srcdir))
 420          (desc (aref (cdr pkg) 2)))
 421     (with-temp-buffer
 422       (insert (archive--html-header (format "GNU ELPA - %s" name)))
 423       (insert (format "<p>Description: %s</p>\n" (archive--quote desc)))
 424       (let* ((file (cdr (assoc latest files)))
 425              (attrs (file-attributes file)))
 426         (insert (format "<p>Latest: <a href=%S>%s</a>, %s, %s</p>\n"
 427                         file (archive--quote file)
 428                         (format-time-string "%Y-%b-%d" (nth 5 attrs))
 429                         (archive--html-bytes-format (nth 7 attrs)))))
 430       (let ((maint (archive--get-prop "Maintainer" name srcdir mainsrcfile)))
 431         (when maint
 432           (insert (format "<p>Maintainer: %s</p>\n" (archive--quote maint)))))
 433       (archive--insert-repolinks name srcdir mainsrcfile)
 434       (let ((rm (archive--get-section
 435                  "Commentary" '("README" "README.rst" "README.md" "README.org")
 436                  srcdir mainsrcfile)))
 437         (when rm
 438           (write-region rm nil (concat name "-readme.txt"))
 439           (insert "<h2>Full description</h2><pre>\n" (archive--quote rm)
 440                   "\n</pre>\n")))
 441       (unless (< (length files) 2)
 442         (insert (format "<h2>Old versions</h2><table cellpadding=\"3\" border=\"1\">\n"))
 443         (dolist (file files)
 444           (unless (equal (pop file) latest)
 445             (let ((attrs (file-attributes file)))
 446               (insert (format "<tr><td><a href=%S>%s</a></td><td>%s</td><td>%s</td>\n"
 447                               file (archive--quote file)
 448                               (format-time-string "%Y-%b-%d" (nth 5 attrs))
 449                               (archive--html-bytes-format (nth 7 attrs)))))))
 450         (insert "</table>\n"))
 451       (let ((news (archive--get-section
 452                    "News" '("NEWS" "NEWS.rst" "NEWS.md" "NEWS.org")
 453                    srcdir mainsrcfile)))
 454         (when news
 455           (insert "<h2>News</h2><pre>\n" (archive--quote news) "\n</pre>\n")))
 456       (insert "</body>\n")
 457       (write-region (point-min) (point-max) (concat name ".html")))))
 458
 459 (defun archive--html-make-index (pkgs)
 460   (with-temp-buffer
 461     (insert (archive--html-header "GNU ELPA Packages"))
 462     (insert "<table cellpadding=\"3\" border=\"1\">\n")
 463     (insert "<tr><th>Package</th><th>Version</th><th>Description</th></tr>\n")
 464     (dolist (pkg pkgs)
 465       (insert (format "<tr><td><a href=\"%s.html\">%s</a></td><td>%s</td><td>%s</td></tr>\n"
 466                       (car pkg) (car pkg)
 467                       (package-version-join (aref (cdr pkg) 0))
 468                       (aref (cdr pkg) 2))))
 469     (insert "</table></body>\n")
 470     (write-region (point-min) (point-max) "index.html")))
 471
 472 (defun batch-html-make-index ()
 473   (let ((packages (make-hash-table :test #'equal))
 474         (archive-contents
 475          (with-temp-buffer
 476            (insert-file-contents "archive-contents")
 477            (goto-char (point-min))
 478            ;; Skip the first element which is a version number.
 479            (cdr (read (current-buffer))))))
 480     (dolist (file (directory-files default-directory nil))
 481       (cond
 482        ((member file '("." ".." "elpa.rss" "index.html" "archive-contents")))
 483        ((string-match "\\.html\\'" file))
 484        ((string-match "-readme\\.txt\\'" file)
 485         (let ((name (substring file 0 (match-beginning 0))))
 486           (puthash name (gethash name packages) packages)))
 487        ((string-match "-\\([0-9][^-]*\\)\\.\\(tar\\|el\\)\\'" file)
 488         (let ((name (substring file 0 (match-beginning 0)))
 489               (version (match-string 1 file)))
 490           (push (cons version file) (gethash name packages))))
 491        (t (message "Unknown file %S" file))))
 492     (dolist (pkg archive-contents)
 493       (archive--html-make-pkg pkg (gethash (symbol-name (car pkg)) packages)))
 494     ;; FIXME: Add (old?) packages that are in `packages' but not in
 495     ;; archive-contents.
 496     (archive--html-make-index archive-contents)))
 497
 498 ;;; Maintain external packages.
 499
 500 (defconst archive--elpa-git-url "git://git.sv.gnu.org/emacs/elpa")
 501
 502 (defun archive-add/remove/update-externals ()
 503   (let ((exts (with-current-buffer (find-file-noselect "externals-list")
 504                 (goto-char (point-min))
 505                 (read (current-buffer)))))
 506     (let ((default-directory (expand-file-name "packages/")))
 507       ;; Remove "old/odd" externals.
 508       (dolist (dir (directory-files "."))
 509         (cond
 510          ((member dir '("." "..")) nil)
 511          ((assoc dir exts) nil)
 512          ((file-directory-p (expand-file-name (format "%s/.git" dir)))
 513           (let ((status
 514                  (with-temp-buffer
 515                    (let ((default-directory (file-name-as-directory
 516                                              (expand-file-name dir))))
 517                      (call-process "git" nil t nil "status" "--porcelain")
 518                      (buffer-string)))))
 519             (if (zerop (length status))
 520                 (progn (delete-directory dir 'recursive t)
 521                        (message "Deleted all of %s" dir))
 522               (message "Keeping leftover unclean %s:\n%s" dir status))))))
 523       (pcase-dolist (`(,dir ,kind ,_url) exts)
 524         (cond
 525          ((eq kind :subtree) nil)       ;Nothing to do.
 526          ((not (eq kind :external))
 527           (message "Unknown external package kind `%S' for %s" kind dir))
 528          ((not (file-exists-p dir))
 529           (let* ((branch (concat "externals/" dir))
 530                  (output
 531                   (with-temp-buffer
 532                     ;; FIXME: Use git-new-workdir!
 533                     (call-process "git" nil t nil "clone"
 534                                   "--reference" ".." "--branch" branch
 535                                   archive--elpa-git-url dir)
 536                     (buffer-string))))
 537             (message "Cloning branch %s:\n%s" dir output)))
 538          ((not (file-directory-p (concat dir "/.git")))
 539           (message "%s is in the way of an external, please remove!" dir))
 540          (t
 541           (let ((default-directory (file-name-as-directory
 542                                     (expand-file-name dir))))
 543             (with-temp-buffer
 544               (message "Running git pull in %S" default-directory)
 545               (call-process "git" nil t nil "pull")
 546               (message "Updated %s:%s" dir (buffer-string))))
 547           ))))))
 548
 549 (provide 'archive-contents)
 550 ;;; archive-contents.el ends here