[darcs-users] Strange bug in xdarcs.el (2/3)
Robin Green
greenrd at greenrd.org
Sun Nov 1 08:48:49 UTC 2009
(defun darcs-refresh-whatsnew ()
"Refresh the whatsnew window without necessarily displaying it"
(let ((root-dir (darcs-root-directory default-directory))
(patch-responses nil))
;; TODO since we destroy and then recreate the entire contents of the window, `save-excursion'
;; doesn't seem to work the way we intended. We might want to behave differently depending on
;; whether the list of changes is "congruent" (ie, is this basically the same set of patches?)
(save-excursion
(when (get-buffer (darcs-format-buffername 'whatsnew root-dir))
(set-buffer (darcs-format-buffername 'whatsnew root-dir))
(setq patch-responses (darcs-collect-patch-responses))
(darcs-whatsnew (or *darcs-narrow-target* root-dir) t *darcs-narrow-target*)
(darcs-apply-patch-responses patch-responses)))))
(defun darcs-record-from-whatsnew ()
"Invoke `darcs-record' with patch inclusion/exclusion pre-populated based on the
setup of the whatsnew window"
(interactive)
(let ((patch-responses (darcs-collect-patch-responses))
(narrow-target *darcs-narrow-target*))
(darcs-record default-directory t nil nil *darcs-narrow-target*)
(darcs-apply-patch-responses patch-responses)
(set (make-local-variable '*darcs-narrow-target*) narrow-target)))
(defun darcs-diff (location)
"Shows all unrecorded differences at LOCATION."
(interactive (list (buffer-truename (current-buffer))))
(darcs-whatsnew location nil t))
(defun darcs-ediff (location)
"Shows the unrecorded differences at LOCATION in an ediff session"
(interactive (list (or (buffer-truename (current-buffer))
default-directory)))
(if darcs-ediff-requires-workaround
(darcs-ediff-workaround location)
(let ((root-dir (darcs-root-directory location)))
(unless root-dir
(error (format "No darcs repo at or around %s" (file-name-directory location))))
(darcs-do-interactive-command root-dir nil
"diff"
"--diff-command=ediff %1 %2"
(darcs-canonical-name location)))))
(defun darcs-ediff-workaround (location)
"Manually query the pristine version of LOCATION and call ediff."
(let ((repo (darcs-root-directory location))
(old-fname (concat temporary-file-directory "/old-" (file-name-nondirectory location))))
(with-temp-buffer
(darcs-do-command repo "show" "contents" location)
(write-file old-fname))
(ediff-files old-fname location)))
(defvar darcs-record-buffer-instructions "***END OF DESCRIPTION***
Place the long patch description above the ***END OF DESCRIPTION*** marker.
The first line of this file will be the patch name.
The patch will contain all the 'included' changes below.
Type x on a change to exclude it from this patch.
Type y on a change to include it.
Type C-c C-c to submit the patch and exit the record buffer.
Type C-x k to abandon this record buffer.
This patch contains the following changes:
" "Instructions for using the record buffer")
(defvar darcs-placeholder-patch-name "<enter patch name>"
"Placeholder patch name for when the user hasn't specified one")
(defun darcs-record (repo-dir &optional same-window patch-name patch-description target-location)
"Displays a buffer for describing a patch and choosing what changes will be included in it. If
SAME-WINDOW is nil (the usual case), displays in the 'other' window; otherwise displays in the
current window. If PATCH-NAME and PATCH-DESCRIPTION are provided, they will be inserted."
(interactive (list (or (buffer-truename (current-buffer))
default-directory)))
(let ((root-dir (darcs-root-directory repo-dir))
(inhibit-read-only t)
(starting-point nil))
(unless root-dir
(error (format "No darcs repo at or around %s" (file-name-directory repo-dir))))
(save-some-buffers)
(setq patch-name (or patch-name
(read-string "What is the patch name? ")))
(darcs-set-buffer 'record root-dir (when same-window 'same-window))
(erase-buffer)
(insert (if (zerop (length patch-name)) darcs-placeholder-patch-name patch-name))
(setq darcs-editable-patch-name-overlay (make-overlay (point-at-bol) (point-at-eol)))
(set-overlay-face darcs-editable-patch-name-overlay 'darcs-patch-name-face)
(insert "\n")
(if patch-description
(insert patch-description)
(insert "\n")
(setq starting-point (if (zerop (length patch-name)) (point-min) (point)))
(insert "\n\n"))
(save-excursion
(insert darcs-record-buffer-instructions)
(unless (zerop (darcs-do-command root-dir "whatsnew" "-u" target-location))
(set-overlay-keymap (make-overlay (point-min) (point-max)) darcs-patch-display-map)
(toggle-read-only 1)
(error (one-line-buffer))))
(darcs-markup-patch-descriptions)
(goto-char (or starting-point (point-min)))))
(defun darcs-refresh-record ()
"Refresh the record window without necessarily displaying it"
(interactive)
(let ((root-dir (darcs-root-directory default-directory))
(patch-responses nil)
(patch-name (save-excursion
(goto-char (point-min))
(buffer-substring (point) (point-at-eol))))
(patch-description (save-excursion
(goto-char (point-min))
(forward-line)
(let ((s (point)))
(re-search-forward (regexp-quote darcs-record-buffer-instructions))
(buffer-substring s (match-beginning 0))))))
(save-excursion
(when (get-buffer (darcs-format-buffername 'record root-dir))
(set-buffer (darcs-format-buffername 'record root-dir))
(setq patch-responses (darcs-collect-patch-responses))
(darcs-record root-dir t patch-name patch-description *darcs-narrow-target*)
(darcs-apply-patch-responses patch-responses)))))
(defvar darcs-comment-filename nil
"Name of the tempfile that contains the comment for the most-recently commited record.")
(defun darcs-commit-record ()
"Commit the patch described by the current buffer"
(interactive)
(let ((patch-name (save-excursion
(goto-char (point-min))
(buffer-substring (point-at-bol) (point-at-eol)))))
(when (string= patch-name darcs-placeholder-patch-name)
(goto-char (point-min))
(error "Please enter a name for this patch")))
(let ((root-dir default-directory)
(patch-responses (darcs-collect-patch-responses))
(logfile-end (save-excursion
(goto-char (point-min))
(re-search-forward (regexp-quote darcs-record-buffer-instructions))
(goto-char (match-beginning 0))
;; skip all but one trailing newline
(while (save-excursion
(forward-line -2)
(looking-at "\n\n"))
(forward-line -1))
(point)))
(comment-filename (make-temp-name "darcs-record-")))
(set (make-local-variable 'darcs-comment-filename)
(expand-file-name (concat root-dir comment-filename)))
(write-region (point-min) logfile-end darcs-comment-filename)
(add-hook 'kill-buffer-hook 'darcs-delete-comment-filename nil t)
(darcs-do-interactive-command root-dir patch-responses
"record" *darcs-narrow-target* (format "--logfile=%s" comment-filename))))
(defun darcs-revert (repo-dir &optional same-window)
(interactive (list (or (buffer-truename (current-buffer))
default-directory)))
(let* ((root-dir (darcs-root-directory repo-dir))
(inhibit-read-only t))
(unless root-dir
(error (format "No darcs repo at or around %s" (file-name-directory repo-dir))))
(save-some-buffers)
(darcs-set-buffer 'revert root-dir (when same-window 'same-window))
(setq default-directory root-dir)
(erase-buffer)
(insert "Select which patches to revert.\nType C-c C-r to revert the included patches.\nType C-x k to abandon revert.\n")
(save-excursion
(unless (zerop (darcs-do-command root-dir "whatsnew" "-u"))
(set-overlay-keymap (make-overlay (point-min) (point-max)) darcs-patch-display-map)
(toggle-read-only 1)
(error (one-line-buffer))))
(darcs-markup-patch-descriptions)
(darcs-exclude-all-patches)
(goto-char (point-min))
(darcs-next-patch)))
(defun darcs-commit-revert ()
"Revert the patches included in the current buffer"
(interactive)
(let ((root-dir default-directory)
(patch-responses (darcs-collect-patch-responses)))
(when (yes-or-no-p "Do you really want to revert these changes? ")
(darcs-do-interactive-command root-dir patch-responses
"revert" *darcs-narrow-target*))))
(defun darcs-refresh-responded ()
"Call `revert-buffer' on each buffer that is visiting a file that has been 'responded to' (ie, all
files that are referenced in `darcs-patch-responses')."
(let* ((root-dir (darcs-root-directory default-directory))
(files (mapcar (lambda (cell)
(when (and (plist-get-with-default (cdr cell) :included t)
(not (plist-get-with-default (cdr cell) :named nil)))
(darcs-associated-file root-dir (car cell))))
darcs-patch-responses)))
(dolist (buffer (buffer-list))
(when (and (buffer-truename buffer)
(member (expand-file-name (buffer-truename buffer))
files))
(with-current-buffer buffer
;; Only confirm if the buffer is modified; otherwise silently revert
(if (buffer-modified-p)
(revert-buffer t)
(revert-buffer t t)))))))
(defun darcs-changes (repo-dir &optional number-of-changes)
"Shows all the changes in the entire repo. Shows the last NUMBER-OF-CHANGES changes if specified;
otherwise shows a complete list."
(interactive (list (or (buffer-truename (current-buffer))
default-directory)
(if (listp current-prefix-arg)
(car current-prefix-arg)
current-prefix-arg)))
(let ((inhibit-read-only t)
(root-dir (darcs-root-directory repo-dir)))
(darcs-set-buffer 'changes root-dir)
(erase-buffer)
(if number-of-changes
(darcs-do-command root-dir "changes" "--verbose"
(format "--last=%d" number-of-changes))
(darcs-do-command root-dir "changes" "--verbose"))
(goto-char (point-min))
(setq darcs-exclude-enabled-function (lambda (ov) nil))
(save-excursion
(darcs-markup-patch-descriptions 4)
(darcs-collapse-all-atomic-patches))))
(defun darcs-filelog (file &optional number-of-changes)
"Shows all the changes that apply to a file. Shows the last NUMBER-OF-CHANGES changes if
specified; otherwise shows a complete list."
(interactive (list (or (buffer-truename (current-buffer))
(error "Current buffer is not associated with a file"))
(if (listp current-prefix-arg)
(car current-prefix-arg)
current-prefix-arg)))
(darcs-set-buffer 'filelog file)
(let ((inhibit-read-only t)
(canon-file (darcs-canonical-name file)))
(erase-buffer)
(if number-of-changes
(darcs-do-command (darcs-root-directory file)
"changes" canon-file "--verbose"
(format "--last=%d" number-of-changes))
(darcs-do-command (darcs-root-directory file)
"changes" canon-file "--verbose"))
(goto-char (point-min))
(setq darcs-exclude-enabled-function (lambda (ov) nil))
(save-excursion
(darcs-markup-patch-descriptions 4)
(darcs-collapse-all-atomic-patches))))
(defun darcs-pull (repo-dir &optional no-prompt)
"Interface to the darcs pull command. A list of possible patches will be displayed for
inclusion/exclusion. With a prefix argument, all patches will be pulled without prompting."
(interactive (list (or (buffer-truename (current-buffer))
default-directory)
current-prefix-arg))
(let ((root-dir (or (darcs-root-directory repo-dir)
(error (format "No darcs repo at or around %s" (file-name-directory repo-dir)))))
(inhibit-read-only t))
(save-some-buffers)
(darcs-set-buffer 'pull root-dir)
(erase-buffer)
(setq darcs-exclude-enabled-function 'darcs-named-patch-p)
(darcs-do-command-async (root-dir "pull" "--verbose" "--dry-run")
(let ((inhibit-read-only t)
(atomic-indentation 4)
(forced-indentation nil))
(goto-char (point-min))
(cond
((re-search-forward "No remote changes to pull in!" nil t)
(goto-char (match-beginning 0))
(delete-region (point-min) (point))
(save-excursion
(darcs-markup-patch-descriptions)))
((re-search-forward "Would pull the following changes:" nil t)
(delete-region (point-min) (point))
;; Detect pre-2.0 darcs format, where atomic patches start from column 1
(save-excursion
(goto-char (point-min))
(when (or (re-search-forward "^\\+" nil t) (re-search-forward "^-" nil t))
(setq atomic-indentation nil)
(setq forced-indentation " ")))
(insert "Select which patches to pull.\nType C-c C-c to pull the included patches.\nType C-x k to abandon pull.\n")
(save-excursion
(darcs-markup-patch-descriptions atomic-indentation forced-indentation)
(darcs-collapse-all-atomic-patches))
(darcs-move-to-patch 1)))))))
(defun darcs-commit-pull ()
"Pull the patches included in the current buffer"
(interactive)
(let ((root-dir default-directory)
(patch-responses (darcs-collect-patch-responses)))
(darcs-do-interactive-command root-dir patch-responses "pull")))
(defun darcs-push (repo-dir &optional no-prompt)
"Interface to the darcs push command. A list of possible patches will be displayed for
inclusion/exclusion. With a prefix argument, all patches will be pushed without prompting."
(interactive (list (or (buffer-truename (current-buffer))
default-directory)
current-prefix-arg))
(let ((root-dir (or (darcs-root-directory repo-dir)
(error (format "No darcs repo at or around %s" (file-name-directory repo-dir)))))
(inhibit-read-only t))
(save-some-buffers)
(darcs-set-buffer 'push root-dir)
(erase-buffer)
(setq darcs-exclude-enabled-function 'darcs-named-patch-p)
(darcs-do-command-async (root-dir "push" "--verbose" "--dry-run")
(let ((inhibit-read-only t)
(atomic-indentation 4)
(forced-indentation nil))
(goto-char (point-min))
(cond
((re-search-forward "\nNo recorded local changes to push!" nil t)
(goto-char (match-beginning 0))
(delete-region (point-min) (point))
(save-excursion
(darcs-markup-patch-descriptions)))
((re-search-forward "\nWould push the following changes:" nil t)
(delete-region (point-min) (point))
;; Detect pre-2.0 darcs format, where atomic patches start from column 1
(save-excursion
(goto-char (point-min))
(when (or (re-search-forward "^\\+" nil t) (re-search-forward "^-" nil t))
(setq atomic-indentation nil)
(setq forced-indentation " ")))
(insert "Select which patches to push.\nType C-c C-c to push the included patches.\nType C-x k to abandon push.\n")
(save-excursion
(darcs-markup-patch-descriptions atomic-indentation forced-indentation)
(darcs-collapse-all-atomic-patches))
(darcs-move-to-patch 1)))))))
(defun darcs-commit-push ()
"Push the patches included in the current buffer"
(interactive)
(let ((root-dir default-directory)
(patch-responses (darcs-collect-patch-responses)))
(darcs-do-interactive-command root-dir patch-responses "push")))
(defun darcs-init (root-dir)
(interactive (list (read-directory-name "Repository directory: " default-directory)))
"Initialize a repository at the ROOT-DIR"
(let ((default-directory root-dir))
(with-temp-buffer
(unless (zerop (darcs-do-command default-directory "init"))
(error (one-line-buffer)))
(message "Created darcs repo %s" root-dir))))
;;;; ======================================== process management ========================================
(defun darcs-do-command (root-dir &rest options)
"Run darcs in ROOT-DIR, passing it OPTIONS."
(let ((default-directory root-dir)
(cmd-line "darcs"))
(setq options (cons (car options) (cons "-q" (remove nil (cdr options)))))
(dolist (opt options)
(setq cmd-line (concat cmd-line " " opt)))
(message cmd-line)
(prog1
(apply 'call-process "darcs" nil (current-buffer) t options)
(message ""))))
(defun kill-current-buffer-process ()
"Kill the process associated with the current buffer. This is intended to be added to
`kill-buffer-hook'"
(let ((proc (get-buffer-process (current-buffer))))
(when proc
(kill-process proc))))
(defun darcs-delete-comment-filename ()
"Delete the comment filename tempfile. This is intended to be added to `kill-buffer-hook'"
(when darcs-comment-filename
(delete-file darcs-comment-filename)
(setq darcs-comment-filename nil)))
;; Really we need a general mechanism for setting process-buffer-local variables, as in darcsum
(defvar darcs-process-scan-pos (point-min)
"The point that `darcs-process-filter' should start scanning from")
(make-variable-buffer-local 'darcs-process-scan-pos)
(defun darcs-do-interactive-command (root-dir patch-responses &rest options)
(let ((default-directory root-dir)
(cmd-line "darcs")
(process nil)
(process-environment (append '("DARCS_DONT_ESCAPE_TRAILING_SPACES=1"
"DARCS_DONT_COLOR=1")
process-environment)))
(setq options (remove nil options))
(dolist (opt options)
(setq cmd-line (concat cmd-line " " opt)))
(message "%s" cmd-line)
(when (and (get-buffer "*darcs output*")
(get-buffer-process "*darcs output*")
(eq 'run (process-status (get-buffer-process "*darcs output*")))
(yes-or-no-p "A darcs process is already running; kill it?"))
(kill-process (get-buffer-process "*darcs output*"))
(kill-buffer "*darcs output*"))
(setq process (apply 'start-process cmd-line "*darcs output*" "darcs" options))
(with-current-buffer (process-buffer process)
(erase-buffer)
(setq darcs-patch-responses patch-responses)
(setq darcs-process-scan-pos (point-min))
(setq default-directory root-dir)
(make-local-hook 'kill-buffer-hook)
(add-hook 'kill-buffer-hook 'kill-current-buffer-process nil t))
(set-process-sentinel process 'darcs-process-sentinel)
(set-process-filter process 'darcs-process-filter)))
(defun darcs-process-sentinel (proc string)
(when (and (string-match "^exited abnormally" string)
(process-buffer proc))
(message "%s: %s" (process-name proc) string))
(when (and (not (eq 'run (process-status proc)))
(buffer-live-p (process-buffer proc))
(not darcs-debug))
(kill-buffer (process-buffer proc))))
(defvar darcs-process-filter-mark-overlay nil
"An overlay that highlights the currently unconsumed output in the darcs output buffer")
;; The starting point for this function was `darcsum-process-filter' in darcsum.el.
(defun darcs-process-filter (proc string)
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
(unless darcs-process-filter-mark-overlay
(setq darcs-process-filter-mark-overlay (make-overlay (process-mark proc) (point-max)))
(set-overlay-face darcs-process-filter-mark-overlay 'highlight))
(goto-char (process-mark proc))
(insert string)
(set-marker (process-mark proc) (point))
(let ((prev-scan-pos nil))
(flet ((send-input (input &optional insert-pos)
"Send input to the process and also insert that input into the buffer"
(when insert-pos (goto-char insert-pos))
(insert input)
(insert "\n")
(when (< (process-mark proc) (point))
(set-marker (process-mark proc) (point)))
(process-send-string proc input)))
(while (and (buffer-live-p (process-buffer proc))
(< darcs-process-scan-pos (point-max))
(not (eql prev-scan-pos darcs-process-scan-pos)))
(setq prev-scan-pos darcs-process-scan-pos)
(goto-char darcs-process-scan-pos)
(move-overlay darcs-process-filter-mark-overlay
(point) (point-max))
(cond
((looking-at "[\r\n ]*Finished recording patch")
(darcs-kill-if-exists 'record default-directory)
(darcs-refresh-whatsnew)
(message "Changes recorded."))
((looking-at "[\r\n ]*Finished applying...")
(darcs-kill-if-exists 'push default-directory)
(message "Finished pushing and applying."))
((looking-at "[\r\n ]*Ok, if you don't want to record anything")
(message "No changes recorded."))
((looking-at "[\r\n ]*[wW]arning:[^\n]*")
(let ((s (match-beginning 0))
(e (match-end 0)))
(message "%s" (buffer-substring s e))
(setq darcs-process-scan-pos e)))
;;TODO - support for automated patch-sending
; ((looking-at "[\r\n ]*What is the target email address")
; (send-input darcsum-process-arg (point-max))
; (setq darcs-process-scan-pos (point-max)))
; ((looking-at "[\r\n ]*Successfully sent patch bundle")
; (message "Changes sent to `%s'." darcsum-process-arg))
((looking-at "[\r\n ]*You don't want to send any patches")
(message "No changes sent."))
((looking-at ".*\nHit return to move on...")
(send-input "\r\n"))
((looking-at "[\r\n ]*Do you really want to .+\\? ")
(send-input "y\n" (point-max))
(setq darcs-process-scan-pos (point-max)))
((looking-at "[\r\n ]*\\([^\n]+\\)'s password:")
(process-send-string proc (read-passwd (format "Password for %s: " (match-string 1))))
(send-input "\n" (point-max))
(setq darcs-process-scan-pos (point-max)))
((looking-at "[\r\n ]*Finished reverting.")
(darcs-refresh-whatsnew)
(darcs-refresh-query-manifest)
(darcs-refresh-responded)
(darcs-kill-if-exists 'revert default-directory)
(message "Changes reverted."))
((looking-at "[\r\n ]*If you don't want to revert")
(message "No changes reverted."))
((looking-at "[\r\n ]*Finished pulling and applying.")
(darcs-refresh-whatsnew)
(darcs-refresh-query-manifest)
(darcs-refresh-responded)
(darcs-kill-if-exists 'pull default-directory)
(message "Finished pulling and applying"))
((looking-at "[\r\n ]*You don't want to pull any patches, and that's fine with me!")
(message "No patches pulled"))
((looking-at "[\r\n ]*\\(Waiting for lock.*\\)\n+")
(setq darcs-process-scan-pos (point-max))
(message (match-string 1)))
((looking-at "[\r\n ]*\\(Couldn't get lock.*\\)[\r\n ]*")
(message (match-string 1)))
((looking-at "[\r\n ]*\\(Pulling from\\|Pushing to\\) \"?\\([^\n\"]+\\)\"?\\.\\.\\.\n")
(let ((verb (match-string 1))
(repo (match-string 2))
(end (match-end 0)))
(message "%s %s..." verb repo)
(setq darcs-process-scan-pos end)))
((looking-at "[\r\n ]*\\(No \\(remote\\|recorded local\\) changes to \\(pull in\\|push\\)!\\)")
(message (match-string 1)))
((looking-at "[\r\n ]*We have conflicts in the following files:\n")
(let ((s (match-beginning 0))
(e (match-end 0))
(conflict-text))
(goto-char e)
(while (looking-at "\\./\\([^\n]+\\)\n")
(forward-line))
(setq conflict-text (buffer-substring s (point)))
(save-selected-window
(switch-to-buffer-other-window (darcs-format-buffername 'conflicts default-directory))
(goto-char (point-max))
(insert conflict-text))
(setq darcs-process-scan-pos (point))))
((looking-at "[\r\n ]*Darcs needs to know what name")
(let* ((default-mail (concat user-full-name
" <" user-mail-address ">"))
(enable-recursive-minibuffers t)
(mail-address (read-string
(format
"What is your email address? (default %s) "
default-mail)
nil nil default-mail)))
(send-input mail-address)
(send-input "\n"))
(re-search-forward "What is your email address\\?.*")
(setq darcs-process-scan-pos (point)))
((looking-at (format "[\r\n ]*\\(\\(%s\\)[^\n]+\\)\n" darcs-patch-headers-re))
(let ((change-desc (match-string 1)))
(save-excursion
(goto-char (match-end 0))
(while (looking-at "^[+-].*")
(forward-line))
(when (looking-at
"^Shall I \\(record\\|send\\|revert\\) this \\(patch\\|change\\)\\?\\( ([0-9]+/[0-9]+)\\)?.+[]:] ")
(let ((response-cell (assoc change-desc darcs-patch-responses)))
(if response-cell
(let ((end (match-end 0))
(response (if (plist-get-with-default (cdr response-cell) :included t)
"y" "n")))
(send-input response end)
(setq darcs-process-scan-pos (point))
(when (match-string 3)
(message (format "%s%s %s%s"
(if (string= response "y") (match-string 1) " skipp")
"ing" (match-string 2) (match-string 3)))))
(send-input "q")
(message (format "Unrecognized change description '%s'" change-desc))))))))
((looking-at "[\r\n ]*\\(Sun\\|Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\)[^\n]+\n[ \t]+\\(?:\\*\\|tag\\(?:ged\\)?\\) \\([^\r\n]+\\)[\r\n]")
(let ((change-desc (match-string 2))
(end (match-end 0)))
(save-excursion
(goto-char end)
(while (looking-at " ")
(forward-line)) ; Skip over the long description
(when (looking-at "Shall I \\(push\\|pull\\) this patch\\?.*[]:] ")
(let ((response-cell (assoc change-desc darcs-patch-responses)))
(if response-cell
(let ((end (match-end 0))
(response (if (plist-get-with-default (cdr response-cell) :included t)
"y" "n")))
(send-input response end)
(setq darcs-process-scan-pos (point))
(message (format "%s%s patch: %s"
(if (string= response "y") (concat " " (match-string 1)) " skipp")
"ing" change-desc)))
(send-input "q" (point-max))
(message (format "Unrecognized change description '%s'" change-desc))))))))
;; Darcs 2 support
((looking-at "[\r\n ]*\\(Identifying repository .*\\)\n")
(message (match-string 1))
(forward-line)
(setq darcs-process-scan-pos (point)))
((looking-at "[\r\n ]*\\(Reading .* of repository .*\\)\n")
(message (match-string 1))
(forward-line)
(setq darcs-process-scan-pos (point)))
((looking-at "[\r\n ]*\\(\\(Reading\\|Writing\\|Synchronizing\\|Cleaning\\|Optimizing\\) .* [0-9]+/[0-9]+.*\\)\n")
(message (match-string 1))
(forward-line)
(setq darcs-process-scan-pos (point)))
((looking-at "[\r\n ]*\\(Skipped \\(push\\|pull\\|record\\|revert\\) of [0-9]+ patch\\(es\\)?.\\)\n")
(message (match-string 1))
(forward-line)
(setq darcs-process-scan-pos (point)))
((looking-at "[\r\n ]*\\(Recording\\|Reverting\\) changes in \".*\"\\(\\.\\.\\|:\\)[\r\n ]*")
(forward-line)
(setq darcs-process-scan-pos (point)))
)))))))
;;;; ----------------- Synchronous operation on asynchronous connections -----------------
(defvar darcs-async-continuation nil
"Code to execute once the command started by `darcs-do-command-async' has terminated.")
(defun darcs-do-command-async-fn (root-dir continuation &rest options)
"Run darcs asynchronously in ROOT-DIR, passig it OPTIONS. When
the process terminates, call CONTINUATION.
It's generally much more convenient to use the
`darcs-do-command-async' macro than to use this function
directly."
(let ((default-directory root-dir)
(cmd-line "darcs")
(process nil)
(process-environment (append '("DARCS_DONT_ESCAPE_TRAILING_SPACES=1"
"DARCS_DONT_COLOR=1")
process-environment)))
(dolist (opt options)
(setq cmd-line (concat cmd-line " " opt)))
(message "%s" cmd-line)
(setq process (apply 'start-process cmd-line (current-buffer) "darcs" options))
(make-local-hook 'kill-buffer-hook)
(add-hook 'kill-buffer-hook 'kill-current-buffer-process nil t)
(set (make-local-variable 'darcs-async-continuation) continuation)
(set-process-sentinel process 'darcs-async-sentinel)
(set-process-filter process 'darcs-async-filter)))
(defun darcs-async-sentinel (proc string)
"Resume `darcs-async-continuation' when the watched process exits."
(when (process-buffer proc)
(with-current-buffer (process-buffer proc)
(when darcs-async-continuation
(funcall darcs-async-continuation)
(setq darcs-async-continuation nil)))))
(defun darcs-async-filter (proc string)
"Provide status updates as the asynchronous update proceeds."
(with-current-buffer (process-buffer proc)
(insert string)))
;;;; ========================================= patch formatting =========================================
(defun darcs-markup-patch-descriptions (&optional allow-leading-whitespace force-leading-whitespace)
"Starting from point and moving down the rest of the buffer, apply formatting to each patch
description. If ALLOW-LEADING-WHITESPACE is a number, leading whitespace precisely of the specified
length will be permitted. (This makes it possible to mark up patch descriptions that have been
indented, as in the `darcs-changes' list). Contrariwise, if FORCE-LEADING-WHITESPACE is specified,
it will be inserted in front of (TODO in place of?) the leading whitespace. This allows us to make
the display consistent even for commands where darcs itself does not display consistently."
(setq allow-leading-whitespace (or allow-leading-whitespace 0)) ; defaults to 0
(let ((lines-left 0)
(prev-header-ov nil)
(prev-patch-name-ov nil)
(orig-pos (point))
(display-ov nil)
(header-re-w/whitespace (format "\\([ \t]*\\)\\(%s\\)" darcs-patch-headers-re)))
(while (zerop lines-left)
(cond
((looking-at "\\([MTWFS].*[0-9][0-9][0-9][0-9]\\)[ \t]+\\([^\r\n]*\\)[\r\n]")
(let* ((local-date (buffer-substring (match-beginning 1) (match-end 1)))
(author (buffer-substring (match-beginning 2) (match-end 2)))
(arpa-date (darcs-cook-date local-date))
(pre-author-point nil)
(patch-name (save-excursion
(forward-line 1)
(and (looking-at "[ \t]+\\(\\*\\|tag\\(?:ged\\)?\\) \\([^\r\n]+\\)[\r\n]")
(buffer-substring (match-beginning 2) (match-end 2)))))
(patch-type (and patch-name (buffer-substring (match-beginning 1) (match-end 1)))))
(when patch-name
(delete-region (point-at-bol) (point-at-eol))
(insert patch-name)
(let ((patch-name-ov (darcs-make-link-overlay (point-at-bol) (point-at-eol)
'(darcs-toggle-patch-expanded))))
(set-overlay-face patch-name-ov (if (string= patch-type "*")
'darcs-patch-name-face
'darcs-tag-name-face))
(set-overlay-keymap patch-name-ov darcs-patch-display-map)
(when prev-header-ov
(overlay-put prev-header-ov 'darcs-patch-ov
(make-overlay (overlay-start prev-header-ov)
(save-excursion
(goto-char (overlay-start patch-name-ov))
(goto-char (point-at-bol))
(forward-char -2)
(point)))))
(when prev-patch-name-ov
(overlay-put prev-patch-name-ov 'darcs-patch-ov
(make-overlay (overlay-start prev-patch-name-ov)
(save-excursion
(goto-char (overlay-start patch-name-ov))
(goto-char (point-at-bol))
(forward-char -2)
(point)))))
(setq prev-patch-name-ov patch-name-ov)
(setq prev-header-ov patch-name-ov)
(goto-char (point-at-bol))
(forward-line 1)
(delete-region (point-at-bol) (point-at-eol))
(insert arpa-date)
(set-overlay-face (make-overlay (point-at-bol) (point)) 'darcs-blame-date-face)
(overlay-put patch-name-ov 'darcs-collapse-point (point))
(insert " ")
(setq pre-author-point (point))
(insert author)
(set-overlay-face (make-overlay pre-author-point (point)) 'darcs-blame-author-face)))))
((and (looking-at "\\([ \t]*\\)\\[")
(or (null prev-header-ov) (not (eq prev-header-ov prev-patch-name-ov)))
(eql allow-leading-whitespace (length (match-string 1))))
;; get rid of leading '[' in patch name
(delete-char 1)
;; Insert forced indentation if requested
(when force-leading-whitespace (insert force-leading-whitespace))
;; highlight patch name..
(set-overlay-face (make-overlay (point-at-bol) (point-at-eol))
'darcs-patch-name-face)
;; ...and also the author line that we know will follow
(forward-line 1)
(set-overlay-face (make-overlay (point-at-bol) (point-at-eol))
'darcs-blame-author-face)
;; trim the author line to get rid of the date (and possibly description-ending delimiters)
;; Re-insert the date at the beginning in a nicer format
(re-search-forward "\\*\\*\\([0-9]+\\)[^*\r\n]+[\r\n$]")
(when (match-beginning 0)
(let* ((date-str (buffer-substring (match-beginning 1) (match-end 1)))
(year (car (read-from-string date-str 0 4)))
(month (car (read-from-string date-str 4 6)))
(day (car (read-from-string date-str 6 8)))
(hour (car (read-from-string date-str 8 10)))
(minute (car (read-from-string date-str 10 12)))
(second (car (read-from-string date-str 12))))
(goto-char (match-beginning 0))
(delete-region (point) (point-at-eol))
(goto-char (point-at-bol))
(save-excursion
(insert (timezone-make-date-arpa-standard
(timezone-make-arpa-date year month day
(timezone-make-time-string hour minute second))))
(set-overlay-face (make-overlay (point-at-bol) (point))
'darcs-blame-date-face)
(insert " ")))))
((and (looking-at "\\([ \t]*\\)[]>] {")
(or (null prev-header-ov) (not (eq prev-header-ov prev-patch-name-ov)))
(eql allow-leading-whitespace (length (match-string 1))))
(delete-region (point-at-bol) (point-at-eol)))
((looking-at "Making no changes: this is a dry run.")
(delete-region (point-at-bol) (point-at-eol)))
((and (looking-at "\\([ \t]*\\)[]{}<>] *[\r\n]")
(eql allow-leading-whitespace (length (match-string 1))))
(delete-region (point-at-bol) (point-at-eol)))
((and (looking-at "\\([ \t]*\\)\\+")
(or (null prev-header-ov) (not (eq prev-header-ov prev-patch-name-ov)))
(eql allow-leading-whitespace (length (match-string 1))))
(when force-leading-whitespace (insert force-leading-whitespace))
(set-overlay-face (make-overlay (point-at-bol) (point-at-eol))
'darcs-line-added-face))
((and (looking-at "\\([ \t]*\\)\\-")
(or (null prev-header-ov) (not (eq prev-header-ov prev-patch-name-ov)))
(eql allow-leading-whitespace (length (match-string 1))))
(when force-leading-whitespace (insert force-leading-whitespace))
(set-overlay-face (make-overlay (point-at-bol) (point-at-eol))
'darcs-line-removed-face))
((and (looking-at header-re-w/whitespace)
(eql allow-leading-whitespace (length (match-string 1))))
(when force-leading-whitespace (insert force-leading-whitespace))
(let* ((bot (save-excursion (beginning-of-line-text) (point)))
(ov (darcs-make-link-overlay bot (point-at-eol)
'(darcs-toggle-patch-expanded))))
(when prev-header-ov
(overlay-put prev-header-ov 'darcs-patch-ov
(make-overlay (overlay-start prev-header-ov)
(save-excursion
(goto-char (overlay-start ov))
(goto-char (point-at-bol))
(forward-char -1)
(point)))))
(set-overlay-face ov 'darcs-header-line-face)
(set-overlay-keymap ov darcs-patch-display-map)
(setq prev-header-ov ov))))
(setq lines-left (forward-line 1)))
(when prev-header-ov
(overlay-put prev-header-ov 'darcs-patch-ov
(make-overlay (overlay-start prev-header-ov)
(point-max))))
(when prev-patch-name-ov
(overlay-put prev-patch-name-ov 'darcs-patch-ov
(make-overlay (overlay-start prev-patch-name-ov)
(point-max))))
(setq display-ov (make-overlay orig-pos (point-max)))
(set-overlay-keymap display-ov darcs-patch-display-map)
(overlay-put display-ov 'read-only t)
(overlay-put display-ov 'start-open t)
(overlay-put display-ov 'end-open nil)
(setq selective-display t)))
;;;; ============================================= utilities ============================================
(defun buffer-truename (buffer)
"Return the truename of BUFFER"
(when (buffer-file-name buffer)
(file-truename (expand-file-name (buffer-file-name buffer)))))
(defun default-directory-truename ()
"Return the truename of the default directory."
(when default-directory
(file-truename (expand-file-name default-directory))))
(defconst time-zone-translations '(("Pacific Standard Time" . "PST")
("Pacific Daylight Time" . "PDT")
("Eastern Daylight Time" . "EDT")
("Eastern Standard Time" . "EST")
("Atlantic Daylight Time" . "ADT")
("Atlantic Standard Time" . "AST")))
(defun darcs-cook-date (local-date)
"Replaces verbose timezones with short-form 3-letter versions
before attempting to translate to an ARPA date."
(let ((cells time-zone-translations)
(arpa-date nil))
;; Try to avoid confusing `timezone-make-date-arpa-standard' by translating long-form timezone
;; names into their short forms before calling it.
(while cells
(setq local-date (replace-regexp-in-string (caar cells) (cdar cells) local-date))
(setq cells (cdr cells)))
;; After we do the translation, just return the local time if we get garbage results; otherwise,
;; return the much-shorter ARPA date.
(setq arpa-date (timezone-make-date-arpa-standard local-date))
(if (string= arpa-date "31 Dec 1999 16:00:00 -0800")
local-date
arpa-date)))
(defun darcs-canonical-name (file)
"Returns a relative path for FILE from its repository root directory, starting from '.'"
(let ((root (darcs-root-directory file))
(abs-path (expand-file-name file)))
(when (string= (substring abs-path 0 (length root))
root)
(concat "./" (substring abs-path (length root))))))
(defun darcs-root-directory (file)
"Returns the nearest repo root directory for FILE. This code
is modified from Jorgen Schaefer's `vc-darcs.el'"
(let ((dir (file-name-directory (expand-file-name file)))
(olddir "/"))
(while (and (not (equal dir olddir))
(not (file-directory-p (concat dir "/_darcs"))))
(setq olddir dir
dir (file-name-directory (directory-file-name dir))))
(and (not (equal dir olddir)) dir)))
(defun xml-get-children* (node child-name)
"A version of `xml-get-children' that actually works in the presence of text children."
(let ((result nil))
(dolist (child (xml-node-children node))
(when child
(if (and (listp child)
(equal (xml-node-name child) child-name))
(push child result))))
(nreverse result)))
(defun darcs-trim-newlines (text)
"Trims leading and trailing newlines from TEXT"
;; TODO The flagrant inefficiency of this function makes baby Jesus cry.
(while (and (> (length text) 0)
(eq ?\n (aref text 0)))
(setq text (substring text 1)))
(while (and (> (length text) 0)
(eq ?\n (aref text (- (length text) 1))))
(setq text (substring text 0 (- (length text) 1))))
text)
(defun darcs-xml-node-text (node)
"Returns the untagged text children of NODE."
(let ((result ""))
(dolist (child (xml-node-children node))
(when (stringp child)
(setq result (concat result child))))
result))
(defun darcs-set-mode-from-name (filename)
"Set the mode of the current buffer based on `auto-mode-alist'"
(let ((alist auto-mode-alist))
(while alist
(let ((cell (car alist)))
(when (string-match (car cell) filename)
(if (listp (cdr cell))
(funcall (car (cdr cell)))
(funcall (cdr cell)))
(setq alist nil))
(setq alist (cdr alist))))))
(defun darcs-manifest (file-or-dir)
"Returns a list of all canonical files that are managed by the repo at or around FILE-OR-DIR"
(let ((repo (darcs-root-directory file-or-dir))
(output nil)
(lines-left 0))
(unless repo
(error (format "No darcs repo at or around %s" file-or-dir) ))
(with-temp-buffer
(darcs-do-command repo "query" "manifest")
(goto-char (point-min))
(while (and (= 0 lines-left)
(/= (point-at-bol) (point-at-eol)))
(push (buffer-substring (point-at-bol) (point-at-eol)) output)
(setq lines-left (forward-line 1)))
(nreverse output))))
(defun darcs-file-registered-p (filename)
"Returns t if FILENAME is in a darcs repo, or nil otherwise"
(and (darcs-root-directory filename)
(member (darcs-canonical-name filename) (darcs-manifest filename))
t))
(defun darcs-associated-file (repo-dir header-string)
"Returns the file that the change described by HEADER-STRING affects."
(cond
((string-match "hunk \\(.*\\) [0-9]" header-string)
(expand-file-name (concat (darcs-root-directory repo-dir)
(match-string 1 header-string))))
((string-match "\\(addfile\\|adddir\\|binary\\|rmfile\\) \\(.*\\)" header-string)
(expand-file-name (concat (darcs-root-directory repo-dir)
(match-string 2 header-string))))
((string-match darcs-patch-headers-re header-string)
;; Otherwise, if we recognize the header but don't currently support treating it as having an
;; associated file, just return nil.
;; TODO (we should probably recognize more types than we currently do)
;; The expected but currently-unhandled types are:
;; ("replace" "move" "changepref" "merger" "regrem" "conflict" "tcilfnoc")
nil)
(t
(error (format "Unparseable header %S" header-string)))))
(defun darcs-associated-line (repo-dir header-string)
"Returns the line associated with the change described by HEADER-STRING, or NIL for
non-line-specific changes (ie, for anything other than a hunk)."
(when (string-match "hunk .* \\([0-9]+\\)" header-string)
(car (read-from-string (match-string 1 header-string)))))
(defun darcs-format-buffername (mode-sym target)
"Creates a standard buffer name. TARGET is usually a file name, repo directory, or patch name.
It is permissable to pass a file name for a type that expects a repo directory; the directory will
be determined from the file name. MODE-SYM specifies the type of buffer to create, and should be
one of the following:
'blame 'changes 'conflicts 'describe 'filelog 'pull 'push 'query-manifest 'record 'revert 'whatsnew"
(cond
((member mode-sym '(blame describe filelog))
(format "*darcs %s: %s*" (symbol-name mode-sym) target))
((member mode-sym '(changes conflicts pull push query-manifest record revert whatsnew))
(format "*darcs %s: (%s)*" (symbol-name mode-sym) (darcs-root-directory target)))
(t
(error (format "Unrecognized MODE-SYM %S" mode-sym)))))
(defun darcs-set-buffer (mode-sym target &optional recursive-p)
"Sets up a specially-named buffer for the operation specified by MODE-SYM and TARGET.
If RECURSIVE-P is T, the buffer will be set in the current window;
If it is NIL, the buffer will be opened using `switch-to-buffer-other-window';
If it is any other value, the buffer will be opened using `switch-to-buffer'."
(let* ((sym-name (symbol-name mode-sym))
(new-mode-sym (intern (format "%s-mode" sym-name)))
(new-mode-name (format "darcs-%s" sym-name))
(new-mode-map (intern (format "darcs-%s-map" sym-name)))
(new-mode-hook (intern (format "darcs-%s-mode-hook" sym-name)))
(new-revert-function (let ((refresh-candidate (intern (format "darcs-refresh-%s" sym-name)))
(redo-candidate (intern (format "darcs-%s" sym-name))))
(if (fboundp refresh-candidate)
refresh-candidate
redo-candidate))))
;; switch to the buffer
(cond
((eq recursive-p t)
(set-buffer (get-buffer-create (darcs-format-buffername mode-sym target))))
(recursive-p
(switch-to-buffer (darcs-format-buffername mode-sym target)))
(t
(switch-to-buffer-other-window (darcs-format-buffername mode-sym target))))
;; setup mode
More information about the darcs-users
mailing list