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 (defconst archive-re-no-dot "\\`\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
  30   "Regular expression matching all files except \".\" and \"..\".")
  31
  32 (defun archive--convert-require (elt)
  33   (list (car elt)
  34         (version-to-list (car (cdr elt)))))
  35
  36 (defun archive--strip-rcs-id (str)
  37   "Strip RCS version ID from the version string STR.
  38 If the result looks like a dotted numeric version, return it.
  39 Otherwise return nil."
  40   (when str
  41     (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
  42       (setq str (substring str (match-end 0))))
  43     (condition-case nil
  44         (if (version-to-list str)
  45             str)
  46       (error nil))))
  47
  48 (defun archive--delete-elc-files (dir)
  49   "Recursively delete all .elc files in DIR."
  50   (dolist (f (directory-files dir t archive-re-no-dot))
  51     (cond ((file-directory-p f)
  52            (archive--delete-elc-files f))
  53           ((string-match "\\.elc\\'" f)
  54            (delete-file f)))))
  55
  56 (defun batch-make-archive ()
  57   "Process package content directories and generate the archive-contents file."
  58   (let ((packages '(1))) ; format-version.
  59     (dolist (dir (directory-files default-directory nil archive-re-no-dot))
  60       (condition-case v
  61           (if (not (file-directory-p dir))
  62               1;(error "Skipping non-package file %s" dir)
  63             (let* ((pkg (file-name-nondirectory dir))
  64                    (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir))
  65                    simple-p version)
  66               ;; Omit autoloads and .elc files from the package.
  67               (if (file-exists-p autoloads-file)
  68                   (delete-file autoloads-file))
  69               (archive--delete-elc-files dir)
  70               ;; Test whether this is a simple or multi-file package.
  71               (setq simple-p (archive--simple-package-p dir pkg))
  72               (push (if simple-p
  73                         (apply 'archive--process-simple-package
  74                                dir pkg simple-p)
  75                       (archive--process-multi-file-package dir pkg))
  76                     packages)))
  77         ;; Error handler
  78         (error (message "%s" (cadr v)))))
  79     (with-current-buffer (find-file-noselect "archive-contents")
  80       (erase-buffer)
  81       (pp (nreverse packages) (current-buffer))
  82       (save-buffer))))
  83
  84 (defun archive--simple-package-p (dir pkg)
  85   "Test whether DIR contains a simple package named PKG.
  86 If so, return a list (VERSION DESCRIPTION REQ COMMENTARY), where
  87 VERSION is the version string of the simple package, DESCRIPTION
  88 is the brief description of the package, REQ is a list of
  89 requirements, and COMMENTARY is the package commentary.
  90 Otherwise, return nil."
  91   (let* ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir))
  92          (mainfile (expand-file-name (concat pkg ".el") dir))
  93          version description req commentary)
  94     (when (and (or (not (file-exists-p pkg-file))
  95                    (= (length (directory-files dir nil archive-re-no-dot)) 2))
  96                (file-exists-p mainfile))
  97       (with-temp-buffer
  98         (insert-file-contents mainfile)
  99         (goto-char (point-min))
 100         (and (looking-at ";;;.*---[ \t]*\\(.*\\)\\(-\\*-.*-\\*-[ \t]*\\)?$")
 101              (progn
 102                (setq description (match-string 1))
 103                (setq version
 104                      (or (archive--strip-rcs-id (lm-header "package-version"))
 105                          (archive--strip-rcs-id (lm-header "version")))))
 106              (progn
 107                ;; Grab the other fields, which are not mandatory.
 108                (let ((requires-str (lm-header "package-requires")))
 109                  (if requires-str
 110                      (setq req (mapcar 'archive--convert-require
 111                                        (car (read-from-string requires-str))))))
 112                (setq commentary (lm-commentary))
 113                (list version description req commentary)))))))
 114
 115 (defun archive--process-simple-package (dir pkg vers desc req commentary)
 116   "Deploy the contents of DIR into the archive as a simple package.
 117 Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and write the
 118 package commentary to PKG-readme.txt.  Return the descriptor."
 119   ;; Write the readme file.
 120   (with-current-buffer (find-file-noselect (concat pkg "-readme.txt"))
 121     (erase-buffer)
 122     (emacs-lisp-mode)
 123     (insert (or commentary
 124                 (prog1 "No description"
 125                   (message "Missing commentary in package %s" pkg))))
 126     (goto-char (point-min))
 127     (while (looking-at ";*[ \t]*\\(commentary[: \t]*\\)?\n")
 128       (delete-region (match-beginning 0)
 129                      (match-end 0)))
 130     (uncomment-region (point-min) (point-max))
 131     (goto-char (point-max))
 132     (while (progn (forward-line -1)
 133                   (looking-at "[ \t]*\n"))
 134       (delete-region (match-beginning 0)
 135                      (match-end 0)))
 136     (save-buffer))
 137   ;; Write DIR/foo.el to foo-VERS.el and delete DIR
 138   (rename-file (expand-file-name (concat pkg ".el") dir)
 139                (concat pkg "-" vers ".el"))
 140   (delete-directory dir t)
 141   (cons (intern pkg) (vector (version-to-list vers) req desc 'single)))
 142
 143 (defun archive--process-multi-file-package (dir pkg)
 144   "Deploy the contents of DIR into the archive as a multi-file package.
 145 Rename DIR/ to PKG-VERS/, and write the package commentary to
 146 PKG-readme.txt.  Return the descriptor."
 147   (let* ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir))
 148          (exp
 149           (with-temp-buffer
 150             (unless pkg-file (error "File not found: %s" pkg-file))
 151             (insert-file-contents pkg-file)
 152             (goto-char (point-min))
 153             (read (current-buffer))))
 154          (vers (nth 2 exp))
 155          (req (mapcar 'archive--convert-require (nth 4 exp)))
 156          (readme (expand-file-name "README" dir)))
 157     (unless (equal (nth 1 exp) pkg)
 158       (error (format "Package name %s doesn't match file name %s"
 159                      (nth 1 exp) pkg)))
 160     ;; Write the readme file.
 161     (when (file-exists-p readme)
 162       (copy-file readme (concat pkg "-readme.txt") 'ok-if-already-exists))
 163     (rename-file dir (concat pkg "-" vers))
 164     (cons (intern pkg) (vector (version-to-list vers) req (nth 3 exp) 'tar))))
 165
 166 ;; Local Variables:
 167 ;; no-byte-compile: t
 168 ;; lexical-binding: t
 169 ;; End:
 170
 171 (provide 'archive-contents)
 172 ;;; archive-contents.el ends here