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 (require 'lisp-mnt)
  25 (require 'package)
  26
  27 (defconst archive-contents-subdirectory-regexp
  28   "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)")
  29
  30 (defconst archive-re-no-dot "\\`\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
  31   "Regular expression matching all files except \".\" and \"..\".")
  32
  33 (defun archive--convert-require (elt)
  34   (list (car elt)
  35         (version-to-list (car (cdr elt)))))
  36
  37 (defun archive--strip-rcs-id (str)
  38   "Strip RCS version ID from the version string STR.
  39 If the result looks like a dotted numeric version, return it.
  40 Otherwise return nil."
  41   (when str
  42     (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
  43       (setq str (substring str (match-end 0))))
  44     (condition-case nil
  45         (if (version-to-list str)
  46             str)
  47       (error nil))))
  48
  49 (defun archive--delete-elc-files (dir &optional only-orphans)
  50   "Recursively delete all .elc files in DIR.
  51 Delete backup files also."
  52   (dolist (f (directory-files dir t archive-re-no-dot))
  53     (cond ((file-directory-p f)
  54            (archive--delete-elc-files f))
  55           ((or (and (string-match "\\.elc\\'" f)
  56                     (not (and only-orphans
  57                               (file-readable-p (replace-match ".el" t t f)))))
  58                (backup-file-name-p f))
  59            (delete-file f)))))
  60
  61 (defun batch-make-archive ()
  62   "Process package content directories and generate the archive-contents file."
  63   (let ((packages '(1))) ; format-version.
  64     (dolist (dir (directory-files default-directory nil archive-re-no-dot))
  65       (condition-case v
  66           (if (not (file-directory-p dir))
  67               (error "Skipping non-package file %s" dir)
  68             (let* ((pkg (file-name-nondirectory dir))
  69                    (autoloads-file (expand-file-name (concat pkg "-autoloads.el") dir))
  70                    simple-p)
  71               ;; Omit autoloads and .elc files from the package.
  72               (if (file-exists-p autoloads-file)
  73                   (delete-file autoloads-file))
  74               (archive--delete-elc-files dir)
  75               ;; Test whether this is a simple or multi-file package.
  76               (setq simple-p (archive--simple-package-p dir pkg))
  77               (push (if simple-p
  78                         (apply 'archive--process-simple-package
  79                                dir pkg simple-p)
  80                       (archive--process-multi-file-package dir pkg))
  81                     packages)))
  82         ;; Error handler
  83         (error (message "%s" (cadr v)))))
  84     (with-temp-buffer
  85       (pp (nreverse packages) (current-buffer))
  86       (write-region nil nil "archive-contents"))))
  87
  88 (defun archive--simple-package-p (dir pkg)
  89   "Test whether DIR contains a simple package named PKG.
  90 If so, return a list (VERSION DESCRIPTION REQ COMMENTARY), where
  91 VERSION is the version string of the simple package, DESCRIPTION
  92 is the brief description of the package, REQ is a list of
  93 requirements, and COMMENTARY is the package commentary.
  94 Otherwise, return nil."
  95   (let* ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir))
  96          (mainfile (expand-file-name (concat pkg ".el") dir))
  97          (files (directory-files dir nil archive-re-no-dot))
  98          version description req commentary)
  99     (dolist (file (prog1 files (setq files ())))
 100       (unless (string-match "\\.elc\\'" file)
 101         (push file files)))
 102     (when (and (or (not (file-exists-p pkg-file))
 103                    (= (length files) 2))
 104                (file-exists-p mainfile))
 105       (with-temp-buffer
 106         (insert-file-contents mainfile)
 107         (goto-char (point-min))
 108         (and (looking-at ";;;.*---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$")
 109              (progn
 110                (setq description (match-string 1))
 111                (setq version
 112                      (or (archive--strip-rcs-id (lm-header "package-version"))
 113                          (archive--strip-rcs-id (lm-header "version"))
 114                          "0.0")))
 115              (progn
 116                ;; Grab the other fields, which are not mandatory.
 117                (let ((requires-str (lm-header "package-requires")))
 118                  (if requires-str
 119                      (setq req (mapcar 'archive--convert-require
 120                                        (car (read-from-string requires-str))))))
 121                (setq commentary (lm-commentary))
 122                (list version description req commentary)))))))
 123
 124 (defun archive--process-simple-package (dir pkg vers desc req commentary)
 125   "Deploy the contents of DIR into the archive as a simple package.
 126 Rename DIR/PKG.el to PKG-VERS.el, delete DIR, and write the
 127 package commentary to PKG-readme.txt.  Return the descriptor."
 128   ;; Write the readme file.
 129   (with-temp-buffer
 130     (erase-buffer)
 131     (emacs-lisp-mode)
 132     (insert (or commentary
 133                 (prog1 "No description"
 134                   (message "Missing commentary in package %s" pkg))))
 135     (goto-char (point-min))
 136     (while (looking-at ";*[ \t]*\\(commentary[: \t]*\\)?\n")
 137       (delete-region (match-beginning 0)
 138                      (match-end 0)))
 139     (uncomment-region (point-min) (point-max))
 140     (goto-char (point-max))
 141     (while (progn (forward-line -1)
 142                   (looking-at "[ \t]*\n"))
 143       (delete-region (match-beginning 0)
 144                      (match-end 0)))
 145     (write-region nil nil (concat pkg "-readme.txt")))
 146   ;; Write DIR/foo.el to foo-VERS.el and delete DIR
 147   (rename-file (expand-file-name (concat pkg ".el") dir)
 148                (concat pkg "-" vers ".el"))
 149   (delete-directory dir t)
 150   (cons (intern pkg) (vector (version-to-list vers) req desc 'single)))
 151
 152 (defun archive--make-changelog (dir)
 153   "Export Bzr log info of DIR into a ChangeLog file."
 154   (let ((default-directory (file-name-as-directory (expand-file-name dir))))
 155     (call-process "bzr" nil '(:file "ChangeLog") nil
 156                   "log" "--gnu-changelog" ".")))
 157
 158 (defun archive--process-multi-file-package (dir pkg)
 159   "Deploy the contents of DIR into the archive as a multi-file package.
 160 Rename DIR/ to PKG-VERS/, and write the package commentary to
 161 PKG-readme.txt.  Return the descriptor."
 162   (let* ((exp (archive--multi-file-package-def dir pkg))
 163          (vers (nth 2 exp))
 164          (req (mapcar 'archive--convert-require (nth 4 exp)))
 165          (readme (expand-file-name "README" dir)))
 166     (archive--make-changelog dir)
 167     (unless (equal (nth 1 exp) pkg)
 168       (error (format "Package name %s doesn't match file name %s"
 169                      (nth 1 exp) pkg)))
 170     ;; Write the readme file.
 171     (when (file-exists-p readme)
 172       (copy-file readme (concat pkg "-readme.txt") 'ok-if-already-exists))
 173     (rename-file dir (concat pkg "-" vers))
 174     (cons (intern pkg) (vector (version-to-list vers) req (nth 3 exp) 'tar))))
 175
 176 (defun archive--multi-file-package-def (dir pkg)
 177   "Reurn the `define-package' form in the file DIR/PKG-pkg.el."
 178   (let ((pkg-file (expand-file-name (concat pkg "-pkg.el") dir)))
 179     (with-temp-buffer
 180       (unless (file-exists-p pkg-file)
 181         (error "File not found: %s" pkg-file))
 182       (insert-file-contents pkg-file)
 183       (goto-char (point-min))
 184       (read (current-buffer)))))
 185
 186 (defun batch-make-site-dir (package-dir site-dir)
 187   (require 'package)
 188   (setq package-dir (expand-file-name package-dir default-directory))
 189   (setq site-dir (expand-file-name site-dir default-directory))
 190   (dolist (dir (directory-files package-dir t archive-re-no-dot))
 191     (condition-case v
 192         (if (not (file-directory-p dir))
 193             (error "Skipping non-package file %s" dir)
 194           (let* ((pkg (file-name-nondirectory dir))
 195                  (autoloads-file (expand-file-name
 196                                   (concat pkg "-autoloads.el") dir))
 197                  simple-p version)
 198             ;; Omit autoloads and .elc files from the package.
 199             (if (file-exists-p autoloads-file)
 200                 (delete-file autoloads-file))
 201             (archive--delete-elc-files dir 'only-orphans)
 202             ;; Test whether this is a simple or multi-file package.
 203             (setq simple-p (archive--simple-package-p dir pkg))
 204             (if simple-p
 205                 (progn
 206                   (apply 'archive--write-pkg-file dir pkg simple-p)
 207                   (setq version (car simple-p)))
 208               (setq version
 209                     (nth 2 (archive--multi-file-package-def dir pkg))))
 210             (make-symbolic-link (expand-file-name dir package-dir)
 211                                 (expand-file-name (concat pkg "-" version)
 212                                                   site-dir)
 213                                 t)
 214             (let ((make-backup-files nil))
 215               (package-generate-autoloads pkg dir))
 216             (let ((load-path (cons dir load-path)))
 217               ;; FIXME: Don't compile the -pkg.el files!
 218               (byte-recompile-directory dir 0))))
 219      ;; Error handler
 220      (error (message "%s" (cadr v))))))
 221
 222 (defun batch-make-site-package (sdir)
 223   (let* ((dest (car (file-attributes sdir)))
 224          (pkg (file-name-nondirectory (directory-file-name (or dest sdir))))
 225          (dir (or dest sdir)))
 226     (let ((make-backup-files nil))
 227       (package-generate-autoloads pkg dir))
 228     (let ((load-path (cons dir load-path)))
 229       ;; FIXME: Don't compile the -pkg.el files!
 230       (byte-recompile-directory dir 0))))
 231
 232 (defun archive--write-pkg-file (pkg-dir name version desc requires &rest ignored)
 233   (let ((pkg-file (expand-file-name (concat name "-pkg.el") pkg-dir))
 234         (print-level nil)
 235         (print-length nil))
 236     (write-region
 237      (concat (format ";; Generated package description from %s.el\n"
 238                      name)
 239              (prin1-to-string
 240               (list 'define-package
 241                     name
 242                     version
 243                     desc
 244                     (list 'quote
 245                           ;; Turn version lists into string form.
 246                           (mapcar
 247                            (lambda (elt)
 248                              (list (car elt)
 249                                    (package-version-join (cadr elt))))
 250                            requires))))
 251              "\n")
 252      nil
 253      pkg-file)))
 254
 255
 256 ;; Local Variables:
 257 ;; no-byte-compile: t
 258 ;; lexical-binding: t
 259 ;; End:
 260
 261 (provide 'archive-contents)
 262 ;;; archive-contents.el ends here