| 1 | ;;; update-changelog.el --- stitch rcs2log output to ChangeLog |
| 2 | |
| 3 | ;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;;;; This library is free software; you can redistribute it and/or |
| 6 | ;;;; modify it under the terms of the GNU Lesser General Public |
| 7 | ;;;; License as published by the Free Software Foundation; either |
| 8 | ;;;; version 3 of the License, or (at your option) any later version. |
| 9 | ;;;; |
| 10 | ;;;; This library 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 GNU |
| 13 | ;;;; Lesser General Public License for more details. |
| 14 | ;;;; |
| 15 | ;;;; You should have received a copy of the GNU Lesser General Public |
| 16 | ;;;; License along with this library; if not, write to the Free |
| 17 | ;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA |
| 18 | ;;;; 02111-1307 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 |