code.delx.au - gnu-emacs-elpa/blob - admin/archive-contents.el

   1 ;;; archive-contents.el --- Auto-generate an Emacs Lisp package archive.
   2
   3 ;; Copyright (C) 2011, 2012  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
  28 (defconst archive-contents-subdirectory-regexp
  29   "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)")
  30
  31 (defconst archive-re-no-dot "\\`\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
  32   "Regular expression matching all files except \".\" and \"..\".")
  33
  34 (defun archive--convert-require (elt)
  35   (list (car elt)
  36         (version-to-list (car (cdr elt)))))
  37
  38 (defun archive--strip-rcs-id (str)
  39   "Strip RCS version ID from the version string STR.
  40 If the result looks like a dotted numeric version, return it.
  41 Otherwise return nil."
  42   (when str
  43     (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
  44       (setq str (substring str (match-end 0))))
  45     (condition-case nil
  46         (if (version-to-list str)
  47             str)
  48       (error nil))))
  49
  50 (defun archive--delete-elc-files (dir &optional only-orphans)
  51   "Recursively delete all .elc files in DIR.
  52 Delete backup files also."
  53   (dolist (f (directory-files dir t archive-re-no-dot))
  54     (cond ((file-directory-p f)
  55            (archive--delete-elc-files f))
  56           ((or (and (string-match "\\.elc\\'" f)
  57                     (not (and only-orphans
  58                               (file-readable-p (replace-match ".el" t t f)))))
  59                (backup-file-name-p f))
  60            (delete-file f)))))
  61
  62 (defun batch-make-archive ()
  63   "Process package content directories and generate the archive-contents file."
  64   (let ((packages '(1))) ; format-version.
  65     (dolist (dir (directory-files default-directory nil archive-re-no-dot))
  66       (condition-case v
  67           (if (not (file-directory-p dir))
  68               (error "Skipping non-package file %s" dir)
  69             (let* ((pkg (file-name-nondirectory dir))
  70                    (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir))
  71                    simple-p)
  72               ;; Omit autoloads and .elc files from the package.
  73               (if (file-exists-p autoloads-file)
  74                   (delete-file autoloads-file))
  75               (archive--delete-elc-files dir)
  76               ;; Test whether this is a simple or multi-file package.
  77               (setq simple-p (archive--simple-package-p dir pkg))
  78               (push (if simple-p
  79                         (apply 'archive--process-simple-package
  80                                dir pkg simple-p)
  81                       (archive--process-multi-file-package dir pkg))
  82                     packages)))
  83         ;; Error handler
  84         (error (message "%s" (cadr v)))))
  85     (with-temp-buffer
  86       (pp (nreverse packages) (current-buffer))
  87       (write-region nil nil "archive-contents"))))
  88
  89 (defun archive--simple-package-p (dir pkg)
  90   "Test whether DIR contains a simple package named PKG.
  91 If so, return a list (VERSION DESCRIPTION REQ COMMENTARY), where
  92 VERSION is the version string of the simple package, DESCRIPTION
  93 is the brief description of the package, REQ is a list of
  94 requirements, and COMMENTARY is the package commentary.
  95 Otherwise, return nil."
  96   (let* ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir))
  97          (mainfile (expand-file-name (concat pkg ".el") dir))
  98          (files (directory-files dir nil archive-re-no-dot))
  99          version description req commentary)
 100     (dolist (file (prog1 files (setq files ())))
 101       (unless (string-match "\\.elc\\'" file)
 102         (push file files)))
 103     (when (and (or (not (file-exists-p pkg-file))
 104                    (= (length files) 2))
 105                (file-exists-p mainfile))
 106       (with-temp-buffer
 107         (insert-file-contents mainfile)
 108         (goto-char (point-min))
 109         (and (looking-at ";;;.*---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$")
 110              (progn
 111                (setq description (match-string 1))
 112                (setq version
 113                      (or (archive--strip-rcs-id (lm-header "package-version"))
 114                          (archive--strip-rcs-id (lm-header "version"))
 115                          "0.0")))
 116              (progn
 117                ;; Grab the other fields, which are not mandatory.
 118                (let ((requires-str (lm-header "package-requires")))
 119                  (if requires-str
 120                      (setq req (mapcar 'archive--convert-require
 121                                        (car (read-from-string requires-str))))))
 122                (setq commentary (lm-commentary))
 123                (list version description req commentary)))))))
 124
 125 (defun archive--process-simple-package (dir pkg vers desc req commentary)
 126   "Deploy the contents of DIR into the archive as a simple package.
 127 Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and write the
 128 package commentary to PKG-readme.txt.  Return the descriptor."
 129   ;; Write the readme file.
 130   (with-temp-buffer
 131     (erase-buffer)
 132     (emacs-lisp-mode)
 133     (insert (or commentary
 134                 (prog1 "No description"
 135                   (message "Missing commentary in package %s" pkg))))
 136     (goto-char (point-min))
 137     (while (looking-at ";*[ \t]*\\(commentary[: \t]*\\)?\n")
 138       (delete-region (match-beginning 0)
 139                      (match-end 0)))
 140     (uncomment-region (point-min) (point-max))
 141     (goto-char (point-max))
 142     (while (progn (forward-line -1)
 143                   (looking-at "[ \t]*\n"))
 144       (delete-region (match-beginning 0)
 145                      (match-end 0)))
 146     (write-region nil nil (concat pkg "-readme.txt")))
 147   ;; Write DIR/foo.el to foo-VERS.el and delete DIR
 148   (rename-file (expand-file-name (concat pkg ".el") dir)
 149                (concat pkg "-" vers ".el"))
 150   (delete-directory dir t)
 151   (cons (intern pkg) (vector (version-to-list vers) req desc 'single)))
 152
 153 (defun archive--make-changelog (dir)
 154   "Export Bzr log info of DIR into a ChangeLog file."
 155   (let ((default-directory (file-name-as-directory (expand-file-name dir))))
 156     (call-process "bzr" nil '(:file "ChangeLog") nil
 157                   "log" "--gnu-changelog" ".")))
 158
 159 (defun archive--process-multi-file-package (dir pkg)
 160   "Deploy the contents of DIR into the archive as a multi-file package.
 161 Rename DIR/ to PKG-VERS/, and write the package commentary to
 162 PKG-readme.txt.  Return the descriptor."
 163   (let* ((exp (archive--multi-file-package-def dir pkg))
 164          (vers (nth 2 exp))
 165          (req (mapcar 'archive--convert-require (nth 4 exp)))
 166          (readme (expand-file-name "README" dir)))
 167     (archive--make-changelog dir)
 168     (unless (equal (nth 1 exp) pkg)
 169       (error (format "Package name %s doesn't match file name %s"
 170                      (nth 1 exp) pkg)))
 171     ;; Write the readme file.
 172     (when (file-exists-p readme)
 173       (copy-file readme (concat pkg "-readme.txt") 'ok-if-already-exists))
 174     (rename-file dir (concat pkg "-" vers))
 175     (cons (intern pkg) (vector (version-to-list vers) req (nth 3 exp) 'tar))))
 176
 177 (defun archive--multi-file-package-def (dir pkg)
 178   "Reurn the `define-package' form in the file DIR/PKG-pkg.el."
 179   (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)))
 180     (with-temp-buffer
 181       (unless (file-exists-p pkg-file)
 182         (error "File not found: %s" pkg-file))
 183       (insert-file-contents pkg-file)
 184       (goto-char (point-min))
 185       (read (current-buffer)))))
 186
 187 (defun batch-make-site-dir (package-dir site-dir)
 188   (require 'package)
 189   (setq package-dir (expand-file-name package-dir default-directory))
 190   (setq site-dir (expand-file-name site-dir default-directory))
 191   (dolist (dir (directory-files package-dir t archive-re-no-dot))
 192     (condition-case v
 193         (if (not (file-directory-p dir))
 194             (error "Skipping non-package file %s" dir)
 195           (let* ((pkg (file-name-nondirectory dir))
 196                  (autoloads-file (expand-file-name
 197                                   (concat pkg "-autoloads.el") dir))
 198                  simple-p version)
 199             ;; Omit autoloads and .elc files from the package.
 200             (if (file-exists-p autoloads-file)
 201                 (delete-file autoloads-file))
 202             (archive--delete-elc-files dir 'only-orphans)
 203             ;; Test whether this is a simple or multi-file package.
 204             (setq simple-p (archive--simple-package-p dir pkg))
 205             (if simple-p
 206                 (progn
 207                   (apply 'archive--write-pkg-file dir pkg simple-p)
 208                   (setq version (car simple-p)))
 209               (setq version
 210                     (nth 2 (archive--multi-file-package-def dir pkg))))
 211             (make-symbolic-link (expand-file-name dir package-dir)
 212                                 (expand-file-name (concat pkg "-" version)
 213                                                   site-dir)
 214                                 t)
 215             (let ((make-backup-files nil))
 216               (package-generate-autoloads pkg dir))
 217             (let ((load-path (cons dir load-path)))
 218               ;; FIXME: Don't compile the -pkg.el files!
 219               (byte-recompile-directory dir 0))))
 220      ;; Error handler
 221      (error (message "%s" (cadr v))))))
 222
 223 (defun batch-make-site-package (sdir)
 224   (let* ((dest (car (file-attributes sdir)))
 225          (pkg (file-name-nondirectory (directory-file-name (or dest sdir))))
 226          (dir (or dest sdir)))
 227     (let ((make-backup-files nil))
 228       (package-generate-autoloads pkg dir))
 229     (let ((load-path (cons dir load-path)))
 230       ;; FIXME: Don't compile the -pkg.el files!
 231       (byte-recompile-directory dir 0))))
 232
 233 (defun archive--write-pkg-file (pkg-dir name version desc requires &rest ignored)
 234   (let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
 235         (print-level nil)
 236         (print-length nil))
 237     (write-region
 238      (concat (format ";; Generated package description from %s.el\n"
 239                      name)
 240              (prin1-to-string
 241               (list 'define-package
 242                     name
 243                     version
 244                     desc
 245                     (list 'quote
 246                           ;; Turn version lists into string form.
 247                           (mapcar
 248                            (lambda (elt)
 249                              (list (car elt)
 250                                    (package-version-join (cadr elt))))
 251                            requires))))
 252              "\n")
 253      nil
 254      pkg-file)))
 255
 256 ;;; Make the HTML pages for online browsing.
 257
 258 (defun archive--html-header (title)
 259   (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">
 260 <html>
 261 <head>
 262   <title>%s</title>
 263   <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
 264 </head>
 265 <body>
 266 <h1 align=\"center\">%s</h1>"
 267           title title))
 268
 269 (defun archive--html-bytes-format (bytes) ;Aka memory-usage-format.
 270   (setq bytes (/ bytes 1024.0))
 271   (let ((units '(;; "B"
 272                  "kB" "MB" "GB" "TB")))
 273     (while (>= bytes 1024)
 274       (setq bytes (/ bytes 1024.0))
 275       (setq units (cdr units)))
 276     (cond
 277      ;; ((integerp bytes) (format "%4d%s" bytes (car units)))
 278      ((>= bytes 100) (format "%4.0f%s" bytes (car units)))
 279      ((>= bytes 10) (format "%4.1f%s" bytes (car units)))
 280      (t (format "%4.2f%s" bytes (car units))))))
 281
 282 (defun archive--html-make-pkg (pkg files)
 283   (let ((name (symbol-name (car pkg)))
 284         (latest (package-version-join (aref (cdr pkg) 0)))
 285         (desc (aref (cdr pkg) 2)))
 286     ;; FIXME: Add maintainer info.
 287     (with-temp-buffer
 288       (insert (archive--html-header (format "GNU ELPA - %s" name)))
 289       (insert (format "<p>Description: %s</p>\n" desc))
 290       (let* ((file (cdr (assoc latest files)))
 291              (attrs (file-attributes file)))
 292         (insert (format "<p>Latest: <a href=%S>%s</a>, %s, %s</p>\n"
 293                         file file
 294                         (format-time-string "%Y-%b-%d" (nth 5 attrs))
 295                         (archive--html-bytes-format (nth 7 attrs)))))
 296       ;; FIXME: This URL is wrong for Org.
 297       (let ((repurl (concat "http://bzr.sv.gnu.org/lh/emacs/elpa/files/head:/packages/" name)))
 298         (insert (format "<p>Repository: <a href=%S>%s</a></p>" repurl repurl)))
 299       (let ((readme (concat name "-readme.txt"))
 300             (end (copy-marker (point) t)))
 301         (when (file-readable-p readme)
 302           (insert "<p>Full description:<pre>\n")
 303           (insert-file-contents readme)
 304           (goto-char end)
 305           (insert "\n</pre></p>")))
 306       (unless (< (length files) 2)
 307         (insert (format "<p>Old versions:<table cellpadding=\"3\" border=\"1\">\n"))
 308         (dolist (file files)
 309           (unless (equal (pop file) latest)
 310             (let ((attrs (file-attributes file)))
 311               (insert (format "<tr><td><a href=%S>%s</a></td><td>%s</td><td>%s</td>\n"
 312                               file file
 313                               (format-time-string "%Y-%b-%d" (nth 5 attrs))
 314                               (archive--html-bytes-format (nth 7 attrs)))))))
 315         (insert "</table></body>\n"))
 316       (write-region (point-min) (point-max) (concat name ".html")))))
 317
 318 (defun archive--html-make-index (pkgs)
 319   (with-temp-buffer
 320     (insert (archive--html-header "GNU ELPA Packages"))
 321     (insert "<table cellpadding=\"3\" border=\"1\">\n")
 322     (insert "<tr><th>Package</th><th>Version</th><th>Description</th></tr>\n")
 323     (dolist (pkg pkgs)
 324       (insert (format "<tr><td><a href=\"%s.html\">%s</a></td><td>%s</td><td>%s</td></tr>\n"
 325                       (car pkg) (car pkg)
 326                       (package-version-join (aref (cdr pkg) 0))
 327                       (aref (cdr pkg) 2))))
 328     (insert "</table></body>\n")
 329     (write-region (point-min) (point-max) "index.html")))
 330
 331 (defun batch-html-make-index ()
 332   (let ((packages (make-hash-table :test #'equal))
 333         (archive-contents
 334          (with-temp-buffer
 335            (insert-file-contents "archive-contents")
 336            (goto-char (point-min))
 337            ;; Skip the first element which is a version number.
 338            (cdr (read (current-buffer))))))
 339     (dolist (file (directory-files default-directory nil))
 340       (cond
 341        ((member file '("." ".." "elpa.rss" "index.html" "archive-contents")))
 342        ((string-match "\\.html\\'" file))
 343        ((string-match "-readme\\.txt\\'" file)
 344         (let ((name (substring file 0 (match-beginning 0))))
 345           (puthash name (gethash name packages) packages)))
 346        ((string-match "-\\([0-9][^-]*\\)\\.\\(tar\\|el\\)\\'" file)
 347         (let ((name (substring file 0 (match-beginning 0)))
 348               (version (match-string 1 file)))
 349           (push (cons version file) (gethash name packages))))
 350        (t (message "Unknown file %S" file))))
 351     (dolist (pkg archive-contents)
 352       (archive--html-make-pkg pkg (gethash (symbol-name (car pkg)) packages)))
 353     ;; FIXME: Add (old?) packages that are in `packages' but not in
 354     ;; archive-contents.
 355     (archive--html-make-index archive-contents)))
 356
 357
 358 ;; Local Variables:
 359 ;; lexical-binding: t
 360 ;; End:
 361
 362 (provide 'archive-contents)
 363 ;;; archive-contents.el ends here