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