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

   1 ;;; archive-contents.el --- Auto-generate the `archive-contents' file
   2
   3 ;; Copyright (C) 2011  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 (require 'lisp-mnt)
  25
  26 (defconst archive-contents-subdirectory-regexp
  27   "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)")
  28
  29 (defun archive-contents--convert-require (elt)
  30   (list (car elt)
  31         (version-to-list (car (cdr elt)))))
  32
  33 (defun archive-contents--strip-rcs-id (str)
  34   "Strip RCS version ID from the version string STR.
  35 If the result looks like a dotted numeric version, return it.
  36 Otherwise return nil."
  37   (when str
  38     (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
  39       (setq str (substring str (match-end 0))))
  40     (condition-case nil
  41         (if (version-to-list str)
  42             str)
  43       (error nil))))
  44
  45 (defun batch-make-archive-contents ()
  46   (let ((packages '(1))) ; format-version.
  47     (dolist (file (directory-files default-directory))
  48       (condition-case v
  49         (cond
  50          ((member file '("." ".." "elpa.rss" "archive-contents"))
  51           nil)
  52          ;; Multi-file package
  53          ((file-directory-p file)
  54           (let* ((pkg (file-name-nondirectory file))
  55                  (exp
  56                   (with-temp-buffer
  57                     (insert-file-contents
  58                      (expand-file-name (concat pkg "-pkg.el") file))
  59                     (goto-char (point-min))
  60                     (read (current-buffer))))
  61                  (vers (nth 2 exp))
  62                  (req (mapcar 'archive-contents--convert-require
  63                               (nth 4 exp)))
  64                  (readme (expand-file-name "README" file)))
  65             (when (file-exists-p readme)
  66               (copy-file readme
  67                          (concat pkg "-readme.txt")
  68                          'ok-if-already-exists))
  69             (unless (equal (nth 1 exp) pkg)
  70               (error (format "Package name %s doesn't match file name %s"
  71                              (nth 1 exp) file)))
  72             (push (cons (intern pkg)
  73                         (vector (version-to-list vers) req (nth 3 exp) 'tar))
  74                   packages)
  75             (rename-file file (concat pkg "-" vers))))
  76          ;; Simple package
  77          ((string-match "\\([^/]+\\)\\.el\\'" file)
  78           (let* ((pkg (match-string 1 file))
  79                  vers desc requires-str req)
  80             (with-temp-buffer
  81               (insert-file-contents file)
  82               (goto-char (point-min))
  83               (unless (looking-at ";;;.*---[ \t]*\\(.*\\)\\(-\\*-.*-\\*-[ \t]*\\)?$")
  84                 (error "Incorrectly formatted header in %s" file))
  85               (setq vers
  86                     (or (archive-contents--strip-rcs-id (lm-header "package-version"))
  87                         (archive-contents--strip-rcs-id (lm-header "version"))
  88                         (error "Missing version number in %s" file)))
  89               (setq desc (match-string 1))
  90               (let ((commentary (lm-commentary)))
  91                 (with-current-buffer (find-file-noselect
  92                                       (concat pkg "-readme.txt"))
  93                   (erase-buffer)
  94                   (emacs-lisp-mode)
  95                   (insert (or commentary
  96                               (prog1 "No description"
  97                                 (message "Missing Commentary in %s"
  98                                          file))))
  99                   (goto-char (point-min))
 100                   (while (looking-at ";*[ \t]*\\(commentary[: \t]*\\)?\n")
 101                     (delete-region (match-beginning 0)
 102                                    (match-end 0)))
 103                   (uncomment-region (point-min) (point-max))
 104                   (goto-char (point-max))
 105                   (while (progn (forward-line -1)
 106                                 (looking-at "[ \t]*\n"))
 107                     (delete-region (match-beginning 0)
 108                                    (match-end 0)))
 109                   (save-buffer)))
 110               (setq req
 111                     (let ((requires-str (lm-header "package-requires")))
 112                       (if requires-str
 113                           (mapcar 'archive-contents--convert-require
 114                                   (car (read-from-string requires-str))))))
 115               (push (cons (intern pkg)
 116                           (vector (version-to-list vers) req desc 'single))
 117                     packages)
 118               (rename-file file (concat (or (file-name-directory file) "")
 119                                         pkg "-" vers ".el")))))
 120          ((not (or (string-match "\\.elc\\'" file)
 121                    (string-match "-readme\\.txt\\'" file)))
 122           (message "Unknown file %s" file)))
 123         ;; Error handler
 124         (error (message (cadr v)))))
 125     (with-current-buffer (find-file-noselect "archive-contents")
 126       (erase-buffer)
 127       (pp (nreverse packages) (current-buffer))
 128       (save-buffer))))
 129
 130 ;; Local Variables:
 131 ;; no-byte-compile: t
 132 ;; lexical-binding: t
 133 ;; End:
 134
 135 (provide 'archive-contents)
 136 ;;; archive-contents.el ends here