Mercurial > emacs

comparison lisp/pcvs-info.el @ 29576:961f303cda37

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(cvs-fi-up-to-date-face, cvs-fi-unknown-face): New vars. (cvs-status-map): Don't inherit from cvs-mode-map anymore. (cvs-filename-map, cvs-dirname-map): Remove. (cvs-default-action): Remove. (cvs-add-face): Use `keymap' rather than `local-map' property, and only if the arg is really a keymap. (cvs-fileinfo-pp): Don't use any special map for file and dir names. Don't hardcode the mapping from state (aka type) to face, but check the var cvs-fi-<type>-face instead. (cvs-fileinfo-from-entries): New function.
author Stefan Monnier <monnier@iro.umontreal.ca>
date Mon, 12 Jun 2000 04:37:50 +0000
parents 06cfa273543d
children 5ca411467bf3
comparison
equal deleted inserted replaced
29575:ab979e3b519a 29576:961f303cda37
3 ;; Copyright (C) 1991-2000 Free Software Foundation, Inc. 3 ;; Copyright (C) 1991-2000 Free Software Foundation, Inc.
4 4
5 ;; Author: Stefan Monnier <monnier@cs.yale.edu> 5 ;; Author: Stefan Monnier <monnier@cs.yale.edu>
6 ;; Keywords: pcl-cvs 6 ;; Keywords: pcl-cvs
7 ;; Version: $Name: $ 7 ;; Version: $Name: $
8 ;; Revision: $Id: pcvs-info.el,v 1.1 2000/03/11 03:42:29 monnier Exp $ 8 ;; Revision: $Id: pcvs-info.el,v 1.2 2000/03/22 02:56:52 monnier Exp $
9 9
10 ;; This file is part of GNU Emacs. 10 ;; This file is part of GNU Emacs.
11 11
12 ;; GNU Emacs is free software; you can redistribute it and/or modify 12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by 13 ;; it under the terms of the GNU General Public License as published by
63 on a directory entry, cvs would commit the whole directory. This seems 63 on a directory entry, cvs would commit the whole directory. This seems
64 to confuse some users sometimes." 64 to confuse some users sometimes."
65 :group 'pcl-cvs 65 :group 'pcl-cvs
66 :type '(boolean)) 66 :type '(boolean))
67 67
68
69 ;;;; 68 ;;;;
70 ;;;; Faces for fontification 69 ;;;; Faces for fontification
71 ;;;; 70 ;;;;
72 71
73 (defface cvs-header-face 72 (defface cvs-header-face
127 (defface cvs-msg-face 126 (defface cvs-msg-face
128 '((t (:italic t))) 127 '((t (:italic t)))
129 "PCL-CVS face used to highlight CVS messages." 128 "PCL-CVS face used to highlight CVS messages."
130 :group 'pcl-cvs) 129 :group 'pcl-cvs)
131 130
131 (defvar cvs-fi-up-to-date-face 'cvs-handled-face)
132 (defvar cvs-fi-unknown-face 'cvs-unknown-face)
132 133
133 ;; There is normally no need to alter the following variable, but if 134 ;; There is normally no need to alter the following variable, but if
134 ;; your site has installed CVS in a non-standard way you might have 135 ;; your site has installed CVS in a non-standard way you might have
135 ;; to change it. 136 ;; to change it.
136 137
137 (defvar cvs-bakprefix ".#" 138 (defvar cvs-bakprefix ".#"
138 "The prefix that CVS prepends to files when rcsmerge'ing.") 139 "The prefix that CVS prepends to files when rcsmerge'ing.")
139 140
140 (easy-mmode-defmap cvs-filename-map
141 '(([(mouse-2)] . cvs-mode-find-file))
142 "Local keymap for text properties of file names"
143 :inherit 'cvs-mode-map)
144
145 (easy-mmode-defmap cvs-status-map 141 (easy-mmode-defmap cvs-status-map
146 '(([(mouse-2)] . cvs-mouse-toggle-mark)) 142 '(([(mouse-2)] . cvs-mouse-toggle-mark))
147 "Local keymap for text properties of status" 143 "Local keymap for text properties of status")
148 :inherit 'cvs-mode-map)
149
150 (easy-mmode-defmap cvs-dirname-map
151 '(([(mouse-2)] . cvs-mode-find-file))
152 "Local keymap for text properties of directory names"
153 :inherit 'cvs-mode-map)
154 144
155 ;; Constructor: 145 ;; Constructor:
156 146
157 (defstruct (cvs-fileinfo 147 (defstruct (cvs-fileinfo
158 (:constructor nil) 148 (:constructor nil)
223 (let ((dir (cvs-fileinfo->dir fileinfo))) 213 (let ((dir (cvs-fileinfo->dir fileinfo)))
224 (if (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE) 214 (if (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE)
225 (if (string= dir "") "." (directory-file-name dir)) 215 (if (string= dir "") "." (directory-file-name dir))
226 ;; Here, I use `concat' rather than `expand-file-name' because I want 216 ;; Here, I use `concat' rather than `expand-file-name' because I want
227 ;; the resulting path to stay relative if `dir' is relative. 217 ;; the resulting path to stay relative if `dir' is relative.
228 ;; I could also use `expand-file-name' with `default-directory = ""'
229 (concat dir (cvs-fileinfo->file fileinfo))))) 218 (concat dir (cvs-fileinfo->file fileinfo)))))
230 219
231 (defun cvs-fileinfo->pp-name (fi) 220 (defun cvs-fileinfo->pp-name (fi)
232 "Return the filename of FI as it should be displayed." 221 "Return the filename of FI as it should be displayed."
233 (if cvs-display-full-path 222 (if cvs-display-full-path
318 307
319 ;;;; 308 ;;;;
320 ;;;; Utility functions 309 ;;;; Utility functions
321 ;;;; 310 ;;;;
322 311
323 ;;----------
324 (defun cvs-applicable-p (fi-or-type func) 312 (defun cvs-applicable-p (fi-or-type func)
325 "Check if FUNC is applicable to FI-OR-TYPE. 313 "Check if FUNC is applicable to FI-OR-TYPE.
326 If FUNC is nil, always return t. 314 If FUNC is nil, always return t.
327 FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo." 315 FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo."
328 (let ((type (if (symbolp fi-or-type) fi-or-type 316 (let ((type (if (symbolp fi-or-type) fi-or-type
329 (cvs-fileinfo->type fi-or-type)))) 317 (cvs-fileinfo->type fi-or-type))))
330 (and (not (eq type 'MESSAGE)) 318 (and (not (eq type 'MESSAGE))
331 (eq (car (memq func (cdr (assq type cvs-states)))) func)))) 319 (eq (car (memq func (cdr (assq type cvs-states)))) func))))
332 320
333 ;; (defun cvs-default-action (fileinfo)
334 ;; "Return some kind of \"default\" action to be performed."
335 ;; (second (assq (cvs-fileinfo->type fileinfo) cvs-states)))
336
337 ;; fileinfo pretty-printers:
338
339 (defun cvs-add-face (str face &optional keymap) 321 (defun cvs-add-face (str face &optional keymap)
340 (when cvs-highlight 322 (when cvs-highlight
341 (add-text-properties 0 (length str) 323 (add-text-properties 0 (length str)
342 (list* 'face face 324 (list* 'face face
343 (when keymap 325 (when keymap
344 (list 'mouse-face 'highlight 326 (list* 'mouse-face 'highlight
345 'local-map keymap))) 327 (when (keymapp keymap)
328 (list 'keymap keymap)))))
346 str)) 329 str))
347 str) 330 str)
348 331
349 ;;----------
350 (defun cvs-fileinfo-pp (fileinfo) 332 (defun cvs-fileinfo-pp (fileinfo)
351 "Pretty print FILEINFO. Insert a printed representation in current buffer. 333 "Pretty print FILEINFO. Insert a printed representation in current buffer.
352 For use by the cookie package." 334 For use by the cookie package."
353 (cvs-check-fileinfo fileinfo) 335 (cvs-check-fileinfo fileinfo)
354 (let ((type (cvs-fileinfo->type fileinfo)) 336 (let ((type (cvs-fileinfo->type fileinfo))
355 (subtype (cvs-fileinfo->subtype fileinfo))) 337 (subtype (cvs-fileinfo->subtype fileinfo)))
356 (insert 338 (insert
357 (case type 339 (case type
358 (DIRCHANGE (concat "In directory " 340 (DIRCHANGE (concat "In directory "
359 (cvs-add-face (cvs-fileinfo->full-path fileinfo) 341 (cvs-add-face (cvs-fileinfo->full-path fileinfo)
360 'cvs-header-face cvs-dirname-map) 342 'cvs-header-face t)
361 ":")) 343 ":"))
362 (MESSAGE 344 (MESSAGE
363 (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo)) 345 (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo))
364 'cvs-msg-face)) 346 'cvs-msg-face))
365 (t 347 (t
366 (let* ((status (if (cvs-fileinfo->marked fileinfo) 348 (let* ((status (if (cvs-fileinfo->marked fileinfo)
367 (cvs-add-face "*" 'cvs-marked-face) 349 (cvs-add-face "*" 'cvs-marked-face)
368 " ")) 350 " "))
369 (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo) 351 (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo)
370 'cvs-filename-face cvs-filename-map)) 352 'cvs-filename-face t))
371 (base (or (cvs-fileinfo->base-rev fileinfo) "")) 353 (base (or (cvs-fileinfo->base-rev fileinfo) ""))
372 (head (cvs-fileinfo->head-rev fileinfo)) 354 (head (cvs-fileinfo->head-rev fileinfo))
373 (type 355 (type
374 (let ((str (case type 356 (let ((str (case type
375 ;;(MOD-CONFLICT "Not Removed") 357 ;;(MOD-CONFLICT "Not Removed")
376 (DEAD "") 358 (DEAD "")
377 (t (capitalize (symbol-name type))))) 359 (t (capitalize (symbol-name type)))))
378 (face (case type 360 (face (let ((sym (intern
379 (UP-TO-DATE 'cvs-handled-face) 361 (concat "cvs-fi-"
380 (UNKNOWN 'cvs-unknown-face) 362 (downcase (symbol-name type))
381 (t 'cvs-need-action-face)))) 363 "-face"))))
364 (or (and (boundp sym) (symbol-value sym))
365 'cvs-need-action-face))))
382 (cvs-add-face str face cvs-status-map))) 366 (cvs-add-face str face cvs-status-map)))
383 (side (or 367 (side (or
384 ;; maybe a subtype 368 ;; maybe a subtype
385 (when subtype (downcase (symbol-name subtype))) 369 (when subtype (downcase (symbol-name subtype)))
386 ;; or the head-rev 370 ;; or the head-rev
403 (cond 387 (cond
404 (merge (setf (cvs-fileinfo->merge fi) merge)) 388 (merge (setf (cvs-fileinfo->merge fi) merge))
405 ((memq type '(UP-TO-DATE NEED-UPDATE)) 389 ((memq type '(UP-TO-DATE NEED-UPDATE))
406 (setf (cvs-fileinfo->merge fi) nil))))) 390 (setf (cvs-fileinfo->merge fi) nil)))))
407 391
408 ;;----------
409 (defun cvs-fileinfo< (a b) 392 (defun cvs-fileinfo< (a b)
410 "Compare fileinfo A with fileinfo B and return t if A is `less'. 393 "Compare fileinfo A with fileinfo B and return t if A is `less'.
411 The ordering defined by this function is such that directories are 394 The ordering defined by this function is such that directories are
412 sorted alphabetically, and inside every directory the DIRCHANGE 395 sorted alphabetically, and inside every directory the DIRCHANGE
413 fileinfo will appear first, followed by all files (alphabetically)." 396 fileinfo will appear first, followed by all files (alphabetically)."
423 ((eq (cvs-fileinfo->type a) 'DIRCHANGE) t) 406 ((eq (cvs-fileinfo->type a) 'DIRCHANGE) t)
424 407
425 ;; All files are sorted by file name. 408 ;; All files are sorted by file name.
426 ((string< (cvs-fileinfo->file a) (cvs-fileinfo->file b)))))) 409 ((string< (cvs-fileinfo->file a) (cvs-fileinfo->file b))))))
427 410
411 ;;;
412 ;;; Look at CVS/Entries to quickly find a first approximation of the status
413 ;;;
414
415 (defun cvs-fileinfo-from-entries (dir &optional all)
416 "List of fileinfos for DIR, extracted from CVS/Entries.
417 Unless ALL is optional, returns only the files that are not up-to-date.
418 DIR can also be a file."
419 (let* ((singlefile
420 (cond
421 ((equal dir "") nil)
422 ((file-directory-p dir) (setq dir (file-name-as-directory dir)) nil)
423 (t (prog1 (file-name-nondirectory dir)
424 (setq dir (or (file-name-directory dir) ""))))))
425 (file (expand-file-name "CVS/Entries" dir))
426 (fis nil))
427 (if (not (file-readable-p file))
428 (push (cvs-create-fileinfo (if singlefile 'UNKNOWN 'DIRCHANGE)
429 dir (or singlefile ".") "") fis)
430 (with-temp-buffer
431 (insert-file-contents file)
432 (goto-char (point-min))
433 ;; Select the single file entry in case we're only interested in a file.
434 (cond
435 ((not singlefile)
436 (push (cvs-create-fileinfo 'DIRCHANGE dir "." "") fis))
437 ((re-search-forward
438 (concat "^[^/]*/" (regexp-quote singlefile) "/.*") nil t)
439 (setq all t)
440 (goto-char (match-beginning 0))
441 (narrow-to-region (point) (match-end 0)))
442 (t
443 (push (cvs-create-fileinfo 'UNKNOWN dir singlefile "") fis)
444 (narrow-to-region (point-min) (point-min))))
445 (while (looking-at "\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/")
446 (if (/= (match-beginning 1) (match-end 1))
447 (setq fis (append (cvs-fileinfo-from-entries
448 (concat dir (file-name-as-directory
449 (match-string 2)))
450 all)
451 fis))
452 (let ((f (match-string 2))
453 (rev (match-string 3))
454 (date (match-string 4))
455 timestamp
456 (type 'MODIFIED)
457 (subtype nil))
458 (cond
459 ((equal (substring rev 0 1) "-")
460 (setq type 'REMOVED rev (substring rev 1)))
461 ((not (file-exists-p (concat dir f))) (setq type 'MISSING))
462 ((equal rev "0") (setq type 'ADDED rev nil))
463 ((equal date "Result of merge") (setq subtype 'MERGED))
464 ((let ((mtime (nth 5 (file-attributes (concat dir f))))
465 (system-time-locale "C"))
466 (equal (setq timestamp (format-time-string "%c" mtime 'utc))
467 date))
468 (setq type (if all 'UP-TO-DATE)))
469 ((equal date (concat "Result of merge+" timestamp))
470 (setq type 'CONFLICT)))
471 (when type
472 (push (cvs-create-fileinfo type dir f ""
473 :base-rev rev :subtype subtype)
474 fis))))
475 (forward-line 1))))
476 fis))
477
428 (provide 'pcvs-info) 478 (provide 'pcvs-info)
429 479
430 ;;; pcl-cvs-info.el ends here 480 ;;; pcl-cvs-info.el ends here