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