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-2015  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 (or (with-demoted-errors
  73                                     ;;(format "batch-make-archive %s: %%s" dir)
  74                                     (archive--metadata dir pkg))
  75                                   '(nil "0"))))
  76                 ;; (nth 1 metadata) is nil for "org" which is the only package
  77                 ;; still using the "org-pkg.el file to specify the metadata.
  78                 (if (and (nth 1 metadata)
  79                          (or (equal (nth 1 metadata) "0")
  80                              ;; Old deprecated convention.
  81                              (< (string-to-number (nth 1 metadata)) 0)))
  82                     (progn ;; Negative version: don't publish this package yet!
  83                       (message "Package %s not released yet!" dir)
  84                       (delete-directory dir 'recursive))
  85                   (push (if (car metadata)
  86                             (apply #'archive--process-simple-package
  87                                    dir pkg (cdr metadata))
  88                           (if (nth 1 metadata)
  89                               (apply #'archive--write-pkg-file
  90                                      dir pkg (cdr metadata)))
  91                           (archive--process-multi-file-package dir pkg))
  92                         packages)))))
  93         ((debug error) (error "Error in %s: %S" dir v))))
  94     (with-temp-buffer
  95       (pp (nreverse packages) (current-buffer))
  96       (write-region nil nil "archive-contents"))))
  97
  98 (defconst archive--revno-re "[0-9a-f]+")
  99
 100 (defun archive-prepare-packages (srcdir)
 101   "Prepare the `packages' directory inside the Git checkout.
 102 Expects to be called from within the `packages' directory.
 103 \"Prepare\" here is for subsequent construction of the packages and archive,
 104 so it is meant to refresh any generated files we may need.
 105 Currently only refreshes the ChangeLog files."
 106   (setq srcdir (file-name-as-directory (expand-file-name srcdir)))
 107   (let* ((wit ".changelog-witness")
 108          (prevno (with-temp-buffer
 109                    (insert-file-contents wit)
 110                    (if (looking-at (concat archive--revno-re "$"))
 111                        (match-string 0)
 112                      (error "Can't find previous revision name"))))
 113          (new-revno
 114           (or (with-temp-buffer
 115                 (let ((default-directory srcdir))
 116                   (call-process "git" nil '(t) nil "rev-parse" "HEAD")
 117                   (goto-char (point-min))
 118                   (when (looking-at (concat archive--revno-re "$"))
 119                     (match-string 0))))
 120               (error "Couldn't find the current revision's name")))
 121          (pkgs '()))
 122     (unless (equal prevno new-revno)
 123       (with-temp-buffer
 124         (let ((default-directory srcdir))
 125           (unless (zerop (call-process "git" nil '(t) nil "diff"
 126                                        "--dirstat=cumulative,0"
 127                                        prevno))
 128             (error "Error signaled by git diff --dirstat %d" prevno)))
 129         (goto-char (point-min))
 130         (while (re-search-forward "^[ \t.0-9%]* packages/\\([-[:alnum:]]+\\)/$"
 131                                   nil t)
 132           (push (match-string 1) pkgs))))
 133     (let ((default-directory (expand-file-name "packages/")))
 134       (dolist (pkg pkgs)
 135         (condition-case v
 136             (if (file-directory-p pkg)
 137                 (archive--make-changelog pkg (expand-file-name "packages/"
 138                                                                srcdir)))
 139           (error (message "Error: %S" v)))))
 140     (write-region new-revno nil wit nil 'quiet)
 141     ;; Also update the ChangeLog of external packages.
 142     (let ((default-directory (expand-file-name "packages/")))
 143       (dolist (dir (directory-files "."))
 144         (and (not (member dir '("." "..")))
 145              (file-directory-p dir)
 146              (let ((index (expand-file-name
 147                            (concat "packages/" dir "/.git/index")
 148                            srcdir))
 149                    (cl (expand-file-name "ChangeLog" dir)))
 150                (and (file-exists-p index)
 151                     (or (not (file-exists-p cl))
 152                         (file-newer-than-file-p index cl))))
 153              (archive--make-changelog
 154               dir (expand-file-name "packages/" srcdir)))))
 155     ))
 156
 157 (defconst archive-default-url-format "http://elpa.gnu.org/packages/%s.html")
 158 (defconst archive-default-url-re (format archive-default-url-format ".*"))
 159
 160 (defun archive--metadata (dir pkg)
 161   "Return a list (SIMPLE VERSION DESCRIPTION REQ EXTRAS),
 162 where SIMPLE is non-nil if the package is 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
 168 PKG is the name of the package and DIR is the directory where it is."
 169   (let* ((mainfile (expand-file-name (concat pkg ".el") dir))
 170          (files (directory-files dir nil "\\`dir\\'\\|\\.el\\'")))
 171     (setq files (delete (concat pkg "-pkg.el") files))
 172     (setq files (delete (concat pkg "-autoloads.el") files))
 173     (cond
 174      ((file-exists-p mainfile)
 175       (with-temp-buffer
 176         (insert-file-contents mainfile)
 177         (goto-char (point-min))
 178         (if (not (looking-at ";;;.*---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$"))
 179             (error "Can't parse first line of %s" mainfile)
 180           ;; Grab the other fields, which are not mandatory.
 181           (let* ((description (match-string 1))
 182                  (pv )
 183                  (version
 184                   (or (lm-header "package-version")
 185                       (lm-header "version")
 186                       (unless (equal pkg "org")
 187                         (error "Missing `version' header"))))
 188                  (_ (archive--version-to-list version)) ; Sanity check!
 189                  (requires-str (lm-header "package-requires"))
 190                  (pt (lm-header "package-type"))
 191                  (simple (if pt (equal pt "simple") (= (length files) 1)))
 192                  (keywords (lm-keywords-list))
 193                  (url (or (lm-header "url")
 194                           (format archive-default-url-format pkg)))
 195                  (req
 196                   (if requires-str
 197                       (mapcar 'archive--convert-require
 198                               (car (read-from-string requires-str))))))
 199             (list simple version description req
 200                   ;; extra parameters
 201                   (list (cons :url url)
 202                         (cons :keywords keywords)))))))
 203      (t
 204       (error "Can't find main file %s file in %s" mainfile dir)))))
 205
 206 (defun archive--process-simple-package (dir pkg vers desc req extras)
 207   "Deploy the contents of DIR into the archive as a simple package.
 208 Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and return the descriptor."
 209   ;; Write DIR/foo.el to foo-VERS.el and delete DIR
 210   (let ((src (expand-file-name (concat pkg ".el") dir)))
 211     (funcall (if (file-symlink-p src) #'copy-file #'rename-file)
 212              src (concat pkg "-" vers ".el")))
 213   ;; Add the content of the ChangeLog.
 214   (let ((cl (expand-file-name "ChangeLog" dir)))
 215     (with-current-buffer (find-file-noselect (concat pkg "-" vers ".el"))
 216       (goto-char (point-max))
 217       (re-search-backward "^;;;.*ends here")
 218       (re-search-backward "^(provide")
 219       (skip-chars-backward " \t\n")
 220       (insert "\n\n;;;; ChangeLog:\n\n")
 221       (let* ((start (point))
 222              (end (copy-marker start t)))
 223         (condition-case nil
 224             (insert-file-contents cl)
 225           (file-error (message "Can't find %S's ChangeLog file" pkg)))
 226         (goto-char end)
 227         (unless (bolp) (insert "\n"))
 228         (while (progn (forward-line -1) (>= (point) start))
 229           (insert ";; ")))
 230       (set (make-local-variable 'backup-inhibited) t)
 231       (basic-save-buffer)               ;Less chatty than save-buffer.
 232       (kill-buffer)))
 233   (delete-directory dir t)
 234   (cons (intern pkg) (vector (archive--version-to-list vers)
 235                              req desc 'single extras)))
 236
 237 (defun archive--make-changelog (dir srcdir)
 238   "Export Git log info of DIR into a ChangeLog file."
 239   (message "Refreshing ChangeLog in %S" dir)
 240   (let ((default-directory (file-name-as-directory (expand-file-name dir))))
 241     (with-temp-buffer
 242       (set-buffer-multibyte nil)
 243       (let ((coding-system-for-read 'binary)
 244             (coding-system-for-write 'binary))
 245         (if (file-readable-p "ChangeLog") (insert-file-contents "ChangeLog"))
 246         (let ((old-md5 (md5 (current-buffer))))
 247           (erase-buffer)
 248           (let ((default-directory
 249                   (file-name-as-directory (expand-file-name dir srcdir))))
 250             (call-process "git" nil (current-buffer) nil
 251                           "log" "--date=short"
 252                           "--format=%cd  %aN  <%ae>%n%n%w(80,8,8)%B%n"
 253                           "."))
 254           (tabify (point-min) (point-max))
 255           (goto-char (point-min))
 256           (while (re-search-forward "\n\n\n+" nil t)
 257             (replace-match "\n\n"))
 258           (if (equal old-md5 (md5 (current-buffer)))
 259               (message "ChangeLog's md5 unchanged for %S" dir)
 260             (write-region (point-min) (point-max) "ChangeLog" nil 'quiet)))))))
 261
 262 (defun archive--alist-to-plist-args (alist)
 263   (mapcar (lambda (x)
 264             (if (and (not (consp x))
 265                      (or (keywordp x)
 266                          (not (symbolp x))
 267                          (memq x '(nil t))))
 268                 x `',x))
 269           (apply #'nconc
 270                  (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist))))
 271
 272 (defun archive--plist-args-to-alist (plist)
 273   (let (alist)
 274     (while plist
 275       (let ((value (cadr plist)))
 276         (when value
 277           (cl-assert (keywordp (car plist)))
 278           (push (cons (car plist)
 279                       (if (eq 'quote (car-safe value)) (cadr value) value))
 280                 alist)))
 281       (setq plist (cddr plist)))
 282     alist))
 283
 284 (defun archive--process-multi-file-package (dir pkg)
 285   "Deploy the contents of DIR into the archive as a multi-file package.
 286 Rename DIR/ to PKG-VERS/, and return the descriptor."
 287   (let* ((exp (archive--multi-file-package-def dir pkg))
 288          (vers (nth 2 exp))
 289          (req-exp (nth 4 exp))
 290          (req (mapcar 'archive--convert-require
 291                       (if (eq 'quote (car-safe req-exp)) (nth 1 req-exp)
 292                         (when req-exp
 293                           (error "REQ should be a quoted constant: %S"
 294                                  req-exp)))))
 295          (extras (archive--plist-args-to-alist (nthcdr 5 exp))))
 296     (unless (equal (nth 1 exp) pkg)
 297       (error (format "Package name %s doesn't match file name %s"
 298                      (nth 1 exp) pkg)))
 299     (rename-file dir (concat pkg "-" vers))
 300     (cons (intern pkg) (vector (archive--version-to-list vers)
 301                                req (nth 3 exp) 'tar extras))))
 302
 303 (defun archive--multi-file-package-def (dir pkg)
 304   "Return the `define-package' form in the file DIR/PKG-pkg.el."
 305   (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)))
 306     (with-temp-buffer
 307       (unless (file-exists-p pkg-file)
 308         (error "File not found: %s" pkg-file))
 309       (insert-file-contents pkg-file)
 310       (goto-char (point-min))
 311       (read (current-buffer)))))
 312
 313 (defun archive--refresh-pkg-file ()
 314   (let* ((dir (directory-file-name default-directory))
 315          (pkg (file-name-nondirectory dir)))
 316     (apply #'archive--write-pkg-file dir pkg
 317            (cdr (archive--metadata dir pkg)))))
 318
 319 (defun archive--write-pkg-file (pkg-dir name version desc requires extras)
 320   (let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
 321         (print-level nil)
 322         (print-quoted t)
 323         (print-length nil))
 324     (write-region
 325      (concat (format ";; Generated package description from %s.el\n"
 326                      name)
 327              (prin1-to-string
 328               (nconc
 329                (list 'define-package
 330                      name
 331                      version
 332                      desc
 333                      (list 'quote
 334                            ;; Turn version lists into string form.
 335                            (mapcar
 336                             (lambda (elt)
 337                               (list (car elt)
 338                                     (package-version-join (cadr elt))))
 339                             requires)))
 340                (archive--alist-to-plist-args extras)))
 341              "\n")
 342      nil
 343      pkg-file)))
 344
 345 ;;; Make the HTML pages for online browsing.
 346
 347 (defun archive--html-header (title)
 348   (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">
 349 <html>
 350 <head>
 351   <title>%s</title>
 352   <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
 353 </head>
 354 <body>
 355 <h1 align=\"center\">%s</h1>\n"
 356           title title))
 357
 358 (defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.
 359   (setq bytes (/ bytes 1024.0))
 360   (let ((units '(;; "B"
 361                  "kB" "MB" "GB" "TB")))
 362     (while (>= bytes 1024)
 363       (setq bytes (/ bytes 1024.0))
 364       (setq units (cdr units)))
 365     (cond
 366      ;; ((integerp bytes) (format "%4d%s" bytes (car units)))
 367      ((>= bytes 100) (format "%4.0f%s" bytes (car units)))
 368      ((>= bytes 10) (format "%4.1f%s" bytes (car units)))
 369      (t (format "%4.2f%s" bytes (car units))))))
 370
 371 (defun archive--get-prop (prop name srcdir mainsrcfile)
 372   (let ((kprop (intern (format ":%s" (downcase prop)))))
 373     (or
 374      (let ((pkgdescfile (expand-file-name (format "%s-pkg.el" name)
 375                                           srcdir)))
 376        (when (file-readable-p pkgdescfile)
 377          (with-temp-buffer
 378            (insert-file-contents pkgdescfile)
 379            (let ((desc (read (current-buffer))))
 380              (plist-get (cdr desc) kprop)))))
 381      (when (file-readable-p mainsrcfile)
 382        (with-temp-buffer
 383          (insert-file-contents mainsrcfile)
 384          (lm-header prop))))))
 385
 386 (defun archive--get-section (hsection fsection srcdir mainsrcfile)
 387   (when (consp fsection)
 388     (while (cdr-safe fsection)
 389       (setq fsection
 390             (if (file-readable-p (expand-file-name (car fsection) srcdir))
 391                 (car fsection)
 392               (cdr fsection))))
 393     (when (consp fsection) (setq fsection (car fsection))))
 394   (cond
 395    ((file-readable-p (expand-file-name fsection srcdir))
 396     (with-temp-buffer
 397       (insert-file-contents (expand-file-name fsection srcdir))
 398       (buffer-string)))
 399    ((file-readable-p mainsrcfile)
 400     (with-temp-buffer
 401       (insert-file-contents mainsrcfile)
 402       (emacs-lisp-mode)       ;lm-section-start needs the outline-mode setting.
 403       (let ((start (lm-section-start hsection)))
 404         (when start
 405           (insert
 406            (prog1
 407                (buffer-substring start (lm-section-end hsection))
 408              (erase-buffer)))
 409           (emacs-lisp-mode)
 410           (goto-char (point-min))
 411           (delete-region (point) (line-beginning-position 2))
 412           (uncomment-region (point-min) (point-max))
 413           (when (looking-at "^\\([ \t]*\n\\)+")
 414             (replace-match ""))
 415           (goto-char (point-max))
 416           (skip-chars-backward " \t\n")
 417           (delete-region (point) (point-max))
 418           (buffer-string)))))))
 419
 420 (defun archive--quote (txt)
 421   (replace-regexp-in-string "<" "&lt;"
 422                             (replace-regexp-in-string "&" "&amp;" txt)))
 423
 424 (defun archive--insert-repolinks (name srcdir mainsrcfile url)
 425   (when url
 426     (insert (format "<p>Home page: <a href=%S>%s</a></p>\n"
 427                     url (archive--quote url)))
 428     (when (string-match archive-default-url-re url)
 429       (setq url nil)))
 430   (let* ((externals
 431           (with-temp-buffer
 432             (insert-file-contents
 433              (expand-file-name "../../../elpa/externals-list" srcdir))
 434             (read (current-buffer))))
 435          (external (eq :external (nth 1 (assoc name externals))))
 436          (git-sv "http://git.savannah.gnu.org/")
 437          (urls (if external
 438                    '("cgit/emacs/elpa.git/?h=externals/"
 439                      "gitweb/?p=emacs/elpa.git;a=shortlog;h=refs/heads/externals/")
 440                  '("cgit/emacs/elpa.git/tree/packages/"
 441                    "gitweb/?p=emacs/elpa.git;a=tree;f=packages/"))))
 442     (insert (format
 443              (concat (format "<p>Browse %srepository: " (if url "ELPA's " ""))
 444                      "<a href=%S>%s</a> or <a href=%S>%s</a></p>\n")
 445              (concat git-sv (nth 0 urls) name)
 446              'CGit
 447              (concat git-sv (nth 1 urls) name)
 448              'Gitweb))))
 449
 450 (defun archive--html-make-pkg (pkg files)
 451   (let* ((name (symbol-name (car pkg)))
 452          (latest (package-version-join (aref (cdr pkg) 0)))
 453          (srcdir (expand-file-name name "../../build/packages"))
 454          (mainsrcfile (expand-file-name (format "%s.el" name) srcdir))
 455          (desc (aref (cdr pkg) 2)))
 456     (with-temp-buffer
 457       (insert (archive--html-header (format "GNU ELPA - %s" name)))
 458       (insert (format "<p>Description: %s</p>\n" (archive--quote desc)))
 459       (if (zerop (length latest))
 460           (insert "<p>This package "
 461                   (if files "is not in GNU ELPA any more"
 462                     "has not been released yet")
 463                   ".</p>\n")
 464         (let* ((file (cdr (assoc latest files)))
 465                (attrs (file-attributes file)))
 466           (insert (format "<p>Latest: <a href=%S>%s</a>, %s, %s</p>\n"
 467                           file (archive--quote file)
 468                           (format-time-string "%Y-%b-%d" (nth 5 attrs))
 469                           (archive--html-bytes-format (nth 7 attrs))))))
 470       (let ((maint (archive--get-prop "Maintainer" name srcdir mainsrcfile)))
 471         (when maint
 472           (insert (format "<p>Maintainer: %s</p>\n" (archive--quote maint)))))
 473       (archive--insert-repolinks
 474        name srcdir mainsrcfile
 475        (or (cdr (assoc :url (aref (cdr pkg) 4)))
 476            (archive--get-prop "URL" name srcdir mainsrcfile)))
 477       (let ((rm (archive--get-section
 478                  "Commentary" '("README" "README.rst"
 479                                 ;; Most README.md files seem to be currently
 480                                 ;; worse than the Commentary: section :-(
 481                                 ;; "README.md"
 482                                 "README.org")
 483                  srcdir mainsrcfile)))
 484         (when rm
 485           (write-region rm nil (concat name "-readme.txt"))
 486           (insert "<h2>Full description</h2><pre>\n" (archive--quote rm)
 487                   "\n</pre>\n")))
 488       (unless (< (length files) (if (zerop (length latest)) 1 2))
 489         (insert (format "<h2>Old versions</h2><table cellpadding=\"3\" border=\"1\">\n"))
 490         (dolist (file files)
 491           (unless (equal (pop file) latest)
 492             (let ((attrs (file-attributes file)))
 493               (insert (format "<tr><td><a href=%S>%s</a></td><td>%s</td><td>%s</td>\n"
 494                               file (archive--quote file)
 495                               (format-time-string "%Y-%b-%d" (nth 5 attrs))
 496                               (archive--html-bytes-format (nth 7 attrs)))))))
 497         (insert "</table>\n"))
 498       (let ((news (archive--get-section
 499                    "News" '("NEWS" "NEWS.rst" "NEWS.md" "NEWS.org")
 500                    srcdir mainsrcfile)))
 501         (when news
 502           (insert "<h2>News</h2><pre>\n" (archive--quote news) "\n</pre>\n")))
 503       (insert "</body>\n")
 504       (write-region (point-min) (point-max) (concat name ".html")))))
 505
 506 (defun archive--html-make-index (pkgs)
 507   (with-temp-buffer
 508     (insert (archive--html-header "GNU ELPA Packages"))
 509     (insert "<table cellpadding=\"3\" border=\"1\">\n")
 510     (insert "<tr><th>Package</th><th>Version</th><th>Description</th></tr>\n")
 511     (dolist (pkg pkgs)
 512       (insert (format "<tr><td><a href=\"%s.html\">%s</a></td><td>%s</td><td>%s</td></tr>\n"
 513                       (car pkg) (car pkg)
 514                       (package-version-join (aref (cdr pkg) 0))
 515                       (aref (cdr pkg) 2))))
 516     (insert "</table></body>\n")
 517     (write-region (point-min) (point-max) "index.html")))
 518
 519 (defun batch-html-make-index ()
 520   (let ((packages (make-hash-table :test #'equal))
 521         (archive-contents
 522          (with-temp-buffer
 523            (insert-file-contents "archive-contents")
 524            (goto-char (point-min))
 525            ;; Skip the first element which is a version number.
 526            (cdr (read (current-buffer))))))
 527     (dolist (subdir (directory-files "../../build/packages" nil))
 528       (cond
 529        ((member subdir '("." ".." "elpa.rss" "index.html" "archive-contents")))
 530        (t (puthash subdir nil packages))))
 531     (dolist (file (directory-files default-directory nil))
 532       (cond
 533        ((member file '("." ".." "elpa.rss" "index.html" "archive-contents")))
 534        ((string-match "\\.html\\'" file))
 535        ((string-match "\\.sig\\'" file))
 536        ((string-match "-readme\\.txt\\'" file)
 537         (let ((name (substring file 0 (match-beginning 0))))
 538           (puthash name (gethash name packages) packages)))
 539        ((string-match "-\\([0-9][^-]*\\)\\.\\(tar\\|el\\)\\'" file)
 540         (let ((name (substring file 0 (match-beginning 0)))
 541               (version (match-string 1 file)))
 542           (push (cons version file) (gethash name packages))))
 543        (t (message "Unknown file %S" file))))
 544     (maphash (lambda (pkg-name files)
 545                (archive--html-make-pkg
 546                 (let ((pkg (intern pkg-name)))
 547                   (or (assq pkg archive-contents)
 548                       ;; Add entries for packages that are either not yet
 549                       ;; released or not released any more.
 550                       ;; FIXME: Get actual description!
 551                       (let ((entry (cons pkg (vector nil nil "" nil nil))))
 552                         (setq archive-contents
 553                               ;; Add entry at the end.
 554                               (nconc archive-contents (list entry)))
 555                         entry)))
 556                 files))
 557              packages)
 558     (archive--html-make-index archive-contents)))
 559
 560 ;;; Maintain external packages.
 561
 562 (defconst archive--elpa-git-url "git://git.sv.gnu.org/emacs/elpa")
 563 (defconst archive--emacs-git-url "git://git.sv.gnu.org/emacs.git")
 564
 565 (defun archive--sync-emacs-repo ()
 566   "Clone and sync Emacs repository."
 567   (let ((reference (expand-file-name
 568                     (or (getenv "EMACS_CLONE_REFERENCE") "../emacs/master")))
 569         (emacs-repo-root (expand-file-name "emacs")))
 570     (when (and (file-exists-p emacs-repo-root)
 571                (not (file-exists-p
 572                      (expand-file-name "README" emacs-repo-root))))
 573       (message "Cleaning stalled Emacs clone: %s" emacs-repo-root)
 574       (delete-directory emacs-repo-root t))
 575     (cond ((file-exists-p emacs-repo-root)
 576            (let ((default-directory emacs-repo-root))
 577              (message "Running git pull in %S" default-directory)
 578              (call-process "git" nil t nil "pull")))
 579           ((file-exists-p reference)
 580            (message "Emacs repository reference found: %s" reference)
 581            (call-process
 582             "git" nil t nil
 583             "clone" archive--emacs-git-url
 584             "--reference" reference
 585             emacs-repo-root))
 586           (t
 587            (error
 588             (concat "Emacs repository not found at: %s\n"
 589                     "Point EMACS_CLONE_REFERENCE environment variable to an "
 590                     "existing checkout.") reference)))))
 591
 592 (defun archive--cleanup-packages (externals-list)
 593   "Remove subdirectories of `packages/' that do not correspond to known packages.
 594 This is any subdirectory inside `packages/' that's not under
 595 version control nor listed in EXTERNALS-LIST."
 596   (let ((default-directory (expand-file-name "packages/")))
 597     (dolist (dir (directory-files "."))
 598       (cond
 599        ((or (not (file-directory-p dir)) (file-symlink-p dir))
 600         ;; We only add/remove plain directories in elpa/packages (not symlinks).
 601         nil)
 602        ((member dir '("." "..")) nil)
 603        ((assoc dir externals-list) nil)
 604        ((file-directory-p (expand-file-name (format "%s/.git" dir)))
 605         (let ((status
 606                (with-temp-buffer
 607                  (let ((default-directory (file-name-as-directory
 608                                            (expand-file-name dir))))
 609                    (call-process "git" nil t nil "status" "--porcelain")
 610                    (buffer-string)))))
 611           (if (zerop (length status))
 612               (progn (delete-directory dir 'recursive t)
 613                      (message "Deleted all of %s" dir))
 614             (message "Keeping leftover unclean %s:\n%s" dir status))))
 615        ;; Check if `dir' is under version control.
 616        ((not (zerop (call-process "git" nil nil nil
 617                                   "ls-files" "--error-unmatch" dir)))
 618         (message "Deleted untracked package %s" dir)
 619         (delete-directory dir 'recursive t))))))
 620
 621 (defun archive--external-package-sync (name)
 622   "Sync external package named NAME."
 623   (let ((default-directory (expand-file-name "packages/")))
 624     (cond ((not (file-exists-p name))
 625            (let* ((branch (concat "externals/" name))
 626                   (output
 627                    (with-temp-buffer
 628                      ;; FIXME: Use git-new-workdir!
 629                      (call-process "git" nil t nil "clone"
 630                                    "--reference" ".." "--single-branch"
 631                                    "--branch" branch
 632                                    archive--elpa-git-url name)
 633                      (buffer-string))))
 634              (message "Cloning branch %s:\n%s" name output)))
 635           ((not (file-directory-p (concat name "/.git")))
 636            (message "%s is in the way of an external, please remove!" name))
 637           (t
 638            (let ((default-directory (file-name-as-directory
 639                                      (expand-file-name name))))
 640              (with-temp-buffer
 641                (message "Running git pull in %S" default-directory)
 642                (call-process "git" nil t nil "pull")
 643                (message "Updated %s:%s" name (buffer-string))))))))
 644
 645 (defun archive--core-package-empty-dest-p (dest)
 646   "Return non-nil if DEST is an empty variant."
 647   (member dest (list "" "." nil)))
 648
 649 (defun archive--core-package-link-file
 650     (source dest emacs-repo-root package-root exclude-regexp)
 651   "Link file from SOURCE to DEST ensuring subdirectories."
 652   (unless (string-match-p exclude-regexp source)
 653     (let* ((absolute-package-file-name
 654             (expand-file-name dest package-root))
 655            (absolute-core-file-name
 656             (expand-file-name source emacs-repo-root))
 657            (directory (file-name-directory absolute-package-file-name)))
 658       (unless (file-directory-p directory)
 659         (make-directory directory t))
 660       (condition-case nil
 661           (make-symbolic-link absolute-core-file-name
 662                               absolute-package-file-name t)
 663         (file-error
 664          (copy-file absolute-core-file-name absolute-package-file-name))))
 665     (message "  %s -> %s" source (if (archive--core-package-empty-dest-p dest)
 666                                      (file-name-nondirectory source)
 667                                    dest))))
 668
 669 (defun archive--core-package-link-directory
 670     (source dest emacs-repo-root package-root exclude-regexp)
 671   "Link directory files from SOURCE to DEST ensuring subdirectories."
 672   (let ((stack (list source))
 673         (base source)
 674         (absolute-source))
 675     (while stack
 676       (setq source (pop stack)
 677             absolute-source (expand-file-name source emacs-repo-root))
 678       (if (file-directory-p absolute-source)
 679           (dolist (file (directory-files absolute-source))
 680             (unless (member file (list "." ".."))
 681               (push (concat (file-name-as-directory source) file) stack)))
 682         (let* ((base (file-name-as-directory base))
 683                (source-sans-base (substring source (length base)))
 684                (package-file-name
 685                 (if (archive--core-package-empty-dest-p dest)
 686                     ;; Link to root with its original filename.
 687                     source-sans-base
 688                   (concat
 689                    ;; Prepend the destination, allowing for directory rename.
 690                    (file-name-as-directory dest) source-sans-base))))
 691           (archive--core-package-link-file
 692            source package-file-name
 693            emacs-repo-root package-root exclude-regexp))))))
 694
 695 (defun archive--core-package-sync (definition)
 696   "Sync core package from DEFINITION."
 697   (pcase-let*
 698       ((`(,name . (:core ,file-patterns :excludes ,excludes)) definition)
 699        (emacs-repo-root (expand-file-name "emacs"))
 700        (package-root (expand-file-name name "packages"))
 701        (default-directory package-root)
 702        (exclude-regexp
 703         (mapconcat #'identity
 704                    (mapcar #'wildcard-to-regexp
 705                            (append '("*.elc" "*~") excludes nil))
 706                    "\\|"))
 707        (file-patterns
 708         (mapcar
 709          (lambda (file-pattern)
 710            (pcase file-pattern
 711              ((pred (stringp)) (cons file-pattern ""))
 712              (`(,file ,dest . ,_) (cons file dest))
 713              (_ (error "Unrecognized file format for package %s: %S"
 714                        name file-pattern))))
 715          (if (stringp file-patterns)
 716              ;; Files may be just a string, normalize.
 717              (list file-patterns)
 718            file-patterns))))
 719     (message "Linking files for package: %s" name)
 720     (when (file-directory-p package-root)
 721       (delete-directory package-root t))
 722     (make-directory package-root t)
 723     (dolist (file-pattern file-patterns)
 724       (pcase-let* ((`(,file . ,dest) file-pattern))
 725         (if (file-directory-p (expand-file-name file emacs-repo-root))
 726             (archive--core-package-link-directory
 727              file dest emacs-repo-root package-root exclude-regexp)
 728           (archive--core-package-link-file
 729            file dest emacs-repo-root package-root exclude-regexp))))))
 730
 731 (defun archive-add/remove/update-externals ()
 732   "Remove non-package directories and fetch external packages."
 733   (let ((externals-list
 734          (with-current-buffer (find-file-noselect "externals-list")
 735            (read (buffer-string)))))
 736     (archive--cleanup-packages externals-list)
 737     (archive--sync-emacs-repo)
 738     (pcase-dolist ((and definition `(,name ,kind ,_url)) externals-list)
 739       (pcase kind
 740         (`:subtree nil)               ;Nothing to do.
 741         (`:external (archive--external-package-sync name))
 742         (`:core (archive--core-package-sync definition))
 743         (_ (message "Unknown external package kind `%S' for %s" kind name))))))
 744
 745 (provide 'archive-contents)
 746 ;;; archive-contents.el ends here