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

   1 ;;; archive-contents.el --- Auto-generate the `archive-contents' file -*- lexical-binding: t -*-
   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 batch-make-archive-contents ()
  34   (let ((packages '(1))) ; format-version.
  35     (dolist (file (directory-files default-directory))
  36       (pcase file
  37        ((or `"." `".." `"elpa.rss" `"archive-contents") nil)
  38        ((pred file-directory-p)
  39         (if (not (string-match (concat archive-contents-subdirectory-regexp "\\'")
  40                                file))
  41             (message "Unknown package directory name format %s" file)
  42           (let* ((pkg  (match-string 1 file))
  43                  (vers (match-string 2 file))
  44                  (exp
  45                   (with-temp-buffer
  46                     (insert-file-contents
  47                      (expand-file-name (concat pkg "-pkg.el") file))
  48                     (goto-char (point-min))
  49                     (read (current-buffer))))
  50                  (req (mapcar 'archive-contents--convert-require
  51                               (nth 4 exp)))
  52                  (readme (expand-file-name "README" file)))
  53             (when (file-exists-p readme)
  54               (copy-file readme
  55                          (concat pkg "-readme.txt")
  56                          'ok-if-already-exists))
  57             (unless (equal (nth 1 exp) pkg)
  58               (message "Package name %s doesn't match file name %s"
  59                        (nth 1 exp) file))
  60             (unless (equal (nth 2 exp) vers)
  61               (message "Package version %s doesn't match file name %s"
  62                        (nth 2 exp) file))
  63             (push (cons (intern pkg)
  64                         (vector (version-to-list vers)
  65                                 req
  66                                 (nth 3 exp)
  67                                 'tar))
  68                   packages))))
  69        ;; Simple package
  70        ((pred (string-match "\\.el\\'"))
  71         (if (not (string-match "-\\([0-9.]+\\)\\.el\\'" file))
  72             (message "Unknown package file name format %s" file)
  73           (let* ((pkg (substring file 0 (match-beginning 0)))
  74                  (vers (match-string 1 file))
  75                  (desc
  76                   (with-temp-buffer
  77                     (insert-file-contents file)
  78                     (goto-char (point-min))
  79                     (if (not (looking-at ";;;.*---[ \t]*\\(.*\\)\\(-\\*-.*-\\*-[ \t]*\\)?$"))
  80                         (message "Incorrectly formatted header in %s" file)
  81                       (prog1 (match-string 1)
  82                         (let ((commentary (lm-commentary)))
  83                           (with-current-buffer (find-file-noselect
  84                                                 (concat pkg "-readme.txt"))
  85                             (erase-buffer)
  86                             (emacs-lisp-mode)
  87                             (insert (or commentary
  88                                         (prog1 "No description"
  89                                           (message "Missing Commentary in %s"
  90                                                    file))))
  91                             (goto-char (point-min))
  92                             (while (looking-at ";*[ \t]*\\(commentary[: \t]*\\)?\n")
  93                               (delete-region (match-beginning 0)
  94                                              (match-end 0)))
  95                             (uncomment-region (point-min) (point-max))
  96                             (goto-char (point-max))
  97                             (while (progn (forward-line -1)
  98                                           (looking-at "[ \t]*\n"))
  99                               (delete-region (match-beginning 0)
 100                                              (match-end 0)))
 101                             (save-buffer)))))))
 102                  (requires-str (lm-header "package-requires"))
 103                  (req (if requires-str
 104                           (mapcar 'archive-contents--convert-require
 105                                   (car (read-from-string requires-str))))))
 106             (push (cons (intern pkg)
 107                         (vector (version-to-list vers)
 108                                 req
 109                                 desc
 110                                 'single))
 111                   packages))))
 112        ((pred (string-match "\\.elc\\'")) nil)
 113        ((pred (string-match "-readme\\.txt\\'")) nil)
 114        (t
 115         (message "Unknown file %s" file))))
 116     (with-current-buffer (find-file-noselect "archive-contents")
 117       (erase-buffer)
 118       (pp (nreverse packages) (current-buffer))
 119       (save-buffer))))
 120
 121 (provide 'archive-contents)
 122 ;;; archive-contents.el ends here