/dvc/mode/lisp/dvc-core.el
Lisp | 1205 lines | 952 code | 149 blank | 104 comment | 41 complexity | 2121e17d30cf9c07615a6c314efca73a MD5 | raw file
1;;; dvc-core.el --- Core functions for distributed version control 2 3;; Copyright (C) 2005-2009 by all contributors 4 5;; Author: Stefan Reichoer, <stefan@xsteve.at> 6;; Contributions From: 7;; Matthieu Moy <Matthieu.Moy@imag.fr> 8 9;; This file is free software; you can redistribute it and/or modify 10;; it under the terms of the GNU General Public License as published by 11;; the Free Software Foundation; either version 3, or (at your option) 12;; any later version. 13 14;; This file is distributed in the hope that it will be useful, 15;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17;; GNU General Public License for more details. 18 19;; You should have received a copy of the GNU General Public License 20;; along with GNU Emacs; see the file COPYING. If not, write to 21;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 22;; Boston, MA 02110-1301, USA. 23 24;;; Commentary: 25 26;; This file provides the low-level functions used by the DVC interfaces 27;; to distributed revison control systems. 28 29 30;;; History: 31 32;; This file holds general useful functions, previously only used for tla. 33 34;;; Code: 35 36(require 'dvc-defs) 37(require 'dvc-register) 38(eval-and-compile (require 'dvc-utils)) 39(require 'dvc-buffers) 40(eval-when-compile (require 'cl)) 41(eval-when-compile (require 'dired)) 42(eval-and-compile (require 'dvc-lisp)) 43 44(defvar dvc-sh-executable "sh" "The shell that is used for dvc interaction.") 45 46;; -------------------------------------------------------------------------------- 47;; Various constants 48;; -------------------------------------------------------------------------------- 49 50(defconst dvc-mark (dvc-face-add "*" 'dvc-mark) "Fontified string used for marking.") 51(defconst dvc-exclude (dvc-face-add "E" 'dvc-mark) "Fontified string used for excluded files.") 52 53;; -------------------------------------------------------------------------------- 54;; Internal variables 55;; -------------------------------------------------------------------------------- 56 57(defvar dvc-memorized-log-header nil) 58(defvar dvc-memorized-log-message nil) 59(defvar dvc-memorized-version nil) 60(defvar dvc-memorized-patch-sender nil) 61 62;; -------------------------------------------------------------------------------- 63;; Various helper functions 64;; -------------------------------------------------------------------------------- 65 66;; list-buffers-directory is used by uniquify to get the directory for 67;; the buffer when buffer-file-name is nil, as it is for many dvc 68;; buffers (dvc-diff-mode, etc). It needs to survive 69;; kill-all-local-variables, so we declare it permanent local. 70(make-variable-buffer-local 'list-buffers-directory) 71(put 'list-buffers-directory 'permanent-local t) 72 73(defun dvc-find-tree-root-file-first (file-or-dir &optional location) 74 "Find FILE-OR-DIR upward in the file system from LOCATION. 75Finding is continued upward to \"/\" until FILE-OR-DIR can be found. 76Once FILE-OR-DIR is found, the finding is broken off. 77A directory which holds FILE-OR-DIR is returned. If no such directory 78`nil' is returned. `default-directory' is used instead if LOCATION is not 79given, 80 81The resulting directory is guaranteed to end in a \"/\" character. 82 83This function may be useful to find \{arch\} and/or _darcs directories." 84 (let ((pwd (or location default-directory)) 85 (pwd-stack nil) 86 new-pwd) 87 (while (not (or (string= pwd "/") 88 (member pwd pwd-stack) 89 (file-exists-p (concat (file-name-as-directory pwd) 90 file-or-dir)))) 91 (setq pwd-stack (cons pwd pwd-stack)) 92 (setq new-pwd 93 (dvc-expand-file-name (concat (file-name-as-directory pwd) ".."))) 94 95 ;; detect MS-Windows roots (c:/, d:/, ...) 96 (setq pwd (if (string= new-pwd pwd) "/" new-pwd))) 97 98 (unless (string= pwd "/") 99 (setq pwd (replace-regexp-in-string "\\([^:]\\)/*$" "\\1" pwd)) 100 (setq pwd (file-name-as-directory pwd)) 101 (if (memq system-type '(ms-dos windows-nt)) 102 (expand-file-name pwd) 103 pwd)))) 104 105(defun dvc-tree-root-helper (file-or-dir interactivep msg 106 &optional location no-error) 107 "Find FILE-OR-DIR upward in the file system from LOCATION. 108 109Calls `dvc-find-tree-root-file-first', shows a message when 110called interactively, and manages no-error. 111 112If LOCATION is nil, the tree root is returned, and it is 113guaranteed to end in a \"/\" character. 114 115MSG must be of the form \"%S is not a ...-managed tree\"." 116 (let ((location (dvc-uniquify-file-name location))) 117 (let ((pwd (dvc-find-tree-root-file-first 118 file-or-dir location))) 119 (when (and interactivep pwd) 120 (dvc-trace "%s" pwd)) 121 (or pwd 122 (if no-error 123 nil 124 (error msg 125 (or location default-directory))))))) 126 127(defun dvc-find-tree-root-file-last (file-or-dir &optional location) 128 "Like `dvc-find-tree-root-file-upward' but recursively if FILE-OR-DIR is found. 129Finding is started from LOCATION but is stoped when FILE-OR-DIR cannot be found. 130Fiddled is continued upward while FILE-OR-DIR can be found. 131The last found directory which holds FILE-OR-DIR is returned. `nil' is returned 132if finding failed. 133`default-directory' is used instead if LOCATION is not given, 134 135This function may be useful to find CVS or .svn directories" 136 (let ((pwd (or location default-directory)) 137 old-pwd) 138 (while (and pwd (not (string= pwd "/"))) 139 (if (file-exists-p (concat (file-name-as-directory pwd) 140 file-or-dir)) 141 (setq old-pwd pwd 142 pwd (expand-file-name (concat (file-name-as-directory pwd) 143 ".."))) 144 (setq pwd nil))) 145 (when old-pwd 146 (expand-file-name 147 (replace-regexp-in-string "/+$" "/" old-pwd))))) 148 149(defmacro dvc-make-bymouse-function (function) 150 "Create a new function by adding mouse interface to FUNCTION. 151The new function is named FUNCTION-by-mouse; and takes one argument, 152a mouse click event. 153Thew new function moves the point to the place where mouse is clicked 154then invoke FUNCTION." 155 (declare (debug (&define name :name -by-mouse))) 156 `(defun ,(intern (concat (symbol-name function) "-by-mouse")) (event) 157 ,(concat "`" (symbol-name function) "'" " with mouse interface.") 158 (interactive "e") 159 (mouse-set-point event) 160 (,function))) 161 162;; Adapted from `dired-delete-file' in Emacs 22 163(defun dvc-delete-recursively (file) 164 "Delete FILE or directory recursively." 165 (let (files) 166 (if (not (eq t (car (file-attributes file)))) 167 (delete-file file) 168 (when (setq files 169 (directory-files 170 file t "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")) 171 (while files 172 (dvc-delete-recursively (car files)) 173 (setq files (cdr files)))) 174 (delete-directory file)))) 175 176;; -------------------------------------------------------------------------------- 177;; File selection helpers 178;; -------------------------------------------------------------------------------- 179 180(defvar dvc-get-file-info-at-point-function nil 181 "Function used to get the file at point, anywhere.") 182 183(defun dvc-get-file-info-at-point () 184 "Gets the filename at point, according to mode. 185Calls the function `dvc-get-file-info-at-point-function' if defined. 186When in dired mode, return the file where point is. 187Otherwise return the buffer file name." 188 (cond (dvc-get-file-info-at-point-function 189 (funcall dvc-get-file-info-at-point-function)) 190 ((eq major-mode 'dired-mode) 191 (dired-get-filename)) 192 (t (buffer-file-name)))) 193 194;;;###autoload 195(defun dvc-current-file-list (&optional selection-mode) 196 "Return a list of currently active files. 197When in dired mode, return the marked files or the file under point. 198In a legacy DVC mode, return `dvc-buffer-marked-file-list' if non-nil. 199In a fileinfo DVC mode, return `dvc-fileinfo-marked-files'. 200otherwise the result depends on SELECTION-MODE: 201* When 'nil-if-none-marked, return nil. 202* When 'all-if-none-marked, return all files. 203* Otherwise return result of calling `dvc-get-file-info-at-point'." 204 (cond 205 ((eq major-mode 'dired-mode) 206 (dired-get-marked-files)) 207 208 ((dvc-derived-mode-p 'dvc-diff-mode 'dvc-status-mode) 209 (or (remove nil dvc-buffer-marked-file-list) 210 (dvc-fileinfo-marked-files) 211 (cond 212 ((eq selection-mode 'nil-if-none-marked) 213 nil) 214 215 ((eq selection-mode 'all-if-none-marked) 216 (dvc-fileinfo-all-files)) 217 218 (t (list (dvc-get-file-info-at-point)))))) 219 220 ((eq major-mode 'dvc-bookmark-mode) 221 (cond 222 ((eq selection-mode 'nil-if-none-marked) 223 nil) 224 225 (t 226 (error "selection-mode %s not implemented for dvc bookmark buffer" selection-mode)))) 227 228 ;; If other modes are added here, dvc-log-edit must be updated to 229 ;; support them as well. 230 231 (t 232 ;; Some other mode. We assume it has no notion of "marked files", 233 ;; so there are none marked. The only file name available is 234 ;; buffer-file-name, so we could just return that. But some DVC 235 ;; mode might set dvc-get-file-info-at-point-function without 236 ;; updating this function, so support that. 237 (if (eq selection-mode 'nil-if-none-marked) 238 nil 239 (list (dvc-get-file-info-at-point)))))) 240 241(defun dvc-confirm-read-file-name (prompt &optional mustmatch file-name default-filename) 242 "A wrapper around `read-file-name' that provides some useful defaults." 243 (unless file-name 244 (setq file-name (dvc-get-file-info-at-point))) 245 (read-file-name prompt 246 (file-name-directory (or file-name "")) 247 default-filename 248 mustmatch 249 (file-name-nondirectory (or file-name "")))) 250 251(defun dvc-confirm-read-file-name-list (prompt &optional files single-prompt mustmatch) 252 (or 253 (if dvc-test-mode files) 254 (let ((num-files (length files))) 255 (if (= num-files 1) 256 (let ((confirmed-file-name 257 (dvc-confirm-read-file-name single-prompt mustmatch (car files)))) 258 ;; I don't think `dvc-confirm-read-file-name' can return nil. 259 (assert confirmed-file-name) 260 (list confirmed-file-name)) 261 (and (y-or-n-p (format prompt num-files)) 262 files))))) 263 264(defcustom dvc-confirm-file-op-method 'y-or-n-p 265 "Function to use for confirming file-based DVC operations. 266Some valid options are: 267y-or-n-p: Prompt for 'y' or 'n' keystroke. 268yes-or-no-p: Prompt for \"yes\" or \"no\" string. 269dvc-always-true: Do not display a prompt." 270 :type 'function 271 :group 'dvc) 272 273(defun dvc-always-true (&rest ignore) 274 "Do nothing and return t. 275This function accepts any number of arguments, but ignores them." 276 (interactive) 277 t) 278 279(defun dvc-confirm-file-op (operation files confirm) 280 "Confirm OPERATION (a string, used in prompt) on FILE (list of strings). 281If CONFIRM is nil, just return FILES (no prompt). 282Returns FILES, or nil if not confirmed. 283 284If you want to adjust the function called to confirm the 285operation, then customize the `dvc-confirm-file-op-method' function." 286 (or 287 ;; Allow bypassing confirmation with `dvc-test-mode'. See 288 ;; tests/xmtn-tests.el dvc-status-add. 289 (if dvc-test-mode files) 290 ;; Abstracted from pcvs.el cvs-do-removal 291 (if (not confirm) 292 files 293 (let ((nfiles (length files))) 294 (if (funcall (or (and (functionp dvc-confirm-file-op-method) 295 dvc-confirm-file-op-method) 296 'y-or-n-p) 297 (if (= 1 nfiles) 298 (format "%s file: \"%s\" ? " 299 operation 300 (car files)) 301 (format "%s %d files? " 302 operation 303 nfiles))) 304 files 305 nil))))) 306 307(defun dvc-dvc-files-to-commit () 308 ;;todo: set the correct modifier, one of dvc-modified, dvc-added, dvc-move, now use only nil 309 ;; FIXME: this is only used by dvc-log-insert-commit-file-list; should just merge this code there. 310 (let ((files 311 (with-current-buffer dvc-partner-buffer (dvc-current-file-list 'all-if-none-marked)))) 312 (mapcar (lambda (arg) (cons nil arg)) files))) 313 314(defun dvc-find-file-at-point () 315 "Opens the file at point. 316The filename is obtained with `dvc-get-file-info-at-point'." 317 (interactive) 318 (let* ((file (dvc-get-file-info-at-point))) 319 (cond 320 ((not file) 321 (error "No file at point")) 322 (t 323 (find-file file))))) 324 325(dvc-make-bymouse-function dvc-find-file-at-point) 326 327(defun dvc-find-file-other-window () 328 "Visit the current file in the other window. 329The filename is obtained with `dvc-get-file-info-at-point'." 330 (interactive) 331 (let ((file (dvc-get-file-info-at-point))) 332 (if file 333 (progn 334 (find-file-other-window file)) 335 (error "No file at point")))) 336 337(defun dvc-view-file () 338 "Visit the current file in `view-mode'. 339The filename is obtained with `dvc-get-file-info-at-point'." 340 (interactive) 341 (let ((file (dvc-get-file-info-at-point))) 342 (if file 343 (view-file-other-window file) 344 (error "No file at point")))) 345 346(defun dvc-dired-jump () 347 "Jump to a dired buffer, containing the file at point." 348 (interactive) 349 (let ((file-full-path (expand-file-name (or (dvc-get-file-info-at-point) "")))) 350 (let ((default-directory (file-name-directory file-full-path))) 351 (dvc-funcall-if-exists dired-jump)) 352 (dired-goto-file file-full-path))) 353 354(defun dvc-purge-files (&rest files) 355 "Delete FILES from the harddisk. No backup is created for these FILES. 356These function bypasses the used revision control system." 357 (interactive (dvc-current-file-list)) 358 (let ((multiprompt (format "Are you sure to purge %%d files? ")) 359 (singleprompt (format "Purge file: "))) 360 (when (dvc-confirm-read-file-name-list multiprompt files singleprompt nil) 361 (mapcar #'delete-file files) 362 (message "Purged %S" files)))) 363 364(defun dvc-current-executable () 365 "Return the name of the binary associated with the current dvc backend. 366This uses `dvc-current-active-dvc'. 367 368\"DVC\" is returned if `dvc-current-active-dvc' returns nil." 369 (let ((dvc (dvc-current-active-dvc))) 370 (if (not dvc) 371 "DVC" 372 (dvc-variable dvc "executable")))) 373 374;; partner buffer stuff 375(defvar dvc-partner-buffer nil 376 "DVC Partner buffer; stores diff buffer for log-edit, etc. 377Local to each buffer, not killed by kill-all-local-variables.") 378(make-variable-buffer-local 'dvc-partner-buffer) 379(put 'dvc-partner-buffer 'permanent-local t) 380 381(defun dvc-buffer-pop-to-partner-buffer () 382 "Pop to dvc-partner-buffer, if available." 383 (interactive) 384 (if (and (boundp 'dvc-partner-buffer) dvc-partner-buffer) 385 (if (buffer-live-p dvc-partner-buffer) 386 (pop-to-buffer dvc-partner-buffer) 387 (message "Partner buffer has been killed")) 388 (message "No partner buffer set for this buffer."))) 389 390 391(defmacro dvc-with-keywords (keywords plist &rest body) 392 "Execute a body of code with keywords bound. 393Each keyword listed in KEYWORDS is bound to its value from PLIST, then 394BODY is evaluated." 395 (declare (indent 1) (debug (sexp form body))) 396 (flet ((keyword-to-symbol (keyword) 397 (intern (substring (symbol-name keyword) 1)))) 398 (let ((keyword (make-symbol "keyword")) 399 (default (make-symbol "default"))) 400 `(let ,(mapcar (lambda (keyword-entry) 401 (keyword-to-symbol (if (consp keyword-entry) 402 (car keyword-entry) 403 keyword-entry))) 404 keywords) 405 (dolist (keyword-entry ',keywords) 406 (let ((,keyword (if (consp keyword-entry) 407 (car keyword-entry) 408 keyword-entry)) 409 (,default (if (consp keyword-entry) 410 (cadr keyword-entry) 411 nil))) 412 (set (intern (substring (symbol-name ,keyword) 1)) 413 (or (cadr (member ,keyword ,plist)) 414 ,default)))) 415 ,@body)))) 416 417 418;; ---------------------------------------------------------------------------- 419;; Process management 420;; ---------------------------------------------------------------------------- 421 422;; Candidates for process handlers 423(defun dvc-default-error-function (output error status arguments) 424 "Default function called when a DVC process ends with a non-zero status. 425OUTPUT is the buffer containing process standard output. 426ERROR is the buffer containing process error output. 427STATUS indicates the return status of the program. 428ARGUMENTS is a list of the arguments that the process was called with." 429 (if (> (with-current-buffer error (point-max)) 1) 430 (dvc-show-error-buffer error) 431 (if (> (with-current-buffer output (point-max)) 1) 432 (dvc-show-error-buffer output) 433 (error "`%s %s' failed with code %d and no output!" 434 (dvc-current-executable) 435 (mapconcat 'identity arguments " ") 436 status))) 437 (error "`%s %s' failed with code %d" 438 (dvc-current-executable) 439 (mapconcat 'identity arguments " ") 440 status)) 441 442(defvar dvc-default-killed-function-noerror 0 443 "The number of killed processes we will ignore until throwing an error. 444If the value is 0, `dvc-default-killed-function' will throw an error. 445See `dvc-default-killed-function'.") 446 447(defun dvc-default-killed-function (output error status arguments) 448 "Default function called when a DVC process is killed. 449OUTPUT is the buffer containing process standard output. 450ERROR is the buffer containing process error output. 451STATUS indicates the return status of the program. 452ARGUMENTS is a list of the arguments that the process was called with." 453 (if (> dvc-default-killed-function-noerror 0) 454 (setq dvc-default-killed-function-noerror 455 (- dvc-default-killed-function-noerror 1)) 456 (dvc-switch-to-buffer error) 457 (error "`%s %s' process killed !" 458 (dvc-current-executable) 459 (mapconcat 'identity arguments " ")))) 460 461(defun dvc-null-handler (output error status arguments) 462 "Handle a finished process without doing anything. 463Candidate as an argument for one of the keywords :finished, :error or :killed 464in `dvc-run-dvc-sync' or `dvc-run-dvc-async'. 465OUTPUT is the buffer containing process standard output. 466ERROR is the buffer containing process error output. 467STATUS indicates the return status of the program. 468ARGUMENTS is a list of the arguments that the process was called with." 469 nil) 470 471(defun dvc-status-handler (output error status arguments) 472 "Return an integer value that reflects the process status. 473Candidate as an argument for one of the keywords :finished, :error or :killed 474in `dvc-run-dvc-sync' or `dvc-run-dvc-async'. 475OUTPUT is the buffer containing process standard output. 476ERROR is the buffer containing process error output. 477STATUS indicates the return status of the program. 478ARGUMENTS is a list of the arguments that the process was called with." 479 (cond ((numberp status) status) 480 ((string-match "^exited abnormally with code \\(.*\\)" status) 481 (string-to-number (match-string 1))) 482 (t (error status)))) 483 484(defun dvc-output-buffer-handler (output error status arguments) 485 "Return the output of a finished process, stripping any trailing newline. 486OUTPUT is the buffer containing process standard output. 487ERROR is the buffer containing process error output. 488STATUS indicates the return status of the program. 489ARGUMENTS is a list of the arguments that the process was called with." 490 (dvc-buffer-content output)) 491 492(defun dvc-output-buffer-handler-withnewline (output error status arguments) 493 "Same as dvc-output-buffer-handler, but keep potential final newline." 494 (with-current-buffer output (buffer-string))) 495 496(defun dvc-output-and-error-buffer-handler (output error status arguments) 497 "Return the output of a finished process, stripping any trailing newline. 498OUTPUT is the buffer containing process standard output. 499ERROR is the buffer containing process error output. 500STATUS indicates the return status of the program. 501ARGUMENTS is a list of the arguments that the process was called with." 502 (concat (dvc-buffer-content output) 503 (dvc-buffer-content error))) 504 505(defun dvc-output-buffer-split-handler (output error status arguments) 506 "Return the output of a finished process as a list of lines. 507OUTPUT is the buffer containing process standard output. 508ERROR is the buffer containing process error output. 509STATUS indicates the return status of the program. 510ARGUMENTS is a list of the arguments that the process was called with." 511 (split-string (dvc-buffer-content output) "\n")) 512 513(defun dvc-default-finish-function (output error status arguments) 514 "Default function called when a DVC process terminates. 515OUTPUT is the buffer containing process standard output. 516ERROR is the buffer containing process error output. 517STATUS indicates the return status of the program. 518ARGUMENTS is a list of the arguments that the process was called with." 519 (let ((has-output)) 520 (with-current-buffer output 521 (dvc-process-buffer-mode) 522 (setq has-output (> (point-max) 1))) 523 (when has-output 524 (dvc-switch-to-buffer output)) 525 (when (or dvc-debug has-output) 526 (message "Process `%s %s' finished" 527 (dvc-current-executable) 528 (mapconcat 'identity arguments " "))) 529 status)) 530 531(defun dvc-finish-function-without-buffer-switch (output error status arguments) 532 "Similar to `dvc-default-finish-function' but no buffer switch. 533OUTPUT is the buffer containing process standard output. 534ERROR is the buffer containing process error output. 535STATUS indicates the return status of the program. 536ARGUMENTS is a list of the arguments that the process was called 537 with." 538 (with-current-buffer output 539 (dvc-trace "Process `%s %s' finished" 540 (dvc-current-executable) 541 (mapconcat 'identity arguments " ")) 542 status)) 543 544(defvar dvc-process-running nil 545 "List of DVC processes running. 546A value of nil indicates no processes are running. 547 548The list is a list of pairs (process event) where EVENT is the event 549corresponding to the beginning of the execution of process. It can be 550used to get more info about the process.") 551 552(defun dvc-build-dvc-command (dvc list-args) 553 "Build a shell command to run DVC with args LIST-ARGS. 554DVC can be one of 'baz, 'xhg, ..." 555 (let ((executable (executable-find (dvc-variable dvc "executable")))) 556 ;; 'executable-find' allows leading ~ 557 (if (not executable) 558 (error "executable for %s not found" (symbol-name dvc))) 559 (mapconcat 'shell-quote-argument 560 (cons executable 561 (remq nil list-args)) 562 " "))) 563 564(defcustom dvc-password-prompt-regexp 565 "[Pp]ass\\(word\\|phrase\\).*:\\s *\\'" 566 "*Regexp matching prompts for passwords in the inferior process." 567 :type 'regexp 568 :group 'dvc) 569 570(defun dvc-process-filter (proc string &optional no-insert) 571 "Filter PROC's STRING. 572Prompt for password with `read-passwd' if the output of PROC matches 573`dvc-password-prompt-regexp'. 574 575If NO-INSERT is non-nil, do not insert the string. 576 577In all cases, a new string is returned after normalizing newlines." 578 (with-current-buffer (process-buffer proc) 579 (setq string (replace-regexp-in-string "\015" "\n" string)) 580 (unless no-insert 581 (goto-char (process-mark proc)) 582 (insert string) 583 (set-marker (process-mark proc) (point))) 584 (when (string-match dvc-password-prompt-regexp string) 585 (string-match "^\\([^\n]+\\)\n*\\'" string) 586 (let ((passwd (read-passwd (match-string 1 string)))) 587 (process-send-string proc (concat passwd "\n")))) 588 string)) 589 590(defun dvc-prepare-environment (env) 591 "By default, do not touch the environment" 592 env) 593 594(defun dvc-default-global-argument () 595 "By default, no global argument." 596 nil) 597 598(defun dvc-run-dvc-async (dvc arguments &rest keys) 599 "Run a process asynchronously. 600Current directory for the process is the current `default-directory'. 601ARGUMENTS is a list of arguments. nil values in this list are removed. 602KEYS is a list of keywords and values. Possible keywords are: 603 604 :finished ....... Function run when the process finishes. If none 605 specified, `dvc-default-finish-function' is run. 606 607 :killed ......... Function run when the process is killed. If none 608 specified, `dvc-default-killed-function' is run. 609 610 :error .......... Function run when the process exits with a non 0 611 status. If none specified, 612 `dvc-default-error-function' is run. 613 614All these functions take 4 arguments : output, error, status, and 615arguments. 616 617 - \"output\" is the output buffer 618 - \"error\" is the buffer where standard error is redirected 619 - \"status\" is the numeric exit-status or the signal number 620 - \"arguments\" is the list of arguments, as a list of strings, 621 like '(\"changes\" \"--diffs\") 622 623 `dvc-null-handler' can be used here if there's nothing to do. 624 625 :filter Function to call every time we receive output from 626 the process. It should take arguments proc and string. 627 The string will have been run through 628 `dvc-process-filter' to deal with password prompts and 629 newlines. 630 631 :output-buffer .. Buffer where the output of the process should be 632 redirected. If none specified, a new one is 633 created, and will be entered in 634 `dvc-dead-process-buffer-queue' to be killed 635 later. 636 637 :error-buffer ... Buffer where the standard error of the process 638 should be redirected. 639 640 :related-buffer . Defaults to `current-buffer'. This is the buffer 641 where the result of the process will be used. If 642 this buffer is killed before the end of the 643 execution, the user is prompted if he wants to kill 644 the process." 645 (dvc-with-keywords 646 (:finished :killed :error :filter 647 :output-buffer :error-buffer :related-buffer) 648 keys 649 (let* ((output-buf (or (and output-buffer 650 (get-buffer-create output-buffer)) 651 (dvc-new-process-buffer nil dvc))) 652 (error-buf (or (and error-buffer (get-buffer-create error-buffer)) 653 (dvc-new-error-buffer nil dvc))) 654 (error-file (dvc-make-temp-name "dvc-errors")) 655 (global-arg (funcall (dvc-function dvc "default-global-argument"))) 656 (command (dvc-build-dvc-command 657 dvc (append global-arg arguments))) 658 ;; Make the `default-directory' unique. The trailing slash 659 ;; may be necessary in some cases. 660 (default-directory (dvc-uniquify-file-name default-directory)) 661 (process 662 (let ((process-environment 663 (funcall (dvc-function dvc "prepare-environment") 664 process-environment))) 665 (with-current-buffer output-buf 666 ;; process filter will need to know which dvc to run 667 ;; if there is a choice 668 (setq dvc-buffer-current-active-dvc dvc)) 669 670 ;; `start-process' sends both stderr and stdout to 671 ;; `output-buf'. But we want to keep stderr separate. So 672 ;; we use a shell to redirect stderr before Emacs sees 673 ;; it. Note that this means we require "sh" even on 674 ;; MS Windows. 675 (start-process 676 (dvc-variable dvc "executable") output-buf 677 dvc-sh-executable "-c" 678 (format "%s 2> %s" 679 command error-file)))) 680 (process-event 681 (list process 682 (dvc-log-event output-buf 683 error-buf 684 command 685 default-directory "started")))) 686 (with-current-buffer (or related-buffer (current-buffer)) 687 (dvc-trace "Running process `%s' in `%s'" command default-directory) 688 (add-to-list 'dvc-process-running process-event) 689 (set-process-filter 690 process 691 (if (not filter) 692 'dvc-process-filter 693 (dvc-capturing-lambda (proc string) 694 (funcall (capture filter) 695 proc 696 (dvc-process-filter proc string t))))) 697 (set-process-sentinel 698 process 699 (dvc-capturing-lambda (process event) 700 (let ((default-directory (capture default-directory))) 701 (dvc-log-event (capture output-buf) (capture error-buf) 702 (capture command) 703 (capture default-directory) 704 (dvc-strip-final-newline event)) 705 (setq dvc-process-running 706 (delq (capture process-event) dvc-process-running)) 707 (when (file-exists-p (capture error-file)) 708 (with-current-buffer (capture error-buf) 709 (insert-file-contents (capture error-file))) 710 (delete-file (capture error-file))) 711 (let ((state (process-status process)) 712 (status (process-exit-status process)) 713 (dvc-temp-current-active-dvc (capture dvc))) 714 (unwind-protect 715 (cond ((and (eq state 'exit) (= status 0)) 716 (funcall (or (capture finished) 717 'dvc-default-finish-function) 718 (capture output-buf) (capture error-buf) 719 status (capture arguments))) 720 ((eq state 'signal) 721 (funcall (or (capture killed) 722 'dvc-default-killed-function) 723 (capture output-buf) (capture error-buf) 724 status (capture arguments))) 725 ((eq state 'exit) ;; status != 0 726 (funcall (or (capture error) 727 'dvc-default-error-function) 728 (capture output-buf) (capture error-buf) 729 status (capture arguments))))) 730 ;; Schedule any buffers we created for killing 731 (unless (capture output-buffer) 732 (dvc-kill-process-buffer (capture output-buf))) 733 (unless (capture error-buffer) 734 (dvc-kill-process-buffer (capture error-buf))))))) 735 process)))) 736 737(defun dvc-run-dvc-sync (dvc arguments &rest keys) 738 "Run DVC synchronously. 739See `dvc-run-dvc-async' for details on possible ARGUMENTS and KEYS." 740 (dvc-with-keywords 741 (:finished :killed :error :output-buffer :error-buffer :related-buffer) 742 keys 743 (let* ((output-buf (or (and output-buffer 744 (get-buffer-create output-buffer)) 745 (dvc-new-process-buffer t dvc))) 746 (error-buf (or (and error-buffer (get-buffer-create error-buffer)) 747 (dvc-new-error-buffer t dvc))) 748 (global-arg (funcall (dvc-function dvc "default-global-argument"))) 749 (command (dvc-build-dvc-command 750 dvc (append global-arg arguments))) 751 (arguments (remq nil arguments)) 752 (error-file (dvc-make-temp-name "arch-errors")) 753 ;; Make the `default-directory' unique. The trailing slash 754 ;; may be necessary in some cases. 755 (default-directory (dvc-uniquify-file-name default-directory))) 756 (with-current-buffer (or related-buffer (current-buffer)) 757 (dvc-log-event output-buf error-buf command default-directory 758 "started") 759 (let ((status (let ((process-environment 760 (funcall (dvc-function dvc "prepare-environment") 761 process-environment))) 762 (call-process dvc-sh-executable nil output-buf nil "-c" 763 (format "%s 2> %s" 764 command 765 error-file))))) 766 (when (file-exists-p error-file) 767 (with-current-buffer error-buf 768 (insert-file-contents error-file)) 769 (delete-file error-file)) 770 (unwind-protect 771 (let ((dvc-temp-current-active-dvc dvc)) 772 (cond ((stringp status) 773 (when (string= status "Terminated") 774 (funcall (or killed 'dvc-default-killed-function) 775 output-buf error-buf status arguments))) 776 ((numberp status) 777 (if (zerop status) 778 (funcall (or finished 'dvc-default-finish-function) 779 output-buf error-buf status arguments) 780 (funcall (or error 'dvc-default-error-function) 781 output-buf error-buf status arguments))) 782 (t (message "Unknown status - %s" status)))) 783 ;; Schedule any buffers we created for killing 784 (unless output-buffer (dvc-kill-process-buffer output-buf)) 785 (unless error-buffer (dvc-kill-process-buffer error-buf)))))))) 786 787(defun dvc-processes-related-to-buffer (buffer) 788 "Returns a list of DVC process whose related buffer is BUFFER." 789 (let ((accu nil)) 790 (dolist (entry dvc-process-running) 791 (when (eq (dvc-event-related-buffer (cadr entry)) buffer) 792 (push (car entry) accu))) 793 (setq accu (nreverse accu)) 794 accu)) 795 796(defun dvc-kill-process-maybe (buffer) 797 "Prompts and possibly kill process whose related buffer is BUFFER." 798 ;; FIXME: It would be reasonable to run this here, to give any 799 ;; process one last chance to run. But somehow this screws up 800 ;; package-maint-clean-some-elc. (accept-process-output) 801 (let* ((processes (dvc-processes-related-to-buffer buffer)) 802 (l (length processes))) 803 (when (and processes 804 (y-or-n-p (format "%s process%s running in buffer %s. Kill %s? " 805 l (if (= l 1) "" "es") 806 (buffer-name buffer) 807 (if (= l 1) "it" "them")))) 808 (dolist (process processes) 809 (when (eq (process-status process) 'run) 810 (incf dvc-default-killed-function-noerror) 811 (kill-process process))))) 812 ;; make sure it worked 813 (let ((processes (dvc-processes-related-to-buffer buffer))) 814 (when processes 815 (error "Process still running in buffer %s" buffer)))) 816 817(add-hook 'kill-buffer-hook 'dvc-kill-buffer-function) 818 819(defun dvc-kill-buffer-function () 820 "Function run when a buffer is killed." 821 (dvc-buffers-tree-remove (current-buffer)) 822 (dvc-kill-process-maybe (current-buffer))) 823 824(defun dvc-run-dvc-display-as-info (dvc arg-list &optional show-error-buffer info-string asynchron) 825 "Call either `dvc-run-dvc-async' or `dvc-run-dvc-sync' and display the result in an info buffer. 826When INFO-STRING is given, insert it at the buffer beginning." 827 (let ((buffer (dvc-get-buffer-create dvc 'info))) 828 (funcall (if asynchron 'dvc-run-dvc-async 'dvc-run-dvc-sync) dvc arg-list 829 :finished 830 (dvc-capturing-lambda (output error status arguments) 831 (progn 832 (with-current-buffer (capture buffer) 833 (let ((inhibit-read-only t)) 834 (erase-buffer) 835 (dvc-info-buffer-mode) 836 (when (capture info-string) 837 (insert (capture info-string))) 838 (insert-buffer-substring output) 839 (when (capture show-error-buffer) 840 (insert-buffer-substring error)) 841 (toggle-read-only 1))) 842 (dvc-switch-to-buffer (capture buffer))))))) 843 844(defvar dvc-info-buffer-mode-map 845 (let ((map (make-sparse-keymap))) 846 (define-key map (dvc-prefix-buffer ?L) 'dvc-open-internal-log-buffer) 847 (define-key map dvc-keyvec-quit 'dvc-buffer-quit) 848 map) 849 "Keymap used in a dvc info buffer.") 850 851(define-derived-mode dvc-info-buffer-mode fundamental-mode 852 "DVC info mode" 853 "Major mode for dvc info buffers" 854 (dvc-install-buffer-menu) 855 (toggle-read-only 1)) 856 857 858(defvar dvc-log-cookie nil) 859 860(defstruct (dvc-event) output-buffer error-buffer related-buffer 861 command tree event time) 862 863(defsubst dvc-log-printer-print-buffer (buffer function) 864 "Helper function for `dvc-log-printer'. 865Print a buffer filed for BUFFER during printing a log event. 866The printed name of BUFFER is mouse sensitive. If the user 867clicks it, FUNCTION is invoked." 868 (let ((alive-p (buffer-live-p buffer)) 869 map) 870 (dvc-face-add 871 (or 872 ;; pp-to-string is very costly. 873 ;; Handle the typical case with hard-coding. 874 (unless alive-p "#<killed buffer>") 875 ;; Normal case. 876 (buffer-name buffer) 877 ;; Extra case. 878 (pp-to-string buffer)) 879 'dvc-buffer 880 (when alive-p 881 (setq map (make-sparse-keymap)) 882 (define-key map [mouse-2] function) 883 map) 884 nil 885 "Show the buffer"))) 886 887(defun dvc-log-recently-p (elem limit-minute) 888 "Check ELEM recorded a recent event or not. 889Return nil If ELEM recorded an event older than LIMIT-MINUTE. 890Else return t." 891 (let* ((recorded (dvc-event-time elem)) 892 (cur (current-time)) 893 (diff-minute (/ (+ (* 65536 (- (nth 0 cur) 894 (nth 0 recorded))) 895 (- (nth 1 cur) 896 (nth 1 recorded))) 897 60))) 898 (if (> limit-minute diff-minute) 899 t 900 nil))) 901 902(defun dvc-log-printer (elem) 903 "Arch event printer which prints ELEM." 904 (let ((event (dvc-event-event elem)) 905 (p (point))) 906 (insert 907 "Command: " (dvc-event-command elem) 908 "\nDirectory: " (dvc-face-add (or (dvc-event-tree elem) "(nil)") 909 'dvc-local-directory) 910 "\nDate: " (format-time-string "%c" (dvc-event-time elem)) 911 "\nRelated Buffer: " (dvc-log-printer-print-buffer 912 (dvc-event-related-buffer elem) 913 'dvc-switch-to-related-buffer-by-mouse) 914 "\nOutput Buffer: " (dvc-log-printer-print-buffer 915 (dvc-event-output-buffer elem) 916 'dvc-switch-to-output-buffer-by-mouse) 917 "\nError Buffer: " (dvc-log-printer-print-buffer 918 (dvc-event-error-buffer elem) 919 'dvc-switch-to-error-buffer-by-mouse) 920 (if (not (string= event "started")) 921 (concat "\nEvent: " event) 922 "") 923 "\n") 924 ;; Reflect the point to `default-directory'. 925 ;; NOTE: XEmacs doesn't have `point-entered' special text property. 926 (put-text-property 927 p (point) 928 'point-entered (lambda (old new) 929 (setq default-directory 930 (dvc-event-tree 931 (ewoc-data 932 (ewoc-locate dvc-log-cookie)))))))) 933 934(defmacro dvc-switch-to-buffer-macro (function accessor) 935 "Define a FUNCTION for switching to the buffer associated with some event. 936ACCESSOR is a function for retrieving the appropriate buffer from a 937`dvc-event' structure." 938 (declare (debug (&define name symbolp))) 939 `(defun ,function () 940 "In a log buffer, pops to the output or error buffer corresponding to the 941process at point" 942 (interactive) 943 (let ((buffer (,accessor 944 (ewoc-data (ewoc-locate dvc-log-cookie))))) 945 (cond ((buffer-live-p buffer) 946 (dvc-switch-to-buffer buffer) 947 (unless (member buffer 948 (mapcar (lambda (p) 949 (process-buffer (car p))) 950 dvc-process-running)) 951 (dvc-process-buffer-mode))) 952 (t (error "Buffer has been killed")))))) 953 954(dvc-switch-to-buffer-macro dvc-switch-to-output-buffer 955 dvc-event-output-buffer) 956 957(dvc-switch-to-buffer-macro dvc-switch-to-error-buffer 958 dvc-event-error-buffer) 959 960(dvc-switch-to-buffer-macro dvc-switch-to-related-buffer 961 dvc-event-related-buffer) 962 963(dvc-make-bymouse-function dvc-switch-to-output-buffer) 964(dvc-make-bymouse-function dvc-switch-to-error-buffer) 965(dvc-make-bymouse-function dvc-switch-to-related-buffer) 966 967(defun dvc-log-event (output error command tree event) 968 "Log an event in the `dvc-log-buffer' buffer. 969OUTPUT is the buffer containing process standard output. 970ERROR is the buffer containing process error output. 971COMMAND is the command that was executed. 972TREE is the process's working directory. 973EVENT is the event that occurred. 974Returns that event." 975 (unless (and dvc-log-cookie 976 (buffer-live-p (ewoc-buffer dvc-log-cookie))) 977 (with-current-buffer (get-buffer-create dvc-log-buffer) 978 (setq dvc-log-cookie 979 (ewoc-create (dvc-ewoc-create-api-select 980 #'dvc-log-printer))) 981 (dvc-log-buffer-mode))) 982 (let ((related-buffer (current-buffer))) 983 (with-current-buffer (ewoc-buffer dvc-log-cookie) 984 (let ((elem (make-dvc-event :output-buffer output 985 :error-buffer error 986 :related-buffer related-buffer 987 :command command 988 :tree tree 989 :event event 990 :time (current-time))) 991 buffer-read-only) 992 (ewoc-enter-last dvc-log-cookie elem) 993 ;; If an event is too old (30 minutes after it has been 994 ;; recorded), throw it away. 995 (ewoc-filter dvc-log-cookie 'dvc-log-recently-p 30) 996 (ewoc-refresh dvc-log-cookie) 997 elem)))) 998 999(defun dvc-log-next () 1000 "Move to the next log entry." 1001 (interactive) 1002 (let ((next (ewoc-next dvc-log-cookie 1003 (ewoc-locate dvc-log-cookie)))) 1004 (when next (goto-char (ewoc-location next))))) 1005 1006(defun dvc-log-prev () 1007 "Move to the previous log entry." 1008 (interactive) 1009 (let ((prev (ewoc-prev dvc-log-cookie 1010 (ewoc-locate dvc-log-cookie)))) 1011 (when prev (goto-char (ewoc-location prev))))) 1012 1013;; 1014;; Log buffer mode section 1015;; 1016(defvar dvc-log-buffer-mode-map 1017 (let ((map (make-sparse-keymap))) 1018 (define-key map dvc-keyvec-help 'describe-mode) 1019 (define-key map [?o] 'dvc-switch-to-output-buffer) 1020 (define-key map "\C-m" 'dvc-switch-to-output-buffer) 1021 (define-key map [?e] 'dvc-switch-to-error-buffer) 1022 (define-key map [?r] 'dvc-switch-to-related-buffer) 1023 (define-key map [?n] 'dvc-log-next) 1024 (define-key map [?p] 'dvc-log-prev) 1025 (define-key map dvc-keyvec-quit 'dvc-buffer-quit) 1026 map) 1027 "Keymap used in DVC's log buffer.") 1028 1029(define-derived-mode dvc-log-buffer-mode fundamental-mode "DVC Log" 1030 "Major mode for DVC's internal log buffer. You can open this buffer 1031with `dvc-open-internal-log-buffer'." 1032 (toggle-read-only 1)) 1033 1034(defun dvc-open-internal-log-buffer () 1035 "Switch to the DVC's internal log buffer. 1036This buffer contains a list of all the DVC commands previously executed. 1037The buffer uses the mode `dvc-log-buffer-mode'" 1038 (interactive) 1039 (let ((buffer-name (buffer-name))) 1040 (dvc-switch-to-buffer dvc-log-buffer) 1041 (goto-char (point-max)) 1042 (when (re-search-backward (concat " Buffer: " 1043 (regexp-quote buffer-name) 1044 "$") 1045 nil t) 1046 (dvc-flash-line)))) 1047 1048(defun dvc-clear-log-buffer () 1049 "Kill the log buffer." 1050 (when (bufferp (get-buffer dvc-log-buffer)) 1051 (kill-buffer dvc-log-buffer))) 1052 1053(defun dvc-get-process-output () 1054 "Return the content of the last process buffer. 1055Strips the final newline if there is one." 1056 (dvc-buffer-content dvc-last-process-buffer)) 1057 1058(defun dvc-get-error-output () 1059 "Return the content of the last error buffer. 1060Strips the final newline if there is one." 1061 (dvc-buffer-content dvc-last-error-buffer)) 1062 1063 1064;; TODO: per backend cound. 1065(add-to-list 'minor-mode-alist 1066 '(dvc-process-running 1067 (:eval (if (equal (length dvc-process-running) 1) 1068 " DVC running" 1069 (concat " DVC running(" 1070 (int-to-string (length dvc-process-running)) 1071 ")"))))) 1072 1073(defun dvc-log-edit-file-name () 1074 "Return a suitable file name to edit the commit message" 1075 ;; FIXME: replace this with define-dvc-unified-command 1076 (dvc-call "dvc-log-edit-file-name-func")) 1077 1078(defun dvc-dvc-log-edit-file-name-func () 1079 (concat (file-name-as-directory (dvc-tree-root)) 1080 (dvc-variable (dvc-current-active-dvc) 1081 "log-edit-file-name"))) 1082 1083;; 1084;; Revision manipulation 1085;; 1086 1087;; revision grammar is specified in ../docs/DVC-API 1088 1089;; accessors 1090(defun dvc-revision-get-dvc (revision-id) 1091 (car revision-id)) 1092 1093(defun dvc-revision-get-type (revision-id) 1094 (car (nth 1 revision-id))) 1095 1096(defun dvc-revision-get-data (revision-id) 1097 (cdr (nth 1 revision-id))) 1098 1099(defun dvc-revision-to-string (revision-id &optional prev-format orig-str) 1100 "Return a string representation for REVISION-ID. 1101 1102If PREV-FORMAT is specified, it is the format string to use for 1103entries that are before the given revision ID. The format string 1104should take two parameters. The first is the revision ID, and 1105the second is a number which indicates how many generations back 1106to travel. 1107 1108If ORIG-STR is specified, it is the string that indicates the 1109current revision of the working tree." 1110 (let* ((type (dvc-revision-get-type revision-id)) 1111 (data (dvc-revision-get-data revision-id))) 1112 ;;(dvc-trace "dvc-revision-to-string: type: %s, data: %s, orig-str: %s" type data orig-str) 1113 (case type 1114 (revision (dvc-name-construct (nth 0 data))) 1115 (local-tree (car data)) 1116 (last-revision (or orig-str "original")) 1117 (previous-revision 1118 (format (or prev-format "%s:-%s") 1119 (dvc-revision-to-string 1120 (list (dvc-revision-get-dvc revision-id) (nth 0 data))) 1121 (int-to-string (nth 1 data)))) 1122 (t "UNKNOWN")))) 1123 1124(defun dvc-revision-get-buffer (file revision-id) 1125 "Return an empty buffer suitable for viewing FILE in REVISION-ID. 1126 1127The name of the buffer is chosen according to FILE and REVISION-ID. 1128 1129REVISION-ID may have the values described in docs/DVC-API." 1130 (let* ((type (dvc-revision-get-type revision-id)) 1131 (name (concat 1132 (file-name-nondirectory file) 1133 "(" (dvc-revision-to-string revision-id) ")"))) 1134 ;; replace / by | to work around uniquify 1135 (setq name (replace-regexp-in-string "\\/" "|" name)) 1136 (let ((buffer (generate-new-buffer name))) 1137 (with-current-buffer buffer 1138 (let ((buffer-file-name file)) 1139 (set-auto-mode t))) 1140 (dvc-buffers-tree-add (dvc-revision-get-dvc revision-id) type file buffer) 1141 buffer))) 1142 1143 1144(defun dvc-revision-get-file-in-buffer (file revision-id) 1145 "Return a buffer with the content of FILE at REVISION-ID. 1146 1147REVISION-ID is as specified in docs/DVC-API." 1148 (dvc-trace "dvc-revision-get-file-in-buffer. revision-id=%S" revision-id) 1149 (let* ((type (dvc-revision-get-type revision-id)) 1150 (inhibit-read-only t) 1151 ;; find-file-noselect will call dvc-current-active-dvc in a 1152 ;; hook; specify dvc for dvc-call 1153 (dvc-temp-current-active-dvc (dvc-revision-get-dvc revision-id)) 1154 (buffer (unless (eq type 'local-tree) (dvc-revision-get-buffer file revision-id)))) 1155 (case type 1156 (local-tree (find-file-noselect file)) 1157 1158 (revision 1159 (with-current-buffer buffer 1160 (dvc-call "revision-get-file-revision" 1161 file (dvc-revision-get-data revision-id)) 1162 (set-buffer-modified-p nil) 1163 (toggle-read-only 1) 1164 buffer)) 1165 1166 (previous-revision 1167 (with-current-buffer buffer 1168 (let* ((dvc (dvc-revision-get-dvc revision-id)) 1169 (data (nth 0 (dvc-revision-get-data revision-id))) 1170 (rev-id (list dvc data))) 1171 (dvc-call "revision-get-previous-revision" file rev-id)) 1172 (set-buffer-modified-p nil) 1173 (toggle-read-only 1) 1174 buffer)) 1175 1176 (last-revision 1177 (with-current-buffer buffer 1178 (dvc-call "revision-get-last-revision" 1179 file (dvc-revision-get-data revision-id)) 1180 (set-buffer-modified-p nil) 1181 (toggle-read-only 1) 1182 buffer)) 1183 1184 (t (error "TODO: dvc-revision-get-file-in-buffer type %S" type))))) 1185 1186(defun dvc-dvc-revision-nth-ancestor (revision n) 1187 "Default function to get the n-th ancestor of REVISION." 1188 (let ((count n) 1189 (res revision)) 1190 (while (> count 0) 1191 (setq res (dvc-revision-direct-ancestor res) 1192 count (- count 1))) 1193 res)) 1194 1195;; 1196;; DVC command version 1197;; 1198(defun dvc-dvc-command-version () 1199 "Fallback for `dvc-command-vesion'. Returns just `nil'. 1200This function is called only if the current backend doesn't 1201implement `command-version' function." 1202 nil) 1203 1204(provide 'dvc-core) 1205;;; dvc-core.el ends here