Paste number 359852: Custom debbugs-gnu-apply-patch

Paste number 359852: Custom debbugs-gnu-apply-patch
Pasted by: Apteryx
When:3 years, 10 months ago
Share:Tweet this! | http://paste.lisp.org/+7PNW
Channel:None
Paste contents:
Raw Source | XML | Display As
;; Put the following in your .emacs.
;; From a debbugs-gnu buffer, you can then apply a message's patches using M-m.

(setq debbugs-gnu-trunk-directory "~/src/guix")
(setq debbugs-gnu-default-packages '("guix"))

(require 'debbugs-gnu)
(defun debbugs-gnu-apply-patch (&optional branch)
  "Apply the patch from the current message.
If given a prefix, patch in the branch directory instead."
  (interactive "P")
  (add-hook 'scheme-mode-hook 'debbugs-gnu-lisp-mode)
  (add-hook 'diff-mode-hook 'debbugs-gnu-diff-mode)
  (add-hook 'change-log-mode-hook 'debbugs-gnu-change-mode)
  (debbugs-gnu-init-current-directory branch)
  (let ((output-buffer (get-buffer-create "*debbugs patch*"))
	(patch-buffers nil))
    (with-current-buffer output-buffer
      (erase-buffer))
    (gnus-summary-select-article nil t)
    ;; The patches are either in MIME attachements or the main article
    ;; buffer.  Determine which.
    (with-current-buffer gnus-article-buffer
      (dolist (handle (mapcar 'cdr (gnus-article-mime-handles)))
	(when
	    (string-match "diff\\|patch\\|plain" (mm-handle-media-type handle))
	  (push (cons (mm-handle-encoding handle)
		      (mm-handle-buffer handle))
		patch-buffers))))
    (unless patch-buffers
      (gnus-summary-show-article 'raw)
      (article-decode-charset)
      (push (cons nil gnus-article-buffer) patch-buffers))
    (dolist (elem patch-buffers)
      (with-current-buffer (generate-new-buffer "*debbugs input patch*")
	(insert-buffer-substring (cdr elem))
	;; Clean patches subject lines from debbugs metadata.
	(goto-char (point-min))
	(when (re-search-forward
	       "^Subject: \\(bug#[[:digit:]]+: \\[PATCH.*\\] \\)"
	       (point-max) t)
	  (replace-match "" nil nil nil 1))
	(cond ((eq (car elem) 'base64)
	       (base64-decode-region (point-min) (point-max)))
	      ((eq (car elem) 'quoted-printable)
	       (quoted-printable-decode-region (point-min) (point-max))))
	(debbugs-gnu-fix-patch debbugs-gnu-current-directory)
	;; XXX: Otherwise the next call returns: error "Can't find the
	;; beginning of the file". This did not occur with the
	;; original `call-process-region'.
	(sit-for 0.3)
	(shell-command-on-region (point-min) (point-max)
				 (format  "cd \"%s\" && git am -s"
					  (expand-file-name
					   debbugs-gnu-current-directory))
				 output-buffer t)))
    (set-buffer output-buffer)
    ;; Git apply is silent when the patches apply cleanly.
    (unless (= (buffer-size) 0)
      (error "Error applying patch"))
    (save-some-buffers t)
    (require 'compile)
    (mapc 'kill-process compilation-in-progress)
    (compile
     (format  "cd \"%s\" && ./pre-inst-env guix environment guix -- make"
	      (expand-file-name debbugs-gnu-current-directory)))
    ;; XXX: All these commands are asynchronous, so just wait a bit.
    ;; This should be done properly a different way.
    (sit-for 2)
    ;; We've now done everything, so arrange the windows we need to see.
    (delete-other-windows)
    (switch-to-buffer "*compilation*")
    (goto-char (point-max))
    (magit-status debbugs-gnu-current-directory)))

This paste has no annotations.

Colorize as:
Show Line Numbers

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.