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