lisp/emacs-lisp/gulp.el

   1 ;;; gulp.el --- Ask for updates for Lisp packages
   2
   3 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   4
   5 ;; Author: Sam Shteingold <shteingd@math.ucla.edu>
   6 ;; Maintainer: FSF
   7 ;; Keywords: maintenance
   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 2, or (at your option)
  14 ;; 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; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Search the emacs/{version}/lisp directory for *.el files, extract the
  28 ;; name of the author or maintainer and send him e-mail requesting
  29 ;; update.
  30
  31 ;;; Code:
  32
  33 (defvar gulp-search-path (concat source-directory "lisp/")
  34   "*The search path for the packages to request updates of.")
  35
  36 (defvar gulp-discard "^;+ *Maintainer: *FSF *$"
  37   "*The regexp matching the packages not requiring the request for updates.")
  38
  39 (defvar gulp-packages (directory-files gulp-search-path nil "\\.el$" t)
  40   "The list of files to consider.")
  41
  42 (defvar gulp-tmp-buffer " *gulp*" "The name of the temporary buffer.")
  43
  44 (defvar gulp-max-len 2000
  45   "*All the interecting info should be among characters 1 through gulp-max-len.")
  46
  47 (defvar gulp-request-header
  48   "This message was created automatically.
  49 Apparently, you are the maintainer of the following package(s):\n\n"
  50   "*The first line of the mesage.")
  51
  52 (defvar gulp-request-end
  53   "\nIf your copy is newer than mine, please email me the patches ASAP.\n\n"
  54   "*The punch line.")
  55
  56 (defun gulp-send-requests ()
  57   "Send requests for updates to the authors of the packages.
  58 Consider each file in `gulp-packages;.
  59 The prepared message consists of `gulp-request-header', followed by the
  60 list of packages with modification times, concluded with `gulp-request-end'.
  61 You will NOT be given an opportunity to edit the message, only to send or cancel.
  62 The list of rejected addresses will be put into `gulp-tmp-buffer'."
  63   (interactive)
  64   (let (mail-setup-hook msg node (m-p-alist aaaa)) ;; (gulp-create-m-p-alist gulp-packages)))
  65     (while (setq node (car m-p-alist))
  66       (setq msg (gulp-create-message (cdr node)))
  67       (setq mail-setup-hook '(lambda () (goto-char (point-max)) (insert msg)))
  68       (mail nil (car node))
  69       (if (y-or-n-p "Send? ") (mail-send)
  70         (kill-this-buffer)
  71         (set-buffer gulp-tmp-buffer)
  72         (insert (format "%s\n\n" node)))
  73       (setq m-p-alist (cdr m-p-alist)))))
  74
  75 (defun gulp-create-message (rec)
  76   "Return the message string for REC, which is a list like (FILE TIME)."
  77   (let (node (str gulp-request-header))
  78     (while (setq node (car rec))
  79       (setq str (concat str "\t" (car node) "\tLast modified:\t" (cdr node) "\n"))
  80       (setq rec (cdr rec)))
  81     (concat str gulp-request-end)))
  82
  83 (defun gulp-create-m-p-alist (flist)
  84   "Create the maintainer/package alist for files in FLIST.
  85 List of elements (MAINTAINER . (LIST of PACKAGES))"
  86   (let (mplist filen node fl-tm)
  87     (get-buffer-create gulp-tmp-buffer)
  88     (while flist
  89       (setq fl-tm (gulp-maintainer (setq filen (car flist))))
  90       (if (setq mnt (car fl-tm));; there is a definite maintainer
  91           (if (setq node (assoc mnt mplist));; this is not a new maintainer
  92               (setq mplist (cons (cons (car node)
  93                                        (cons (cons filen (cdr fl-tm))
  94                                              (cdr node)))
  95                                  (delete node mplist)))
  96             (setq mplist (cons (list mnt (cons filen (cdr fl-tm))) mplist))))
  97       (message "%s -- %s" filen fl-tm)
  98       (setq flist (cdr flist)))
  99     (set-buffer gulp-tmp-buffer)
 100     (erase-buffer)
 101     mplist))
 102
 103 (defun gulp-maintainer (filenm)
 104   "Return a list (MAINTAINER TIMESTAMP) for the package FILENM."
 105   (save-excursion
 106     (let* ((fl (concat gulp-search-path filenm)) mnt
 107            (timest (format-time-string "%Y-%m-%d %a %T %Z"
 108                                        (elt (file-attributes fl) 5))))
 109       (set-buffer gulp-tmp-buffer)
 110       (erase-buffer)
 111       (insert-file-contents fl nil 0 gulp-max-len)
 112       (goto-char 1)
 113       (if (re-search-forward gulp-discard nil t)
 114           (setq mnt nil) ;; do nothing, return nil
 115         (goto-char 1)
 116         (if (and (re-search-forward "^;+ *Maintainer: \\(.*\\)$" nil t)
 117                  (> (length (setq mnt (match-string 1))) 0))
 118             () ;; found!
 119           (goto-char 1)
 120           (if (re-search-forward "^;+ *Author: \\(.*\\)$" nil t)
 121               (setq mnt (match-string 1))))
 122         (if (= (length mnt) 0) (setq mnt nil))) ;; "^;; Author: $" --> nil
 123       (cons mnt timest))))
 124
 125 ;;; gulp.el ends here