guile18/emacs/update-changelog.el

   1 ;;; update-changelog.el --- stitch rcs2log output to ChangeLog
   2
   3 ;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to the
  17 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  18 ;; Boston, MA 02110-1301, USA.
  19
  20 ;;; Commentary:
  21
  22 ;; Usage: emacs -batch -l update-changelog.el
  23 ;;
  24 ;; This program is basically a wrapper around rcs2log, and inherits rcs2log's
  25 ;; weaknesses, namely, the requirement that there be a checked out (working
  26 ;; directory) copy.  It would be nice if rcs2log grokked with the repository
  27 ;; directly, but until then, we work around it by requiring the environment
  28 ;; var `LOCAL_WORK_ROOT' to be defined.  This should be a directory under
  29 ;; which cvs modules are checked out.
  30 ;;
  31 ;; Flash!  Newer versions of rcs2log do indeed understand the repository,
  32 ;; and can be invoked with "-R" therein.  We infer this if `LOCAL_WORK_ROOT'
  33 ;; is not set, and use instead `CVSROOT'.  At least one of these must be set.
  34 ;;
  35 ;; You can pass additional options to rcs2log using env var `RCS2LOG_OPTS'.
  36 ;;
  37 ;; Usage from a Lisp program:
  38 ;;   (ucl-update filename) -- Update FILENAME, a Change Log file
  39
  40 ;;; Code:
  41
  42 ;;;---------------------------------------------------------------------------
  43 ;;; Variables
  44
  45 (defvar ucl-o (or (getenv "RCS2LOG_OPTS") "")
  46   "Additional options to pass to rcs2log.")
  47
  48 ;;;---------------------------------------------------------------------------
  49 ;;; Cleanup functions
  50
  51 (defun ucl-stitch-new-old (new-old &rest ignore)
  52   "In a changelog buffer, remove redundancy around NEW-OLD point.
  53 The new text is before NEW-OLD point, and the old after."
  54   (goto-char new-old)
  55   (or (= new-old (point-max))           ; no old
  56       (let ((last-new
  57              (save-excursion
  58                (buffer-substring (re-search-backward "^[0-9]+") new-old))))
  59         (let ((has-diff (string-match "\n\tdiff.*-r" last-new))) ; ugh
  60           (and has-diff (setq last-new (substring last-new 0 has-diff))))
  61         (let ((overlap (search-forward last-new (point-max) t)))
  62           (and overlap (delete-region new-old overlap))))))
  63
  64 ;; Sometimes wannabe developers append diffs to their log entries.
  65 (defun ucl-omit-diffs (&rest ignore)
  66   "In a changelog buffer, delete diffs (assumed at end of entry)."
  67   (goto-char (point-min))
  68   (while (re-search-forward "^\tdiff .*-r" (point-max) t)
  69     (beginning-of-line)
  70     (delete-region (point)
  71                    (save-excursion
  72                      (if (re-search-forward "^[0-9]+" (point-max))
  73                          (- (point) 4)
  74                        (point-max))))))
  75
  76 (defun ucl-space-out-entries (&rest ignore)
  77   "In a changelog buffer, ensure proper spacing between entries."
  78   (goto-char (point-max))
  79   (while (re-search-backward "^[0-9]+" (point-min) t)
  80     (unless (= (point) (point-min))
  81       (open-line 3)                     ; yuk
  82       (delete-blank-lines))))
  83
  84 (defun ucl-kill-eol-white-space (&rest ignore)
  85   "In a changelog buffer, delete end-of-line white space."
  86   (goto-char (point-min))
  87   (while (re-search-forward "[ \t]+$" (point-max) t)
  88     (delete-region
  89      (match-beginning 0) (match-end 0))))
  90
  91 (defvar ucl-cleanup-hook '(ucl-stitch-new-old
  92                            ucl-omit-diffs
  93                            ucl-space-out-entries
  94                            ucl-kill-eol-white-space)
  95   "Hook run after combining the new fragment with the old changelog.  These
  96 are called with the argument NEW-OLD, which is the buffer position at the
  97 boundary of the two pieces of text.  This is suboptimal; we should use a
  98 marker so that munges on the text do not lose this position.  The result is
  99 that currently, `ucl-stitch-new-old' must be called first because it depends
 100 on NEW-OLD, while the other cleanup funcs ignore it.  (Sigh.)")
 101
 102 ;;;---------------------------------------------------------------------------
 103 ;;; Update functions
 104
 105 (defun ucl-root ()
 106   (let ((lwr (getenv "LOCAL_WORK_ROOT"))
 107         (cr  (getenv "CVSROOT")))
 108     (concat (or lwr
 109                 (and cr (progn
 110                           (setq ucl-o (concat "-R " ucl-o))     ; hmm
 111                           cr))
 112                 (error "Must set env var LOCAL_WORK_ROOT or CVSROOT"))
 113             "/")))
 114
 115 (defun ucl-update (filename)
 116   (interactive "fChangeLog: ")
 117   (let* ((ofile (expand-file-name filename))
 118          (cmd   (concat "rcs2log " ucl-o " -c " ofile))
 119          (obuf  "*ucl-work*"))
 120     (when (and (file-exists-p ofile)
 121                (progn
 122                  (shell-command cmd obuf)
 123                  (get-buffer obuf)))
 124       (save-excursion                   ; prevent default-directory hosing
 125         (set-buffer obuf)
 126         (unless (= 0 (buffer-size))
 127           (let ((new-old-boundary (point-max)))
 128             (goto-char new-old-boundary)
 129             (insert-file ofile)
 130             (run-hook-with-args 'ucl-cleanup-hook new-old-boundary))
 131           (or (= (buffer-size) (nth 7 (file-attributes ofile)))
 132               (let (make-backup-files)  ; less clutter
 133                 (write-file ofile))))
 134         (kill-buffer (current-buffer))))))
 135
 136 ;;;---------------------------------------------------------------------------
 137 ;;; Load-time actions
 138
 139 (when noninteractive                    ; only when `-batch'
 140   (or (ucl-update "ChangeLog")
 141       (message "Sorry, could not update ChangeLog in %s" default-directory)))
 142
 143 (provide 'update-changelog)
 144
 145 ;;; update-changelog.el ends here