Mercurial > emacs

changeset 18174:238e30645d07

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(diff-switches): defvar deleted. (vc-annotate-*): New functions and variables.
author Richard M. Stallman <rms@gnu.org>
date Mon, 09 Jun 1997 06:01:12 +0000
parents 9747b115c12c
children f8af1810653b
files lisp/vc.el
diffstat 1 files changed, 220 insertions(+), 1 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/vc.el	Mon Jun 09 04:56:02 1997 +0000
+++ b/lisp/vc.el	Mon Jun 09 06:01:12 1997 +0000
@@ -154,10 +154,50 @@
   "Maximum number of saved comments in the comment ring.")
 
 ;;; This is duplicated in diff.el.
-;;; ...and customized.
 (defvar diff-switches "-c"
   "*A string or list of strings specifying switches to be be passed to diff.")
 
+(defcustom vc-annotate-color-map
+  '(( 26.3672 . "#FF0000")
+    ( 52.7344 . "#FF3800")
+    ( 79.1016 . "#FF7000")
+    (105.4688 . "#FFA800")
+    (131.8359 . "#FFE000")
+    (158.2031 . "#E7FF00")
+    (184.5703 . "#AFFF00")
+    (210.9375 . "#77FF00")
+    (237.3047 . "#3FFF00")
+    (263.6719 . "#07FF00")
+    (290.0391 . "#00FF31")
+    (316.4063 . "#00FF69")
+    (342.7734 . "#00FFA1")
+    (369.1406 . "#00FFD9")
+    (395.5078 . "#00EEFF")
+    (421.8750 . "#00B6FF")
+    (448.2422 . "#007EFF"))
+  "*Association list of age versus color, for \\[vc-annotate].
+Ages are given in units of 2**-16 seconds.
+Default is eighteen steps using a twenty day increment."
+  :type 'sexp
+  :group 'vc)
+
+(defcustom vc-annotate-very-old-color "#0046FF"
+  "*Color for lines older than CAR of last cons in `vc-annotate-color-map'."
+  :type 'string
+  :group 'vc)
+
+(defcustom vc-annotate-background "black"
+  "*Background color for \\[vc-annotate].
+Default color is used if nil."
+  :type 'string
+  :group 'vc)
+
+(defcustom vc-annotate-menu-elements '(2 0.5 0.1 0.01)
+  "*Menu elements for the mode-specific menu of VC-Annotate mode.
+List of factors, used to expand/compress the time scale.  See `vc-annotate'."
+  :type 'sexp
+  :group 'vc)
+
 ;;;###autoload
 (defcustom vc-checkin-hook nil
   "*Normal hook (List of functions) run after a checkin is done.
@@ -172,6 +212,12 @@
   :type 'hook
   :group 'vc)
 
+;;;###autoload
+(defcustom vc-annotate-mode-hook nil
+  "*Hooks to run when VC-Annotate mode is turned on."
+  :type 'hook
+  :group 'vc)
+
 ;; Header-insertion hair
 
 (defcustom vc-header-alist
@@ -1933,7 +1979,179 @@
 		     "failed"))
 	       (cd (file-name-directory changelog))
 	       (delete-file tempfile)))))
+
+;; vc-annotate functionality (CVS only).
+(defvar vc-annotate-mode nil
+  "Variable indicating if VC-Annotate mode is active.")
 
+(defvar vc-annotate-mode-map ()
+  "Local keymap used for VC-Annotate mode.")
+
+;; Syntax Table
+(defvar vc-annotate-mode-syntax-table nil
+  "Syntax table used in VC-Annotate mode buffers.")
+
+(defun vc-annotate-mode-variables ()
+  (if (not vc-annotate-mode-syntax-table)
+      (progn   (setq vc-annotate-mode-syntax-table (make-syntax-table))
+	       (set-syntax-table vc-annotate-mode-syntax-table)))
+  (if (not vc-annotate-mode-map)
+      (setq vc-annotate-mode-map (make-sparse-keymap))))
+
+(defun vc-annotate-mode ()
+  "Major mode for buffers displaying output from the CVS `annotate' command.
+
+You can use the mode-specific menu to alter the time-span of the used
+colors.  See variable `vc-annotate-menu-elements' for customizing the
+menu items."
+  (interactive)
+  (kill-all-local-variables)		; Recommended by RMS.
+  (vc-annotate-mode-variables)		; This defines various variables.
+  (use-local-map vc-annotate-mode-map)	; This provides the local keymap.
+  (set-syntax-table vc-annotate-mode-syntax-table)
+  (setq major-mode 'vc-annotate-mode)	; This is how `describe-mode'
+					;   finds out what to describe.
+  (setq mode-name "Annotate")		; This goes into the mode line.
+  (run-hooks 'vc-annotate-mode-hook)
+  (vc-annotate-add-menu))
+
+(defun vc-annotate-display-default (&optional event)
+  "Use the default color spectrum for VC Annotate mode."
+  (interactive)
+  (vc-annotate-display (get-buffer (buffer-name))))
+
+(defun vc-annotate-add-menu ()
+  "Adds the menu 'Annotate' to the menu bar in VC-Annotate mode."
+  (setq vc-annotate-mode-menu (make-sparse-keymap "Annotate"))
+  (define-key vc-annotate-mode-menu [default]
+    '("Default" . vc-annotate-display-default))
+  (let ((menu-elements vc-annotate-menu-elements))
+    (while menu-elements
+      (let* ((element (car menu-elements))
+	     (days (round (* element 
+			     (vc-annotate-car-last-cons vc-annotate-color-map) 
+			     0.7585))))
+	(setq menu-elements (cdr menu-elements))
+	(define-key vc-annotate-mode-menu
+	  (vector days)
+	  (cons (format "Span %d days"
+			days)
+		`(lambda ()
+		   ,(format "Use colors spanning %d days" days)
+		   (vc-annotate-display (get-buffer (buffer-name))
+					(vc-annotate-time-span ,element)))))))))
+
+(defvar vc-annotate-ratio)
+
+;;;###autoload
+(defun vc-annotate (ratio)
+  "Display the result of the CVS `annotate' command using colors.
+New lines are displayed in red, old in blue.
+A prefix argument specifies a factor for stretching the time scale.
+
+`vc-annotate-menu-elements' customizes the menu elements of the
+mode-specific menu. `vc-annotate-color-map' and
+`vc-annotate-very-old-color' defines the mapping of time to
+colors. `vc-annotate-background' specifies the background color."
+  (interactive "p")
+  (if (not (eq (vc-buffer-backend) 'CVS)) ; This only works with CVS
+      (vc-registration-error (buffer-file-name)))
+  (message "Annotating...")
+  (let ((temp-buffer-name (concat "*cvs annotate " (buffer-name) "*"))
+	(temp-buffer-show-function 'vc-annotate-display)
+	(vc-annotate-ratio ratio))
+    (with-output-to-temp-buffer temp-buffer-name
+      (call-process "cvs" nil (get-buffer temp-buffer-name) nil
+		    "annotate" (file-name-nondirectory (buffer-file-name)))))
+  (message "Annotating... done"))
+
+(defun vc-annotate-car-last-cons (assoc-list)
+  "Return car of last cons in ASSOC-LIST."
+  (if (not (eq nil (cdr assoc-list)))
+      (vc-annotate-car-last-cons (cdr assoc-list))
+    (car (car assoc-list))))
+
+;; Return an association list with span factor applied to the
+;; time-span of assoc-list.  Optionaly quantize to the factor of
+;; quantize.
+(defun vc-annotate-time-span (assoc-list span &optional quantize)
+  ;; Apply span to each car of every cons
+  (if (not (eq nil assoc-list)) 
+      (append (list (cons (* (car (car assoc-list)) span)
+			  (cdr (car assoc-list))))
+	      (vc-annotate-time-span (nthcdr (cond (quantize) ; optional
+						   (1)) ; Default to cdr
+					     assoc-list) span quantize))))
+
+(defun vc-annotate-compcar (threshold &rest args)
+  "Test successive cars of ARGS against THRESHOLD.
+Return the first cons which CAR is not less than THRESHOLD, nil otherwise"
+  ;; If no list is exhausted,
+  (if (and (not (memq 'nil args)) (< (car (car (car args))) threshold))
+      ;; apply to CARs.
+      (apply 'vc-annotate-compcar threshold
+	     ;; Recurse for rest of elements.
+	     (mapcar 'cdr args))
+    ;; Return the proper result
+    (car (car args))))
+
+(defun vc-annotate-display (buffer &optional color-map)
+  "Do the VC-Annotate display in BUFFER using COLOR-MAP."
+
+  (if (and (not color-map) vc-annotate-ratio)
+      (setq color-map (vc-annotate-time-span color-map vc-annotate-ratio)))
+      
+  ;; We need a list of months and their corresponding numbers.
+  (let* ((local-month-numbers 
+	  '(("Jan" . 1) ("Feb" .  2) ("Mar" .  3) ("Apr" .  4)
+	    ("May" . 5) ("Jun" .  6) ("Jul" .  7) ("Aug" .  8) 
+	    ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))
+	 ;; XEmacs use extents, GNU Emacs overlays.
+	 (overlay-or-extent (if (string-match "XEmacs" emacs-version)
+				(cons 'make-extent 'set-extent-property)
+			      (cons 'make-overlay 'overlay-put)))
+	 (make-overlay-or-extent (car overlay-or-extent))
+	 (set-property-overlay-or-extent (cdr overlay-or-extent)))
+
+    (set-buffer buffer)
+    (display-buffer buffer)
+    (if (not vc-annotate-mode)		; Turn on vc-annotate-mode if not done
+	(vc-annotate-mode))
+    (goto-char (point-min))		; Position at the top of the buffer.
+    (while (re-search-forward 
+	    "^[0-9]+\\(\.[0-9]+\\)*\\s-+(\\sw+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): "
+	    nil t)
+
+      (let* (;; Unfortunately, order is important. match-string will
+             ;; be corrupted by extent functions in XEmacs. Access
+             ;; string-matches first.
+	     (day (string-to-number (match-string 2)))
+             (month (cdr (assoc (match-string 3) local-month-numbers)))
+	     (year-tmp (string-to-number (match-string 4)))
+	     (year (+ (if (> 100 year-tmp) 1900 0) year-tmp)) ; Possible millenium problem
+	     (high (- (car (current-time))
+		      (car (encode-time 0 0 0 day month year))))
+	     (color (cond ((vc-annotate-compcar high (cond (color-map)
+							   (vc-annotate-color-map))))
+			  ((cons nil vc-annotate-very-old-color))))
+	     ;; substring from index 1 to remove any leading `#' in the name
+	     (face-name (concat "vc-annotate-face-" (substring (cdr color) 1)))
+	     ;; Make the face if not done.
+	     (face (cond ((intern-soft face-name))
+			 ((make-face (intern face-name)))))
+	     (point (point))
+	     (foo (forward-line 1))
+	     (overlay (cond ((if (string-match "XEmacs" emacs-version)
+				 (extent-at point)
+			       (car (overlays-at point ))))
+			    ((apply make-overlay-or-extent point (point) nil)))))
+
+	(if vc-annotate-background
+	    (set-face-background face vc-annotate-background))
+	(set-face-foreground face (cdr color))
+	(apply set-property-overlay-or-extent overlay
+	       'face face nil)))))
+
 ;; Collect back-end-dependent stuff here
 
 (defun vc-backend-admin (file &optional rev comment)
@@ -2451,6 +2669,7 @@
 \\[vc-diff]		show diffs between file versions
 \\[vc-version-other-window]		visit old version in another window
 \\[vc-directory]		show all files locked by any user in or below .
+\\[vc-annotate]		colorful display of the cvs annotate command 
 \\[vc-update-change-log]		add change log entry from recent checkins
 
 While you are entering a change log message for a version, the following