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 (split-string (or (lm-header "keywords") "")
 191                                          "," t "[ ]+"))
 192                  (url (or (lm-header "url")
 193                           (format "http://elpa.gnu.org/packages/%s.html" pkg)))
 194                  (req
 195                   (if requires-str
 196                       (mapcar 'archive--convert-require
 197                               (car (read-from-string requires-str))))))
 198             (list simple version description req
 199                   ;; extra parameters
 200                   (list (cons :url url)
 201                         (cons :keywords keywords)))))))
 202      ((not (file-exists-p pkg-file))
 203       (error "Can find single file nor package desc file in %s" dir)))))
 204
 205 (defun archive--process-simple-package (dir pkg vers desc req extras)
 206   "Deploy the contents of DIR into the archive as a simple package.
 207 Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and return the descriptor."
 208   ;; Write DIR/foo.el to foo-VERS.el and delete DIR
 209   (rename-file (expand-file-name (concat pkg ".el") dir)
 210                (concat pkg "-" vers ".el"))
 211   ;; Add the content of the ChangeLog.
 212   (let ((cl (expand-file-name "ChangeLog" dir)))
 213     (with-current-buffer (find-file-noselect (concat pkg "-" vers ".el"))
 214       (goto-char (point-max))
 215       (re-search-backward "^;;;.*ends here")
 216       (re-search-backward "^(provide")
 217       (skip-chars-backward " \t\n")
 218       (insert "\n\n;;;; ChangeLog:\n\n")
 219       (let* ((start (point))
 220              (end (copy-marker start t)))
 221         (insert-file-contents cl)
 222         (goto-char end)
 223         (unless (bolp) (insert "\n"))
 224         (while (progn (forward-line -1) (>= (point) start))
 225           (insert ";; ")))
 226       (set (make-local-variable 'backup-inhibited) t)
 227       (basic-save-buffer)               ;Less chatty than save-buffer.
 228       (kill-buffer)))
 229   (delete-directory dir t)
 230   (cons (intern pkg) (vector (archive--version-to-list vers)
 231                              req desc 'single extras)))
 232
 233 (defun archive--make-changelog (dir srcdir)
 234   "Export Git log info of DIR into a ChangeLog file."
 235   (message "Refreshing ChangeLog in %S" dir)
 236   (let ((default-directory (file-name-as-directory (expand-file-name dir))))
 237     (with-temp-buffer
 238       (set-buffer-multibyte nil)
 239       (let ((coding-system-for-read 'binary)
 240             (coding-system-for-write 'binary))
 241         (if (file-readable-p "ChangeLog") (insert-file-contents "ChangeLog"))
 242         (let ((old-md5 (md5 (current-buffer))))
 243           (erase-buffer)
 244           (let ((default-directory
 245                   (file-name-as-directory (expand-file-name dir srcdir))))
 246             (call-process "git" nil (current-buffer) nil
 247                           "log" "--date=short"
 248                           "--format=%cd  %aN  <%ae>%n%n%w(80,8,8)%B%n"
 249                           "."))
 250           (tabify (point-min) (point-max))
 251           (goto-char (point-min))
 252           (while (re-search-forward "\n\n\n+" nil t)
 253             (replace-match "\n\n"))
 254           (if (equal old-md5 (md5 (current-buffer)))
 255               (message "ChangeLog's md5 unchanged for %S" dir)
 256             (write-region (point-min) (point-max) "ChangeLog" nil 'quiet)))))))
 257
 258 (defun archive--alist-to-plist (alist)
 259   (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))
 260
 261 (defun archive--plist-to-alist (plist)
 262   (let (alist)
 263     (while plist
 264       (let ((value (cadr plist)))
 265         (when value
 266           (push (cons (car plist) value)
 267                 alist)))
 268       (setq plist (cddr plist)))
 269     alist))
 270
 271 (defun archive--process-multi-file-package (dir pkg)
 272   "Deploy the contents of DIR into the archive as a multi-file package.
 273 Rename DIR/ to PKG-VERS/, and return the descriptor."
 274   (let* ((exp (archive--multi-file-package-def dir pkg))
 275          (vers (nth 2 exp))
 276          (req-exp (nth 4 exp))
 277          (req (mapcar 'archive--convert-require
 278                       (if (eq 'quote (car-safe req-exp)) (nth 1 req-exp)
 279                         (when req-exp
 280                           (error "REQ should be a quoted constant: %S"
 281                                  req-exp)))))
 282          (extras (archive--plist-to-alist (nthcdr 5 exp))))
 283     (unless (equal (nth 1 exp) pkg)
 284       (error (format "Package name %s doesn't match file name %s"
 285                      (nth 1 exp) pkg)))
 286     (rename-file dir (concat pkg "-" vers))
 287     (cons (intern pkg) (vector (archive--version-to-list vers)
 288                                req (nth 3 exp) 'tar extras))))
 289
 290 (defun archive--multi-file-package-def (dir pkg)
 291   "Return the `define-package' form in the file DIR/PKG-pkg.el."
 292   (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)))
 293     (with-temp-buffer
 294       (unless (file-exists-p pkg-file)
 295         (error "File not found: %s" pkg-file))
 296       (insert-file-contents pkg-file)
 297       (goto-char (point-min))
 298       (read (current-buffer)))))
 299
 300 (defun archive--refresh-pkg-file ()
 301   (let* ((dir (directory-file-name default-directory))
 302          (pkg (file-name-nondirectory dir))
 303          (simple-p (archive--simple-package-p dir pkg)))
 304     (if simple-p
 305         (progn
 306           ;; (message "Refreshing pkg description of %s" pkg)
 307           (apply 'archive--write-pkg-file dir pkg (cdr simple-p)))
 308       ;; (message "Not refreshing pkg description of %s" pkg)
 309       )))
 310
 311 (defun archive--write-pkg-file (pkg-dir name version desc requires extras)
 312   (let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
 313         (print-level nil)
 314         (print-quoted t)
 315         (print-length nil))
 316     (write-region
 317      (concat (format ";; Generated package description from %s.el\n"
 318                      name)
 319              (prin1-to-string
 320               (nconc
 321                (list 'define-package
 322                      name
 323                      version
 324                      desc
 325                      (list 'quote
 326                            ;; Turn version lists into string form.
 327                            (mapcar
 328                             (lambda (elt)
 329                               (list (car elt)
 330                                     (package-version-join (cadr elt))))
 331                             requires)))
 332                (archive--alist-to-plist extras)))
 333              "\n")
 334      nil
 335      pkg-file)))
 336
 337 ;;; Make the HTML pages for online browsing.
 338
 339 (defun archive--html-header (title)
 340   (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">
 341 <html>
 342 <head>
 343   <title>%s</title>
 344   <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
 345 </head>
 346 <body>
 347 <h1 align=\"center\">%s</h1>\n"
 348           title title))
 349
 350 (defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.
 351   (setq bytes (/ bytes 1024.0))
 352   (let ((units '(;; "B"
 353                  "kB" "MB" "GB" "TB")))
 354     (while (>= bytes 1024)
 355       (setq bytes (/ bytes 1024.0))
 356       (setq units (cdr units)))
 357     (cond
 358      ;; ((integerp bytes) (format "%4d%s" bytes (car units)))
 359      ((>= bytes 100) (format "%4.0f%s" bytes (car units)))
 360      ((>= bytes 10) (format "%4.1f%s" bytes (car units)))
 361      (t (format "%4.2f%s" bytes (car units))))))
 362
 363 (defun archive--get-prop (prop name srcdir mainsrcfile)
 364   (let ((kprop (intern (format ":%s" (downcase prop)))))
 365     (or
 366      (let ((pkgdescfile (expand-file-name (format "%s-pkg.el" name)
 367                                           srcdir)))
 368        (when (file-readable-p pkgdescfile)
 369          (with-temp-buffer
 370            (insert-file-contents pkgdescfile)
 371            (let ((desc (read (current-buffer))))
 372              (plist-get (cdr desc) kprop)))))
 373      (when (file-readable-p mainsrcfile)
 374        (with-temp-buffer
 375          (insert-file-contents mainsrcfile)
 376          (lm-header prop))))))
 377
 378 (defun archive--get-section (hsection fsection srcdir mainsrcfile)
 379   (when (consp fsection)
 380     (while (cdr-safe fsection)
 381       (setq fsection
 382             (if (file-readable-p (expand-file-name (car fsection) srcdir))
 383                 (car fsection)
 384               (cdr fsection))))
 385     (when (consp fsection) (setq fsection (car fsection))))
 386   (cond
 387    ((file-readable-p (expand-file-name fsection srcdir))
 388     (with-temp-buffer
 389       (insert-file-contents (expand-file-name fsection srcdir))
 390       (buffer-string)))
 391    ((file-readable-p mainsrcfile)
 392     (with-temp-buffer
 393       (insert-file-contents mainsrcfile)
 394       (let ((start (lm-section-start hsection)))
 395         (when start
 396           (insert
 397            (prog1
 398                (buffer-substring start (lm-section-end hsection))
 399              (erase-buffer)))
 400           (emacs-lisp-mode)
 401           (goto-char (point-min))
 402           (delete-region (point) (line-beginning-position 2))
 403           (uncomment-region (point-min) (point-max))
 404           (when (looking-at "^\\([ \t]*\n\\)+")
 405             (replace-match ""))
 406           (goto-char (point-max))
 407           (skip-chars-backward " \t\n")
 408           (delete-region (point) (point-max))
 409           (buffer-string)))))))
 410
 411 (defun archive--quote (txt)
 412   (replace-regexp-in-string "<" "&lt;"
 413                             (replace-regexp-in-string "&" "&amp;" txt)))
 414
 415 (defun archive--insert-repolinks (name srcdir mainsrcfile url)
 416   (if url
 417       (insert (format "<p>Origin: <a href=%S>%s</a></p>\n"
 418                       url (archive--quote url)))
 419     (let* ((externals
 420             (with-temp-buffer
 421               (insert-file-contents
 422                (expand-file-name "../../../elpa/externals-list" srcdir))
 423               (read (current-buffer))))
 424            (external (eq :external (nth 1 (assoc name externals))))
 425            (git-sv "http://git.savannah.gnu.org/")
 426            (urls (if external
 427                      '("cgit/emacs/elpa.git/?h=externals/"
 428                        "gitweb/?p=emacs/elpa.git;a=shortlog;h=refs/heads/externals/")
 429                    '("cgit/emacs/elpa.git/tree/packages/"
 430                      "gitweb/?p=emacs/elpa.git;a=tree;f=packages/"))))
 431       (insert (format
 432                (concat "<p>Browse repository: <a href=%S>%s</a>"
 433                        " or <a href=%S>%s</a></p>\n")
 434                (concat git-sv (nth 0 urls) name)
 435                'CGit
 436                (concat git-sv (nth 1 urls) name)
 437                'Gitweb)))))
 438
 439 (defun archive--html-make-pkg (pkg files)
 440   (let* ((name (symbol-name (car pkg)))
 441          (latest (package-version-join (aref (cdr pkg) 0)))
 442          (srcdir (expand-file-name name "../../build/packages"))
 443          (mainsrcfile (expand-file-name (format "%s.el" name) srcdir))
 444          (desc (aref (cdr pkg) 2)))
 445     (with-temp-buffer
 446       (insert (archive--html-header (format "GNU ELPA - %s" name)))
 447       (insert (format "<p>Description: %s</p>\n" (archive--quote desc)))
 448       (let* ((file (cdr (assoc latest files)))
 449              (attrs (file-attributes file)))
 450         (insert (format "<p>Latest: <a href=%S>%s</a>, %s, %s</p>\n"
 451                         file (archive--quote file)
 452                         (format-time-string "%Y-%b-%d" (nth 5 attrs))
 453                         (archive--html-bytes-format (nth 7 attrs)))))
 454       (let ((maint (archive--get-prop "Maintainer" name srcdir mainsrcfile)))
 455         (when maint
 456           (insert (format "<p>Maintainer: %s</p>\n" (archive--quote maint)))))
 457       (archive--insert-repolinks name srcdir mainsrcfile
 458                                  (cdr (assoc :url (aref (cdr pkg) 4))))
 459       (let ((rm (archive--get-section
 460                  "Commentary" '("README" "README.rst"
 461                                 ;; Most README.md files seem to be currently
 462                                 ;; worse than the Commentary: section :-(
 463                                 ;; "README.md"
 464                                 "README.org")
 465                  srcdir mainsrcfile)))
 466         (when rm
 467           (write-region rm nil (concat name "-readme.txt"))
 468           (insert "<h2>Full description</h2><pre>\n" (archive--quote rm)
 469                   "\n</pre>\n")))
 470       (unless (< (length files) 2)
 471         (insert (format "<h2>Old versions</h2><table cellpadding=\"3\" border=\"1\">\n"))
 472         (dolist (file files)
 473           (unless (equal (pop file) latest)
 474             (let ((attrs (file-attributes file)))
 475               (insert (format "<tr><td><a href=%S>%s</a></td><td>%s</td><td>%s</td>\n"
 476                               file (archive--quote file)
 477                               (format-time-string "%Y-%b-%d" (nth 5 attrs))
 478                               (archive--html-bytes-format (nth 7 attrs)))))))
 479         (insert "</table>\n"))
 480       (let ((news (archive--get-section
 481                    "News" '("NEWS" "NEWS.rst" "NEWS.md" "NEWS.org")
 482                    srcdir mainsrcfile)))
 483         (when news
 484           (insert "<h2>News</h2><pre>\n" (archive--quote news) "\n</pre>\n")))
 485       (insert "</body>\n")
 486       (write-region (point-min) (point-max) (concat name ".html")))))
 487
 488 (defun archive--html-make-index (pkgs)
 489   (with-temp-buffer
 490     (insert (archive--html-header "GNU ELPA Packages"))
 491     (insert "<table cellpadding=\"3\" border=\"1\">\n")
 492     (insert "<tr><th>Package</th><th>Version</th><th>Description</th></tr>\n")
 493     (dolist (pkg pkgs)
 494       (insert (format "<tr><td><a href=\"%s.html\">%s</a></td><td>%s</td><td>%s</td></tr>\n"
 495                       (car pkg) (car pkg)
 496                       (package-version-join (aref (cdr pkg) 0))
 497                       (aref (cdr pkg) 2))))
 498     (insert "</table></body>\n")
 499     (write-region (point-min) (point-max) "index.html")))
 500
 501 (defun batch-html-make-index ()
 502   (let ((packages (make-hash-table :test #'equal))
 503         (archive-contents
 504          (with-temp-buffer
 505            (insert-file-contents "archive-contents")
 506            (goto-char (point-min))
 507            ;; Skip the first element which is a version number.
 508            (cdr (read (current-buffer))))))
 509     (dolist (file (directory-files default-directory nil))
 510       (cond
 511        ((member file '("." ".." "elpa.rss" "index.html" "archive-contents")))
 512        ((string-match "\\.html\\'" file))
 513        ((string-match "-readme\\.txt\\'" file)
 514         (let ((name (substring file 0 (match-beginning 0))))
 515           (puthash name (gethash name packages) packages)))
 516        ((string-match "-\\([0-9][^-]*\\)\\.\\(tar\\|el\\)\\'" file)
 517         (let ((name (substring file 0 (match-beginning 0)))
 518               (version (match-string 1 file)))
 519           (push (cons version file) (gethash name packages))))
 520        (t (message "Unknown file %S" file))))
 521     (dolist (pkg archive-contents)
 522       (archive--html-make-pkg pkg (gethash (symbol-name (car pkg)) packages)))
 523     ;; FIXME: Add (old?) packages that are in `packages' but not in
 524     ;; archive-contents.
 525     (archive--html-make-index archive-contents)))
 526
 527 ;;; Maintain external packages.
 528
 529 (defconst archive--elpa-git-url "git://git.sv.gnu.org/emacs/elpa")
 530
 531 (defun archive-add/remove/update-externals ()
 532   (let ((exts (with-current-buffer (find-file-noselect "externals-list")
 533                 (goto-char (point-min))
 534                 (read (current-buffer)))))
 535     (let ((default-directory (expand-file-name "packages/")))
 536       ;; Remove "old/odd" externals.
 537       (dolist (dir (directory-files "."))
 538         (cond
 539          ((member dir '("." "..")) nil)
 540          ((assoc dir exts) nil)
 541          ((file-directory-p (expand-file-name (format "%s/.git" dir)))
 542           (let ((status
 543                  (with-temp-buffer
 544                    (let ((default-directory (file-name-as-directory
 545                                              (expand-file-name dir))))
 546                      (call-process "git" nil t nil "status" "--porcelain")
 547                      (buffer-string)))))
 548             (if (zerop (length status))
 549                 (progn (delete-directory dir 'recursive t)
 550                        (message "Deleted all of %s" dir))
 551               (message "Keeping leftover unclean %s:\n%s" dir status))))))
 552       (pcase-dolist (`(,dir ,kind ,_url) exts)
 553         (cond
 554          ((eq kind :subtree) nil)       ;Nothing to do.
 555          ((not (eq kind :external))
 556           (message "Unknown external package kind `%S' for %s" kind dir))
 557          ((not (file-exists-p dir))
 558           (let* ((branch (concat "externals/" dir))
 559                  (output
 560                   (with-temp-buffer
 561                     ;; FIXME: Use git-new-workdir!
 562                     (call-process "git" nil t nil "clone"
 563                                   "--reference" ".." "--branch" branch
 564                                   archive--elpa-git-url dir)
 565                     (buffer-string))))
 566             (message "Cloning branch %s:\n%s" dir output)))
 567          ((not (file-directory-p (concat dir "/.git")))
 568           (message "%s is in the way of an external, please remove!" dir))
 569          (t
 570           (let ((default-directory (file-name-as-directory
 571                                     (expand-file-name dir))))
 572             (with-temp-buffer
 573               (message "Running git pull in %S" default-directory)
 574               (call-process "git" nil t nil "pull")
 575               (message "Updated %s:%s" dir (buffer-string))))
 576           ))))))
 577
 578 (provide 'archive-contents)
 579 ;;; archive-contents.el ends here