PageRenderTime 69ms CodeModel.GetById 19ms RepoModel.GetById 0ms app.codeStats 1ms

/monky.el

http://github.com/ananthakumaran/monky
Emacs Lisp | 3276 lines | 2749 code | 432 blank | 95 comment | 54 complexity | 863a30ac743630b265f81a214c3a9723 MD5 | raw file
Possible License(s): GPL-3.0
  1. ;;; monky.el --- Control Hg from Emacs. -*- lexical-binding: t; -*-
  2. ;; Copyright (C) 2011 Anantha Kumaran.
  3. ;; Author: Anantha kumaran <ananthakumaran@gmail.com>
  4. ;; URL: http://github.com/ananthakumaran/monky
  5. ;; Version: 0.2
  6. ;; Keywords: tools
  7. ;; Monky is free software: you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation, either version 3 of the License, or
  10. ;; (at your option) any later version.
  11. ;; Monky is distributed in the hope that it will be useful, but
  12. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  14. ;; General Public License for more details.
  15. ;; You should have received a copy of the GNU General Public License
  16. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  17. ;;; Commentary:
  18. ;;; Code:
  19. (require 'cl)
  20. (require 'cl-lib)
  21. (require 'bindat)
  22. (require 'ediff)
  23. (require 'subr-x)
  24. (require 'view)
  25. (require 'tramp)
  26. (defgroup monky nil
  27. "Controlling Hg from Emacs."
  28. :prefix "monky-"
  29. :group 'tools)
  30. (defcustom monky-hg-executable "hg"
  31. "The name of the Hg executable."
  32. :group 'monky
  33. :type 'string)
  34. (defcustom monky-hg-standard-options '("--config" "diff.git=Off" "--config" "ui.merge=:merge")
  35. "Standard options when running Hg."
  36. :group 'monky
  37. :type '(repeat string))
  38. (defcustom monky-hg-process-environment '("TERM=dumb" "HGPLAIN=" "LANGUAGE=C")
  39. "Default environment variables for hg."
  40. :group 'monky
  41. :type '(repeat string))
  42. ;; TODO
  43. (defcustom monky-save-some-buffers t
  44. "Non-nil means that \\[monky-status] will save modified buffers before running.
  45. Setting this to t will ask which buffers to save, setting it to 'dontask will
  46. save all modified buffers without asking."
  47. :group 'monky
  48. :type '(choice (const :tag "Never" nil)
  49. (const :tag "Ask" t)
  50. (const :tag "Save without asking" dontask)))
  51. (defcustom monky-revert-item-confirm t
  52. "Require acknowledgment before reverting an item."
  53. :group 'monky
  54. :type 'boolean)
  55. (defcustom monky-log-edit-confirm-cancellation nil
  56. "Require acknowledgment before canceling the log edit buffer."
  57. :group 'monky
  58. :type 'boolean)
  59. (defcustom monky-process-popup-time -1
  60. "Popup the process buffer if a command takes longer than this many seconds."
  61. :group 'monky
  62. :type '(choice (const :tag "Never" -1)
  63. (const :tag "Immediately" 0)
  64. (integer :tag "After this many seconds")))
  65. (defcustom monky-log-cutoff-length 100
  66. "The maximum number of commits to show in the log buffer."
  67. :group 'monky
  68. :type 'integer)
  69. (defcustom monky-log-infinite-length 99999
  70. "Number of log used to show as maximum for `monky-log-cutoff-length'."
  71. :group 'monky
  72. :type 'integer)
  73. (defcustom monky-log-auto-more t
  74. "Insert more log entries automatically when moving past the last entry.
  75. Only considered when moving past the last entry with `monky-goto-next-section'."
  76. :group 'monky
  77. :type 'boolean)
  78. (defcustom monky-incoming-repository "default"
  79. "The repository from which changes are pulled from by default."
  80. :group 'monky
  81. :type 'string)
  82. (defcustom monky-outgoing-repository ""
  83. "The repository to which changes are pushed to by default."
  84. :group 'monky
  85. :type 'string)
  86. (defcustom monky-process-type nil
  87. "How monky spawns Mercurial processes.
  88. Monky can either spawn a new Mercurial process for each request or
  89. use Mercurial's command server feature to run several commands in a
  90. single process instances. While the former is more robust, the latter
  91. is usually faster if Monky runs several commands."
  92. :group 'monky
  93. :type '(choice (const :tag "Single processes" :value nil)
  94. (const :tag "Use command server" :value cmdserver)))
  95. (defcustom monky-pull-args ()
  96. "Extra args to pass to pull."
  97. :group 'monky
  98. :type '(repeat string))
  99. (defcustom monky-repository-paths nil
  100. "*Paths where to find repositories. For each repository an alias is defined, which can then be passed to `monky-open-repository` to open the repository.
  101. Lisp-type of this option: The value must be a list L whereas each
  102. element of L is a 2-element list: The first element is the full
  103. path of a directory \(string) and the second element is an
  104. arbitrary alias \(string) for this directory which is then
  105. displayed instead of the underlying directory."
  106. :group 'monky
  107. :initialize 'custom-initialize-default
  108. :set (function (lambda (symbol value)
  109. (set symbol value)
  110. (if (and (boundp 'ecb-minor-mode)
  111. ecb-minor-mode
  112. (functionp 'ecb-update-directories-buffer))
  113. (ecb-update-directories-buffer))))
  114. :type '(repeat (cons :tag "Path with alias"
  115. (string :tag "Alias")
  116. (directory :tag "Path"))))
  117. (defun monky-root-dir-descr (dir)
  118. "Return the name of dir if it matches a path in monky-repository-paths, otherwise return nil"
  119. (catch 'exit
  120. (dolist (root-dir monky-repository-paths)
  121. (let ((base-dir
  122. (concat
  123. (replace-regexp-in-string
  124. "/$" ""
  125. (replace-regexp-in-string
  126. "^\~" (getenv "HOME")
  127. (cdr root-dir)))
  128. "/")))
  129. (when (equal base-dir dir)
  130. (throw 'exit (cons (car root-dir)
  131. base-dir)))))))
  132. (defun monky-open-repository ()
  133. "Prompt for a repository path or alias, then display the status
  134. buffer. Aliases are set in monky-repository-paths."
  135. (interactive)
  136. (let* ((rootdir (condition-case nil
  137. (monky-get-root-dir)
  138. (error nil)))
  139. (default-repo (or (monky-root-dir-descr rootdir) rootdir))
  140. (msg (if default-repo
  141. (concat "repository (default " (car default-repo) "): ")
  142. "repository: "))
  143. (repo-name (completing-read msg (mapcar 'car monky-repository-paths)))
  144. (repo (or (assoc repo-name monky-repository-paths) default-repo)))
  145. (when repo (monky-status (cdr repo)))))
  146. (defgroup monky-faces nil
  147. "Customize the appearance of Monky"
  148. :prefix "monky-"
  149. :group 'faces
  150. :group 'monky)
  151. (defface monky-header
  152. '((t :weight bold))
  153. "Face for generic header lines.
  154. Many Monky faces inherit from this one by default."
  155. :group 'monky-faces)
  156. (defface monky-section-title
  157. '((((class color) (background light)) :foreground "DarkGoldenrod4" :inherit monky-header)
  158. (((class color) (background dark)) :foreground "LightGoldenrod2" :inherit monky-header))
  159. "Face for section titles."
  160. :group 'monky-faces)
  161. (defface monky-branch
  162. '((t :weight bold :inherit monky-header))
  163. "Face for the current branch."
  164. :group 'monky-faces)
  165. (defface monky-diff-title
  166. '((t :inherit (monky-header)))
  167. "Face for diff title lines."
  168. :group 'monky-faces)
  169. (defface monky-diff-hunk-header
  170. '((((class color) (background light))
  171. :background "grey80"
  172. :foreground "grey30")
  173. (((class color) (background dark))
  174. :background "grey25"
  175. :foreground "grey70"))
  176. "Face for diff hunk header lines."
  177. :group 'monky-faces)
  178. (defface monky-diff-add
  179. '((((class color) (background light))
  180. :background "#cceecc"
  181. :foreground "#22aa22")
  182. (((class color) (background dark))
  183. :background "#336633"
  184. :foreground "#cceecc"))
  185. "Face for lines in a diff that have been added."
  186. :group 'monky-faces)
  187. (defface monky-diff-none
  188. '((t))
  189. "Face for lines in a diff that are unchanged."
  190. :group 'monky-faces)
  191. (defface monky-diff-del
  192. '((((class color) (background light))
  193. :background "#eecccc"
  194. :foreground "#aa2222")
  195. (((class color) (background dark))
  196. :background "#663333"
  197. :foreground "#eecccc"))
  198. "Face for lines in a diff that have been deleted."
  199. :group 'monky-faces)
  200. (defface monky-commit-id
  201. '((((class color) (background light))
  202. :foreground "firebrick")
  203. (((class color) (background dark))
  204. :foreground "tomato"))
  205. "Face for commit IDs: SHA1 codes and commit numbers."
  206. :group 'monky-faces)
  207. (defface monky-log-sha1
  208. '((t :inherit monky-commit-id))
  209. "Face for the sha1 element of the log output."
  210. :group 'monky-faces)
  211. (defface monky-log-message
  212. '((t))
  213. "Face for the message element of the log output."
  214. :group 'monky-faces)
  215. (defface monky-log-author
  216. '((((class color) (background light))
  217. :foreground "navy")
  218. (((class color) (background dark))
  219. :foreground "cornflower blue"))
  220. "Face for author shown in log buffer."
  221. :group 'monky-faces)
  222. (defface monky-log-head-label-local
  223. '((((class color) (background light))
  224. :box t
  225. :background "Grey85"
  226. :foreground "LightSkyBlue4")
  227. (((class color) (background dark))
  228. :box t
  229. :background "Grey13"
  230. :foreground "LightSkyBlue1"))
  231. "Face for local branch head labels shown in log buffer."
  232. :group 'monky-faces)
  233. (defface monky-log-head-label-tags
  234. '((((class color) (background light))
  235. :box t
  236. :background "LemonChiffon1"
  237. :foreground "goldenrod4")
  238. (((class color) (background dark))
  239. :box t
  240. :background "LemonChiffon1"
  241. :foreground "goldenrod4"))
  242. "Face for tag labels shown in log buffer."
  243. :group 'monky-faces)
  244. (defface monky-queue-patch
  245. '((t :weight bold :inherit (monky-header highlight)))
  246. "Face for patch name"
  247. :group 'monky-faces)
  248. (defface monky-log-head-label-bookmarks
  249. '((((class color) (background light))
  250. :box t
  251. :background "IndianRed1"
  252. :foreground "IndianRed4")
  253. (((class color) (background dark))
  254. :box t
  255. :background "IndianRed1"
  256. :foreground "IndianRed4"))
  257. "Face for bookmark labels shown in log buffer."
  258. :group 'monky-faces)
  259. (defface monky-log-head-label-phase
  260. '((((class color) (background light))
  261. :box t
  262. :background "light green"
  263. :foreground "dark olive green")
  264. (((class color) (background dark))
  265. :box t
  266. :background "light green"
  267. :foreground "dark olive green"))
  268. "Face for phase label shown in log buffer."
  269. :group 'monky-faces)
  270. (defface monky-log-date
  271. '((t :weight bold :inherit monky-header))
  272. "Face for date in log."
  273. :group 'monky-faces)
  274. (defface monky-queue-active
  275. '((((class color) (background light))
  276. :box t
  277. :background "light green"
  278. :foreground "dark olive green")
  279. (((class color) (background dark))
  280. :box t
  281. :background "light green"
  282. :foreground "dark olive green"))
  283. "Face for active patch queue"
  284. :group 'monky-faces)
  285. (defface monky-queue-positive-guard
  286. '((((class color) (background light))
  287. :box t
  288. :background "light green"
  289. :foreground "dark olive green")
  290. (((class color) (background dark))
  291. :box t
  292. :background "light green"
  293. :foreground "dark olive green"))
  294. "Face for queue postive guards"
  295. :group 'monky-faces)
  296. (defface monky-queue-negative-guard
  297. '((((class color) (background light))
  298. :box t
  299. :background "IndianRed1"
  300. :foreground "IndianRed4")
  301. (((class color) (background dark))
  302. :box t
  303. :background "IndianRed1"
  304. :foreground "IndianRed4"))
  305. "Face for queue negative guards"
  306. :group 'monky-faces)
  307. (defvar monky-mode-hook nil
  308. "Hook run by `monky-mode'.")
  309. ;;; User facing configuration
  310. (put 'monky-mode 'mode-class 'special)
  311. ;;; Compatibilities
  312. (eval-when-compile
  313. (when (< emacs-major-version 23)
  314. (defvar line-move-visual nil)))
  315. ;;; Utilities
  316. (defmacro monky-with-process-environment (&rest body)
  317. (declare (indent 0)
  318. (debug (body)))
  319. `(let ((process-environment (append monky-hg-process-environment
  320. process-environment)))
  321. ,@body))
  322. (defmacro monky-with-refresh (&rest body)
  323. "Refresh monky buffers after evaluating BODY.
  324. It is safe to call the functions which uses this macro inside of
  325. this macro. As it is time consuming to refresh monky buffers,
  326. this macro enforces refresh to occur exactly once by pending
  327. refreshes inside of this macro. Nested calls of this
  328. macro (possibly via functions) does not refresh buffers multiple
  329. times. Instead, only the outside-most call of this macro
  330. refreshes buffers."
  331. (declare (indent 0)
  332. (debug (body)))
  333. `(monky-refresh-wrapper (lambda () ,@body)))
  334. (defun monky-completing-read (&rest args)
  335. (apply (if (null ido-mode)
  336. 'completing-read
  337. 'ido-completing-read)
  338. args))
  339. (defun monky-start-process (&rest args)
  340. (monky-with-process-environment
  341. (apply (if (functionp 'start-file-process)
  342. 'start-file-process
  343. 'start-process) args)))
  344. (defun monky-process-file-single (&rest args)
  345. (monky-with-process-environment
  346. (apply 'process-file args)))
  347. ;; Command server
  348. (defvar monky-process nil)
  349. (defvar monky-process-buffer-name "*monky-process*")
  350. (defvar monky-process-client-buffer nil)
  351. (defvar monky-cmd-process nil)
  352. (defvar monky-cmd-process-buffer-name "*monky-cmd-process*")
  353. (defvar monky-cmd-process-input-buffer nil)
  354. (defvar monky-cmd-process-input-point nil)
  355. (defvar monky-cmd-error-message nil)
  356. (defvar monky-cmd-hello-message nil
  357. "Variable to store parsed hello message.")
  358. ;; TODO: does this need to be permanent? If it's only used in monky buffers (not source file buffers), it shouldn't be.
  359. (defvar-local monky-root-dir nil)
  360. (put 'monky-root-dir 'permanent-local t)
  361. (defun monky-cmdserver-sentinel (proc _change)
  362. (unless (memq (process-status proc) '(run stop))
  363. (delete-process proc)))
  364. (defun monky-cmdserver-read-data (size)
  365. (with-current-buffer (process-buffer monky-cmd-process)
  366. (while (< (point-max) size)
  367. (accept-process-output monky-cmd-process 0.1 nil t))
  368. (let ((str (buffer-substring (point-min) (+ (point-min) size))))
  369. (delete-region (point-min) (+ (point-min) size))
  370. (goto-char (point-min))
  371. (vconcat str))))
  372. (defun monky-cmdserver-read ()
  373. "Read one channel and return cons (CHANNEL . RAW-DATA)."
  374. (let* ((data (bindat-unpack '((channel byte) (len u32))
  375. (monky-cmdserver-read-data 5)))
  376. (channel (bindat-get-field data 'channel))
  377. (len (bindat-get-field data 'len)))
  378. (cons channel (monky-cmdserver-read-data len))))
  379. (defun monky-cmdserver-unpack-int (data)
  380. (bindat-get-field (bindat-unpack '((field u32)) data) 'field))
  381. (defun monky-cmdserver-unpack-string (data)
  382. (bindat-get-field (bindat-unpack `((field str ,(length data))) data) 'field))
  383. (defun monky-cmdserver-write (data)
  384. (process-send-string monky-cmd-process
  385. (concat (bindat-pack '((len u32))
  386. `((len . ,(length data))))
  387. data)))
  388. (defun monky-cmdserver-start ()
  389. (unless monky-root-dir
  390. (let (monky-process monky-process-type)
  391. (setq monky-root-dir (monky-get-root-dir))))
  392. (let ((dir monky-root-dir)
  393. (buf (get-buffer-create monky-cmd-process-buffer-name))
  394. (default-directory monky-root-dir)
  395. (process-connection-type nil))
  396. (with-current-buffer buf
  397. (setq buffer-read-only nil)
  398. (setq buffer-file-coding-system 'no-conversion)
  399. (set-buffer-multibyte nil)
  400. (erase-buffer)
  401. (setq view-exit-action
  402. #'(lambda (buffer)
  403. (with-current-buffer buffer
  404. (bury-buffer))))
  405. (setq default-directory dir)
  406. (let ((monky-cmd-process (monky-start-process
  407. "monky-hg" buf "sh" "-c"
  408. (format "%s --config extensions.mq= serve --cmdserver pipe 2> /dev/null" monky-hg-executable))))
  409. (set-process-coding-system monky-cmd-process 'no-conversion 'no-conversion)
  410. (set-process-sentinel monky-cmd-process #'monky-cmdserver-sentinel)
  411. (setq monky-cmd-hello-message
  412. (monky-cmdserver-parse-hello (monky-cmdserver-read)))
  413. monky-cmd-process))))
  414. (defun monky-cmdserver-parse-hello (hello-message)
  415. "Parse hello message to get encoding information."
  416. (let ((channel (car hello-message))
  417. (text (cdr hello-message)))
  418. (if (eq channel ?o)
  419. (progn
  420. (mapcar
  421. (lambda (s)
  422. (string-match "^\\([a-z0-9]+\\) *: *\\(.*\\)$" s)
  423. (let ((field-name (match-string 1 s))
  424. (field-data (match-string 2 s)))
  425. (cons (intern field-name) field-data)))
  426. (split-string (monky-cmdserver-unpack-string text) "\n")))
  427. (error "unknown channel %c for hello message" channel))))
  428. (defun monky-cmdserver-get-encoding (&optional default)
  429. "Get encoding stored in `monky-cmd-hello-message'."
  430. (let ((e (assoc 'encoding monky-cmd-hello-message)))
  431. (if e
  432. (cond
  433. ((string-equal (downcase (cdr e)) "ascii")
  434. 'us-ascii)
  435. (t
  436. (intern (downcase (cdr e)))))
  437. default)))
  438. (defun monky-cmdserver-runcommand (&rest cmd-and-args)
  439. (setq monky-cmd-error-message nil)
  440. (with-current-buffer (process-buffer monky-cmd-process)
  441. (setq buffer-read-only nil)
  442. (erase-buffer))
  443. (process-send-string monky-cmd-process "runcommand\n")
  444. (monky-cmdserver-write (mapconcat #'identity cmd-and-args "\0"))
  445. (let* ((inhibit-read-only t)
  446. (start (point))
  447. (result
  448. (catch 'finished
  449. (while t
  450. (let* ((result (monky-cmdserver-read))
  451. (channel (car result))
  452. (text (cdr result)))
  453. (cond
  454. ((eq channel ?o)
  455. (insert (monky-cmdserver-unpack-string text)))
  456. ((eq channel ?r)
  457. (throw 'finished
  458. (monky-cmdserver-unpack-int text)))
  459. ((eq channel ?e)
  460. (setq monky-cmd-error-message
  461. (concat monky-cmd-error-message text)))
  462. ((memq channel '(?I ?L))
  463. (with-current-buffer monky-cmd-process-input-buffer
  464. (let* ((max (if (eq channel ?I)
  465. (point-max)
  466. (save-excursion
  467. (goto-char monky-cmd-process-input-point)
  468. (line-beginning-position 2))))
  469. (maxreq (monky-cmdserver-unpack-int text))
  470. (len (min (- max monky-cmd-process-input-point)
  471. maxreq))
  472. (end (+ monky-cmd-process-input-point len)))
  473. (monky-cmdserver-write
  474. (buffer-substring monky-cmd-process-input-point end))
  475. (setq monky-cmd-process-input-point end))))
  476. (t
  477. (setq monky-cmd-error-message
  478. (format "Unsupported channel: %c" channel)))))))))
  479. (decode-coding-region start (point)
  480. (monky-cmdserver-get-encoding 'utf-8))
  481. result))
  482. (defun monky-cmdserver-process-file (program infile buffer display &rest args)
  483. "Same as `process-file' but uses the currently active hg command-server."
  484. (if (or infile display)
  485. (apply #'monky-process-file-single program infile buffer display args)
  486. (let ((stdout (if (consp buffer) (car buffer) buffer))
  487. (stderr (and (consp buffer) (cadr buffer))))
  488. (if (eq stdout t) (setq stdout (current-buffer)))
  489. (if (eq stderr t) (setq stderr stdout))
  490. (let ((result
  491. (if stdout
  492. (with-current-buffer stdout
  493. (apply #'monky-cmdserver-runcommand args))
  494. (with-temp-buffer
  495. (apply #'monky-cmdserver-runcommand args)))))
  496. (cond
  497. ((bufferp stderr)
  498. (when monky-cmd-error-message
  499. (with-current-buffer stderr
  500. (insert monky-cmd-error-message))))
  501. ((stringp stderr)
  502. (with-temp-file stderr
  503. (when monky-cmd-error-message
  504. (insert monky-cmd-error-message)))))
  505. result))))
  506. (defun monky-process-file (&rest args)
  507. "Same as `process-file' in the current hg environment.
  508. This function either calls `monky-cmdserver-process-file' or
  509. `monky-process-file-single' depending on whether the hg
  510. command-server should be used."
  511. (apply (cond
  512. (monky-cmd-process #'monky-cmdserver-process-file)
  513. ;; ((eq monky-process-type 'cmdserver)
  514. ;; (error "No process started (forget `monky-with-process`?)"))
  515. (t #'monky-process-file-single))
  516. args))
  517. (defmacro monky-with-process (&rest body)
  518. (declare (indent 0)
  519. (debug (body)))
  520. `(let ((outer (not monky-cmd-process)))
  521. (when (and outer (eq monky-process-type 'cmdserver))
  522. (setq monky-cmd-process (monky-cmdserver-start)))
  523. (unwind-protect
  524. (progn ,@body)
  525. (when (and monky-cmd-process outer (eq monky-process-type 'cmdserver))
  526. (delete-process monky-cmd-process)
  527. (setq monky-cmd-process nil)))))
  528. (defvar monky-bug-report-url "http://github.com/ananthakumaran/monky/issues")
  529. (defun monky-bug-report (str)
  530. (message "Unknown error: %s\nPlease file a bug at %s"
  531. str monky-bug-report-url))
  532. (defun monky-string-starts-with-p (string prefix)
  533. (eq (compare-strings string nil (length prefix) prefix nil nil) t))
  534. (defun monky-trim-line (str)
  535. (if (string= str "")
  536. nil
  537. (if (equal (elt str (- (length str) 1)) ?\n)
  538. (substring str 0 (- (length str) 1))
  539. str)))
  540. (defun monky-delete-line (&optional end)
  541. "Delete the text in current line.
  542. If END is non-nil, deletes the text including the newline character"
  543. (let ((end-point (if end
  544. (1+ (point-at-eol))
  545. (point-at-eol))))
  546. (delete-region (point-at-bol) end-point)))
  547. (defun monky-split-lines (str)
  548. (if (string= str "")
  549. nil
  550. (let ((lines (nreverse (split-string str "\n"))))
  551. (if (string= (car lines) "")
  552. (setq lines (cdr lines)))
  553. (nreverse lines))))
  554. (defun monky-put-line-property (prop val)
  555. (put-text-property (line-beginning-position) (line-beginning-position 2)
  556. prop val))
  557. (defun monky-parse-args (command)
  558. (require 'pcomplete)
  559. (car (with-temp-buffer
  560. (insert command)
  561. (pcomplete-parse-buffer-arguments))))
  562. (defun monky-prefix-p (prefix list)
  563. "Return non-nil if PREFIX is a prefix of LIST.
  564. PREFIX and LIST should both be lists.
  565. If the car of PREFIX is the symbol '*, then return non-nil if the cdr of PREFIX
  566. is a sublist of LIST (as if '* matched zero or more arbitrary elements of LIST)"
  567. (or (null prefix)
  568. (if (eq (car prefix) '*)
  569. (or (monky-prefix-p (cdr prefix) list)
  570. (and (not (null list))
  571. (monky-prefix-p prefix (cdr list))))
  572. (and (not (null list))
  573. (equal (car prefix) (car list))
  574. (monky-prefix-p (cdr prefix) (cdr list))))))
  575. (defun monky-wash-sequence (func)
  576. "Run FUNC until end of buffer is reached.
  577. FUNC should leave point at the end of the modified region"
  578. (while (and (not (eobp))
  579. (funcall func))))
  580. (defun monky-goto-line (line)
  581. "Like `goto-line' but doesn't set the mark."
  582. (save-restriction
  583. (widen)
  584. (goto-char 1)
  585. (forward-line (1- line))))
  586. ;;; Key bindings
  587. (defvar monky-mode-map
  588. (let ((map (make-keymap)))
  589. (suppress-keymap map t)
  590. (define-key map (kbd "n") 'monky-goto-next-section)
  591. (define-key map (kbd "p") 'monky-goto-previous-section)
  592. (define-key map (kbd "RET") 'monky-visit-item)
  593. (define-key map (kbd "TAB") 'monky-toggle-section)
  594. (define-key map (kbd "SPC") 'monky-show-item-or-scroll-up)
  595. (define-key map (kbd "DEL") 'monky-show-item-or-scroll-down)
  596. (define-key map (kbd "g") 'monky-refresh)
  597. (define-key map (kbd "$") 'monky-display-process)
  598. (define-key map (kbd ":") 'monky-hg-command)
  599. (define-key map (kbd "l l") 'monky-log-current-branch)
  600. (define-key map (kbd "l a") 'monky-log-all)
  601. (define-key map (kbd "l r") 'monky-log-revset)
  602. (define-key map (kbd "b") 'monky-branches)
  603. (define-key map (kbd "Q") 'monky-queue)
  604. (define-key map (kbd "q") 'monky-quit-window)
  605. (define-key map (kbd "M-1") 'monky-section-show-level-1-all)
  606. (define-key map (kbd "M-2") 'monky-section-show-level-2-all)
  607. (define-key map (kbd "M-3") 'monky-section-show-level-3-all)
  608. (define-key map (kbd "M-4") 'monky-section-show-level-4-all)
  609. map))
  610. (defvar monky-status-mode-map
  611. (let ((map (make-keymap)))
  612. (define-key map (kbd "s") 'monky-stage-item)
  613. (define-key map (kbd "S") 'monky-stage-all)
  614. (define-key map (kbd "u") 'monky-unstage-item)
  615. (define-key map (kbd "U") 'monky-unstage-all)
  616. (define-key map (kbd "a") 'monky-commit-amend)
  617. (define-key map (kbd "c") 'monky-log-edit)
  618. (define-key map (kbd "e") 'monky-ediff-item)
  619. (define-key map (kbd "y") 'monky-bookmark-create)
  620. (define-key map (kbd "C") 'monky-checkout)
  621. (define-key map (kbd "M") 'monky-merge)
  622. (define-key map (kbd "B") 'monky-backout)
  623. (define-key map (kbd "P") 'monky-push)
  624. (define-key map (kbd "f") 'monky-pull)
  625. (define-key map (kbd "k") 'monky-discard-item)
  626. (define-key map (kbd "m") 'monky-resolve-item)
  627. (define-key map (kbd "x") 'monky-unresolve-item)
  628. (define-key map (kbd "X") 'monky-reset-tip)
  629. (define-key map (kbd "A") 'monky-addremove-all)
  630. (define-key map (kbd "L") 'monky-rollback)
  631. map))
  632. (defvar monky-log-mode-map
  633. (let ((map (make-keymap)))
  634. (define-key map (kbd "e") 'monky-log-show-more-entries)
  635. (define-key map (kbd "C") 'monky-checkout-item)
  636. (define-key map (kbd "M") 'monky-merge-item)
  637. (define-key map (kbd "B") 'monky-backout-item)
  638. (define-key map (kbd "i") 'monky-qimport-item)
  639. map))
  640. (defvar monky-blame-mode-map
  641. (let ((map (make-keymap)))
  642. map))
  643. (defvar monky-branches-mode-map
  644. (let ((map (make-keymap)))
  645. (define-key map (kbd "C") 'monky-checkout-item)
  646. (define-key map (kbd "M") 'monky-merge-item)
  647. map))
  648. (defvar monky-commit-mode-map
  649. (let ((map (make-keymap)))
  650. map))
  651. (defvar monky-queue-mode-map
  652. (let ((map (make-keymap)))
  653. (define-key map (kbd "u") 'monky-qpop-item)
  654. (define-key map (kbd "U") 'monky-qpop-all)
  655. (define-key map (kbd "s") 'monky-qpush-item)
  656. (define-key map (kbd "S") 'monky-qpush-all)
  657. (define-key map (kbd "r") 'monky-qrefresh)
  658. (define-key map (kbd "R") 'monky-qrename-item)
  659. (define-key map (kbd "k") 'monky-qremove-item)
  660. (define-key map (kbd "N") 'monky-qnew)
  661. (define-key map (kbd "f") 'monky-qfinish-item)
  662. (define-key map (kbd "F") 'monky-qfinish-applied)
  663. (define-key map (kbd "d") 'monky-qfold-item)
  664. (define-key map (kbd "G") 'monky-qguard-item)
  665. (define-key map (kbd "o") 'monky-qreorder)
  666. (define-key map (kbd "A") 'monky-addremove-all)
  667. map))
  668. (defvar monky-pre-log-edit-window-configuration nil)
  669. (defvar monky-log-edit-client-buffer nil)
  670. (defvar monky-log-edit-operation nil)
  671. (defvar monky-log-edit-info nil)
  672. (defvar monky-log-edit-mode-map
  673. (let ((map (make-sparse-keymap)))
  674. (define-key map (kbd "C-c C-c") 'monky-log-edit-commit)
  675. (define-key map (kbd "C-c C-k") 'monky-log-edit-cancel-log-message)
  676. (define-key map (kbd "C-x C-s")
  677. (lambda ()
  678. (interactive)
  679. (message "Not saved. Use C-c C-c to finalize this %s." monky-log-edit-operation)))
  680. map))
  681. ;;; Sections
  682. (defvar-local monky-top-section nil)
  683. (defvar monky-old-top-section nil)
  684. (defvar monky-section-hidden-default nil)
  685. ;; A buffer in monky-mode is organized into hierarchical sections.
  686. ;; These sections are used for navigation and for hiding parts of the
  687. ;; buffer.
  688. ;;
  689. ;; Most sections also represent the objects that Monky works with,
  690. ;; such as files, diffs, hunks, commits, etc. The 'type' of a section
  691. ;; identifies what kind of object it represents (if any), and the
  692. ;; parent and grand-parent, etc provide the context.
  693. (defstruct monky-section
  694. parent children beginning end type title hidden info)
  695. (defun monky-set-section-info (info &optional section)
  696. (setf (monky-section-info (or section monky-top-section)) info))
  697. (defun monky-new-section (title type)
  698. "Create a new section with title TITLE and type TYPE in current buffer.
  699. If not `monky-top-section' exist, the new section will be the new top-section
  700. otherwise, the new-section will be a child of the current top-section.
  701. If TYPE is nil, the section won't be highlighted."
  702. (let* ((s (make-monky-section :parent monky-top-section
  703. :title title
  704. :type type
  705. :hidden monky-section-hidden-default))
  706. (old (and monky-old-top-section
  707. (monky-find-section (monky-section-path s)
  708. monky-old-top-section))))
  709. (if monky-top-section
  710. (push s (monky-section-children monky-top-section))
  711. (setq monky-top-section s))
  712. (if old
  713. (setf (monky-section-hidden s) (monky-section-hidden old)))
  714. s))
  715. (defmacro monky-with-section (title type &rest body)
  716. "Create a new section of title TITLE and type TYPE and evaluate BODY there.
  717. Sections create into BODY will be child of the new section.
  718. BODY must leave point at the end of the created section.
  719. If TYPE is nil, the section won't be highlighted."
  720. (declare (indent 2)
  721. (debug (symbolp symbolp body)))
  722. (let ((s (make-symbol "*section*")))
  723. `(let* ((,s (monky-new-section ,title ,type))
  724. (monky-top-section ,s))
  725. (setf (monky-section-beginning ,s) (point))
  726. ,@body
  727. (setf (monky-section-end ,s) (point))
  728. (setf (monky-section-children ,s)
  729. (nreverse (monky-section-children ,s)))
  730. ,s)))
  731. (defmacro monky-create-buffer-sections (&rest body)
  732. "Empty current buffer of text and monky's section, and then evaluate BODY."
  733. (declare (indent 0)
  734. (debug (body)))
  735. `(let ((inhibit-read-only t))
  736. (erase-buffer)
  737. (let ((monky-old-top-section monky-top-section))
  738. (setq monky-top-section nil)
  739. ,@body
  740. (when (null monky-top-section)
  741. (monky-with-section 'top nil
  742. (insert "(empty)\n")))
  743. (monky-propertize-section monky-top-section)
  744. (monky-section-set-hidden monky-top-section
  745. (monky-section-hidden monky-top-section)))))
  746. (defun monky-propertize-section (section)
  747. "Add text-property needed for SECTION."
  748. (put-text-property (monky-section-beginning section)
  749. (monky-section-end section)
  750. 'monky-section section)
  751. (dolist (s (monky-section-children section))
  752. (monky-propertize-section s)))
  753. (defun monky-find-section (path top)
  754. "Find the section at the path PATH in subsection of section TOP."
  755. (if (null path)
  756. top
  757. (let ((secs (monky-section-children top)))
  758. (while (and secs (not (equal (car path)
  759. (monky-section-title (car secs)))))
  760. (setq secs (cdr secs)))
  761. (and (car secs)
  762. (monky-find-section (cdr path) (car secs))))))
  763. (defun monky-section-path (section)
  764. "Return the path of SECTION."
  765. (if (not (monky-section-parent section))
  766. '()
  767. (append (monky-section-path (monky-section-parent section))
  768. (list (monky-section-title section)))))
  769. (defun monky-insert-section (section-title-and-type buffer-title washer cmd &rest args)
  770. "Run CMD and put its result in a new section.
  771. SECTION-TITLE-AND-TYPE is either a string that is the title of the section
  772. or (TITLE . TYPE) where TITLE is the title of the section and TYPE is its type.
  773. If there is no type, or if type is nil, the section won't be highlighted.
  774. BUFFER-TITLE is the inserted title of the section
  775. WASHER is a function that will be run after CMD.
  776. The buffer will be narrowed to the inserted text.
  777. It should add sectioning as needed for monky interaction
  778. CMD is an external command that will be run with ARGS as arguments"
  779. (monky-with-process
  780. (let* ((body-beg nil)
  781. (section-title (if (consp section-title-and-type)
  782. (car section-title-and-type)
  783. section-title-and-type))
  784. (section-type (if (consp section-title-and-type)
  785. (cdr section-title-and-type)
  786. nil))
  787. (section (monky-with-section section-title section-type
  788. (if buffer-title
  789. (insert (propertize buffer-title 'face 'monky-section-title) "\n"))
  790. (setq body-beg (point))
  791. (apply 'monky-process-file cmd nil t nil args)
  792. (if (not (eq (char-before) ?\n))
  793. (insert "\n"))
  794. (if washer
  795. (save-restriction
  796. (narrow-to-region body-beg (point))
  797. (goto-char (point-min))
  798. (funcall washer)
  799. (goto-char (point-max)))))))
  800. (when (= body-beg (point))
  801. (monky-cancel-section section))
  802. section)))
  803. (defun monky-cancel-section (section)
  804. (delete-region (monky-section-beginning section)
  805. (monky-section-end section))
  806. (let ((parent (monky-section-parent section)))
  807. (if parent
  808. (setf (monky-section-children parent)
  809. (delq section (monky-section-children parent)))
  810. (setq monky-top-section nil))))
  811. (defun monky-current-section ()
  812. "Return the monky section at point."
  813. (monky-section-at (point)))
  814. (defun monky-section-at (pos)
  815. "Return the monky section at position POS."
  816. (or (get-text-property pos 'monky-section)
  817. monky-top-section))
  818. (defun monky-find-section-after (pos secs)
  819. "Find the first section that begins after POS in the list SECS."
  820. (while (and secs
  821. (not (> (monky-section-beginning (car secs)) pos)))
  822. (setq secs (cdr secs)))
  823. (car secs))
  824. (defun monky-find-section-before (pos secs)
  825. "Find the last section that begins before POS in the list SECS."
  826. (let ((prev nil))
  827. (while (and secs
  828. (not (> (monky-section-beginning (car secs)) pos)))
  829. (setq prev (car secs))
  830. (setq secs (cdr secs)))
  831. prev))
  832. (defun monky-next-section (section)
  833. "Return the section that is after SECTION."
  834. (let ((parent (monky-section-parent section)))
  835. (if parent
  836. (let ((next (cadr (memq section
  837. (monky-section-children parent)))))
  838. (or next
  839. (monky-next-section parent))))))
  840. (defvar-local monky-submode nil)
  841. (defvar-local monky-refresh-function nil)
  842. (defvar-local monky-refresh-args nil)
  843. (defun monky-goto-next-section ()
  844. "Go to the next monky section."
  845. (interactive)
  846. (let* ((section (monky-current-section))
  847. (next (or (and (not (monky-section-hidden section))
  848. (monky-section-children section)
  849. (monky-find-section-after (point)
  850. (monky-section-children
  851. section)))
  852. (monky-next-section section))))
  853. (cond
  854. ((and next (eq (monky-section-type next) 'longer))
  855. (when monky-log-auto-more
  856. (monky-log-show-more-entries)
  857. (monky-goto-next-section)))
  858. (next
  859. (goto-char (monky-section-beginning next))
  860. (if (memq monky-submode '(log blame))
  861. (monky-show-commit next)))
  862. (t (message "No next section")))))
  863. (defun monky-prev-section (section)
  864. "Return the section that is before SECTION."
  865. (let ((parent (monky-section-parent section)))
  866. (if parent
  867. (let ((prev (cadr (memq section
  868. (reverse (monky-section-children parent))))))
  869. (cond (prev
  870. (while (and (not (monky-section-hidden prev))
  871. (monky-section-children prev))
  872. (setq prev (car (reverse (monky-section-children prev)))))
  873. prev)
  874. (t
  875. parent))))))
  876. (defun monky-goto-previous-section ()
  877. "Goto the previous monky section."
  878. (interactive)
  879. (let ((section (monky-current-section)))
  880. (cond ((= (point) (monky-section-beginning section))
  881. (let ((prev (monky-prev-section (monky-current-section))))
  882. (if prev
  883. (progn
  884. (if (memq monky-submode '(log blame))
  885. (monky-show-commit prev))
  886. (goto-char (monky-section-beginning prev)))
  887. (message "No previous section"))))
  888. (t
  889. (let ((prev (monky-find-section-before (point)
  890. (monky-section-children
  891. section))))
  892. (if (memq monky-submode '(log blame))
  893. (monky-show-commit (or prev section)))
  894. (goto-char (monky-section-beginning (or prev section))))))))
  895. (defun monky-section-context-type (section)
  896. (if (null section)
  897. '()
  898. (let ((c (or (monky-section-type section)
  899. (if (symbolp (monky-section-title section))
  900. (monky-section-title section)))))
  901. (if c
  902. (cons c (monky-section-context-type
  903. (monky-section-parent section)))
  904. '()))))
  905. (defun monky-hg-section (section-title-and-type buffer-title washer &rest args)
  906. (apply #'monky-insert-section
  907. section-title-and-type
  908. buffer-title
  909. washer
  910. monky-hg-executable
  911. (append monky-hg-standard-options args)))
  912. (defun monky-section-set-hidden (section hidden)
  913. "Hide SECTION if HIDDEN is not nil, show it otherwise."
  914. (setf (monky-section-hidden section) hidden)
  915. (let ((inhibit-read-only t)
  916. (beg (save-excursion
  917. (goto-char (monky-section-beginning section))
  918. (forward-line)
  919. (point)))
  920. (end (monky-section-end section)))
  921. (if (< beg end)
  922. (put-text-property beg end 'invisible hidden)))
  923. (if (not hidden)
  924. (dolist (c (monky-section-children section))
  925. (monky-section-set-hidden c (monky-section-hidden c)))))
  926. (defun monky-toggle-section ()
  927. "Toggle hidden status of current section."
  928. (interactive)
  929. (let ((section (monky-current-section)))
  930. (when (monky-section-parent section)
  931. (goto-char (monky-section-beginning section))
  932. (monky-section-set-hidden section (not (monky-section-hidden section))))))
  933. (defun monky-section-show-level-1-all ()
  934. "Collapse all the sections in the monky status buffer."
  935. (interactive)
  936. (save-excursion
  937. (goto-char (point-min))
  938. (while (not (eobp))
  939. (let ((section (monky-current-section)))
  940. (monky-section-set-hidden section t))
  941. (forward-line 1))))
  942. (defun monky-section-show-level-2-all ()
  943. "Show all the files changes, but not their contents."
  944. (interactive)
  945. (save-excursion
  946. (goto-char (point-min))
  947. (while (not (eobp))
  948. (let ((section (monky-current-section)))
  949. (if (memq (monky-section-type section) (list 'hunk 'diff))
  950. (monky-section-set-hidden section t)
  951. (monky-section-set-hidden section nil)))
  952. (forward-line 1))))
  953. (defun monky-section-show-level-3-all ()
  954. "Expand all file contents and line numbers, but not the actual changes."
  955. (interactive)
  956. (save-excursion
  957. (goto-char (point-min))
  958. (while (not (eobp))
  959. (let ((section (monky-current-section)))
  960. (if (memq (monky-section-type section) (list 'hunk))
  961. (monky-section-set-hidden section t)
  962. (monky-section-set-hidden section nil)))
  963. (forward-line 1))))
  964. (defun monky-section-show-level-4-all ()
  965. "Expand all sections."
  966. (interactive)
  967. (save-excursion
  968. (goto-char (point-min))
  969. (while (not (eobp))
  970. (let ((section (monky-current-section)))
  971. (monky-section-set-hidden section nil))
  972. (forward-line 1))))
  973. ;;; Running commands
  974. (defun monky-set-mode-line-process (str)
  975. (let ((pr (if str (concat " " str) "")))
  976. (save-excursion
  977. (monky-for-all-buffers (lambda ()
  978. (setq mode-line-process pr))))))
  979. (defun monky-process-indicator-from-command (comps)
  980. (if (monky-prefix-p (cons monky-hg-executable monky-hg-standard-options)
  981. comps)
  982. (setq comps (nthcdr (+ (length monky-hg-standard-options) 1) comps)))
  983. (car comps))
  984. (defun monky-run* (cmd-and-args
  985. &optional logline noerase noerror nowait input)
  986. (if (and monky-process
  987. (get-buffer monky-process-buffer-name))
  988. (error "Hg is already running"))
  989. (let ((cmd (car cmd-and-args))
  990. (args (cdr cmd-and-args))
  991. (dir default-directory)
  992. (buf (get-buffer-create monky-process-buffer-name))
  993. (successp nil))
  994. (monky-set-mode-line-process
  995. (monky-process-indicator-from-command cmd-and-args))
  996. (setq monky-process-client-buffer (current-buffer))
  997. (with-current-buffer buf
  998. (view-mode 1)
  999. (set (make-local-variable 'view-no-disable-on-exit) t)
  1000. (setq view-exit-action
  1001. (lambda (buffer)
  1002. (with-current-buffer buffer
  1003. (bury-buffer))))
  1004. (setq buffer-read-only t)
  1005. (let ((inhibit-read-only t))
  1006. (setq default-directory dir)
  1007. (if noerase
  1008. (goto-char (point-max))
  1009. (erase-buffer))
  1010. (insert "$ " (or logline
  1011. (mapconcat #'identity cmd-and-args " "))
  1012. "\n")
  1013. (cond (nowait
  1014. (setq monky-process
  1015. (let ((process-connection-type nil))
  1016. (apply 'monky-start-process cmd buf cmd args)))
  1017. (set-process-sentinel monky-process 'monky-process-sentinel)
  1018. (set-process-filter monky-process 'monky-process-filter)
  1019. (when input
  1020. (with-current-buffer input
  1021. (process-send-region monky-process
  1022. (point-min) (point-max))
  1023. (process-send-eof monky-process)
  1024. (sit-for 0.1 t)))
  1025. (cond ((= monky-process-popup-time 0)
  1026. (pop-to-buffer (process-buffer monky-process)))
  1027. ((> monky-process-popup-time 0)
  1028. (run-with-timer
  1029. monky-process-popup-time nil
  1030. (function
  1031. (lambda (buf)
  1032. (with-current-buffer buf
  1033. (when monky-process
  1034. (display-buffer (process-buffer monky-process))
  1035. (goto-char (point-max))))))
  1036. (current-buffer))))
  1037. (setq successp t))
  1038. (monky-cmd-process
  1039. (let ((monky-cmd-process-input-buffer input)
  1040. (monky-cmd-process-input-point (and input
  1041. (with-current-buffer input
  1042. (point-min)))))
  1043. (setq successp
  1044. (equal (apply #'monky-cmdserver-runcommand (cdr cmd-and-args)) 0))
  1045. (monky-set-mode-line-process nil)
  1046. (monky-need-refresh monky-process-client-buffer)))
  1047. (input
  1048. (with-current-buffer input
  1049. (setq default-directory dir)
  1050. (setq monky-process
  1051. ;; Don't use a pty, because it would set icrnl
  1052. ;; which would modify the input (issue #20).
  1053. (let ((process-connection-type nil))
  1054. (apply 'monky-start-process cmd buf cmd args)))
  1055. (set-process-filter monky-process 'monky-process-filter)
  1056. (process-send-region monky-process
  1057. (point-min) (point-max))
  1058. (process-send-eof monky-process)
  1059. (while (equal (process-status monky-process) 'run)
  1060. (sit-for 0.1 t))
  1061. (setq successp
  1062. (equal (process-exit-status monky-process) 0))
  1063. (setq monky-process nil))
  1064. (monky-set-mode-line-process nil)
  1065. (monky-need-refresh monky-process-client-buffer))
  1066. (t
  1067. (setq successp
  1068. (equal (apply 'monky-process-file-single cmd nil buf nil args) 0))
  1069. (monky-set-mode-line-process nil)
  1070. (monky-need-refresh monky-process-client-buffer))))
  1071. (or successp
  1072. noerror
  1073. (error
  1074. (or monky-cmd-error-message
  1075. (monky-abort-message (get-buffer monky-process-buffer-name))
  1076. "Hg failed")))
  1077. successp)))
  1078. (defun monky-process-sentinel (process event)
  1079. (let ((msg (format "Hg %s." (substring event 0 -1)))
  1080. (successp (string-match "^finished" event)))
  1081. (with-current-buffer (process-buffer process)
  1082. (let ((inhibit-read-only t))
  1083. (goto-char (point-max))
  1084. (insert msg "\n")
  1085. (message msg)))
  1086. (when (not successp)
  1087. (let ((msg (monky-abort-message (process-buffer process))))
  1088. (when msg
  1089. (message msg))))
  1090. (setq monky-process nil)
  1091. (monky-set-mode-line-process nil)
  1092. (if (buffer-live-p monky-process-client-buffer)
  1093. (with-current-buffer monky-process-client-buffer
  1094. (monky-with-refresh
  1095. (monky-need-refresh monky-process-client-buffer))))))
  1096. (defun monky-abort-message (buffer)
  1097. (with-current-buffer buffer
  1098. (save-excursion
  1099. (goto-char (point-min))
  1100. (when (re-search-forward
  1101. (concat "^abort: \\(.*\\)" paragraph-separate) nil t)
  1102. (match-string 1)))))
  1103. ;; TODO password?
  1104. (defun monky-process-filter (proc string)
  1105. (save-current-buffer
  1106. (set-buffer (process-buffer proc))
  1107. (let ((inhibit-read-only t))
  1108. (goto-char (process-mark proc))
  1109. (insert string)
  1110. (set-marker (process-mark proc) (point)))))
  1111. (defun monky-run-hg (&rest args)
  1112. (monky-with-refresh
  1113. (monky-run* (append (cons monky-hg-executable
  1114. monky-hg-standard-options)
  1115. args))))
  1116. (defun monky-run-hg-sync (&rest args)
  1117. (message "Running %s %s"
  1118. monky-hg-executable
  1119. (mapconcat #'identity args " "))
  1120. (monky-run* (append (cons monky-hg-executable
  1121. monky-hg-standard-options)
  1122. args)))
  1123. (defun monky-run-hg-async (&rest args)
  1124. (message "Running %s %s"
  1125. monky-hg-executable
  1126. (mapconcat #'identity args " "))
  1127. (monky-run* (append (cons monky-hg-executable
  1128. monky-hg-standard-options)
  1129. args)
  1130. nil nil nil t))
  1131. (defun monky-run-async-with-input (input cmd &rest args)
  1132. (monky-run* (cons cmd args) nil nil nil t input))
  1133. (defun monky-display-process ()
  1134. "Display output from most recent hg command."
  1135. (interactive)
  1136. (unless (get-buffer monky-process-buffer-name)
  1137. (user-error "No Hg commands have run"))
  1138. (display-buffer monky-process-buffer-name))
  1139. (defun monky-hg-command (command)
  1140. "Perform arbitrary Hg COMMAND."
  1141. (interactive "sRun hg like this: ")
  1142. (let ((args (monky-parse-args command))
  1143. (monky-process-popup-time 0))
  1144. (monky-with-refresh
  1145. (monky-run* (append (cons monky-hg-executable
  1146. monky-hg-standard-options)
  1147. args)
  1148. nil nil nil t))))
  1149. ;;; Actions
  1150. (defmacro monky-section-case (opname &rest clauses)
  1151. "Make different action depending of current section.
  1152. HEAD is (SECTION INFO &optional OPNAME),
  1153. SECTION will be bind to the current section,
  1154. INFO will be bind to the info's of the current section,
  1155. OPNAME is a string that will be used to describe current action,
  1156. CLAUSES is a list of CLAUSE, each clause is (SECTION-TYPE &BODY)
  1157. where SECTION-TYPE describe section where BODY will be run.
  1158. This returns non-nil if some section matches. If the
  1159. corresponding body return a non-nil value, it is returned,
  1160. otherwise it return t.
  1161. If no section matches, this returns nil if no OPNAME was given
  1162. and throws an error otherwise."
  1163. (declare (indent 1)
  1164. (debug (form &rest (sexp body))))
  1165. (let ((section (make-symbol "*section*"))
  1166. (type (make-symbol "*type*"))
  1167. (context (make-symbol "*context*")))
  1168. `(let* ((,section (monky-current-section))
  1169. (,type (monky-section-type ,section))
  1170. (,context (monky-section-context-type ,section)))
  1171. (cond ,@(mapcar (lambda (clause)
  1172. (let ((prefix (car clause))
  1173. (body (cdr clause)))
  1174. `(,(if (eq prefix t)
  1175. `t
  1176. `(monky-prefix-p ',(reverse prefix) ,context))
  1177. (or (progn ,@body)
  1178. t))))
  1179. clauses)
  1180. ,@(when opname
  1181. `(((not ,type)
  1182. (user-error "Nothing to %s here" ,opname))
  1183. (t
  1184. (error "Can't %s as %s"
  1185. ,opname
  1186. ,type))))))))
  1187. (defmacro monky-section-action (opname &rest clauses)
  1188. "Refresh monky buffers after executing action defined in CLAUSES.
  1189. See `monky-section-case' for the definition of HEAD and CLAUSES and
  1190. `monky-with-refresh' for how the buffers are refreshed."
  1191. (declare (indent 1)
  1192. (debug (form &rest (sexp body))))
  1193. `(monky-with-refresh
  1194. (monky-section-case ,opname ,@clauses)))
  1195. (defun monky-visit-item (&optional other-window)
  1196. "Visit current item.
  1197. With a prefix argument, visit in other window."
  1198. (interactive (list current-prefix-arg))
  1199. (let ((ff (if other-window 'find-file-other-window 'find-file)))
  1200. (monky-section-action "visit"
  1201. ((file)
  1202. (funcall ff (monky-section-info (monky-current-section))))
  1203. ((diff)
  1204. (funcall ff (monky-diff-item-file (monky-current-section))))
  1205. ((hunk)
  1206. (let ((file (monky-diff-item-file (monky-hunk-item-diff (monky-current-section))))
  1207. (line (monky-hunk-item-target-line (monky-current-section))))
  1208. (funcall ff file)
  1209. (goto-char (point-min))
  1210. (forward-line (1- line))))
  1211. ((commit)
  1212. (monky-show-commit (monky-section-info (monky-current-section))))
  1213. ((longer)
  1214. (monky-log-show-more-entries))
  1215. ((queue)
  1216. (monky-qqueue (monky-section-info (monky-current-section))))
  1217. ((branch)
  1218. (monky-checkout (monky-section-info (monky-current-section))))
  1219. ((shelf)
  1220. (monky-show-shelf
  1221. (monky-section-info (monky-current-section)))))))
  1222. (defun monky-ediff-item ()
  1223. "Open the ediff merge editor on the item."
  1224. (interactive)
  1225. (monky-section-action "ediff"
  1226. ((merged diff)
  1227. (if (eq (monky-diff-item-kind (monky-current-section)) 'unresolved)
  1228. (monky-ediff-merged (monky-current-section))
  1229. (user-error "Already resolved. Unresolve first.")))
  1230. ((unmodified diff)
  1231. (user-error "Cannot ediff an unmodified file during a merge."))
  1232. ((staged diff)
  1233. (user-error "Already staged"))
  1234. ((changes diff)
  1235. (monky-ediff-changes (monky-current-section)))
  1236. ))
  1237. (defun monky-ediff-merged (item)
  1238. (let* ((file (monky-diff-item-file item))
  1239. (file-path (concat (monky-get-root-dir) file)))
  1240. (condition-case nil
  1241. (monky-run-hg-sync "resolve" "--tool" "internal:dump" file)
  1242. (error nil))
  1243. (condition-case nil
  1244. (ediff-merge-files-with-ancestor
  1245. (concat file-path ".local")
  1246. (concat file-path ".other")
  1247. (concat file-path ".base")
  1248. nil file)
  1249. (error nil))
  1250. (delete-file (concat file-path ".local"))
  1251. (delete-file (concat file-path ".other"))
  1252. (delete-file (concat file-path ".base"))
  1253. (delete-file (concat file-path ".orig"))))
  1254. (defun monky-ediff-changes (item)
  1255. (ediff-revision
  1256. (concat (monky-get-root-dir)
  1257. (monky-diff-item-file item))))
  1258. (defvar monky-staged-all-files nil)
  1259. (defvar monky-old-staged-files '())
  1260. (defvar-local monky-staged-files nil)
  1261. (defun monky-stage-all ()
  1262. "Add all items in Changes to the staging area."
  1263. (interactive)
  1264. (monky-with-refresh
  1265. (setq monky-staged-all-files t)
  1266. (monky-refresh-buffer)))
  1267. (defun monky-stage-item ()
  1268. "Add the item at point to the staging area."
  1269. (interactive)
  1270. (monky-section-action "stage"
  1271. ((untracked file)
  1272. (monky-run-hg "add" (monky-section-info (monky-current-section))))
  1273. ((untracked)
  1274. (monky-run-hg "add"))
  1275. ((missing file)
  1276. (monky-run-hg "remove" "--after" (monky-section-info (monky-current-section))))
  1277. ((changes diff)
  1278. (monky-stage-file (monky-section-title (monky-current-section)))
  1279. (monky-refresh-buffer))
  1280. ((changes)
  1281. (monky-stage-all))
  1282. ((staged diff)
  1283. (user-error "Already staged"))
  1284. ((unmodified diff)
  1285. (user-error "Cannot partially commit a merge"))
  1286. ((merged diff)
  1287. (user-error "Cannot partially commit a merge"))))
  1288. (defun monky-unstage-all ()
  1289. "Remove all items from the staging area"
  1290. (interactive)
  1291. (monky-with-refresh
  1292. (setq monky-staged-files '())
  1293. (monky-refresh-buffer)))
  1294. (defun monky-unstage-item ()
  1295. "Remove the item at point from the staging area."
  1296. (interactive)
  1297. (monky-with-process
  1298. (monky-section-action "unstage"
  1299. ((staged diff)
  1300. (monky-unstage-file (monky-section-title (monky-current-section)))
  1301. (monky-refresh-buffer))
  1302. ((staged)
  1303. (monky-unstage-all))
  1304. ((changes diff)
  1305. (user-error "Already unstaged")))))
  1306. ;;; Updating
  1307. (defun monky-pull ()
  1308. "Run hg pull. The monky-pull-args variable contains extra arguments to pass to hg."
  1309. (interactive)
  1310. (let ((remote (if current-prefix-arg
  1311. (monky-read-remote "Pull from : ")
  1312. monky-incoming-repository)))
  1313. (apply #'monky-run-hg-async
  1314. "pull" (append monky-pull-args (list remote)))))
  1315. (defun monky-remotes ()
  1316. (mapcar #'car (monky-hg-config-section "paths")))
  1317. (defun monky-read-remote (prompt)
  1318. (monky-completing-read prompt
  1319. (monky-remotes)))
  1320. (defun monky-read-revision (prompt)
  1321. (let ((revision (read-string prompt)))
  1322. (unless (monky-hg-revision-p revision)
  1323. (error "%s is not a revision" revision))
  1324. revision))
  1325. (defun monky-push ()
  1326. "Pushes current branch to the default path."
  1327. (interactive)
  1328. (let* ((branch (monky-current-branch))
  1329. (remote (if current-prefix-arg
  1330. (monky-read-remote
  1331. (format "Push branch %s to : " branch))
  1332. monky-outgoing-repository)))
  1333. (if (string= "" remote)
  1334. (monky-run-hg-async "push" "--branch" branch)
  1335. (monky-run-hg-async "push" "--branch" branch remote))))
  1336. (defun monky-checkout (node)
  1337. (interactive (list (monky-read-revision "Update to: ")))
  1338. (monky-run-hg "update" node))
  1339. (defun monky-merge (node)
  1340. (interactive (list (monky-read-revision "Merge with: ")))
  1341. (monky-run-hg "merge" node))
  1342. (defun monky-reset-tip ()
  1343. (interactive)
  1344. (when (yes-or-no-p "Discard all uncommitted changes? ")
  1345. (monky-run-hg "update" "--clean")))
  1346. (defun monky-addremove-all ()
  1347. (interactive)
  1348. (monky-run-hg "addremove"))
  1349. (defun monky-rollback ()
  1350. (interactive)
  1351. (monky-run-hg "rollback"))
  1352. ;;; Merging
  1353. (defun monky-unresolve-item ()
  1354. "Mark the item at point as unresolved."
  1355. (interactive)
  1356. (monky-section-action "unresolve"
  1357. ((merged diff)
  1358. (if (eq (monky-diff-item-kind (monky-current-section)) 'resolved)
  1359. (monky-run-hg "resolve" "--unmark" (monky-diff-item-file (monky-current-section)))
  1360. (user-error "Already unresolved")))))
  1361. (defun monky-resolve-item ()
  1362. "Mark the item at point as resolved."
  1363. (interactive)
  1364. (monky-section-action "resolve"
  1365. ((merged diff)
  1366. (if (eq (monky-diff-item-kind (monky-current-section)) 'unresolved)
  1367. (monky-run-hg "resolve" "--mark" (monky-diff-item-file (monky-current-section)))
  1368. (user-error "Already resolved")))))
  1369. ;; History
  1370. (defun monky-backout (revision)
  1371. "Runs hg backout."
  1372. (interactive (list (monky-read-revision "Backout : ")))
  1373. (monky-pop-to-log-edit 'backout revision))
  1374. (defun monky-backout-item ()
  1375. "Backout the revision represented by current item."
  1376. (interactive)
  1377. (monky-section-action "backout"
  1378. ((log commits commit)
  1379. (monky-backout (monky-section-info (monky-current-section))))))
  1380. (defun monky-show-item-or-scroll-up ()
  1381. (interactive)
  1382. (monky-section-action "show"
  1383. ((commit)
  1384. (monky-show-commit (monky-section-info (monky-current-section)) nil #'scroll-up))
  1385. (t
  1386. (scroll-up))))
  1387. (defun monky-show-item-or-scroll-down ()
  1388. (interactive)
  1389. (monky-section-action "show"
  1390. ((commit)
  1391. (monky-show-commit (monky-section-info (monky-current-section)) nil #'scroll-down))
  1392. (t
  1393. (scroll-down))))
  1394. ;;; Miscellaneous
  1395. (defun monky-revert-file (file)
  1396. (when (or (not monky-revert-item-confirm)
  1397. (yes-or-no-p (format "Revert %s? " file)))
  1398. (monky-run-hg "revert" "--no-backup" file)
  1399. (let ((file-buf (find-buffer-visiting
  1400. (concat (monky-get-root-dir) file))))
  1401. (if file-buf
  1402. (save-current-buffer
  1403. (set-buffer file-buf)
  1404. (revert-buffer t t t))))))
  1405. (defun monky-discard-item ()
  1406. "Delete the file if not tracked, otherwise revert it."
  1407. (interactive)
  1408. (monky-section-action "discard"
  1409. ((untracked file)
  1410. (when (yes-or-no-p (format "Delete %s? " (monky-section-info (monky-current-section))))
  1411. (delete-file (monky-section-info (monky-current-section)))
  1412. (monky-refresh-buffer)))
  1413. ((changes diff)
  1414. (monky-revert-file (monky-diff-item-file (monky-current-section))))
  1415. ((staged diff)
  1416. (monky-revert-file (monky-diff-item-file (monky-current-section))))
  1417. ((missing file)
  1418. (monky-revert-file (monky-section-info (monky-current-section))))
  1419. ((shelf)
  1420. (monky-delete-shelf (monky-section-info (monky-current-section))))))
  1421. (defun monky-quit-window (&optional kill-buffer)
  1422. "Bury the buffer and delete its window. With a prefix argument, kill the
  1423. buffer instead."
  1424. (interactive "P")
  1425. (quit-window kill-buffer (selected-window)))
  1426. ;;; Refresh
  1427. (defun monky-revert-buffers (dir &optional ignore-modtime)
  1428. (dolist (buffer (buffer-list))
  1429. (when (and buffer
  1430. (buffer-file-name buffer)
  1431. (monky-string-starts-with-p (buffer-file-name buffer) dir)
  1432. (file-readable-p (buffer-file-name buffer))
  1433. (or ignore-modtime (not (verify-visited-file-modtime buffer)))
  1434. (not (buffer-modified-p buffer)))
  1435. (with-current-buffer buffer
  1436. (condition-case var
  1437. (revert-buffer t t t)
  1438. (error (let ((signal-data (cadr var)))
  1439. (cond (t (monky-bug-report signal-data))))))))))
  1440. (defvar monky-refresh-needing-buffers nil)
  1441. (defvar monky-refresh-pending nil)
  1442. (defun monky-refresh-wrapper (func)
  1443. "A helper function for `monky-with-refresh'."
  1444. (monky-with-process
  1445. (if monky-refresh-pending
  1446. (funcall func)
  1447. (let* ((dir default-directory)
  1448. (status-buffer (monky-find-status-buffer dir))
  1449. (monky-refresh-needing-buffers nil)
  1450. (monky-refresh-pending t))
  1451. (unwind-protect
  1452. (funcall func)
  1453. (when monky-refresh-needing-buffers
  1454. (monky-revert-buffers dir)
  1455. (dolist (b (adjoin status-buffer
  1456. monky-refresh-needing-buffers))
  1457. (monky-refresh-buffer b))))))))
  1458. (defun monky-need-refresh (&optional buffer)
  1459. (let ((buffer (or buffer (current-buffer))))
  1460. (setq monky-refresh-needing-buffers
  1461. (adjoin buffer monky-refresh-needing-buffers))))
  1462. (defun monky-refresh ()
  1463. "Refresh current buffer to match repository state.
  1464. Also revert every unmodified buffer visiting files
  1465. in the corresponding directory."
  1466. (interactive)
  1467. (monky-with-refresh
  1468. (monky-need-refresh)))
  1469. (defun monky-refresh-buffer (&optional buffer)
  1470. (with-current-buffer (or buffer (current-buffer))
  1471. (let* ((old-line (line-number-at-pos))
  1472. (old-section (monky-current-section))
  1473. (old-path (and old-section
  1474. (monky-section-path old-section)))
  1475. (section-line (and old-section
  1476. (count-lines
  1477. (monky-section-beginning old-section)
  1478. (point)))))
  1479. (if monky-refresh-function
  1480. (apply monky-refresh-function
  1481. monky-refresh-args))
  1482. (let ((s (and old-path (monky-find-section old-path monky-top-section))))
  1483. (cond (s
  1484. (goto-char (monky-section-beginning s))
  1485. (forward-line section-line))
  1486. (t
  1487. (monky-goto-line old-line)))
  1488. (dolist (w (get-buffer-window-list (current-buffer)))
  1489. (set-window-point w (point)))))))
  1490. (defvar monky-last-point nil)
  1491. (defun monky-remember-point ()
  1492. (setq monky-last-point (point)))
  1493. (defun monky-invisible-region-end (pos)
  1494. (while (and (not (= pos (point-max))) (invisible-p pos))
  1495. (setq pos (next-char-property-change pos)))
  1496. pos)
  1497. (defun monky-invisible-region-start (pos)
  1498. (while (and (not (= pos (point-min))) (invisible-p pos))
  1499. (setq pos (1- (previous-char-property-change pos))))
  1500. pos)
  1501. (defun monky-correct-point-after-command ()
  1502. "Move point outside of invisible regions.
  1503. Emacs often leaves point in invisible regions, it seems. To fix
  1504. this, we move point ourselves and never let Emacs do its own
  1505. adjustments.
  1506. When point has to be moved out of an invisible region, it can be
  1507. moved to its end or its beginning. We usually move it to its
  1508. end, except when that would move point back to where it was
  1509. before the last command."
  1510. (if (invisible-p (point))
  1511. (let ((end (monky-invisible-region-end (point))))
  1512. (goto-char (if (= end monky-last-point)
  1513. (monky-invisible-region-start (point))
  1514. end))))
  1515. (setq disable-point-adjustment t))
  1516. (defun monky-post-command-hook ()
  1517. (monky-correct-point-after-command))
  1518. ;;; Monky mode
  1519. (define-derived-mode monky-mode special-mode "Monky"
  1520. "View the status of a mercurial repository.
  1521. \\{monky-mode-map}"
  1522. (setq buffer-read-only t)
  1523. (setq mode-line-process "")
  1524. (setq truncate-lines t)
  1525. (add-hook 'pre-command-hook #'monky-remember-point nil t)
  1526. (add-hook 'post-command-hook #'monky-post-command-hook t t))
  1527. (defun monky-mode-init (dir submode refresh-func &rest refresh-args)
  1528. (monky-mode)
  1529. (setq default-directory dir
  1530. monky-submode submode
  1531. monky-refresh-function refresh-func
  1532. monky-refresh-args refresh-args)
  1533. (monky-refresh-buffer))
  1534. ;;; Hg utils
  1535. (defmacro monky-with-temp-file (file &rest body)
  1536. "Create a temporary file name, evaluate BODY and delete the file."
  1537. (declare (indent 1)
  1538. (debug (symbolp body)))
  1539. `(let ((,file (make-temp-file "monky-temp-file")))
  1540. (unwind-protect
  1541. (progn ,@body)
  1542. (delete-file ,file))))
  1543. (defun monky-hg-insert (args)
  1544. (insert (monky-hg-output args)))
  1545. (defun monky-hg-output (args)
  1546. (monky-with-temp-file stderr
  1547. (save-current-buffer
  1548. (with-temp-buffer
  1549. (unless (eq 0 (apply #'monky-process-file
  1550. monky-hg-executable
  1551. nil (list t stderr) nil
  1552. (append monky-hg-standard-options args)))
  1553. (error (with-temp-buffer
  1554. (insert-file-contents stderr)
  1555. (buffer-string))))
  1556. (buffer-string)))))
  1557. (defun monky-hg-string (&rest args)
  1558. (monky-trim-line (monky-hg-output args)))
  1559. (defun monky-hg-lines (&rest args)
  1560. (monky-split-lines (monky-hg-output args)))
  1561. (defun monky-hg-exit-code (&rest args)
  1562. (apply #'monky-process-file monky-hg-executable nil nil nil
  1563. (append monky-hg-standard-options args)))
  1564. (defun monky-hg-revision-p (revision)
  1565. (eq 0 (monky-hg-exit-code "identify" "--rev" revision)))
  1566. ;; TODO needs cleanup
  1567. (defun monky-get-root-dir ()
  1568. (if (and (featurep 'tramp)
  1569. (tramp-tramp-file-p default-directory))
  1570. (monky-get-tramp-root-dir)
  1571. (monky-get-local-root-dir)))
  1572. (defun monky-get-local-root-dir ()
  1573. (let ((root (monky-hg-string "root")))
  1574. (if root
  1575. (concat root "/")
  1576. (user-error "Not inside a hg repo"))))
  1577. (defun monky-get-tramp-root-dir ()
  1578. (let ((root (monky-hg-string "root"))
  1579. (tramp-path (vconcat (tramp-dissect-file-name default-directory))))
  1580. (if root
  1581. (progn (aset tramp-path 6 root)
  1582. (concat (apply 'tramp-make-tramp-file-name (cdr (append tramp-path nil)))
  1583. "/"))
  1584. (user-error "Not inside a hg repo"))))
  1585. (defun monky-find-buffer (submode &optional dir)
  1586. (let ((rootdir (expand-file-name (or dir (monky-get-root-dir)))))
  1587. (find-if (lambda (buf)
  1588. (with-current-buffer buf
  1589. (and default-directory
  1590. (equal (expand-file-name default-directory) rootdir)
  1591. (eq major-mode 'monky-mode)
  1592. (eq monky-submode submode))))
  1593. (buffer-list))))
  1594. (defun monky-find-status-buffer (&optional dir)
  1595. (monky-find-buffer 'status dir))
  1596. (defun monky-for-all-buffers (func &optional dir)
  1597. (dolist (buf (buffer-list))
  1598. (with-current-buffer buf
  1599. (if (and (eq major-mode 'monky-mode)
  1600. (or (null dir)
  1601. (equal default-directory dir)))
  1602. (funcall func)))))
  1603. (defun monky-hg-config ()
  1604. "Return an alist of ((section . key) . value)"
  1605. (mapcar (lambda (line)
  1606. (string-match "^\\([^.]*\\)\.\\([^=]*\\)=\\(.*\\)$" line)
  1607. (cons (cons (match-string 1 line)
  1608. (match-string 2 line))
  1609. (match-string 3 line)))
  1610. (monky-hg-lines "debugconfig")))
  1611. (defun monky-hg-config-section (section)
  1612. "Return an alist of (name . value) for section"
  1613. (mapcar (lambda (item)
  1614. (cons (cdar item) (cdr item)))
  1615. (remove-if-not (lambda (item)
  1616. (equal section (caar item)))
  1617. (monky-hg-config))))
  1618. (defvar monky-el-directory
  1619. (file-name-directory (or load-file-name default-directory))
  1620. "The parent directory of monky.el")
  1621. (defun monky-get-style-path (filename)
  1622. (concat (file-name-as-directory (concat monky-el-directory "style"))
  1623. filename))
  1624. (defvar monky-hg-style-log-graph
  1625. (monky-get-style-path "log-graph"))
  1626. (defvar monky-hg-style-files-status
  1627. (monky-get-style-path "files-status"))
  1628. (defvar monky-hg-style-tags
  1629. (monky-get-style-path "tags"))
  1630. (defun monky-hg-log-tags (revision &rest args)
  1631. (apply #'monky-hg-lines "log"
  1632. "--style" monky-hg-style-tags
  1633. "--rev" revision args))
  1634. (defun monky-qtip-p ()
  1635. "Return non-nil if the current revision is qtip"
  1636. (let ((rev (replace-regexp-in-string "\\+$" ""
  1637. (monky-hg-string "identify" "--id"))))
  1638. (let ((monky-cmd-process nil)) ; use single process
  1639. (member "qtip" (monky-hg-log-tags rev "--config" "extensions.mq=")))))
  1640. ;;; Washers
  1641. (defun monky-wash-status-lines (callback)
  1642. "For every status line in the current buffer, remove it and call CALLBACK.
  1643. CALLBACK is called with the status and the associated filename."
  1644. (while (and (not (eobp))
  1645. (looking-at "\\([A-Z!? ]\\) \\([^\t\n]+\\)$"))
  1646. (let ((status (case (string-to-char (match-string-no-properties 1))
  1647. (?M 'modified)
  1648. (?A 'new)
  1649. (?R 'removed)
  1650. (?C 'clean)
  1651. (?! 'missing)
  1652. (?? 'untracked)
  1653. (?I 'ignored)
  1654. (?U 'unresolved)
  1655. (t nil)))
  1656. (file (match-string-no-properties 2)))
  1657. (monky-delete-line t)
  1658. (funcall callback status file))))
  1659. ;; File
  1660. (defun monky-wash-files ()
  1661. (let ((empty t))
  1662. (monky-wash-status-lines
  1663. (lambda (_status file)
  1664. (setq empty nil)
  1665. (monky-with-section file 'file
  1666. (monky-set-section-info file)
  1667. (insert file "\n"))))
  1668. (unless empty
  1669. (insert "\n"))))
  1670. ;; Hunk
  1671. (defun monky-hunk-item-diff (hunk)
  1672. (let ((diff (monky-section-parent hunk)))
  1673. (or (eq (monky-section-type diff) 'diff)
  1674. (error "Huh? Parent of hunk not a diff"))
  1675. diff))
  1676. (defun monky-hunk-item-target-line (hunk)
  1677. (save-excursion
  1678. (beginning-of-line)
  1679. (let ((line (line-number-at-pos)))
  1680. (goto-char (monky-section-beginning hunk))
  1681. (if (not (looking-at "@@+ .* \\+\\([0-9]+\\),[0-9]+ @@+"))
  1682. (error "Hunk header not found"))
  1683. (let ((target (string-to-number (match-string 1))))
  1684. (forward-line)
  1685. (while (< (line-number-at-pos) line)
  1686. ;; XXX - deal with combined diffs
  1687. (if (not (looking-at "-"))
  1688. (setq target (+ target 1)))
  1689. (forward-line))
  1690. target))))
  1691. (defun monky-wash-hunk ()
  1692. (if (looking-at "\\(^@+\\)[^@]*@+")
  1693. (let ((n-columns (1- (length (match-string 1))))
  1694. (head (match-string 0)))
  1695. (monky-with-section head 'hunk
  1696. (add-text-properties (match-beginning 0) (1+ (match-end 0))
  1697. '(face monky-diff-hunk-header))
  1698. (forward-line)
  1699. (while (not (or (eobp)
  1700. (looking-at "^diff\\|^@@")))
  1701. (let ((prefix (buffer-substring-no-properties
  1702. (point) (min (+ (point) n-columns) (point-max)))))
  1703. (cond ((string-match "\\+" prefix)
  1704. (monky-put-line-property 'face 'monky-diff-add))
  1705. ((string-match "-" prefix)
  1706. (monky-put-line-property 'face 'monky-diff-del))
  1707. (t
  1708. (monky-put-line-property 'face 'monky-diff-none))))
  1709. (forward-line))))
  1710. nil))
  1711. ;; Diff
  1712. (defvar monky-hide-diffs nil)
  1713. (defun monky-diff-item-kind (diff)
  1714. (car (monky-section-info diff)))
  1715. (defun monky-diff-item-file (diff)
  1716. (cadr (monky-section-info diff)))
  1717. (defun monky-diff-line-file ()
  1718. (cond ((looking-at "^diff -r \\([^ ]*\\) \\(-r \\([^ ]*\\) \\)?\\(.*\\)$")
  1719. (match-string-no-properties 4))
  1720. ((looking-at (rx "diff --git a/" (group (+? anything)) " b/"))
  1721. (match-string-no-properties 1))
  1722. (t
  1723. nil)))
  1724. (defun monky-wash-diff-section (&optional status file)
  1725. (let ((case-fold-search nil))
  1726. (cond ((looking-at "^diff ")
  1727. (let* ((file (monky-diff-line-file))
  1728. (end (save-excursion
  1729. (forward-line)
  1730. (if (search-forward-regexp "^diff \\|^@@" nil t)
  1731. (goto-char (match-beginning 0))
  1732. (goto-char (point-max)))
  1733. (point-marker)))
  1734. (status (or status
  1735. (cond
  1736. ((save-excursion
  1737. (search-forward-regexp "^--- /dev/null" end t))
  1738. 'new)
  1739. ((save-excursion
  1740. (search-forward-regexp "^+++ /dev/null" end t))
  1741. 'removed)
  1742. (t 'modified)))))
  1743. (monky-set-section-info (list status file))
  1744. (monky-insert-diff-title status file)
  1745. ;; Remove the 'diff ...' text and '+++' text, as it's redundant.
  1746. (delete-region (point) end)
  1747. (let ((monky-section-hidden-default nil))
  1748. (monky-wash-sequence #'monky-wash-hunk))))
  1749. ;; sometimes diff returns empty output
  1750. ((and status file)
  1751. (monky-set-section-info (list status file))
  1752. (monky-insert-diff-title status file))
  1753. (t nil))))
  1754. (defun monky-wash-diff ()
  1755. (let ((monky-section-hidden-default monky-hide-diffs))
  1756. (monky-with-section nil 'diff
  1757. (monky-wash-diff-section))))
  1758. (defun monky-wash-diffs ()
  1759. (monky-wash-sequence #'monky-wash-diff))
  1760. (defun monky-insert-diff (file &optional status cmd)
  1761. (let ((p (point)))
  1762. (monky-hg-insert (list (or cmd "diff") file))
  1763. (if (not (eq (char-before) ?\n))
  1764. (insert "\n"))
  1765. (save-restriction
  1766. (narrow-to-region p (point))
  1767. (goto-char p)
  1768. (monky-wash-diff-section status file)
  1769. (goto-char (point-max)))))
  1770. (defun monky-insert-diff-title (status file)
  1771. (insert
  1772. (format "%-10s %s\n"
  1773. (propertize
  1774. (symbol-name status)
  1775. 'face
  1776. (if (eq status 'unresolved) 'warning 'monky-diff-title))
  1777. (propertize file 'face 'monky-diff-title))))
  1778. ;;; Untracked files
  1779. (defun monky-insert-untracked-files ()
  1780. (monky-hg-section 'untracked "Untracked files:" #'monky-wash-files
  1781. "status" "--unknown"))
  1782. ;;; Missing files
  1783. (defun monky-insert-missing-files ()
  1784. (monky-hg-section 'missing "Missing files:" #'monky-wash-files
  1785. "status" "--deleted"))
  1786. ;;; Changes
  1787. (defun monky-wash-changes ()
  1788. (let ((changes-p nil))
  1789. (monky-wash-status-lines
  1790. (lambda (status file)
  1791. (let ((monky-section-hidden-default monky-hide-diffs))
  1792. (if (or monky-staged-all-files
  1793. (member file monky-old-staged-files))
  1794. (monky-stage-file file)
  1795. (monky-with-section file 'diff
  1796. (monky-insert-diff file status))
  1797. (setq changes-p t)))))
  1798. (when changes-p
  1799. (insert "\n"))))
  1800. (defun monky-insert-changes ()
  1801. (let ((monky-hide-diffs t))
  1802. (setq monky-old-staged-files (copy-list monky-staged-files))
  1803. (setq monky-staged-files '())
  1804. (monky-hg-section 'changes "Changes:" #'monky-wash-changes
  1805. "status" "--modified" "--added" "--removed")))
  1806. ;; Staged Changes
  1807. (defun monky-stage-file (file)
  1808. (if (not (member file monky-staged-files))
  1809. (setq monky-staged-files (cons file monky-staged-files))))
  1810. (defun monky-unstage-file (file)
  1811. (setq monky-staged-files (delete file monky-staged-files)))
  1812. (defun monky-insert-staged-changes ()
  1813. (when monky-staged-files
  1814. (monky-with-section 'staged nil
  1815. (insert (propertize "Staged changes:" 'face 'monky-section-title) "\n")
  1816. (let ((monky-section-hidden-default t))
  1817. (dolist (file monky-staged-files)
  1818. (monky-with-section file 'diff
  1819. (monky-insert-diff file)))))
  1820. (insert "\n"))
  1821. (setq monky-staged-all-files nil))
  1822. ;;; Shelves
  1823. (defun monky-extensions ()
  1824. "Return a list of all the enabled mercurial extensions."
  1825. (let* ((config
  1826. (string-trim (shell-command-to-string "hg config extensions")))
  1827. (lines
  1828. (split-string config "\n"))
  1829. extensions)
  1830. (dolist (line lines)
  1831. (unless (string-match-p (rx "!" eos) line)
  1832. (setq line (string-remove-prefix "extensions." line))
  1833. (setq line (string-remove-suffix "=" line)))
  1834. (push line extensions))
  1835. (nreverse extensions)))
  1836. (defun monky-insert-shelves ()
  1837. (when (member "shelve" (monky-extensions))
  1838. (monky-hg-section 'shelves "Shelves:" #'monky-wash-shelves
  1839. "shelve" "--list")))
  1840. (defun monky-wash-shelves ()
  1841. "Set shelf names on each line.
  1842. This is naive and assumes that shelf names never contain (."
  1843. (while (re-search-forward
  1844. (rx bol (group (+? not-newline))
  1845. (+ space) "(")
  1846. nil
  1847. t)
  1848. (goto-char (line-beginning-position))
  1849. (monky-with-section 'shelf nil
  1850. (monky-set-section-info (match-string 1))
  1851. (put-text-property
  1852. (match-beginning 1)
  1853. (match-end 1)
  1854. 'face
  1855. 'monky-commit-id)
  1856. (goto-char (line-end-position)))))
  1857. ;;; Parents
  1858. (defvar-local monky-parents nil)
  1859. (defun monky-merge-p ()
  1860. (> (length monky-parents) 1))
  1861. (defun monky-wash-parent ()
  1862. (if (looking-at "changeset:\s*\\([0-9]+\\):\\([0-9a-z]+\\)")
  1863. (let ((changeset (match-string 2))
  1864. (line (buffer-substring (line-beginning-position) (line-end-position))))
  1865. (push changeset monky-parents)
  1866. ;; Remove the plain text 'changeset: ...' and replace it with
  1867. ;; propertized text, plus a section that knows the changeset
  1868. ;; (so RET shows the full commit).
  1869. (monky-with-section 'commit nil
  1870. (monky-set-section-info changeset)
  1871. (monky-delete-line t)
  1872. (insert line "\n")
  1873. (put-text-property
  1874. (match-beginning 1)
  1875. (match-end 1)
  1876. 'face
  1877. 'monky-commit-id)
  1878. (put-text-property
  1879. (match-beginning 2)
  1880. (match-end 2)
  1881. 'face
  1882. 'monky-commit-id))
  1883. (while (not (or (eobp)
  1884. (looking-at "changeset:\s*\\([0-9]+\\):\\([0-9a-z]+\\)")))
  1885. (forward-line))
  1886. t)
  1887. nil))
  1888. (defun monky-wash-parents ()
  1889. (monky-wash-sequence #'monky-wash-parent))
  1890. (defun monky-insert-parents ()
  1891. (monky-hg-section 'parents "Parents:"
  1892. #'monky-wash-parents "parents"))
  1893. ;;; Merged Files
  1894. (defvar-local monky-merged-files nil)
  1895. (defun monky-wash-merged-files ()
  1896. (let ((empty t))
  1897. (monky-wash-status-lines
  1898. (lambda (status file)
  1899. (setq empty nil)
  1900. (let ((monky-section-hidden-default monky-hide-diffs))
  1901. (push file monky-merged-files)
  1902. ;; XXX hg uses R for resolved and removed status
  1903. (let ((status (if (eq status 'unresolved)
  1904. 'unresolved
  1905. 'resolved)))
  1906. (monky-with-section file 'diff
  1907. (monky-insert-diff file status))))))
  1908. (unless empty
  1909. (insert "\n"))))
  1910. (defun monky-insert-merged-files ()
  1911. (let ((monky-hide-diffs t))
  1912. (setq monky-merged-files '())
  1913. (monky-hg-section 'merged "Merged Files:" #'monky-wash-merged-files
  1914. "resolve" "--list")))
  1915. ;;; Unmodified Files
  1916. (defun monky-wash-unmodified-files ()
  1917. (monky-wash-status-lines
  1918. (lambda (_status file)
  1919. (let ((monky-section-hidden-default monky-hide-diffs))
  1920. (when (not (member file monky-merged-files))
  1921. (monky-with-section file 'diff
  1922. (monky-insert-diff file)))))))
  1923. (defun monky-insert-resolved-files ()
  1924. (let ((monky-hide-diffs t))
  1925. (monky-hg-section 'unmodified "Unmodified files during merge:" #'monky-wash-unmodified-files
  1926. "status" "--modified" "--added" "--removed")))
  1927. ;;; Status mode
  1928. (defun monky-refresh-status ()
  1929. (setq monky-parents nil
  1930. monky-merged-files nil)
  1931. (monky-create-buffer-sections
  1932. (monky-with-section 'status nil
  1933. (monky-insert-parents)
  1934. (if (monky-merge-p)
  1935. (progn
  1936. (monky-insert-merged-files)
  1937. (monky-insert-resolved-files))
  1938. (monky-insert-untracked-files)
  1939. (monky-insert-missing-files)
  1940. (monky-insert-changes)
  1941. (monky-insert-staged-changes)
  1942. (monky-insert-shelves)))))
  1943. (define-minor-mode monky-status-mode
  1944. "Minor mode for hg status.
  1945. \\{monky-status-mode-map}"
  1946. :group monky
  1947. :init-value ()
  1948. :lighter ()
  1949. :keymap monky-status-mode-map)
  1950. ;;;###autoload
  1951. (defun monky-status (&optional directory)
  1952. "Show the status of Hg repository."
  1953. (interactive)
  1954. (monky-with-process
  1955. (let* ((rootdir (or directory (monky-get-root-dir)))
  1956. (buf (or (monky-find-status-buffer rootdir)
  1957. (generate-new-buffer
  1958. (concat "*monky: "
  1959. (file-name-nondirectory
  1960. (directory-file-name rootdir)) "*")))))
  1961. (pop-to-buffer buf)
  1962. (monky-mode-init rootdir 'status #'monky-refresh-status)
  1963. (monky-status-mode t))))
  1964. ;;; Log mode
  1965. (define-minor-mode monky-log-mode
  1966. "Minor mode for hg log.
  1967. \\{monky-log-mode-map}"
  1968. :group monky
  1969. :init-value ()
  1970. :lighter ()
  1971. :keymap monky-log-mode-map)
  1972. (defvar monky-log-buffer-name "*monky-log*")
  1973. (defun monky-propertize-labels (label-list &rest properties)
  1974. "Propertize labels (tag/branch/bookmark/...) in LABEL-LIST.
  1975. PROPERTIES is the arguments for the function `propertize'."
  1976. (apply #'concat
  1977. (apply #'append
  1978. (mapcar (lambda (l)
  1979. (unless (or (string= l "") (string= l "None"))
  1980. (list (apply #'propertize l properties) " ")))
  1981. label-list))))
  1982. (defun monky-present-log-line (width graph id branches tags bookmarks phase author date message)
  1983. (let* ((hg-info (concat
  1984. (propertize (substring id 0 8) 'face 'monky-log-sha1)
  1985. " "
  1986. graph
  1987. (monky-propertize-labels branches 'face 'monky-log-head-label-local)
  1988. (monky-propertize-labels tags 'face 'monky-log-head-label-tags)
  1989. (monky-propertize-labels bookmarks 'face 'monky-log-head-label-bookmarks)
  1990. (unless (or (string= phase "") (string= phase "public"))
  1991. (monky-propertize-labels `(,phase) 'face 'monky-log-head-label-phase))))
  1992. (total-space-left (max 0 (- width (length hg-info))))
  1993. (author-date-space-taken (+ 16 (min 10 (length author))))
  1994. (message-space-left (number-to-string (max 0 (- total-space-left author-date-space-taken 1))))
  1995. (msg-format (concat "%-" message-space-left "." message-space-left "s"))
  1996. (msg (format msg-format message)))
  1997. (let* ((shortened-msg (if (< 3 (length msg))
  1998. (concat (substring msg 0 -3) "...")
  1999. msg))
  2000. (msg (if (>= (string-to-number message-space-left) (length message))
  2001. msg
  2002. shortened-msg)))
  2003. (concat
  2004. hg-info
  2005. (propertize msg 'face 'monky-log-message)
  2006. (propertize (format " %.10s" author) 'face 'monky-log-author)
  2007. (propertize (format " %.10s" date) 'face 'monky-log-date)))))
  2008. (defun monky-log-current-branch ()
  2009. (interactive)
  2010. (monky-log "ancestors(.)"))
  2011. (defun monky-log-buffer-file ()
  2012. "View a log of commits that affected the current file."
  2013. (interactive)
  2014. (monky-log "ancestors(.)" (buffer-file-name)))
  2015. (defun monky-log-all ()
  2016. (interactive)
  2017. (monky-log nil))
  2018. (defun monky-log-revset (revset)
  2019. (interactive "sRevset: ")
  2020. (monky-log revset))
  2021. (defun monky-log (revs &optional path)
  2022. (monky-with-process
  2023. (let ((topdir (monky-get-root-dir)))
  2024. (pop-to-buffer monky-log-buffer-name)
  2025. (setq default-directory topdir
  2026. monky-root-dir topdir)
  2027. (monky-mode-init topdir 'log (monky-refresh-log-buffer revs path))
  2028. (monky-log-mode t))))
  2029. (defvar monky-log-graph-re
  2030. (concat
  2031. "^\\([-_\\/@o+|\s]+\s*\\) " ; 1. graph
  2032. "\\([a-z0-9]\\{40\\}\\) " ; 2. id
  2033. "<branches>\\(.?*\\)</branches>" ; 3. branches
  2034. "<tags>\\(.?*\\)</tags>" ; 4. tags
  2035. "<bookmarks>\\(.?*\\)</bookmarks>" ; 5. bookmarks
  2036. "<phase>\\(.?*\\)</phase>" ; 6. phase
  2037. "<author>\\(.*?\\)</author>" ; 7. author
  2038. "<monky-date>\\([0-9]+\\).?*</monky-date>" ; 8. date
  2039. "\\(.*\\)$" ; 9. msg
  2040. ))
  2041. (defun monky-decode-xml-entities (str)
  2042. (setq str (replace-regexp-in-string "&lt;" "<" str))
  2043. (setq str (replace-regexp-in-string "&gt;" ">" str))
  2044. (setq str (replace-regexp-in-string "&amp;" "&" str))
  2045. str)
  2046. (defun monky-xml-items-to-list (xml-like tag)
  2047. "Convert XML-LIKE string which has repeated TAG items into a list of strings.
  2048. Example:
  2049. (monky-xml-items-to-list \"<tag>A</tag><tag>B</tag>\" \"tag\")
  2050. ; => (\"A\" \"B\")
  2051. "
  2052. (mapcar #'monky-decode-xml-entities
  2053. (split-string (replace-regexp-in-string
  2054. (format "^<%s>\\|</%s>$" tag tag) "" xml-like)
  2055. (format "</%s><%s>" tag tag))))
  2056. (defvar monky-log-count ()
  2057. "Internal var used to count the number of logs actually added in a buffer.")
  2058. (defun monky--author-name (s)
  2059. "Extract the name from a Mercurial author string."
  2060. (save-match-data
  2061. (cond
  2062. ((string-match
  2063. ;; If S contains a space, take the first word.
  2064. (rx (group (1+ (not space)))
  2065. space)
  2066. s)
  2067. (match-string 1 s))
  2068. ((string-match
  2069. ;; If S is just an email, take the username.
  2070. (rx (group (1+ (not (any "@"))))
  2071. "@")
  2072. s)
  2073. (match-string 1 s))
  2074. (t s))))
  2075. (defun monky-wash-log-line ()
  2076. (if (looking-at monky-log-graph-re)
  2077. (let ((width (window-total-width))
  2078. (graph (match-string 1))
  2079. (id (match-string 2))
  2080. (branches (match-string 3))
  2081. (tags (match-string 4))
  2082. (bookmarks (match-string 5))
  2083. (phase (match-string 6))
  2084. (author (monky--author-name (match-string 7)))
  2085. (date (format-time-string "%Y-%m-%d" (seconds-to-time (string-to-number (match-string 8)))))
  2086. (msg (match-string 9)))
  2087. (monky-delete-line)
  2088. (monky-with-section id 'commit
  2089. (insert (monky-present-log-line
  2090. width
  2091. graph id
  2092. (monky-xml-items-to-list branches "branch")
  2093. (monky-xml-items-to-list tags "tag")
  2094. (monky-xml-items-to-list bookmarks "bookmark")
  2095. (monky-decode-xml-entities phase)
  2096. (monky-decode-xml-entities author)
  2097. (monky-decode-xml-entities date)
  2098. (monky-decode-xml-entities msg)))
  2099. (monky-set-section-info id)
  2100. (when monky-log-count (incf monky-log-count))
  2101. (forward-line)
  2102. (when (looking-at "^\\([\\/@o+-|\s]+\s*\\)$")
  2103. (let ((graph (match-string 1)))
  2104. (insert " ")
  2105. (forward-line))))
  2106. t)
  2107. nil))
  2108. (defun monky-wash-logs ()
  2109. (let ((monky-old-top-section nil))
  2110. (monky-wash-sequence #'monky-wash-log-line)))
  2111. (defmacro monky-create-log-buffer-sections (&rest body)
  2112. "Empty current buffer of text and monky's section, and then evaluate BODY.
  2113. if the number of logs inserted in the buffer is `monky-log-cutoff-length'
  2114. insert a line to tell how to insert more of them"
  2115. (declare (indent 0)
  2116. (debug (body)))
  2117. `(let ((monky-log-count 0))
  2118. (monky-create-buffer-sections
  2119. (monky-with-section 'log nil
  2120. ,@body
  2121. (if (= monky-log-count monky-log-cutoff-length)
  2122. (monky-with-section "longer" 'longer
  2123. (insert "type \"e\" to show more logs\n")))))))
  2124. (defun monky-log-show-more-entries (&optional arg)
  2125. "Grow the number of log entries shown.
  2126. With no prefix optional ARG, show twice as much log entries.
  2127. With a numerical prefix ARG, add this number to the number of shown log entries.
  2128. With a non numeric prefix ARG, show all entries"
  2129. (interactive "P")
  2130. (make-local-variable 'monky-log-cutoff-length)
  2131. (cond
  2132. ((numberp arg)
  2133. (setq monky-log-cutoff-length (+ monky-log-cutoff-length arg)))
  2134. (arg
  2135. (setq monky-log-cutoff-length monky-log-infinite-length))
  2136. (t (setq monky-log-cutoff-length (* monky-log-cutoff-length 2))))
  2137. (monky-refresh))
  2138. (defun monky-refresh-log-buffer (revs path)
  2139. (lambda ()
  2140. (monky-create-log-buffer-sections
  2141. (monky-hg-section
  2142. 'commits
  2143. (if path
  2144. (format "Commits affecting %s:"
  2145. (file-relative-name path monky-root-dir))
  2146. "Commits:")
  2147. #'monky-wash-logs
  2148. "log"
  2149. "--config" "extensions.graphlog="
  2150. "-G"
  2151. "--limit" (number-to-string monky-log-cutoff-length)
  2152. "--style" monky-hg-style-log-graph
  2153. (if revs "--rev" "")
  2154. (if revs revs "")
  2155. (if path path "")))))
  2156. (defun monky-next-sha1 (pos)
  2157. "Return position of next sha1 after given position POS"
  2158. (while (and pos
  2159. (not (equal (get-text-property pos 'face) 'monky-log-sha1)))
  2160. (setq pos (next-single-property-change pos 'face)))
  2161. pos)
  2162. (defun monky-previous-sha1 (pos)
  2163. "Return position of previous sha1 before given position POS"
  2164. (while (and pos
  2165. (not (equal (get-text-property pos 'face) 'monky-log-sha1)))
  2166. (setq pos (previous-single-property-change pos 'face)))
  2167. pos)
  2168. ;;; Blame mode
  2169. (define-minor-mode monky-blame-mode
  2170. "Minor mode for hg blame.
  2171. \\{monky-blame-mode-map}"
  2172. :group monky
  2173. :init-value ()
  2174. :lighter ()
  2175. :keymap monky-blame-mode-map)
  2176. (defun monky-present-blame-line (author changeset text)
  2177. (concat author
  2178. " "
  2179. (propertize changeset 'face 'monky-log-sha1)
  2180. ": "
  2181. text))
  2182. (defvar monky-blame-re
  2183. (concat
  2184. "\\(.*\\) " ; author
  2185. "\\([a-f0-9]\\{12\\}\\):" ; changeset
  2186. "\\(.*\\)$" ; text
  2187. ))
  2188. (defun monky-wash-blame-line ()
  2189. (if (looking-at monky-blame-re)
  2190. (let ((author (match-string 1))
  2191. (changeset (match-string 2))
  2192. (text (match-string 3)))
  2193. (monky-delete-line)
  2194. (monky-with-section changeset 'commit
  2195. (insert (monky-present-blame-line author changeset text))
  2196. (monky-set-section-info changeset)
  2197. (forward-line))
  2198. t)))
  2199. (defun monky-wash-blame ()
  2200. (monky-wash-sequence #'monky-wash-blame-line))
  2201. (defun monky-refresh-blame-buffer (file-name)
  2202. (monky-create-buffer-sections
  2203. (monky-with-section file-name 'blame
  2204. (monky-hg-section nil nil
  2205. #'monky-wash-blame
  2206. "blame"
  2207. "--user"
  2208. "--changeset"
  2209. file-name))))
  2210. (defun monky-blame-current-file ()
  2211. (interactive)
  2212. (monky-with-process
  2213. (let ((file-name (buffer-file-name))
  2214. (topdir (monky-get-root-dir))
  2215. (line-num (line-number-at-pos))
  2216. (column (current-column)))
  2217. (pop-to-buffer
  2218. (format "*monky-blame: %s*"
  2219. (file-name-nondirectory buffer-file-name)))
  2220. (monky-mode-init topdir 'blame #'monky-refresh-blame-buffer file-name)
  2221. (monky-blame-mode t)
  2222. ;; Put point on the same line number as the original file.
  2223. (forward-line (1- line-num))
  2224. (while (and (not (looking-at ":")) (not (eolp)))
  2225. (forward-char))
  2226. ;; Step over the blame information columns.
  2227. (forward-char (length ": "))
  2228. ;; Put point at the same column as the original file.
  2229. (forward-char column))))
  2230. ;;; Commit mode
  2231. (define-minor-mode monky-commit-mode
  2232. "Minor mode to view a hg commit.
  2233. \\{monky-commit-mode-map}"
  2234. :group monky
  2235. :init-value ()
  2236. :lighter ()
  2237. :keymap monky-commit-mode-map)
  2238. (defvar monky-commit-buffer-name "*monky-commit*")
  2239. (defun monky-empty-buffer-p (buffer)
  2240. (with-current-buffer buffer
  2241. (< (length (buffer-string)) 1)))
  2242. (defun monky-show-commit (commit &optional select scroll)
  2243. (monky-with-process
  2244. (when (monky-section-p commit)
  2245. (setq commit (monky-section-info commit)))
  2246. (unless (and commit
  2247. (monky-hg-revision-p commit))
  2248. (error "%s is not a commit" commit))
  2249. (let ((topdir (monky-get-root-dir))
  2250. (buffer (get-buffer-create monky-commit-buffer-name)))
  2251. (cond
  2252. ((and scroll
  2253. (not (monky-empty-buffer-p buffer)))
  2254. (let ((win (get-buffer-window buffer)))
  2255. (cond ((not win)
  2256. (display-buffer buffer))
  2257. (t
  2258. (with-selected-window win
  2259. (funcall scroll))))))
  2260. (t
  2261. (display-buffer buffer)
  2262. (with-current-buffer buffer
  2263. (monky-mode-init topdir 'commit
  2264. #'monky-refresh-commit-buffer commit)
  2265. (monky-commit-mode t))))
  2266. (if select
  2267. (pop-to-buffer buffer)))))
  2268. (defun monky-show-shelf (name)
  2269. (let ((buffer (get-buffer-create "*monky-shelf*"))
  2270. (inhibit-read-only t))
  2271. (pop-to-buffer buffer)
  2272. (erase-buffer)
  2273. (monky-hg-section
  2274. nil nil
  2275. #'ignore
  2276. "shelve" "-l" "-p" name)
  2277. (goto-char (point-min))
  2278. (when (re-search-forward "^diff " nil t)
  2279. (goto-char (line-beginning-position))
  2280. (monky-wash-diffs))
  2281. (monky-mode)))
  2282. (defun monky-delete-shelf (name)
  2283. (unless (zerop (monky-hg-exit-code "shelve" "--delete" name))
  2284. (user-error "Could not drop shelved %s" name))
  2285. (monky-refresh-buffer))
  2286. (defun monky-refresh-commit-buffer (commit)
  2287. (monky-create-buffer-sections
  2288. (monky-hg-section nil nil
  2289. #'monky-wash-commit
  2290. "-v"
  2291. "log"
  2292. "--stat"
  2293. "--patch"
  2294. "--rev" commit)))
  2295. (defun monky-wash-commit ()
  2296. (save-excursion
  2297. (monky-wash-parent))
  2298. (let ((case-fold-search nil))
  2299. (while (and (not (eobp)) (not (looking-at "^diff ")) )
  2300. (forward-line))
  2301. (when (looking-at "^diff ")
  2302. (monky-wash-diffs))))
  2303. ;;; Branch mode
  2304. (define-minor-mode monky-branches-mode
  2305. "Minor mode for hg branch.
  2306. \\{monky-branches-mode-map}"
  2307. :group monky
  2308. :init-value ()
  2309. :lighter ()
  2310. :keymap monky-branches-mode-map)
  2311. (defvar monky-branches-buffer-name "*monky-branches*")
  2312. (defvar monky-branch-re "^\\(.*[^\s]\\)\s* \\([0-9]+\\):\\([0-9a-z]\\{12\\}\\)\\(.*\\)$")
  2313. (defvar-local monky-current-branch-name nil)
  2314. (defun monky-present-branch-line (name rev node status)
  2315. (concat rev " : "
  2316. (propertize node 'face 'monky-log-sha1) " "
  2317. (if (equal name monky-current-branch-name)
  2318. (propertize name 'face 'monky-branch)
  2319. name)
  2320. " "
  2321. status))
  2322. (defun monky-wash-branch-line ()
  2323. (if (looking-at monky-branch-re)
  2324. (let ((name (match-string 1))
  2325. (rev (match-string 2))
  2326. (node (match-string 3))
  2327. (status (match-string 4)))
  2328. (monky-delete-line)
  2329. (monky-with-section name 'branch
  2330. (insert (monky-present-branch-line name rev node status))
  2331. (monky-set-section-info node)
  2332. (forward-line))
  2333. t)
  2334. nil))
  2335. (defun monky-wash-branches ()
  2336. (monky-wash-sequence #'monky-wash-branch-line))
  2337. (defun monky-refresh-branches-buffer ()
  2338. (setq monky-current-branch-name (monky-current-branch))
  2339. (monky-create-buffer-sections
  2340. (monky-with-section 'buffer nil
  2341. (monky-hg-section nil "Branches:"
  2342. #'monky-wash-branches
  2343. "branches"))))
  2344. (defun monky-current-branch ()
  2345. (monky-hg-string "branch"))
  2346. (defun monky-branches ()
  2347. (interactive)
  2348. (let ((topdir (monky-get-root-dir)))
  2349. (pop-to-buffer monky-branches-buffer-name)
  2350. (monky-mode-init topdir 'branches #'monky-refresh-branches-buffer)
  2351. (monky-branches-mode t)))
  2352. (defun monky-checkout-item ()
  2353. "Checkout the revision represented by current item."
  2354. (interactive)
  2355. (monky-section-action "checkout"
  2356. ((branch)
  2357. (monky-checkout (monky-section-info (monky-current-section))))
  2358. ((log commits commit)
  2359. (monky-checkout (monky-section-info (monky-current-section))))))
  2360. (defun monky-merge-item ()
  2361. "Merge the revision represented by current item."
  2362. (interactive)
  2363. (monky-section-action "merge"
  2364. ((branch)
  2365. (monky-merge (monky-section-info (monky-current-section))))
  2366. ((log commits commit)
  2367. (monky-merge (monky-section-info (monky-current-section))))))
  2368. ;;; Queue mode
  2369. (define-minor-mode monky-queue-mode
  2370. "Minor mode for hg Queue.
  2371. \\{monky-queue-mode-map}"
  2372. :group monky
  2373. :init-value ()
  2374. :lighter ()
  2375. :keymap monky-queue-mode-map)
  2376. (defvar monky-queue-buffer-name "*monky-queue*")
  2377. (defvar-local monky-patches-dir ".hg/patches/")
  2378. (defun monky-patch-series-file ()
  2379. (concat monky-patches-dir "series"))
  2380. (defun monky-insert-patch (patch inserter &rest args)
  2381. (let ((p (point))
  2382. (monky-hide-diffs nil))
  2383. (save-restriction
  2384. (narrow-to-region p p)
  2385. (apply inserter args)
  2386. (goto-char (point-max))
  2387. (if (not (eq (char-before) ?\n))
  2388. (insert "\n"))
  2389. (goto-char p)
  2390. (while (and (not (eobp)) (not (looking-at "^diff")))
  2391. (monky-delete-line t))
  2392. (when (looking-at "^diff")
  2393. (monky-wash-diffs))
  2394. (goto-char (point-max)))))
  2395. (defun monky-insert-guards (patch)
  2396. (let ((guards (remove-if
  2397. (lambda (guard) (string= "unguarded" guard))
  2398. (split-string
  2399. (cadr (split-string
  2400. (monky-hg-string "qguard" patch
  2401. "--config" "extensions.mq=")
  2402. ":"))))))
  2403. (dolist (guard guards)
  2404. (insert (propertize " " 'face 'monky-queue-patch)
  2405. (propertize guard
  2406. 'face
  2407. (if (monky-string-starts-with-p guard "+")
  2408. 'monky-queue-positive-guard
  2409. 'monky-queue-negative-guard))))
  2410. (insert (propertize "\n" 'face 'monky-queue-patch))))
  2411. (defun monky-wash-queue-patch ()
  2412. (monky-wash-queue-insert-patch #'insert-file-contents))
  2413. (defvar monky-queue-staged-all-files nil)
  2414. (defvar-local monky-queue-staged-files nil)
  2415. (defvar-local monky-queue-old-staged-files nil)
  2416. (defun monky-wash-queue-discarding ()
  2417. (monky-wash-status-lines
  2418. (lambda (status file)
  2419. (let ((monky-section-hidden-default monky-hide-diffs))
  2420. (if (or monky-queue-staged-all-files
  2421. (member file monky-old-staged-files)
  2422. (member file monky-queue-old-staged-files))
  2423. (monky-queue-stage-file file)
  2424. (monky-with-section file 'diff
  2425. (monky-insert-diff file status "qdiff"))))))
  2426. (setq monky-queue-staged-all-files nil))
  2427. (defun monky-wash-queue-insert-patch (inserter)
  2428. (if (looking-at "^\\([^\n]+\\)$")
  2429. (let ((patch (match-string 1)))
  2430. (monky-delete-line)
  2431. (let ((monky-section-hidden-default t))
  2432. (monky-with-section patch 'patch
  2433. (monky-set-section-info patch)
  2434. (insert
  2435. (propertize (format "\t%s" patch) 'face 'monky-queue-patch))
  2436. (monky-insert-guards patch)
  2437. (funcall #'monky-insert-patch
  2438. patch inserter (concat monky-patches-dir patch))
  2439. (forward-line)))
  2440. t)
  2441. nil))
  2442. (defun monky-wash-queue-queue ()
  2443. (if (looking-at "^\\([^()\n]+\\)\\(\\s-+([^)]*)\\)?$")
  2444. (let ((queue (match-string 1)))
  2445. (monky-delete-line)
  2446. (when (match-beginning 2)
  2447. (setq monky-patches-dir
  2448. (if (string= queue "patches")
  2449. ".hg/patches/"
  2450. (concat ".hg/patches-" queue "/")))
  2451. (put-text-property 0 (length queue) 'face 'monky-queue-active queue))
  2452. (monky-with-section queue 'queue
  2453. (monky-set-section-info queue)
  2454. (insert "\t" queue)
  2455. (forward-line))
  2456. t)
  2457. nil))
  2458. (defun monky-wash-queue-queues ()
  2459. (if (looking-at "^patches (.*)\n?\\'")
  2460. (progn
  2461. (monky-delete-line t)
  2462. nil)
  2463. (monky-wash-sequence #'monky-wash-queue-queue)))
  2464. (defun monky-wash-queue-patches ()
  2465. (monky-wash-sequence #'monky-wash-queue-patch))
  2466. ;;; Queues
  2467. (defun monky-insert-queue-queues ()
  2468. (monky-hg-section 'queues "Patch Queues:"
  2469. #'monky-wash-queue-queues
  2470. "qqueue" "--list" "extensions.mq="))
  2471. ;;; Applied Patches
  2472. (defun monky-insert-queue-applied ()
  2473. (monky-hg-section 'applied "Applied Patches:" #'monky-wash-queue-patches
  2474. "qapplied" "--config" "extensions.mq="))
  2475. ;;; UnApplied Patches
  2476. (defun monky-insert-queue-unapplied ()
  2477. (monky-hg-section 'unapplied "UnApplied Patches:" #'monky-wash-queue-patches
  2478. "qunapplied" "--config" "extensions.mq="))
  2479. ;;; Series
  2480. (defun monky-insert-queue-series ()
  2481. (monky-hg-section 'qseries "Series:" #'monky-wash-queue-patches
  2482. "qseries" "--config" "extensions.mq="))
  2483. ;;; Qdiff
  2484. (defun monky-insert-queue-discarding ()
  2485. (when (monky-qtip-p)
  2486. (setq monky-queue-old-staged-files (copy-list monky-queue-staged-files))
  2487. (setq monky-queue-staged-files '())
  2488. (let ((monky-hide-diffs t))
  2489. (monky-hg-section 'discarding "Discarding (qdiff):"
  2490. #'monky-wash-queue-discarding
  2491. "log" "--style" monky-hg-style-files-status
  2492. "--rev" "qtip"))))
  2493. (defun monky-insert-queue-staged-changes ()
  2494. (when (and (monky-qtip-p)
  2495. (or monky-queue-staged-files monky-staged-files))
  2496. (monky-with-section 'queue-staged nil
  2497. (insert (propertize "Staged changes (qdiff):"
  2498. 'face 'monky-section-title) "\n")
  2499. (let ((monky-section-hidden-default t))
  2500. (dolist (file (delete-dups (copy-list (append monky-queue-staged-files
  2501. monky-staged-files))))
  2502. (monky-with-section file 'diff
  2503. (monky-insert-diff file nil "qdiff")))))
  2504. (insert "\n")))
  2505. (defun monky-wash-active-guards ()
  2506. (if (looking-at "^no active guards")
  2507. (monky-delete-line t)
  2508. (monky-wash-sequence
  2509. (lambda ()
  2510. (let ((guard (buffer-substring (point) (point-at-eol))))
  2511. (monky-delete-line)
  2512. (insert " " (propertize guard 'face 'monky-queue-positive-guard))
  2513. (forward-line))))))
  2514. ;;; Active guards
  2515. (defun monky-insert-active-guards ()
  2516. (monky-hg-section 'active-guards "Active Guards:" #'monky-wash-active-guards
  2517. "qselect" "--config" "extensions.mq="))
  2518. ;;; Queue Staged Changes
  2519. (defun monky-queue-stage-file (file)
  2520. (push file monky-queue-staged-files))
  2521. (defun monky-queue-unstage-file (file)
  2522. (setq monky-queue-staged-files (delete file monky-queue-staged-files)))
  2523. (defun monky-refresh-queue-buffer ()
  2524. (monky-create-buffer-sections
  2525. (monky-with-section 'queue nil
  2526. (monky-insert-untracked-files)
  2527. (monky-insert-missing-files)
  2528. (monky-insert-changes)
  2529. (monky-insert-staged-changes)
  2530. (monky-insert-queue-discarding)
  2531. (monky-insert-queue-staged-changes)
  2532. (monky-insert-queue-queues)
  2533. (monky-insert-active-guards)
  2534. (monky-insert-queue-applied)
  2535. (monky-insert-queue-unapplied)
  2536. (monky-insert-queue-series))))
  2537. (defun monky-queue ()
  2538. (interactive)
  2539. (monky-with-process
  2540. (let ((topdir (monky-get-root-dir)))
  2541. (pop-to-buffer monky-queue-buffer-name)
  2542. (monky-mode-init topdir 'queue #'monky-refresh-queue-buffer)
  2543. (monky-queue-mode t))))
  2544. (defun monky-qqueue (queue)
  2545. (monky-run-hg "qqueue"
  2546. "--config" "extensions.mq="
  2547. queue))
  2548. (defun monky-qpop (&optional patch)
  2549. (interactive)
  2550. (apply #'monky-run-hg
  2551. "qpop"
  2552. "--config" "extensions.mq="
  2553. (if patch (list patch) '())))
  2554. (defun monky-qpush (&optional patch)
  2555. (interactive)
  2556. (apply #'monky-run-hg
  2557. "qpush"
  2558. "--config" "extensions.mq="
  2559. (if patch (list patch) '())))
  2560. (defun monky-qpush-all ()
  2561. (interactive)
  2562. (monky-run-hg "qpush" "--all"
  2563. "--config" "extensions.mq="))
  2564. (defun monky-qpop-all ()
  2565. (interactive)
  2566. (monky-run-hg "qpop" "--all"
  2567. "--config" "extensions.mq="))
  2568. (defvar monky-log-edit-buffer-name "*monky-edit-log*"
  2569. "Buffer name for composing commit messages.")
  2570. (defun monky-qrefresh ()
  2571. (interactive)
  2572. (if (not current-prefix-arg)
  2573. (apply #'monky-run-hg "qrefresh"
  2574. "--config" "extensions.mq="
  2575. (append monky-staged-files monky-queue-staged-files))
  2576. ;; get last commit message
  2577. (with-current-buffer (get-buffer-create monky-log-edit-buffer-name)
  2578. (monky-hg-insert
  2579. (list "log" "--config" "extensions.mq="
  2580. "--template" "{desc}" "-r" "-1")))
  2581. (monky-pop-to-log-edit 'qrefresh)))
  2582. (defun monky-qremove (patch)
  2583. (monky-run-hg "qremove" patch
  2584. "--config" "extensions.mq="))
  2585. (defun monky-qnew (patch)
  2586. (interactive (list (read-string "Patch Name : ")))
  2587. (if (not current-prefix-arg)
  2588. (monky-run-hg "qnew" patch
  2589. "--config" "extensions.mq=")
  2590. (monky-pop-to-log-edit 'qnew patch)))
  2591. (defun monky-qinit ()
  2592. (interactive)
  2593. (monky-run-hg "qinit"
  2594. "--config" "extensions.mq="))
  2595. (defun monky-qimport (node-1 &optional node-2)
  2596. (monky-run-hg "qimport" "--rev"
  2597. (if node-2 (concat node-1 ":" node-2) node-1)
  2598. "--config" "extensions.mq="))
  2599. (defun monky-qrename (old-patch &optional new-patch)
  2600. (let ((new-patch (or new-patch
  2601. (read-string "New Patch Name : "))))
  2602. (monky-run-hg "qrename" old-patch new-patch
  2603. "--config" "extensions.mq=")))
  2604. (defun monky-qfold (patch)
  2605. (monky-run-hg "qfold" patch
  2606. "--config" "extensions.mq="))
  2607. (defun monky-qguard (patch)
  2608. (let ((guards (monky-parse-args (read-string "Guards : "))))
  2609. (apply #'monky-run-hg "qguard" patch
  2610. "--config" "extensions.mq="
  2611. "--" guards)))
  2612. (defun monky-qselect ()
  2613. (interactive)
  2614. (let ((guards (monky-parse-args (read-string "Guards : "))))
  2615. (apply #'monky-run-hg "qselect"
  2616. "--config" "extensions.mq="
  2617. guards)))
  2618. (defun monky-qfinish (patch)
  2619. (monky-run-hg "qfinish" patch
  2620. "--config" "extensions.mq="))
  2621. (defun monky-qfinish-applied ()
  2622. (interactive)
  2623. (monky-run-hg "qfinish" "--applied"
  2624. "--config" "extensions.mq="))
  2625. (defun monky-qreorder ()
  2626. "Pop all patches and edit .hg/patches/series file to reorder them"
  2627. (interactive)
  2628. (let ((series (monky-patch-series-file)))
  2629. (monky-qpop-all)
  2630. (with-current-buffer (get-buffer-create monky-log-edit-buffer-name)
  2631. (erase-buffer)
  2632. (insert-file-contents series))
  2633. (monky-pop-to-log-edit 'qreorder)))
  2634. (defun monky-queue-stage-all ()
  2635. "Add all items in Changes to the staging area."
  2636. (interactive)
  2637. (monky-with-refresh
  2638. (setq monky-queue-staged-all-files t)
  2639. (monky-refresh-buffer)))
  2640. (defun monky-queue-unstage-all ()
  2641. "Remove all items from the staging area"
  2642. (interactive)
  2643. (monky-with-refresh
  2644. (setq monky-queue-staged-files '())
  2645. (monky-refresh-buffer)))
  2646. (defun monky-qimport-item ()
  2647. (interactive)
  2648. (monky-section-action "qimport"
  2649. ((log commits commit)
  2650. (if (region-active-p)
  2651. (monky-qimport
  2652. (monky-section-info (monky-section-at (monky-next-sha1 (region-beginning))))
  2653. (monky-section-info (monky-section-at
  2654. (monky-previous-sha1 (- (region-end) 1)))))
  2655. (monky-qimport (monky-section-info (monky-current-section)))))))
  2656. (defun monky-qpop-item ()
  2657. (interactive)
  2658. (monky-section-action "qpop"
  2659. ((applied patch)
  2660. (monky-qpop (monky-section-info (monky-current-section)))
  2661. (monky-qpop))
  2662. ((applied)
  2663. (monky-qpop-all))
  2664. ((staged diff)
  2665. (monky-unstage-file (monky-section-title (monky-current-section)))
  2666. (monky-queue-unstage-file (monky-section-title (monky-current-section)))
  2667. (monky-refresh-buffer))
  2668. ((staged)
  2669. (monky-unstage-all)
  2670. (monky-queue-unstage-all))
  2671. ((queue-staged diff)
  2672. (monky-unstage-file (monky-section-title (monky-current-section)))
  2673. (monky-queue-unstage-file (monky-section-title (monky-current-section)))
  2674. (monky-refresh-buffer))
  2675. ((queue-staged)
  2676. (monky-unstage-all)
  2677. (monky-queue-unstage-all))))
  2678. (defun monky-qpush-item ()
  2679. (interactive)
  2680. (monky-section-action "qpush"
  2681. ((unapplied patch)
  2682. (monky-qpush (monky-section-info (monky-current-section))))
  2683. ((unapplied)
  2684. (monky-qpush-all))
  2685. ((untracked file)
  2686. (monky-run-hg "add" (monky-section-info (monky-current-section))))
  2687. ((untracked)
  2688. (monky-run-hg "add"))
  2689. ((missing file)
  2690. (monky-run-hg "remove" "--after" (monky-section-info (monky-current-section))))
  2691. ((changes diff)
  2692. (monky-stage-file (monky-section-title (monky-current-section)))
  2693. (monky-queue-stage-file (monky-section-title (monky-current-section)))
  2694. (monky-refresh-buffer))
  2695. ((changes)
  2696. (monky-stage-all)
  2697. (monky-queue-stage-all))
  2698. ((discarding diff)
  2699. (monky-stage-file (monky-section-title (monky-current-section)))
  2700. (monky-queue-stage-file (monky-section-title (monky-current-section)))
  2701. (monky-refresh-buffer))
  2702. ((discarding)
  2703. (monky-stage-all)
  2704. (monky-queue-stage-all))))
  2705. (defun monky-qremove-item ()
  2706. (interactive)
  2707. (monky-section-action "qremove"
  2708. ((unapplied patch)
  2709. (monky-qremove (monky-section-info (monky-current-section))))))
  2710. (defun monky-qrename-item ()
  2711. (interactive)
  2712. (monky-section-action "qrename"
  2713. ((patch)
  2714. (monky-qrename (monky-section-info (monky-current-section))))))
  2715. (defun monky-qfold-item ()
  2716. (interactive)
  2717. (monky-section-action "qfold"
  2718. ((unapplied patch)
  2719. (monky-qfold (monky-section-info (monky-current-section))))))
  2720. (defun monky-qguard-item ()
  2721. (interactive)
  2722. (monky-section-action "qguard"
  2723. ((patch)
  2724. (monky-qguard (monky-section-info (monky-current-section))))))
  2725. (defun monky-qfinish-item ()
  2726. (interactive)
  2727. (monky-section-action "qfinish"
  2728. ((applied patch)
  2729. (monky-qfinish (monky-section-info (monky-current-section))))))
  2730. ;;; Log edit mode
  2731. (define-derived-mode monky-log-edit-mode text-mode "Monky Log Edit")
  2732. (defun monky-restore-pre-log-edit-window-configuration ()
  2733. (when monky-pre-log-edit-window-configuration
  2734. (set-window-configuration monky-pre-log-edit-window-configuration)
  2735. (setq monky-pre-log-edit-window-configuration nil)))
  2736. (defun monky-log-edit-commit ()
  2737. "Finish edit and commit."
  2738. (interactive)
  2739. (when (= (buffer-size) 0)
  2740. (user-error "No %s message" monky-log-edit-operation))
  2741. (let ((commit-buf (current-buffer)))
  2742. (case monky-log-edit-operation
  2743. ('commit
  2744. (with-current-buffer (monky-find-status-buffer default-directory)
  2745. (apply #'monky-run-async-with-input commit-buf
  2746. monky-hg-executable
  2747. (append monky-hg-standard-options
  2748. (list "commit" "--logfile" "-")
  2749. monky-staged-files))))
  2750. ('amend
  2751. (with-current-buffer (monky-find-status-buffer default-directory)
  2752. (apply #'monky-run-async-with-input commit-buf
  2753. monky-hg-executable
  2754. (append monky-hg-standard-options
  2755. (list "commit" "--amend" "--logfile" "-")
  2756. monky-staged-files))))
  2757. ('backout
  2758. (with-current-buffer monky-log-edit-client-buffer
  2759. (monky-run-async-with-input commit-buf
  2760. monky-hg-executable
  2761. "backout"
  2762. "--merge"
  2763. "--logfile" "-"
  2764. monky-log-edit-info)))
  2765. ('qnew
  2766. (with-current-buffer monky-log-edit-client-buffer
  2767. (monky-run-async-with-input commit-buf
  2768. monky-hg-executable
  2769. "qnew" monky-log-edit-info
  2770. "--config" "extensions.mq="
  2771. "--logfile" "-")))
  2772. ('qrefresh
  2773. (with-current-buffer monky-log-edit-client-buffer
  2774. (apply #'monky-run-async-with-input commit-buf
  2775. monky-hg-executable "qrefresh"
  2776. "--config" "extensions.mq="
  2777. "--logfile" "-"
  2778. (append monky-staged-files monky-queue-staged-files))))
  2779. ('qreorder
  2780. (let* ((queue-buffer (monky-find-buffer 'queue))
  2781. (series (with-current-buffer queue-buffer
  2782. (monky-patch-series-file))))
  2783. (with-current-buffer monky-log-edit-buffer-name
  2784. (write-region (point-min) (point-max) series))
  2785. (with-current-buffer queue-buffer
  2786. (monky-refresh))))))
  2787. (erase-buffer)
  2788. (bury-buffer)
  2789. (monky-restore-pre-log-edit-window-configuration))
  2790. (defun monky-log-edit-cancel-log-message ()
  2791. "Abort edits and erase commit message being composed."
  2792. (interactive)
  2793. (when (or (not monky-log-edit-confirm-cancellation)
  2794. (yes-or-no-p
  2795. "Really cancel editing the log (any changes will be lost)?"))
  2796. (erase-buffer)
  2797. (bury-buffer)
  2798. (monky-restore-pre-log-edit-window-configuration)))
  2799. (defun monky-pop-to-log-edit (operation &optional info)
  2800. (let ((dir default-directory)
  2801. (buf (get-buffer-create monky-log-edit-buffer-name)))
  2802. (setq monky-pre-log-edit-window-configuration
  2803. (current-window-configuration)
  2804. monky-log-edit-operation operation
  2805. monky-log-edit-client-buffer (current-buffer)
  2806. monky-log-edit-info info)
  2807. (pop-to-buffer buf)
  2808. (setq default-directory dir)
  2809. (monky-log-edit-mode)
  2810. (message "Type C-c C-c to %s (C-c C-k to cancel)." monky-log-edit-operation)))
  2811. (defun monky-log-edit ()
  2812. "Bring up a buffer to allow editing of commit messages."
  2813. (interactive)
  2814. (when (not (or monky-staged-files (monky-merge-p)))
  2815. (if (y-or-n-p "Nothing staged. Stage and commit all changes? ")
  2816. (monky-stage-all)
  2817. (user-error "Nothing staged")))
  2818. (monky-pop-to-log-edit 'commit))
  2819. (defun monky-commit-amend ()
  2820. "Amends previous commit.
  2821. Brings up a buffer to allow editing of commit message."
  2822. (interactive)
  2823. ;; get last commit message
  2824. (with-current-buffer (get-buffer-create monky-log-edit-buffer-name)
  2825. (monky-hg-insert
  2826. (list "log"
  2827. "--template" "{desc}" "-r" ".")))
  2828. (monky-pop-to-log-edit 'amend))
  2829. (defun monky-bookmark-create (bookmark-name)
  2830. "Create a bookmark at the current location"
  2831. (interactive "sBookmark name: ")
  2832. (monky-run-hg-async "bookmark" bookmark-name))
  2833. (defun monky-killall-monky-buffers ()
  2834. (interactive)
  2835. (cl-flet ((monky-buffer-p (b) (string-match "\*monky\\(:\\|-\\).*" (buffer-name b))))
  2836. (let ((monky-buffers (cl-remove-if-not #'monky-buffer-p (buffer-list))))
  2837. (cl-loop for mb in monky-buffers
  2838. do
  2839. (kill-buffer mb)))))
  2840. (provide 'monky)
  2841. ;; Local Variables:
  2842. ;; byte-compile-warnings: (not cl-functions)
  2843. ;; End:
  2844. ;;; monky.el ends here