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

   1 ;;; patcher-instance.el --- Process instantiation
   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:43:33 2010
   9 ;; Last Revision: Thu Jan 12 22:04:43 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
  42
  43 \f
  44 ;; ==========================================================================
  45 ;; Utilities
  46 ;; ==========================================================================
  47
  48 (patcher-define-error 'status
  49   "Patcher status error.")
  50
  51
  52
  53 \f
  54 ;; ==========================================================================
  55 ;; Project instantiation
  56 ;; ==========================================================================
  57
  58 (defstruct (patcher-project (:constructor patcher-make-project))
  59   name
  60   subject
  61   committed-p
  62   window-configuration
  63   mail-buffer
  64   process-buffer
  65   cmtcmd-buffer
  66   logmsg-buffer
  67   ;; The name of the temporary file in which to store the log message. The
  68   ;; reason why the logmsg-buffer does not visit this file (hence the need for
  69   ;; this variable) is that we want the logmsg buffer's name to be readable,
  70   ;; and the user doesn't care about the name of the temporary file.
  71   logmsg-file-name
  72   ;; The diff command to use. This string is not supposed to include the files
  73   ;; to which the command applies. Only the command itself. This variable is
  74   ;; needed because the user has the ability to override the project's diff
  75   ;; command by giving a prefix to `patcher-generate-diff'.
  76   diff-command
  77   ;; The commit command to use. This variable is needed because the user has
  78   ;; the ability to override the project's commit command by giving a prefix
  79   ;; to `patcher-logmsg-commit'.
  80   commit-command
  81   ;; The project's base directory. This variable is used to anchor ephemeral
  82   ;; ChangeLogs, and is needed because a subproject may modify the original
  83   ;; project's value for it.
  84   base-directory
  85   ;; The project's command directory. This variable is needed for supporting
  86   ;; relocatable projects.
  87   command-directory
  88   ;; List of files/directories command-line specification for the diff
  89   ;; command. This variable is needed because a temporary subproject may
  90   ;; modify the original project's value for it.
  91   specification
  92   ;; List of ChangeLog absolute file names.
  93   change-logs
  94   ;; List of source absolute file names.
  95   sources)
  96
  97
  98 ;; Accessors ================================================================
  99
 100 (put 'patcher-project-option 'lisp-indent-function 1)
 101 (defun* patcher-project-option
 102     (project option &optional non-nil
 103                     &aux (name (patcher-project-name project))
 104                          (opt (patcher-descriptor-option
 105                                (patcher-project-descriptor name) option 0)))
 106   ;; Return the value of OPTION in PROJECT, or fall back to the value of
 107   ;; `patcher-default-OPTION'. If NON-NIL, check that the retreived value is
 108   ;; not null.
 109   (if opt
 110       (cadr opt)
 111     (or (symbol-value (intern-soft (concat "patcher-default-"
 112                                            (substring
 113                                             (symbol-name option) 1))))
 114         (when non-nil
 115           (patcher-error "Project %s: option %s is null" name option)))))
 116
 117 (defun patcher-project-command-name (project)
 118   ;; Return the value of the :name option in PROJECT, or PROJECT's name.
 119   (or (patcher-project-option project :name)
 120       (patcher-project-name project)))
 121
 122 (defun patcher-project-files (project)
 123   ;; Return the sorted list of PROJECT's files.
 124   ;; The files are returned relative to PROJECT's command directory.
 125   ;; Files include both sources and ChangeLogs, unless ChangeLogs are
 126   ;; ephemeral in PROJECT.
 127   (let ((dir (patcher-project-command-directory project)))
 128     (patcher-sort-files
 129      (mapcar (lambda (file)
 130                (patcher-file-relative-name file dir))
 131              (if (eq (patcher-project-option project :change-logs-status)
 132                      'ephemeral)
 133                  (patcher-project-sources project)
 134                  (append (patcher-project-change-logs project)
 135                          (patcher-project-sources project)))))))
 136
 137 (defun patcher-project-sources-string (project)
 138   ;; Return a string of all PROJECT's source files.
 139   (patcher-files-string (patcher-project-sources project)))
 140
 141 (defun patcher-project-change-logs-string (project)
 142   ;; Return a string of all PROJECT's ChangeLog files.
 143   (patcher-files-string (patcher-project-change-logs project)))
 144
 145
 146 ;; Instantiation ============================================================
 147
 148 ;; #### NOTE: this variable is set in every auxiliary buffer (see below).
 149 ;; Technically, it is not required in process buffers; only in buffers where
 150 ;; interactive functions might be called without a project as argument. This
 151 ;; variable is not set in reference buffers (see also below) because they
 152 ;; might be shared by different instances of patcher. In ChangeLog files for
 153 ;; instance, we have extents providing the necessary information about every
 154 ;; entry instead.
 155 (make-variable-buffer-local
 156  (defvar patcher-project nil
 157    ;; Instance of the PATCHER-PROJECT structure describing the current
 158    ;; project.
 159    ))
 160
 161 (defvar patcher-subject-history nil)
 162
 163 (defun* patcher-prompt-subject
 164     (project
 165      &aux (subject (read-string "Subject: "
 166                      (let ((s (patcher-project-option project :subject)))
 167                        (unless (zerop (length s))
 168                          (patcher-substitute-name project s)))
 169                      'patcher-subject-history)))
 170   ;; Prompt for, and return a subject for PROJECT.
 171   ;; Also create the 'patcher-subject extent in the string.
 172   (set-extent-properties (make-extent 0 (length subject) subject)
 173                          '(duplicable t
 174                            start-open t
 175                            patcher-subject t))
 176   subject)
 177
 178 (defvar patcher-directory-history nil)
 179
 180
 181 ;; #### NOTE: supporting subprojects is in fact rather complicated because of
 182 ;; the various ways the supported RCSes behave. The situation is as follows:
 183
 184 ;; 1/ At first glance, it may seem simpler to always execute commands from the
 185 ;; (super)project's base directory, turning a :subdirectory into a
 186 ;; specification. However, this would make things difficult for the user of a
 187 ;; Mercurial repository with plenty of submodules (e.g. the XEmacs packages).
 188 ;; Indeed, it would then be necessary to define one distinct project for every
 189 ;; submodule because the commands need to be executed locally in every
 190 ;; submodule. Patcher could perhaps support this by parsing .hgsub and
 191 ;; dynamically create all subprojects as regular projects but we're not quite
 192 ;; there yet (this brings the more general question of submodules that exist
 193 ;; in various forms in different RCSes). So at least for the time being, we
 194 ;; choose to work directly in the specified subdirectory, if any. This,
 195 ;; however, causes additional problems.
 196
 197 ;; 2/ PRCS can't work in subdirectories. Only from the toplevel. Hence the
 198 ;; :command-directory option which cancels the above policy.
 199
 200 ;; 3/ Some RCSes like CVS output diff paths relative to the current directory
 201 ;; by default. Some others like Git don't (Git needs --relative, so we need
 202 ;; to be careful in themes). In Mercurial, there doesn't seem to be a way to
 203 ;; get relative paths and that is currently a problem.
 204
 205 ;; 4/ Then, there is the commit command problem. While Git diff --relative
 206 ;; restricts to the current directory, there's no corresponding behavior for
 207 ;; the commit command. For instance, if you git commit -a from a subdirctory,
 208 ;; even the changes outside the current directory will be committed. Because
 209 ;; of that, we can't work with empty specifications in subdirectories (we need
 210 ;; at least to use ".").
 211
 212 ;; All in all, this is why the function below is such a mess.
 213
 214 (defun* patcher-prompt-project
 215     (relocate override
 216      &aux (project (patcher-make-project :name (patcher-prompt-name)))
 217           (base-directory
 218            (patcher-descriptor-directory
 219             (patcher-project-descriptor (patcher-project-name project))))
 220           (subdirectory (patcher-project-option project :subdirectory))
 221           (command-directory
 222            (patcher-project-option project :command-directory))
 223           (files (patcher-project-option project :files))
 224           default-working-directory working-directory)
 225   ;; Create and return a new project by prompting for it.
 226   ;; Always prompt for the project's name and subject.
 227   ;; When RELOCATE, offer to use an alternate directory.
 228   ;; When OVERRIDE, offer to work on a temporary subproject.
 229   ;; Note that it is possible to both relocate and  override.
 230
 231   ;; Initialize non problematic slots.
 232   (setf (patcher-project-subject project) (patcher-prompt-subject project))
 233   (setf (patcher-project-diff-command project)
 234         (patcher-project-option project :diff-command t))
 235   (setf (patcher-project-commit-command project)
 236         (patcher-project-option project :commit-command t))
 237
 238   ;; Handle relocation. SUBDIRECTORY, COMMAND-DIRECTORY and FILES are all
 239   ;; supposed to be relative paths so only BASE-DIRECTORY needs to be modified
 240   ;; at that point.
 241   (when (or relocate (null base-directory))
 242     (setq base-directory
 243           (read-directory-name
 244            (if subdirectory
 245                (format (if base-directory
 246                            "Relocate %s under: "
 247                          "%s location: ")
 248                    (file-name-as-directory subdirectory))
 249              (if base-directory "Relocate to: " "Project location: "))
 250            ;; #### NOTE: I think it's nice to start from ../ because many
 251            ;; people keep clones of the same project under one directory. It
 252            ;; might however not be so intuitive that if you don't type
 253            ;; anything, you will get the original directory, not the one
 254            ;; that's printed in the minibuffer.
 255            (when base-directory
 256              (file-name-as-directory (expand-file-name ".." base-directory)))
 257            base-directory t nil patcher-directory-history))
 258
 259     ;; Check that the relocation is valid: we need both a valid subdirectory
 260     ;; and command (super) directory.
 261     (when subdirectory
 262       (unless (file-exists-p (expand-file-name subdirectory base-directory))
 263         (patcher-error "Unable to relocate subdirectory %s under %s"
 264                        subdirectory base-directory)))
 265     (when command-directory
 266       (unless (file-exists-p (expand-file-name command-directory
 267                                                base-directory))
 268         (patcher-error "Unable to relocate command directory %s under %s"
 269                        command-directory base-directory))))
 270   (setf (patcher-project-base-directory project) base-directory)
 271
 272   ;; Compute the default working directory (that is, before a potential
 273   ;; override) and the actual one which may be overridden.
 274   (setq default-working-directory
 275         (directory-file-name
 276          (if subdirectory
 277              (expand-file-name subdirectory base-directory)
 278            base-directory)))
 279   (setq working-directory
 280         (if override
 281             (directory-file-name
 282              (read-directory-name "Subdirectory: "
 283                                   (file-name-as-directory
 284                                    default-working-directory)
 285                                   default-working-directory
 286                                   t))
 287           default-working-directory))
 288
 289   ;; #### WARNING: this filtering is very complicated to do because of the
 290   ;; possibility to use wildcards. The code below doesn't really work so for
 291   ;; the time being, I'm backing this out and just cancelling the :files
 292   ;; preselection.
 293
 294 ;;;  ;; If we have overridden the working directory, we need to filter out the
 295 ;;;  ;; :files that do not belong to that new subdirectory.
 296 ;;;  (unless (string= default-working-directory working-directory)
 297 ;;;    ;; #### FIXME: this will break if someone dares to define a subproject
 298 ;;;    ;; with files starting with ../ and other clever tricks. Let's just hope
 299 ;;;    ;; nobody does that.
 300 ;;;    (setq files (loop with subdir = (directory-file-name
 301 ;;;                                  (patcher-file-relative-name
 302 ;;;                                          working-directory
 303 ;;;                                          default-working-directory))
 304 ;;;                   with length = (length subdir)
 305 ;;;                   for file in files
 306 ;;;                   if (string= subdir (directory-file-name file))
 307 ;;;                     collect "*" and collect ".*"
 308 ;;;                   else
 309 ;;;                     when (and (> (length file) (1+ length))
 310 ;;;                               (string= subdir
 311 ;;;                                        (substring file 0 length))
 312 ;;;                               (char= ?/ (aref file length)))
 313 ;;;                       collect (substring file (1+ length)))))
 314
 315   (unless (string= default-working-directory working-directory)
 316     (setq files nil))
 317
 318   ;; Handle a request for overriding the :files.
 319   (when override
 320     (setq files
 321           ;; #### FIXME: this will break when a filename contains spaces!
 322           (split-string
 323            (let ((default-directory
 324                   (file-name-as-directory working-directory)))
 325              (or (when files
 326                    (let ((files-string (mapconcat #'identity files " ")))
 327                      (read-shell-command "Files: "
 328                                          (concat files-string " "))))
 329                  (let* ((default-file (when (buffer-file-name)
 330                                         (patcher-file-relative-name
 331                                          (buffer-file-name)
 332                                          working-directory)))
 333                         (default-file
 334                          ;; If the file is not actually underneath the
 335                          ;; project, then don't suggest it as a possibility.
 336                          (when default-file
 337                            (if (string-match "^\\.\\.$\\|^\\.\\.[/\\]"
 338                                              default-file)
 339                                nil
 340                              default-file))))
 341                    (read-shell-command "Files: " default-file)))))))
 342
 343   ;; If we are working in a subdirectory with no specification (no :files
 344   ;; option provided), then we need to make an explicit specification of ".".
 345   ;; See point #4 in the comment above this function.
 346   (when (and (or (not (string= default-working-directory working-directory))
 347                  subdirectory)
 348              (not files))
 349     (setq files (list ".")))
 350
 351   ;; Initialize the project's command directory and files specification.
 352   ;; When a command directory is given, we further need to relativize all the
 353   ;; :files to this directory.
 354   (cond (command-directory
 355          (setq command-directory
 356                (directory-file-name
 357                 (expand-file-name command-directory base-directory)))
 358          (setf (patcher-project-command-directory project) command-directory)
 359          (setf (patcher-project-specification project)
 360                (if files
 361                    (mapcar
 362                     (lambda (file)
 363                       (patcher-file-relative-name
 364                        (expand-file-name file working-directory)
 365                        command-directory))
 366                     files)
 367                  (unless (string= command-directory working-directory)
 368                    (list (patcher-file-relative-name
 369                           working-directory command-directory))))))
 370         (t
 371          (setf (patcher-project-command-directory project) working-directory)
 372          (setf (patcher-project-specification project) files)))
 373
 374   ;; Finally, initialize the process buffer. This needs to wait until the
 375   ;; command directory is properly initialized.
 376   ;; unclean forward reference
 377   (patcher-setup-auxiliary-buffer project
 378     (setf (patcher-project-process-buffer project)
 379           (generate-new-buffer " *Patcher Process*")))
 380
 381   project)
 382
 383 (defun patcher-project-interactive (prefix)
 384   ;; Create and return a new project based on PREFIX requests in a list.
 385   ;; See `patcher-mail' for the semantics of PREFIX.
 386   (list (patcher-prompt-project (member prefix '(1 -1))
 387                                 (and prefix (not (eq prefix 1))))))
 388
 389
 390
 391
 392 \f
 393 ;; ==========================================================================
 394 ;; Project-related utilities
 395 ;; ==========================================================================
 396
 397 (put 'patcher-substitute-name 'lisp-indent-function 1)
 398 (defun* patcher-substitute-name
 399     (project str &aux (command-name (patcher-project-command-name project))
 400                       (name (patcher-project-name project)))
 401   ;; Replace a %n in STR with PROJECT's command name.
 402   ;; Replace a %N in STR with PROJECT's name.
 403   (let (case-fold-search)
 404     (replace-in-string (replace-in-string str "%N" name) "%n" command-name)))
 405
 406 (defun* patcher-prefixed-subject
 407     (project &optional old-subject
 408              &aux (subject-prefix (patcher-project-option project
 409                                     :subject-prefix))
 410                   (subject (patcher-project-subject project)))
 411   ;; Return PROJECT's prefixed subject, possibly adapting OLD-SUBJECT.
 412   (unless (zerop (length subject-prefix))
 413     (setq subject-prefix (patcher-substitute-name project subject-prefix))
 414     (set-extent-properties (make-extent 0 (length subject-prefix)
 415                                         subject-prefix)
 416                            '(duplicable t
 417                              start-open t
 418                              patcher-subject-prefix t)))
 419   (unless (zerop (length old-subject))
 420     (setq subject
 421           (if (zerop (length subject))
 422               old-subject
 423             (let (case-fold-search)
 424               (replace-in-string
 425                (replace-in-string
 426                 (patcher-project-option project :subject-rewrite-format)
 427                 "%S" old-subject t)
 428                "%s" subject t)) )))
 429   (concat subject-prefix
 430           (unless (or (zerop (length subject-prefix))
 431                       (zerop (length subject)))
 432             " ")
 433           subject))
 434
 435 (defun patcher-change-subject (project)
 436   ;; Read a new subject for PROJECT and propagate it to relevant buffers.
 437   (setf (patcher-project-subject project)
 438         (read-string "New subject: " (patcher-project-subject project)))
 439   (dolist (buffer (list (patcher-project-mail-buffer   project)
 440                         (patcher-project-logmsg-buffer project)))
 441     (when buffer
 442       (with-current-buffer buffer
 443         (patcher-within-extent (extent 'subject)
 444           (insert (patcher-project-subject project))
 445           (delete-region (point) (extent-end-position extent)))))))
 446
 447 (put 'patcher-command 'lisp-indent-function 1)
 448 (defun patcher-command (project command &optional files)
 449   ;; Build a Patcher command from COMMAND that applies to FILES.
 450   ;; This involves %n, %N, %f, %!f and %?f substitutions,
 451   ;; as well as :pre-command handling.
 452   ;; Special value t for FILES means use all ChangeLog (unless ephemeral) and
 453   ;; source files explicitely.
 454   (when command
 455     (when (eq files t)
 456       (setq files (if (patcher-project-specification project)
 457                       (patcher-project-files project)
 458                     nil)))
 459     (setq command (patcher-substitute-name project command))
 460     (setq command (replace-in-string command "%!f{\\(.*?\\)}"
 461                                      (if files "" "\\1")))
 462     (setq command (replace-in-string command "%\\?f{\\(.*?\\)}"
 463                                      (if files "\\1" "")))
 464     (setq command (replace-in-string command "%f"
 465                                      (if files
 466                                          (mapconcat #'identity files " ")
 467                                        "")
 468                                      t))
 469     (let ((precmd (patcher-project-option project :pre-command)))
 470       (unless (zerop (length precmd))
 471         (setq command (concat precmd " " command))))
 472     (setq command (replace-in-string command "[ \t]+" " " t))
 473     command))
 474
 475
 476 ;; Auxiliary buffers ========================================================
 477
 478 ;; Auxiliary buffers are used by Patcher to perform specific tasks. They are
 479 ;; not shared across Patcher instances, may be lazily generated and behave
 480 ;; like singletons. Patcher process, log message and commit command buffers
 481 ;; are auxiliary buffers.
 482
 483 (put 'patcher-setup-auxiliary-buffer 'lisp-indent-function 1)
 484 (defun patcher-setup-auxiliary-buffer (project buffer)
 485   ;; Setup BUFFER as auxiliary for PROJECT.
 486   (with-current-buffer buffer
 487     (setq patcher-project project)
 488     (cd (patcher-project-command-directory project))))
 489
 490
 491 ;; Reference buffers ========================================================
 492
 493 ;; Reference buffers are used by Patcher to get project-related information.
 494 ;; They may be shared across patcher instances and may exist independently
 495 ;; from patcher. Source and ChangeLog buffers are reference buffers.
 496
 497 (make-variable-buffer-local
 498  (defvar patcher-references nil
 499    ;; List of Patcher instances referencing this buffer.
 500    ;; Automatically becomes buffer-local when set.
 501    ;; - If this list contains the special value t, it means that the buffer
 502    ;; existed before any instance of Patcher required it, so it will never be
 503    ;; killed (by Patcher).
 504    ;; - Otherwise, Patcher may kill this buffer when there are no more
 505    ;; references to it.
 506    ))
 507
 508 (put 'patcher-reference-buffer 'lisp-indent-function 1)
 509 (defun patcher-reference-buffer (project buffer)
 510   ;; Add a reference to PROJECT in BUFFER.
 511   ;; Return non-nil if the reference didn't exist before.
 512   (with-current-buffer buffer
 513     (unless (member* project patcher-references :test #'eq)
 514       (push project patcher-references))))
 515
 516 (put 'patcher-unreference-buffer 'lisp-indent-function 2)
 517 (defun patcher-unreference-buffer (project buffer &optional kill force-save)
 518   ;; Remove the reference to PROJECT from BUFFER.
 519   ;; If KILL and PROJECT was the last reference in BUFFER, authorize Patcher
 520   ;; to kill BUFFER. If FORCE-SAVE, force saving before killing.
 521   ;; Return two values: whether PROJECT was the last Patcher reference in
 522   ;; BUFFER, and whether BUFFER was killed.
 523   (with-current-buffer buffer
 524     (assert (member* project patcher-references :test #'eq))
 525     (setq patcher-references (delete* project patcher-references :test #'eq))
 526     (let ((lastp (or (null patcher-references)
 527                      (equal patcher-references '(t))))
 528           killp)
 529       (when (and (null patcher-references) kill)
 530         (patcher-save-buffer buffer force-save)
 531         (kill-buffer buffer)
 532         (setq killp t))
 533       (values lastp killp))))
 534
 535
 536 ;; Project cleanup ==========================================================
 537
 538 (defun patcher-delete-project (project &optional kill-mail-buffer)
 539   ;; Delete PROJECT and remove all dependencies.
 540   (declare-fboundp (patcher-unlink-sources     project))
 541   (declare-fboundp (patcher-unlink-change-logs project))
 542   (kill-buffer (patcher-project-process-buffer project))
 543   (when (patcher-project-logmsg-buffer project)
 544     (kill-buffer (patcher-project-logmsg-buffer project)))
 545   (when (patcher-project-cmtcmd-buffer project)
 546     (kill-buffer (patcher-project-cmtcmd-buffer project)))
 547   (when (patcher-project-mail-buffer project)
 548     (if kill-mail-buffer
 549         (kill-buffer (patcher-project-mail-buffer project))
 550       (with-current-buffer (patcher-project-mail-buffer project)
 551         (setq patcher-project nil)))))
 552
 553 (defun patcher-kill-project (project)
 554   ;; Abort PROJECT.
 555   (when (yes-or-no-p "Really abort the project? ")
 556     (unless (or (eq (patcher-project-option project :change-logs-status)
 557                     'ephemeral)
 558                 (patcher-project-committed-p project))
 559       (with-fboundp '(patcher-generated-change-logs
 560                       patcher-ungenerate-change-logs)
 561         (let ((change-log-buffers
 562                (patcher-generated-change-logs patcher-project)))
 563           (when change-log-buffers
 564             (case (patcher-with-message
 565                       (format "\
 566 Some ChangeLog skeletons for this project have been generated.
 567 The relevant ChangeLog files are the following: %s.
 568
 569 Before killing the project, please answer the question below to
 570 remove all skeletons (y), keep them all (n) or choose interactively (i)."
 571                           (patcher-buffers-string change-log-buffers))
 572                     (patcher-read-char "Remove ChangeLog skeletons? " "yni"))
 573               (?y (patcher-ungenerate-change-logs patcher-project
 574                     change-log-buffers))
 575               (?i (patcher-ungenerate-change-logs patcher-project
 576                     change-log-buffers
 577                     :interactive t
 578                     :prompt "Remove this skeleton? ")))))))
 579     (patcher-delete-project project 'kill-mail-buffer)))
 580
 581
 582 ;; Project commands ==========================================================
 583
 584 (put 'patcher-call-command 'common-lisp-indent-function 2)
 585 (defun* patcher-call-command
 586     (project command &key (erase t) progression ignore-exit-status)
 587   ;; Call COMMAND for PROJECT.
 588   ;; Output goes to process buffer.
 589   ;; If ERASE (the default), erase BUFFER first.
 590   ;; Return two values delimiting the process output's region.
 591   ;; Throw a PATCHER-PROCESS error for non-zero exit status or a
 592   ;; failed-command-regexp option match in the process output.
 593   (with-current-buffer (patcher-project-process-buffer project)
 594     (when erase
 595       (erase-buffer))
 596     (let ((beg (point))
 597           (end (patcher-call-process command progression ignore-exit-status))
 598           (failed-command-regexp (patcher-project-option project
 599                                    :failed-command-regexp)))
 600       (when failed-command-regexp
 601         (patcher-with-progression "Checking command output"
 602           (goto-char beg)
 603           (when (re-search-forward failed-command-regexp end t)
 604             (patcher-error 'process command))))
 605       (values beg end))))
 606
 607
 608 ;; Project commit ===========================================================
 609
 610 (patcher-define-error 'committed
 611   "Patcher committed error."
 612   'status)
 613
 614 (defun patcher-detect-committed-project (project)
 615   ;; Detect an already committed PROJECT.
 616   ;; Throw a committed error when detected.
 617   (when (patcher-project-committed-p project)
 618     (patcher-error 'committed)))
 619
 620
 621 (patcher-define-error 'undiffable
 622   "Patcher undiffable error."
 623   'status)
 624
 625 (defun patcher-detect-undiffable-project (project)
 626   ;; Detect an undiffable PROJECT.
 627   ;; Throw an undiffable error when detected.
 628   (when (patcher-project-committed-p project)
 629     (patcher-error 'undiffable)))
 630
 631
 632 (patcher-define-error 'commit
 633   "Patcher commit error."
 634   'process)
 635
 636 ;; #### NOTE: this function assumes that PROJECT is committable because it is
 637 ;; too low-level to perform the check. Other, upper-level functions will
 638 ;; perform the check.
 639 (defun patcher-commit-project (project command)
 640   ;; Commit PROJECT with commit COMMAND.
 641   (patcher-condition-case nil
 642       (patcher-call-command project command
 643                             :progression "Committing changes")
 644     (process
 645      (patcher-error 'commit command)))
 646   (setf (patcher-project-committed-p project) t)
 647   ;; Record the successful commit in the mail message.
 648   (set-window-configuration (patcher-project-window-configuration project))
 649   (with-current-buffer (patcher-project-mail-buffer project)
 650     (save-excursion
 651       ;; Possibly change the subject:
 652       (let ((subject-committed-prefix
 653              (patcher-project-option project :subject-committed-prefix)))
 654         (when subject-committed-prefix
 655           (setq subject-committed-prefix
 656                 (patcher-substitute-name project subject-committed-prefix))
 657           (patcher-within-extent (extent 'subject-prefix)
 658             (insert subject-committed-prefix)
 659             (delete-region (point) (extent-end-position extent)))
 660           (goto-char (extent-end-position (patcher-extent 'subject-prefix)))
 661           (when (looking-at "\\S-")
 662             (insert " "))))
 663       ;; Insert the `committed' notice:
 664       (goto-char (point-min))
 665       (when (re-search-forward
 666              (concat "^" (regexp-quote mail-header-separator))
 667              nil t)
 668         (forward-line 1)
 669         (let ((notice (patcher-project-option patcher-project
 670                         :committed-notice)))
 671           (unless (zerop (length notice))
 672             (insert notice "\n")))))))
 673
 674
 675 (provide 'patcher-instance)
 676
 677 ;;; patcher-instance.el ends here