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