| 1 | ;;; gulp.el --- ask for updates for Lisp packages |
| 2 | |
| 3 | ;; Copyright (C) 1996, 2001-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Sam Shteingold <shteingd@math.ucla.edu> |
| 6 | ;; Maintainer: emacs-devel@gnu.org |
| 7 | ;; Keywords: maint |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or |
| 14 | ;; (at your option) any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | |
| 26 | ;; Search the emacs/{version}/lisp directory for *.el files, extract the |
| 27 | ;; name of the author or maintainer and send him e-mail requesting |
| 28 | ;; update. |
| 29 | |
| 30 | ;;; Code: |
| 31 | (defgroup gulp nil |
| 32 | "Ask for updates for Lisp packages." |
| 33 | :prefix "-" |
| 34 | :group 'maint) |
| 35 | |
| 36 | (defcustom gulp-discard "^;+ *Maintainer: *FSF *$" |
| 37 | "The regexp matching the packages not requiring the request for updates." |
| 38 | :type 'regexp |
| 39 | :group 'gulp) |
| 40 | |
| 41 | (defcustom gulp-tmp-buffer "*gulp*" |
| 42 | "The name of the temporary buffer." |
| 43 | :type 'string |
| 44 | :group 'gulp) |
| 45 | |
| 46 | (defcustom gulp-max-len 2000 |
| 47 | "Distance into a Lisp source file to scan for keywords." |
| 48 | :type 'integer |
| 49 | :group 'gulp) |
| 50 | |
| 51 | (defcustom gulp-request-header |
| 52 | (concat |
| 53 | "This message was created automatically. |
| 54 | I'm going to start pretesting a new version of GNU Emacs soon, so I'd |
| 55 | like to ask if you have any updates for the Emacs packages you work on. |
| 56 | You're listed as the maintainer of the following package(s):\n\n") |
| 57 | "The starting text of a gulp message." |
| 58 | :type 'string |
| 59 | :group 'gulp) |
| 60 | |
| 61 | (defcustom gulp-request-end |
| 62 | (concat |
| 63 | "\nIf you have any changes since the version in the previous release (" |
| 64 | (format "%d.%d" emacs-major-version emacs-minor-version) |
| 65 | "), |
| 66 | please send them to me ASAP. |
| 67 | |
| 68 | Please don't send the whole file. Instead, please send a patch made with |
| 69 | `diff -c' that shows precisely the changes you would like me to install. |
| 70 | Also please include itemized change log entries for your changes; |
| 71 | please use lisp/ChangeLog as a guide for the style and for what kinds |
| 72 | of information to include. |
| 73 | |
| 74 | Thanks.") |
| 75 | "The closing text in a gulp message." |
| 76 | :type 'string |
| 77 | :group 'gulp) |
| 78 | |
| 79 | (declare-function mail-subject "sendmail" ()) |
| 80 | (declare-function mail-send "sendmail" ()) |
| 81 | |
| 82 | (defun gulp-send-requests (dir &optional time) |
| 83 | "Send requests for updates to the authors of Lisp packages in directory DIR. |
| 84 | For each maintainer, the message consists of `gulp-request-header', |
| 85 | followed by the list of packages (with modification times if the optional |
| 86 | prefix argument TIME is non-nil), concluded with `gulp-request-end'. |
| 87 | |
| 88 | You can't edit the messages, but you can confirm whether to send each one. |
| 89 | |
| 90 | The list of addresses for which you decided not to send mail |
| 91 | is left in the `*gulp*' buffer at the end." |
| 92 | (interactive "DRequest updates for Lisp directory: \nP") |
| 93 | (with-current-buffer (get-buffer-create gulp-tmp-buffer) |
| 94 | (let ((m-p-alist (gulp-create-m-p-alist |
| 95 | (directory-files dir nil "^[^=].*\\.el$" t) |
| 96 | dir)) |
| 97 | ;; Temporarily inhibit undo in the *gulp* buffer. |
| 98 | (buffer-undo-list t) |
| 99 | mail-setup-hook msg node) |
| 100 | (setq m-p-alist |
| 101 | (sort m-p-alist |
| 102 | (function (lambda (a b) |
| 103 | (string< (car a) (car b)))))) |
| 104 | (while (setq node (car m-p-alist)) |
| 105 | (setq msg (gulp-create-message (cdr node) time)) |
| 106 | (setq mail-setup-hook |
| 107 | (lambda () |
| 108 | (mail-subject) |
| 109 | (insert "It's time for Emacs updates again") |
| 110 | (goto-char (point-max)) |
| 111 | (insert msg))) |
| 112 | (mail nil (car node)) |
| 113 | (goto-char (point-min)) |
| 114 | (if (y-or-n-p "Send? ") (mail-send) |
| 115 | (kill-this-buffer) |
| 116 | (set-buffer gulp-tmp-buffer) |
| 117 | (insert (format "%s\n\n" node))) |
| 118 | (setq m-p-alist (cdr m-p-alist)))) |
| 119 | (set-buffer gulp-tmp-buffer) |
| 120 | (setq buffer-undo-list nil))) |
| 121 | |
| 122 | |
| 123 | (defun gulp-create-message (rec time) |
| 124 | "Return the message string for REC, which is a list like (FILE TIME)." |
| 125 | (let (node (str gulp-request-header)) |
| 126 | (while (setq node (car rec)) |
| 127 | (setq str (concat str "\t" (car node) |
| 128 | (if time (concat "\tLast modified:\t" (cdr node))) |
| 129 | "\n")) |
| 130 | (setq rec (cdr rec))) |
| 131 | (concat str gulp-request-end))) |
| 132 | |
| 133 | |
| 134 | (defun gulp-create-m-p-alist (flist dir) |
| 135 | "Create the maintainer/package alist for files in FLIST in DIR. |
| 136 | That is a list of elements, each of the form (MAINTAINER PACKAGES...)." |
| 137 | (save-excursion |
| 138 | (let (mplist filen node mnt-tm mnt tm fl-tm) |
| 139 | (get-buffer-create gulp-tmp-buffer) |
| 140 | (set-buffer gulp-tmp-buffer) |
| 141 | (setq buffer-undo-list t) |
| 142 | (while flist |
| 143 | (setq fl-tm (gulp-maintainer (setq filen (car flist)) dir)) |
| 144 | (if (setq tm (cdr fl-tm) mnt (car fl-tm));; there is a definite maintainer |
| 145 | (if (setq node (assoc mnt mplist));; this is not a new maintainer |
| 146 | (setq mplist (cons (cons mnt (cons (cons filen tm) (cdr node))) |
| 147 | (delete node mplist))) |
| 148 | (setq mplist (cons (list mnt (cons filen (cdr fl-tm))) mplist)))) |
| 149 | (setq flist (cdr flist))) |
| 150 | (erase-buffer) |
| 151 | mplist))) |
| 152 | |
| 153 | (defun gulp-maintainer (filenm dir) |
| 154 | "Return a list (MAINTAINER TIMESTAMP) for the package FILENM in directory DIR." |
| 155 | (save-excursion |
| 156 | (let* ((fl (expand-file-name filenm dir)) mnt |
| 157 | (timest (format-time-string "%Y-%m-%d %a %T %Z" |
| 158 | (elt (file-attributes fl) 5)))) |
| 159 | (set-buffer gulp-tmp-buffer) |
| 160 | (erase-buffer) |
| 161 | (insert-file-contents fl nil 0 gulp-max-len) |
| 162 | (goto-char 1) |
| 163 | (if (re-search-forward gulp-discard nil t) |
| 164 | (setq mnt nil) ;; do nothing, return nil |
| 165 | (goto-char 1) |
| 166 | (if (and (re-search-forward "^;+ *Maintainer: \\(.*\\)$" nil t) |
| 167 | (> (length (setq mnt (match-string 1))) 0)) |
| 168 | () ;; found! |
| 169 | (goto-char 1) |
| 170 | (if (re-search-forward "^;+ *Author: \\(.*\\)$" nil t) |
| 171 | (setq mnt (match-string 1)))) |
| 172 | (if (= (length mnt) 0) (setq mnt nil))) ;; "^;; Author: $" --> nil |
| 173 | (cons mnt timest)))) |
| 174 | |
| 175 | (provide 'gulp) |
| 176 | |
| 177 | ;;; gulp.el ends here |