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