cgit.sxemacs.org Git - packages/blob - xemacs-packages/patcher/lisp/patcher-change-log.el

   1 ;;; patcher-change-log.el --- ChangeLog utilities
   2
   3 ;; Copyright (C) 2008, 2009, 2010, 2011 Didier Verna
   4 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007 Didier Verna
   5
   6 ;; Author:        Didier Verna <didier@xemacs.org>
   7 ;; Maintainer:    Didier Verna <didier@xemacs.org>
   8 ;; Created:       Sat Feb 13 22:20:24 2010
   9 ;; Last Revision: Thu Jan 12 21:56:06 2012
  10 ;; Keywords:      maint
  11
  12
  13 ;; This file is part of Patcher.
  14
  15 ;; Patcher is free software; you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License version 3,
  17 ;; as published by the Free Software Foundation.
  18
  19 ;; Patcher is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with this program; if not, write to the Free Software
  26 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  27
  28
  29 ;;; Commentary:
  30
  31 ;; Contents management by FCM version 0.1.
  32
  33
  34 ;;; Code:
  35
  36 (require 'cl)
  37
  38 (eval-when-compile (require 'patcher-cutil))
  39 (require 'patcher-util)
  40 (require 'patcher-project)
  41 (require 'patcher-instance)
  42 (require 'patcher-source)
  43
  44
  45 \f
  46 ;; ==========================================================================
  47 ;; Utilities
  48 ;; ==========================================================================
  49
  50 (defgroup patcher-change-log nil
  51   "Patcher settings for ChangeLog buffers."
  52   :group 'patcher)
  53
  54
  55 (patcher-define-error 'change-log
  56   "Patcher ChangeLog error.")
  57
  58
  59 (defconst +patcher-change-log-entry-start-regexp+
  60   "^[0-9]\\{4,4\\}-[0-9]\\{2,2\\}-[0-9]\\{2,2\\} "
  61   ;; Regexp matching the beginning of a ChangeLog entry
  62   )
  63
  64
  65 ;; This function is based on find-change-log from the add-log library.
  66 (put 'patcher-locate-change-log 'lisp-indent-function 1)
  67 (defun* patcher-locate-change-log
  68     (project source
  69      &aux (change-log-file-name
  70            (patcher-project-option project :change-log-file-name)))
  71   ;; Locate PROJECT's ChangeLog file for SOURCE.
  72   ;; SOURCE must be an absolute file name.
  73   ;; If PROJECT does only ephemeral ChangeLogs, return always the same one,
  74   ;; located at the base directory.
  75   ;; If PROJECT doesn't have ChangeLogs yet, return a ChangeLog file in
  76   ;; SOURCE's directory (symlinks followed). Otherwise, try to find a
  77   ;; ChangeLog file the usual way.
  78   (if (eq (patcher-project-option project :change-logs-status) 'ephemeral)
  79       (expand-file-name change-log-file-name
  80                         (patcher-project-base-directory project))
  81       (setq source (file-truename source)) ;; follow SOURCE symlinks
  82       (let* ((directory (file-name-directory source))
  83              (first-change-log (file-truename change-log-file-name directory)))
  84         (if (patcher-project-option project :change-logs-updating)
  85             (flet ((change-log-exists-p (change-log)
  86                      (or (get-file-buffer change-log)
  87                          (file-exists-p change-log))))
  88               (let ((change-log first-change-log))
  89                 (while (and (not (change-log-exists-p change-log))
  90                             (let ((parent (file-name-directory
  91                                            (directory-file-name directory))))
  92                               (prog1 (not (string= parent directory))
  93                                 (setq directory parent))))
  94                        (setq change-log
  95                              (file-truename change-log-file-name directory)))
  96                 (if (change-log-exists-p change-log)
  97                     change-log
  98                     first-change-log)))
  99             first-change-log))))
 100
 101 (put 'patcher-mapcar-change-log-extents 'lisp-indent-function 1)
 102 (defmacro* patcher-mapcar-change-log-extents
 103     ((var &optional buffer) &body body)
 104   ;; Mapcar BODY with VAR bound to all ChangeLog extents in BUFFER.
 105   `(patcher-mapcar-extents (,var 'change-log :here ,buffer)
 106     ,@body))
 107
 108 (defun patcher-change-logs (&optional buffer)
 109   ;; Return the list of ChangeLog absolute file names appearing in BUFFER.
 110   (patcher-collect-extents-property 'change-log buffer))
 111
 112 (defun patcher-change-log-extents (&optional buffer)
 113   ;; Return the list of ChangeLog extents in BUFFER.
 114   (patcher-extents 'change-log :here buffer))
 115
 116 (defun patcher-change-log-contents (&optional buffer)
 117   ;; Return the string containing all ChangeLog contents in BUFFER.
 118   (apply #'concat
 119     (patcher-mapcar-change-log-extents (extent buffer)
 120       (extent-string extent))))
 121
 122 (patcher-define-error 'change-logs-consistency
 123   "Patcher ChangeLogs consistency error."
 124   'change-log)
 125
 126 (defun patcher-detect-inconsistent-change-logs (project)
 127   ;; Detect inconsistent ChangLogs in PROJECT's process buffer diff.
 128   ;; Inconsistent means either spurious or missing diff.
 129   ;; Throw a change-logs-consistency error when detected.
 130   (multiple-value-bind (result spurious missing)
 131       (patcher-list=
 132           (patcher-change-logs (patcher-project-process-buffer project))
 133           (patcher-project-change-logs project)
 134         :test #'string=)
 135     (unless result
 136       (patcher-error 'change-logs-consistency
 137                      (when spurious (patcher-files-string spurious))
 138                      (when missing (patcher-files-string missing))))))
 139
 140 (defun patcher-detect-missing-change-logs (project)
 141   ;; Detect missing ChangLogs in PROJECT's process buffer diff.
 142   ;; Throw a change-logs-consistency error when detected.
 143   (multiple-value-bind (result spurious missing)
 144       (patcher-list=
 145           (patcher-change-logs (patcher-project-process-buffer project))
 146           (patcher-project-change-logs project)
 147         :test #'string=)
 148     (assert (null spurious))
 149     (unless result
 150       (patcher-error 'change-logs-consistency
 151                      nil
 152                      (when missing (patcher-files-string missing))))))
 153
 154 (defun* patcher-detect-spurious-change-logs (project change-logs &aux spurious)
 155   ;; Detect spurious CHANGE-LOGS in PROJECT's process buffer diff.
 156   ;; Throw a change-logs-consistency error when detected.
 157   (dolist (change-log change-logs)
 158     (when (patcher-extent 'change-log
 159             :value change-log
 160             :test #'string=
 161             :here (patcher-project-process-buffer project))
 162       (patcher-endpush change-log spurious)))
 163   (when spurious
 164     (patcher-error 'change-logs-consistency
 165                    (patcher-files-string spurious)
 166                    nil)))
 167
 168 (defun patcher-inconsistent-change-logs-description (spurious missing)
 169   ;; Return a string describing SPURIOUS and/or MISSING ChangeLogs.
 170   (concat "ChangeLogs inconsistency detected."
 171           (when spurious
 172             (format "\n
 173 The following ChangeLog files contain spurious entries: %s.
 174 Possible causes are:
 175   - your project is out of date (someone else has modified the ChangeLog
 176     files in the meantime.  You should then update your project before running
 177     Patcher.
 178   - you have filled the ChangeLogs files manually, but Patcher is supposed to
 179     do so automatically.  You need to either clean up the ChangeLog files,
 180     or set the :change-logs-updating project option to 'manual." spurious))
 181           (when missing
 182             (format "\n
 183 The following ChangeLog files miss some entries: %s.
 184 Possible causes are:
 185   - the ChangeLog files have already been checked in by another instance of
 186     Patcher or anyone else.  You should probably fix the last commit.
 187   - the ChangeLog entries are supposed to be written manually, but you forgot
 188     some of them.  You need to either write them by hand, or set the
 189     :change-logs-updating project option to 'automatic." missing))))
 190
 191
 192 (patcher-define-error 'undiffable-change-logs
 193   "Patcher undiffable ChangeLogs."
 194   'change-log)
 195
 196 (defun patcher-detect-ephemeral-change-logs (project)
 197   ;; Detect ephemeral ChangeLogs for PROJECT.
 198   ;; Throw an undiffable-change-logs when detected.
 199   (when (eq (patcher-project-option project :change-logs-status) 'ephemeral)
 200     (patcher-error 'undiffable-change-logs)))
 201
 202
 203
 204 \f
 205 ;; ==========================================================================
 206 ;; ChangeLog Navigation
 207 ;; ==========================================================================
 208
 209 ;; #### NOTE: in case the user decides to browse manual ChangeLog entries, we
 210 ;; need to make sure that the project/change-log extents exist. That's why we
 211 ;; call patcher-change-log-extent in the functions below.
 212
 213 (defun patcher-switch-to-first-change-log (project)
 214   ;; Switch to the first PROJECT ChangeLog.
 215   (multiple-value-bind (buffer)
 216       (patcher-change-log-buffer project
 217           (car (patcher-project-change-logs project))
 218         'find)
 219     (switch-to-buffer buffer))
 220   (patcher-change-log-extent project (current-buffer) 'create))
 221
 222 (defun patcher-switch-to-last-change-log (project)
 223   ;; Switch to the last PROJECT ChangeLog.
 224   (multiple-value-bind (buffer)
 225       (patcher-change-log-buffer project
 226           (car (last (patcher-project-change-logs project)))
 227         'find)
 228     (switch-to-buffer buffer))
 229   (patcher-change-log-extent project (current-buffer) 'create))
 230
 231 (defun patcher-switch-to-next-change-log (project)
 232   ;; Circularly switch to PROJECT's next ChangeLog or mail buffer.
 233   (switch-to-buffer
 234    (let* ((change-logs (patcher-project-change-logs project))
 235           (from-file (buffer-file-name (current-buffer)))
 236           (tail (member from-file change-logs)))
 237      (assert tail)
 238      (if (cdr tail)
 239          (multiple-value-bind (buffer)
 240              (patcher-change-log-buffer project (cadr tail) 'find)
 241            buffer)
 242        (patcher-project-mail-buffer project))))
 243   (patcher-change-log-extent project (current-buffer) 'create))
 244
 245 (defun patcher-switch-to-previous-change-log (project)
 246   ;; Circularly switch to PROJECT's previous ChangeLog or mail buffer.
 247   (switch-to-buffer
 248    (let* ((change-logs (patcher-project-change-logs project))
 249           (from-file (buffer-file-name (current-buffer))))
 250      (if (string= from-file (first change-logs))
 251          (patcher-project-mail-buffer project)
 252        (do ((tail change-logs (cdr tail)))
 253            ((string= from-file (cadr tail))
 254             (progn (assert tail)
 255                    (multiple-value-bind (buffer)
 256                        (patcher-change-log-buffer project (car tail) 'find)
 257                      buffer)))))))
 258   (patcher-change-log-extent project (current-buffer) 'create))
 259
 260
 261
 262 \f
 263 ;; ==========================================================================
 264 ;; ChangeLog minor mode
 265 ;; ==========================================================================
 266
 267 (defun* patcher-change-log-interactive
 268     (&aux (extent (extent-at (point) (current-buffer) 'patcher-project))
 269           (project (when extent
 270                      (extent-property extent 'patcher-project))))
 271   ;; Find a project in the current ChangeLog buffer.
 272   ;; Prefer the project related to the ChangeLog entry at point.
 273   ;; Otherwise, use the first one found if it is the only one.
 274   ;; Otherwise, barf.
 275   (or (when project
 276         (list project))
 277       (let ((projects (patcher-mapcar-change-log-extents (extent)
 278                         (extent-property extent 'patcher-project))))
 279         (if (= (length projects) 1)
 280             (list (first projects))
 281           (patcher-error "\
 282 Unable to determine project. Please move point to a relevant entry.")))))
 283
 284 (defun patcher-change-log-change-subject (project)
 285   "Read a new subject for PROJECT.
 286
 287 The new subject is propagated to all relevant buffers.
 288
 289 PROJECT is determined by the ChangeLog entry at point if there is one.
 290 Otherwise, if the ChangeLog buffer is associated with a single project,
 291 it is used. Otherwise, it fails."
 292   (interactive (patcher-change-log-interactive))
 293   (patcher-change-subject project))
 294
 295 (defun patcher-change-log-mail (project)
 296   "Switch to PROJECT's mail buffer.
 297
 298 PROJECT is determined by the ChangeLog entry at point if there is one.
 299 Otherwise, if the ChangeLog buffer is associated with a single project,
 300 it is used. Otherwise, it fails."
 301   (interactive (patcher-change-log-interactive))
 302   (switch-to-buffer (patcher-project-mail-buffer project)))
 303
 304 (defun patcher-change-log-insert-change-logs (project)
 305   "Switch to PROJECT's mail buffer and insert ChangeLog entries.
 306
 307 PROJECT is determined by the ChangeLog entry at point if there is one.
 308 Otherwise, if the ChangeLog buffer is associated with a single project,
 309 it is used. Otherwise, it fails."
 310   (interactive (patcher-change-log-interactive))
 311   (switch-to-buffer (patcher-project-mail-buffer project))
 312   (declare-fboundp (patcher-mail-insert-change-logs)))
 313
 314 (defun patcher-change-log-first (project)
 315   "Switch to PROJECT's first ChangeLog buffer.
 316
 317 PROJECT is determined by the ChangeLog entry at point if there is one.
 318 Otherwise, if the ChangeLog buffer is associated with a single project,
 319 it is used. Otherwise, it fails."
 320   (interactive (patcher-change-log-interactive))
 321   (patcher-switch-to-first-change-log project))
 322
 323 (defun patcher-change-log-next (project)
 324   "Circularly switch to PROJECT's next ChangeLog or mail buffer.
 325
 326 PROJECT is determined by the ChangeLog entry at point if there is one.
 327 Otherwise, if the ChangeLog buffer is associated with a single project,
 328 it is used. Otherwise, it fails."
 329   (interactive (patcher-change-log-interactive))
 330   (patcher-switch-to-next-change-log project))
 331
 332 (defun patcher-change-log-last (project)
 333   "Switch to PROJECT's last ChangeLog buffer.
 334
 335 PROJECT is determined by the ChangeLog entry at point if there is one.
 336 Otherwise, if the ChangeLog buffer is associated with a single project,
 337 it is used. Otherwise, it fails."
 338   (interactive (patcher-change-log-interactive))
 339   (patcher-switch-to-last-change-log project))
 340
 341 (defun patcher-change-log-previous (project)
 342   "Circularly switch to PROJECT's previous ChangeLog or mail buffer.
 343
 344 PROJECT is determined by the ChangeLog entry at point if there is one.
 345 Otherwise, if the ChangeLog buffer is associated with a single project,
 346 it is used. Otherwise, it fails."
 347   (interactive (patcher-change-log-interactive))
 348   (patcher-switch-to-previous-change-log project))
 349
 350 (defun patcher-change-log-kill (project)
 351   "Kill PROJECT.
 352
 353 PROJECT is determined by the ChangeLog entry at point if there is one.
 354 Otherwise, if the ChangeLog buffer is associated with a single project,
 355 it is used. Otherwise, it fails."
 356   (interactive (patcher-change-log-interactive))
 357   (patcher-kill-project project))
 358
 359 (defcustom patcher-change-log-minor-mode-string " Patch"
 360   "*Patcher ChangeLog minor mode modeline string."
 361   :group 'patcher
 362   :type 'string)
 363
 364 (defcustom patcher-change-log-minor-mode-hook nil
 365   "*Hooks to run after setting up Patcher ChangeLog minor mode."
 366   :group 'patcher
 367   :type 'hook)
 368
 369 (defvar patcher-change-log-minor-mode-map
 370   (let ((map (make-sparse-keymap 'patcher-change-log-minor-mode-map)))
 371     (define-key map [(control c) (control p) S]
 372       'patcher-change-log-change-subject)
 373     (define-key map [(control c) (control p) m] 'patcher-change-log-mail)
 374     (define-key map [(control c) (control p) l]
 375       'patcher-change-log-insert-change-logs)
 376     (define-key map [(control c) (control p) P] 'patcher-change-log-first)
 377     (define-key map [(control c) (control p) n] 'patcher-change-log-next)
 378     (define-key map [(control c) (control p) N] 'patcher-change-log-last)
 379     (define-key map [(control c) (control p) p] 'patcher-change-log-previous)
 380     (define-key map [(control c) (control p) k] 'patcher-change-log-kill)
 381     (define-key map [(control c) (control p) v] 'patcher-version)
 382     map)
 383   ;; Patcher minor mode keymap.
 384   )
 385
 386 (make-variable-buffer-local
 387  (defvar patcher-change-log-minor-mode nil))
 388
 389 (defun patcher-change-log-minor-mode (&optional arg)
 390   "Toggles Patcher ChangeLog minor mode.
 391
 392 This mode is set up automatically by Patcher.
 393 You're not supposed to use this, unless you know what you're doing.
 394
 395 The Patcher ChangeLog minor mode provides the following commands:
 396 \\{patcher-change-log-minor-mode-map}"
 397   (interactive "*P")
 398   (let ((was-off (not patcher-change-log-minor-mode)))
 399     (setq patcher-change-log-minor-mode
 400           (if (null arg)
 401               was-off
 402             (> (prefix-numeric-value arg) 0)))
 403     (when (and patcher-change-log-minor-mode was-off)
 404       (run-hooks 'patcher-change-log-minor-mode-hook))))
 405
 406 (add-minor-mode 'patcher-change-log-minor-mode
 407                 patcher-change-log-minor-mode-string
 408                 patcher-change-log-minor-mode-map)
 409
 410
 411
 412 \f
 413 ;; ==========================================================================
 414 ;; ChangeLog referencing
 415 ;; ==========================================================================
 416
 417 ;; ChangeLog buffers ========================================================
 418
 419 (put 'patcher-reference-change-log 'lisp-indent-function 1)
 420 (defun patcher-reference-change-log (project change-log existing)
 421   ;; Add a reference to PROJECT in CHANGE-LOG buffer.
 422   ;; EXISTING means that the buffer was not loaded by Patcher, so it should be
 423   ;; protected with an initial t value in patcher-references.
 424   ;; This function also adds PROJECT's after-save-hook in the CHANGE-LOG
 425   ;; buffer when necessary.
 426   (when change-log
 427     (with-current-buffer change-log
 428       (when (and existing (null patcher-references))
 429         (push t patcher-references))
 430       (patcher-change-log-minor-mode t)
 431       (when (and (patcher-reference-buffer project change-log)
 432                  (eq (patcher-project-option project :change-logs-updating)
 433                      'automatic))
 434         (dolist (hook (patcher-project-option project
 435                         :after-save-change-log-hook))
 436           (add-hook 'after-save-hook
 437                     (patcher-wrap-hook project hook) nil t))))))
 438
 439 (put 'patcher-unreference-change-log 'lisp-indent-function 1)
 440 (defun patcher-unreference-change-log (project change-log kill)
 441   ;; Remove the reference to PROJECT from CHANGE-lOG buffer.
 442   ;; If KILL and PROJECT was the last reference in the CHANGE-LOG buffer,
 443   ;; authorize Patcher to kill the CHANGE-LOG buffer.
 444   ;; This function also removes PROJECT's after-save-hook and the ChangeLog
 445   ;; minor mode  from the CHANGE-LOG buffer when necessary.
 446   ;; Return t if CHANGE-LOG was killed.
 447   (when change-log
 448     (patcher-delete-extent (patcher-change-log-extent project change-log))
 449     (with-current-buffer change-log
 450       (when (eq (patcher-project-option project :change-logs-updating)
 451                 'automatic)
 452         (dolist (hook (patcher-project-option project
 453                         :after-save-change-log-hook))
 454           ;; #### NOTE: we remove the after-save-hook before possibly killing
 455           ;; (hence saving) the buffer, because unreferencing a ChangeLog
 456           ;; means that we're done with the project.
 457           (remove-hook 'after-save-hook (patcher-wrap-hook project hook) t)))
 458       (multiple-value-bind (lastp killp)
 459           (patcher-unreference-buffer project change-log
 460             kill
 461             ;; #### NOTE: this FORCE-SAVE flag is here because there's
 462             ;; currently no way to kill an unsaved buffer without asking
 463             ;; confirmation (kill-buffer is a built-in function). Normally, I
 464             ;; would rather kill without saving here.
 465             (when (eq (patcher-project-option project :change-logs-status)
 466                       'ephemeral)
 467               'force-save))
 468         (when lastp ;; no harm done even if the buffer was killed.
 469           (patcher-change-log-minor-mode -1))
 470         killp))))
 471
 472 (put 'patcher-change-log-buffer 'lisp-indent-function 2)
 473 (defun* patcher-change-log-buffer (project change-log &optional find)
 474   ;; Find a buffer visiting PROJECT's CHANGE-LOG.
 475   ;; Return 2 values: a buffer visiting CHANGE-LOG and a boolean indicating
 476   ;; whether CHANGE-LOG was already visited. If CHANGE-LOG is not visited,
 477   ;; return nil unless FIND, in which case force visiting.
 478   ;; This function also references PROJECT in the buffer.
 479   (multiple-value-bind (buffer existing)
 480       (patcher-file-buffer change-log find)
 481     (patcher-reference-change-log project buffer existing)
 482     (values buffer existing)))
 483
 484 (put 'patcher-change-log-buffers 'lisp-indent-function 1)
 485 (defun* patcher-change-log-buffers (project &optional find &aux buffers)
 486   ;; Return a list of buffers visiting PROJECT's ChangeLog files.
 487   ;; If FIND, make sure to visit all ChangeLog files. Otherwise, skip
 488   ;; unvisited ones.
 489   ;; This function also references PROJECT in each ChangeLog buffer.
 490   (dolist (change-log (patcher-project-change-logs project) buffers)
 491     (multiple-value-bind (buffer)
 492         (patcher-change-log-buffer project change-log find)
 493       (when buffer
 494         (patcher-endpush buffer buffers)))))
 495
 496 (defun patcher-save-change-logs (project)
 497   ;; Save PROJECT's ChangeLog buffers (unless ephemeral).
 498   (unless (eq (patcher-project-option project :change-logs-status) 'ephemeral)
 499     (patcher-save-buffers (patcher-change-log-buffers project))))
 500
 501
 502 ;; ChangeLog files ==========================================================
 503
 504 (globally-declare-boundp 'patcher-link-change-log-hook)
 505
 506 (put 'patcher-link-change-log 'lisp-indent-function 1)
 507 (defun patcher-link-change-log (project change-log)
 508   ;; Link CHANGE-LOG to PROJECT.
 509   ;; This function handles buffer reference if CHANGE-lOG is already loaded,
 510   ;; but doesn't load it otherwise.
 511   (unless (member change-log (patcher-project-change-logs project))
 512     (patcher-endpush change-log (patcher-project-change-logs project))
 513     (patcher-reference-change-log project (get-file-buffer change-log)
 514                                   'existing)
 515     (patcher-with-progression "Running the link-change-log hook"
 516       (let ((patcher-link-change-log-hook
 517              (patcher-project-option project :link-change-log-hook)))
 518         (run-hook-with-args 'patcher-link-change-log-hook
 519                             (patcher-file-relative-name change-log))))))
 520
 521 (defun patcher-link-change-logs (project change-logs)
 522   ;; Link CHANGE-LOGS to PROJECT.
 523   (dolist (change-log change-logs)
 524     (patcher-link-change-log project change-log)))
 525
 526 (defun* patcher-unlink-change-log
 527     (project change-log override-kill
 528      &aux (kill (or override-kill
 529                     (patcher-project-option project
 530                       :kill-change-logs-after-sending))))
 531   ;; Unlink CHANGE-LOG from PROJECT.
 532   ;; If OVERRIDE-KILL, override the :kill-change-logs-after-sending option.
 533   ;; If PROJECT has ephemeral ChangeLogs and the ChangeLog buffer was killed,
 534   ;; also delete the file.
 535   (when (member change-log (patcher-project-change-logs project))
 536     (when (and (patcher-unreference-change-log project
 537                  (get-file-buffer change-log) kill)
 538                (eq (patcher-project-option project :change-logs-status)
 539                    'ephemeral))
 540       ;; ChangeLog files may in fact not exist if they are both ephemeral and
 541       ;; not saved.
 542       (condition-case nil
 543           (delete-file change-log)
 544         (file-error nil)))
 545     (setf (patcher-project-change-logs project)
 546           (delete change-log (patcher-project-change-logs project)))))
 547
 548 (put 'patcher-unlink-change-logs 'lisp-indent-function 1)
 549 (defun* patcher-unlink-change-logs
 550     (project
 551      &key (change-logs (patcher-project-change-logs project))
 552           override-kill
 553      &aux (kill (or override-kill
 554                     (patcher-project-option project
 555                       :kill-change-logs-after-sending))))
 556   ;; Unlink CHANGE-LOGS from PROJECT.
 557   ;; If OVERRIDE-KILL, override the :kill-change-logs-after-sending option.
 558   (dolist (change-log change-logs)
 559     (patcher-unlink-change-log project change-log kill)))
 560
 561
 562
 563 \f
 564 ;; ==========================================================================
 565 ;; ChangeLog entries in ChangeLog files
 566 ;; ==========================================================================
 567
 568 (put 'patcher-change-log-extent 'lisp-indent-function 1)
 569 (defun* patcher-change-log-extent
 570     (project change-log
 571      &optional create
 572      &aux (extent (patcher-extent 'project
 573                     :value project
 574                     :here change-log)))
 575   ;; Return a ChangeLog extent for PROJECT in CHANGE-LOG.
 576   ;; Maybe CREATE one instead of returning nil.
 577   (when (and (not extent) create)
 578     (save-window-excursion
 579       (display-buffer change-log t)
 580       (let ((entries (patcher-read-natnum "\
 581 How many entries belong to the project (1): "
 582                                           1))
 583             beg end)
 584         (when (> entries 0)
 585           (save-excursion
 586             (set-buffer change-log)
 587             (save-restriction
 588               (widen)
 589               (goto-char (point-min))
 590               (skip-chars-forward " \n\t")
 591               (unless (looking-at +patcher-change-log-entry-start-regexp+)
 592                 (patcher-error "\
 593 Beginning of buffer doesn't look like a ChangeLog entry."))
 594               (setq beg (point))
 595               (condition-case nil
 596                   (while (> entries 0)
 597                     (re-search-forward +patcher-change-log-entry-start-regexp+)
 598                     (setq entries (1- entries)))
 599                 (t
 600                  (patcher-error "\
 601 Buffer is missing %s ChangeLog entr%s to do the count."
 602                                 entries (if (= entries 1) "y" "ies"))))
 603               (setq end
 604                     (or (when (re-search-forward
 605                                +patcher-change-log-entry-start-regexp+ nil t)
 606                           (progn (beginning-of-line) (point)))
 607                         (point-max)))
 608               (set-extent-properties (setq extent (make-extent beg end))
 609                                      `(start-open t
 610                                        duplicable t
 611                                        patcher-project ,project
 612                                        patcher-change-log
 613                                        (buffer-file-name)))))))))
 614   extent)
 615
 616 (put 'patcher-generate-change-logs 'lisp-indent-function 1)
 617 (defun* patcher-generate-change-logs
 618     (project &aux (buffer (patcher-project-process-buffer project)))
 619   ;; Generate PROJECT's ChangeLog skeletons.
 620   ;; These skeletons are based on the current process buffer's diff.
 621
 622   ;; #### NOTE: if we let patch-to-change-log visit the files as needed, we
 623   ;; won't know which ones were already there, hence messing up with the
 624   ;; referencing. So instead, we start by loading them explicitely.
 625   (patcher-with-progression "Loading the source files"
 626     (patcher-source-buffers project 'find))
 627   (patcher-with-progression "Loading the ChangeLog files"
 628     (patcher-change-log-buffers project 'find))
 629   (patcher-with-progression "Generating the ChangeLog skeletons"
 630     (with-current-buffer buffer
 631       ;; #### NOTE: before version 3.11, every diff output was cleaned up by
 632       ;; after-diff hooks to remove (some of the) RCS specific syntax. This
 633       ;; isn't the case anymore so in order for patch-to-change-log to keep on
 634       ;; working, we need to do this cleanup here.
 635       (let ((diff-cleaner (patcher-project-option project :diff-cleaner))
 636             (string (patcher-source-contents buffer)))
 637         (with-string-as-buffer-contents string
 638           (require 'add-log)
 639           (beginning-of-buffer)
 640           (when diff-cleaner
 641             (funcall diff-cleaner
 642                      (patcher-project-option project :diff-header t)))
 643           ;; #### WARNING: temporary hack to let patch-to-change-log use my
 644           ;; own ChangeLog locating function. Note the free reference to
 645           ;; ABSFILE. I will eventually provide my own version of this
 646           ;; function.
 647           (flet ((find-change-log ()
 648                    (patcher-locate-change-log project
 649                      (declare-boundp absfile))))
 650             (patch-to-change-log (patcher-project-command-directory project)
 651                                  :my-name (or (patcher-project-option project
 652                                                 :change-logs-user-name)
 653                                               (patcher-project-option project
 654                                                 :user-name))
 655                                  :my-email (or (patcher-project-option project
 656                                                  :change-logs-user-mail)
 657                                                (patcher-project-option project
 658                                                  :user-mail))
 659                                  :extent-property 'patcher-project
 660                                  :extent-property-value project)))))
 661     ;; Now that we have our ChangeLog skeletons, let's loop over them and add
 662     ;; the patcher-change-log property to the extents.
 663
 664     ;; #### NOTE: the part about burying in the comment below is obsolete
 665     ;; because we now have proper navigation commands.
 666
 667     ;; Also, patch-to-change-log has the unfortunate side effect of burying
 668     ;; all the ChangeLog buffers when it's done. This is exactly the opposite
 669     ;; of what we want, since once the ChangeLogs have been generated, the
 670     ;; next step is to go visit them. so put them (in order!) directly below
 671     ;; the current buffer, and while we're at it, also add the
 672     ;; patcher-change-log property to every extent.
 673     (let ((topbuf (car (buffer-list))))
 674       (dolist (clbuf (patcher-change-log-buffers project))
 675         (bury-buffer clbuf topbuf)
 676         (let ((extent (patcher-change-log-extent project clbuf)))
 677           (assert extent)
 678           (set-extent-properties extent
 679                                  `(start-open t
 680                                    duplicable t
 681                                    patcher-change-log
 682                                    ,(buffer-file-name clbuf)))
 683           (with-current-buffer clbuf
 684             ;; window-start ends up past the newly inserted entry, so fix that.
 685             (goto-char (extent-start-position extent)))))
 686       (bury-buffer topbuf (car (buffer-list))))))
 687
 688 (put 'patcher-ungenerate-change-log 'lisp-indent-function 2)
 689 (defun patcher-ungenerate-change-log
 690     (project change-log interactive prompt)
 691   ;; Remove PROJECT's previously generated ChangeLog entries in CHANGE-LOG.
 692   ;; If INTERACTIVE, ask confirmation.
 693   (when change-log
 694     (let ((extent (patcher-change-log-extent project change-log)))
 695       (when (and extent
 696                  (or (not interactive)
 697                      (progn (display-buffer change-log)
 698                             (y-or-n-p prompt))))
 699         (patcher-delete-extent-and-region extent)))
 700     ;; Always offer to save the buffer now (even if nothing really happened),
 701     ;; because ungeneration is often followed by a diff, and the question
 702     ;; would be asked anyway, only later. Doing it here is better because the
 703     ;; buffer might already be displayed.
 704     (unless (eq (patcher-project-option project :change-logs-status)
 705                 'ephemeral)
 706       (patcher-save-buffer change-log))))
 707
 708 (put 'patcher-ungenerate-change-logs 'lisp-indent-function 1)
 709 (defun* patcher-ungenerate-change-logs
 710     (project change-logs
 711      &key interactive
 712           (prompt "Remove this skeleton? "))
 713   ;; Remove PROJECT's previously generated ChangeLog entries.
 714   ;; If INTERACTIVE, ask confirmation for each ChangeLog buffer with PROMPT.
 715   ;; Perform on CHANGE-LOGS (all PROJECT's ChangeLog buffers by default).
 716   (save-window-excursion
 717     (dolist (change-log change-logs)
 718       (patcher-ungenerate-change-log project change-log interactive prompt))))
 719
 720 (defun* patcher-generated-change-logs (project &aux change-log-buffers)
 721   ;; Return a list of generated ChangeLog buffers for PROJECT.
 722   (when (eq (patcher-project-option patcher-project :change-logs-updating)
 723             'automatic)
 724     (dolist (change-log-buffer (patcher-change-log-buffers project))
 725       (when (patcher-change-log-extent project change-log-buffer)
 726         (patcher-endpush change-log-buffer change-log-buffers))))
 727   change-log-buffers)
 728
 729
 730
 731 \f
 732 ;; ==========================================================================
 733 ;; ChangeLog entries outside ChangeLog files
 734 ;; ==========================================================================
 735
 736 (put 'patcher-compress-change-logs 'lisp-indent-function 1)
 737 (defun patcher-compress-change-logs ()
 738   ;; Compress ChangeLog entries in the patcher-change-logs extent.
 739   ;; Make it a 'patcher-compressed-change-logs extent afterwards.
 740   ;; #### WARNING: this will break if someone wants BOTH ChangeLogs and
 741   ;; compressed ChangeLogs.
 742   (patcher-within-extent (extent 'change-logs)
 743     (narrow-to-region (extent-start-position extent)
 744                       (extent-end-position   extent))
 745     (patcher-delete-extent-and-region (patcher-extent 'change-log-prologue))
 746     (delete-matching-lines +patcher-change-log-entry-start-regexp+)
 747     ;; Now compress the change log specs into just files, so that mostly just
 748     ;; the annotations are left.
 749     (let ((change-log-change-line
 750            "^\\([ \t]+\\)\\* \\(\\S-+\\)\\( (.*)\\)?:\\( New\\.\\)?"))
 751       (while (re-search-forward change-log-change-line nil t)
 752         ;; Change to match-end if you want the indentation.
 753         (let ((beg (match-beginning 1))
 754               (end (match-end 0))
 755               files)
 756           (push (match-string 2) files)
 757           (forward-line 1)
 758           (while (looking-at change-log-change-line)
 759             (setq end (match-end 0))
 760             (unless (member (match-string 2) files)
 761               (push (match-string 2) files))
 762             (forward-line 1))
 763           (goto-char beg)
 764           (delete-region beg end)
 765           (insert (mapconcat #'identity (nreverse files) ", ") ":")
 766           (when (looking-at "\\s-+")
 767             (let ((p (point))
 768                   (end (match-end 0)))
 769               ;; If there's no annotation at all for this change, make sure
 770               ;; we don't treat the next change as an annotation for this
 771               ;; one!
 772               (if (save-excursion
 773                     (goto-char end)
 774                     (beginning-of-line)
 775                     (looking-at change-log-change-line))
 776                   (progn
 777                     (if (looking-at "[ \t]+")
 778                         (delete-region p (match-end 0))))
 779                 (delete-region p end)
 780                 (insert " ")))))))
 781     ;; Shrink extra blank lines.
 782     (let ((blank-line "^\\s-*$"))
 783       (goto-char (point-min))
 784       (while (and (not (eobp))
 785                   (progn (forward-line 1)
 786                          (re-search-forward blank-line nil t)))
 787         (delete-blank-lines))
 788       (goto-char (point-min))
 789       (if (looking-at blank-line)
 790           (delete-blank-lines)))
 791     (widen)
 792     (set-extent-properties extent '(patcher-change-logs nil
 793                                     patcher-compressed-change-logs t))))
 794
 795 ;; This function is used in patcher-mail and patcher-logmsg. ChangeLog
 796 ;; contents means ChangeLog entries, possibly prepended by a ChangeLog
 797 ;; prologue.
 798 (defun* patcher-insert-change-log-contents
 799     (project point
 800      &aux (prologue (patcher-project-option project :change-logs-prologue)))
 801   ;; Insert PROJECT's ChangeLog contents in current buffer at POINT.
 802   ;; Create the patcher-change-logs extent.
 803   ;; Return t if something has indeed been inserted.
 804   (patcher-with-progression "Inserting ChangeLog contents"
 805     (save-excursion
 806       (goto-char point)
 807       (dolist (change-log (patcher-change-log-buffers project 'find))
 808         (insert "\n")
 809         (unless (zerop (length prologue))
 810           (let ((beg (point)))
 811             (insert (replace-in-string prologue "%f"
 812                                        (patcher-file-relative-name
 813                                         (buffer-file-name change-log)))
 814                     "\n\n")
 815             (set-extent-properties (make-extent beg (point))
 816                                    `(start-open t
 817                                      duplicable t
 818                                      patcher-change-log-prologue
 819                                      ,(buffer-file-name change-log)))))
 820         (insert (extent-string (patcher-change-log-extent project
 821                                  change-log 'create))))
 822       (set-extent-properties (make-extent point (point))
 823                              '(start-open t
 824                                duplicable t
 825                                patcher-change-logs t))
 826       (not (= (point) point)))))
 827
 828
 829 (provide 'patcher-change-log)
 830
 831 ;;; patcher-change-log.el ends here