X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/5b467bf4e2787e3290280cadbae9e915df88dacd..f720b30e1123ca3549436b0a5b8ea65b4473329b:/lisp/pcvs-info.el diff --git a/lisp/pcvs-info.el b/lisp/pcvs-info.el index 51b791e8ae..291e4ae85c 100644 --- a/lisp/pcvs-info.el +++ b/lisp/pcvs-info.el @@ -1,11 +1,10 @@ -;;; pcvs-info.el --- Internal representation of a fileinfo entry +;;; pcvs-info.el --- internal representation of a fileinfo entry -;; Copyright (C) 1991-2000 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +;; 2000, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Author: Stefan Monnier ;; Keywords: pcl-cvs -;; Version: $Name: $ -;; Revision: $Id: pcl-cvs-info.el,v 1.28 2000/03/05 21:32:21 monnier Exp $ ;; This file is part of GNU Emacs. @@ -21,8 +20,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -42,20 +41,13 @@ ;;;; config variables ;;;; -(defcustom cvs-display-full-path t - "*Specifies how the filenames should look like in the listing. -If t, their full path name will be displayed, else only the filename." - :group 'pcl-cvs - :type '(boolean)) - -(defvar global-font-lock-mode) -(defvar font-lock-auto-fontify) -(defcustom cvs-highlight - (or (and (boundp 'font-lock-auto-fontify) font-lock-auto-fontify) - (and (boundp 'global-font-lock-mode) global-font-lock-mode)) - "*Whether to use text highlighting (à la font-lock) or not." +(defcustom cvs-display-full-name t + "*Specifies how the filenames should be displayed in the listing. +If non-nil, their full filename name will be displayed, else only the +non-directory part." :group 'pcl-cvs :type '(boolean)) +(define-obsolete-variable-alias 'cvs-display-full-path 'cvs-display-full-name) (defcustom cvs-allow-dir-commit nil "*Allow `cvs-mode-commit' on directories. @@ -65,21 +57,22 @@ to confuse some users sometimes." :group 'pcl-cvs :type '(boolean)) - ;;;; ;;;; Faces for fontification ;;;; -(defface cvs-header-face +(defface cvs-header '((((class color) (background dark)) - (:foreground "lightyellow" :bold t)) + (:foreground "lightyellow" :weight bold)) (((class color) (background light)) - (:foreground "blue4" :bold t)) - (t (:bold t))) + (:foreground "blue4" :weight bold)) + (t (:weight bold))) "PCL-CVS face used to highlight directory changes." :group 'pcl-cvs) +;; backward-compatibility alias +(put 'cvs-header-face 'face-alias 'cvs-header) -(defface cvs-filename-face +(defface cvs-filename '((((class color) (background dark)) (:foreground "lightblue")) (((class color) (background light)) @@ -87,17 +80,21 @@ to confuse some users sometimes." (t ())) "PCL-CVS face used to highlight file names." :group 'pcl-cvs) +;; backward-compatibility alias +(put 'cvs-filename-face 'face-alias 'cvs-filename) -(defface cvs-unknown-face +(defface cvs-unknown '((((class color) (background dark)) (:foreground "red")) (((class color) (background light)) (:foreground "red")) - (t (:italic t))) + (t (:slant italic))) "PCL-CVS face used to highlight unknown file status." :group 'pcl-cvs) +;; backward-compatibility alias +(put 'cvs-unknown-face 'face-alias 'cvs-unknown) -(defface cvs-handled-face +(defface cvs-handled '((((class color) (background dark)) (:foreground "pink")) (((class color) (background light)) @@ -105,30 +102,43 @@ to confuse some users sometimes." (t ())) "PCL-CVS face used to highlight handled file status." :group 'pcl-cvs) +;; backward-compatibility alias +(put 'cvs-handled-face 'face-alias 'cvs-handled) -(defface cvs-need-action-face +(defface cvs-need-action '((((class color) (background dark)) (:foreground "orange")) (((class color) (background light)) (:foreground "orange")) - (t (:italic t))) + (t (:slant italic))) "PCL-CVS face used to highlight status of files needing action." :group 'pcl-cvs) - -(defface cvs-marked-face - '((((class color) (background dark)) - (:foreground "green" :bold t)) +;; backward-compatibility alias +(put 'cvs-need-action-face 'face-alias 'cvs-need-action) + +(defface cvs-marked + '((((min-colors 88) (class color) (background dark)) + (:foreground "green1" :weight bold)) + (((class color) (background dark)) + (:foreground "green" :weight bold)) (((class color) (background light)) - (:foreground "green3" :bold t)) - (t (:bold t))) + (:foreground "green3" :weight bold)) + (t (:weight bold))) "PCL-CVS face used to highlight marked file indicator." :group 'pcl-cvs) +;; backward-compatibility alias +(put 'cvs-marked-face 'face-alias 'cvs-marked) -(defface cvs-msg-face - '((t (:italic t))) +(defface cvs-msg + '((t (:slant italic))) "PCL-CVS face used to highlight CVS messages." :group 'pcl-cvs) +;; backward-compatibility alias +(put 'cvs-msg-face 'face-alias 'cvs-msg) +(defvar cvs-fi-up-to-date-face 'cvs-handled) +(defvar cvs-fi-unknown-face 'cvs-unknown) +(defvar cvs-fi-conflict-face 'font-lock-warning-face) ;; There is normally no need to alter the following variable, but if ;; your site has installed CVS in a non-standard way you might have @@ -137,20 +147,9 @@ to confuse some users sometimes." (defvar cvs-bakprefix ".#" "The prefix that CVS prepends to files when rcsmerge'ing.") -(easy-mmode-defmap cvs-filename-map - '(([(mouse-2)] . cvs-mode-find-file)) - "Local keymap for text properties of file names" - :inherit 'cvs-mode-map) - (easy-mmode-defmap cvs-status-map - '(([(mouse-2)] . cvs-mouse-toggle-mark)) - "Local keymap for text properties of status" - :inherit 'cvs-mode-map) - -(easy-mmode-defmap cvs-dirname-map - '(([(mouse-2)] . cvs-mode-find-file)) - "Local keymap for text properties of directory names" - :inherit 'cvs-mode-map) + '(([(mouse-2)] . cvs-mode-toggle-mark)) + "Local keymap for text properties of status") ;; Constructor: @@ -182,14 +181,14 @@ to confuse some users sometimes." ;; In addition to the above, the following values can be extracted: ;; handled ;; t if this file doesn't require further action. - ;; full-path ;; The complete relative filename. + ;; full-name ;; The complete relative filename. ;; pp-name ;; The printed file name ;; backup-file;; For MERGED and CONFLICT files after a \"cvs update\", ;; this is a full path to the backup file where the ;; untouched version resides. ;; The meaning of the type field: - + ;; Value ---Used by--- Explanation ;; update status ;; NEED-UPDATE x file needs update @@ -212,28 +211,26 @@ to confuse some users sometimes." ;; to display a text that should be in ;; full-log." ;; TEMP A temporary message that should be removed - ;; HEADER A message that should stick at the top of the display - ;; FOOTER A message that should stick at the bottom of the display ) (defun cvs-create-fileinfo (type dir file msg &rest keys) (cvs-check-fileinfo (apply #'-cvs-create-fileinfo type dir file msg keys))) ;; Fake selectors: -(defun cvs-fileinfo->full-path (fileinfo) +(defun cvs-fileinfo->full-name (fileinfo) "Return the full path for the file that is described in FILEINFO." (let ((dir (cvs-fileinfo->dir fileinfo))) (if (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE) (if (string= dir "") "." (directory-file-name dir)) ;; Here, I use `concat' rather than `expand-file-name' because I want ;; the resulting path to stay relative if `dir' is relative. - ;; I could also use `expand-file-name' with `default-directory = ""' (concat dir (cvs-fileinfo->file fileinfo))))) +(define-obsolete-function-alias 'cvs-fileinfo->full-path 'cvs-fileinfo->full-name) (defun cvs-fileinfo->pp-name (fi) "Return the filename of FI as it should be displayed." - (if cvs-display-full-path - (cvs-fileinfo->full-path fi) + (if cvs-display-full-name + (cvs-fileinfo->full-name fi) (cvs-fileinfo->file fi))) (defun cvs-fileinfo->backup-file (fileinfo) @@ -242,13 +239,14 @@ to confuse some users sometimes." (file (cvs-fileinfo->file fileinfo)) (default-directory (file-name-as-directory (expand-file-name dir))) (files (directory-files "." nil - (concat "^" (regexp-quote cvs-bakprefix) - (regexp-quote file) "\\."))) + (concat "\\`" (regexp-quote cvs-bakprefix) + (regexp-quote file) "\\(\\.[0-9]+\\.[0-9]+\\)+\\'"))) bf) - (dolist (f files bf) + (dolist (f files) (when (and (file-readable-p f) (or (null bf) (file-newer-than-file-p f bf))) - (setq bf (concat dir f)))))) + (setq bf f))) + (concat dir bf))) ;; (defun cvs-fileinfo->handled (fileinfo) ;; "Tell if this requires further action" @@ -257,7 +255,6 @@ to confuse some users sometimes." ;; Predicate: -(defun boolp (x) (or (eq t x) (null x))) (defun cvs-check-fileinfo (fi) "Check FI's conformance to some conventions." (let ((check 'none) @@ -269,7 +266,7 @@ to confuse some users sometimes." (base-rev (cvs-fileinfo->base-rev fi)) (head-rev (cvs-fileinfo->head-rev fi)) (full-log (cvs-fileinfo->full-log fi))) - (if (and (setq check 'marked) (boolp marked) + (if (and (setq check 'marked) (memq marked '(t nil)) (setq check 'base-rev) (or (null base-rev) (stringp base-rev)) (setq check 'head-rev) (or (null head-rev) (stringp head-rev)) (setq check 'full-log) (stringp full-log) @@ -292,12 +289,12 @@ to confuse some users sometimes." (error "Invalid :%s in cvs-fileinfo %s" check fi)))) -;;;; +;;;; ;;;; State table to indicate what you can do when. -;;;; +;;;; (defconst cvs-states - `((NEED-UPDATE update diff) + `((NEED-UPDATE update diff ignore) (UP-TO-DATE update nil remove diff safe-rm revert) (MODIFIED update commit undo remove diff merge diff-base) (ADDED update commit remove) @@ -322,7 +319,6 @@ Most of the actions have the obvious meaning. ;;;; Utility functions ;;;; -;;---------- (defun cvs-applicable-p (fi-or-type func) "Check if FUNC is applicable to FI-OR-TYPE. If FUNC is nil, always return t. @@ -332,23 +328,14 @@ FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo." (and (not (eq type 'MESSAGE)) (eq (car (memq func (cdr (assq type cvs-states)))) func)))) -;; (defun cvs-default-action (fileinfo) -;; "Return some kind of \"default\" action to be performed." -;; (second (assq (cvs-fileinfo->type fileinfo) cvs-states))) - -;; fileinfo pretty-printers: - -(defun cvs-add-face (str face &optional keymap) - (when cvs-highlight - (add-text-properties 0 (length str) - (list* 'face face - (when keymap - (list 'mouse-face 'highlight - 'local-map keymap))) - str)) +(defun cvs-add-face (str face &optional keymap &rest props) + (when keymap + (when (keymapp keymap) + (setq props (list* 'keymap keymap props))) + (setq props (list* 'mouse-face 'highlight props))) + (add-text-properties 0 (length str) (list* 'font-lock-face face props) str) str) -;;---------- (defun cvs-fileinfo-pp (fileinfo) "Pretty print FILEINFO. Insert a printed representation in current buffer. For use by the cookie package." @@ -358,20 +345,18 @@ For use by the cookie package." (insert (case type (DIRCHANGE (concat "In directory " - (cvs-add-face (cvs-fileinfo->full-path fileinfo) - 'cvs-header-face cvs-dirname-map) + (cvs-add-face (cvs-fileinfo->full-name fileinfo) + 'cvs-header t 'cvs-goal-column t) ":")) (MESSAGE - (if (memq (cvs-fileinfo->subtype fileinfo) '(FOOTER HEADER)) - (cvs-fileinfo->full-log fileinfo) - (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo)) - 'cvs-msg-face))) + (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo)) + 'cvs-msg)) (t (let* ((status (if (cvs-fileinfo->marked fileinfo) - (cvs-add-face "*" 'cvs-marked-face) + (cvs-add-face "*" 'cvs-marked) " ")) (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo) - 'cvs-filename-face cvs-filename-map)) + 'cvs-filename t 'cvs-goal-column t)) (base (or (cvs-fileinfo->base-rev fileinfo) "")) (head (cvs-fileinfo->head-rev fileinfo)) (type @@ -379,10 +364,12 @@ For use by the cookie package." ;;(MOD-CONFLICT "Not Removed") (DEAD "") (t (capitalize (symbol-name type))))) - (face (case type - (UP-TO-DATE 'cvs-handled-face) - (UNKNOWN 'cvs-unknown-face) - (t 'cvs-need-action-face)))) + (face (let ((sym (intern + (concat "cvs-fi-" + (downcase (symbol-name type)) + "-face")))) + (or (and (boundp sym) (symbol-value sym)) + 'cvs-need-action)))) (cvs-add-face str face cvs-status-map))) (side (or ;; maybe a subtype @@ -390,24 +377,9 @@ For use by the cookie package." ;; or the head-rev (when (and head (not (string= head base))) head) ;; or nothing - "")) - ;; (action (cvs-add-face (case (cvs-default-action fileinfo) - ;; (commit "com") - ;; (update "upd") - ;; (undo "udo") - ;; (t " ")) - ;; 'cvs-action-face - ;; cvs-action-map)) - ) - (concat (cvs-string-fill side 11) " " - status " " - (cvs-string-fill type 11) " " - ;; action " " - (cvs-string-fill base 11) " " - file))))))) -;; it seems that `format' removes text-properties. Too bad! -;; (format "%-11s %s %-11s %-11s %s" -;; side status type base file))))))) + ""))) + (format "%-11s %s %-11s %-11s %s" + side status type base file))))))) (defun cvs-fileinfo-update (fi fi-new) @@ -424,7 +396,6 @@ For use by the cookie package." ((memq type '(UP-TO-DATE NEED-UPDATE)) (setf (cvs-fileinfo->merge fi) nil))))) -;;---------- (defun cvs-fileinfo< (a b) "Compare fileinfo A with fileinfo B and return t if A is `less'. The ordering defined by this function is such that directories are @@ -433,12 +404,6 @@ fileinfo will appear first, followed by all files (alphabetically)." (let ((subtypea (cvs-fileinfo->subtype a)) (subtypeb (cvs-fileinfo->subtype b))) (cond - ;; keep header and footer where they belong. Note: the order is important - ((eq subtypeb 'HEADER) nil) - ((eq subtypea 'HEADER) t) - ((eq subtypea 'FOOTER) nil) - ((eq subtypeb 'FOOTER) t) - ;; Sort according to directories. ((string< (cvs-fileinfo->dir a) (cvs-fileinfo->dir b)) t) ((not (string= (cvs-fileinfo->dir a) (cvs-fileinfo->dir b))) nil) @@ -450,6 +415,79 @@ fileinfo will appear first, followed by all files (alphabetically)." ;; All files are sorted by file name. ((string< (cvs-fileinfo->file a) (cvs-fileinfo->file b)))))) +;;; +;;; Look at CVS/Entries to quickly find a first approximation of the status +;;; + +(defun cvs-fileinfo-from-entries (dir &optional all) + "List of fileinfos for DIR, extracted from CVS/Entries. +Unless ALL is optional, returns only the files that are not up-to-date. +DIR can also be a file." + (let* ((singlefile + (cond + ((equal dir "") nil) + ((file-directory-p dir) (setq dir (file-name-as-directory dir)) nil) + (t (prog1 (file-name-nondirectory dir) + (setq dir (or (file-name-directory dir) "")))))) + (file (expand-file-name "CVS/Entries" dir)) + (fis nil)) + (if (not (file-readable-p file)) + (push (cvs-create-fileinfo (if singlefile 'UNKNOWN 'DIRCHANGE) + dir (or singlefile ".") "") fis) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + ;; Select the single file entry in case we're only interested in a file. + (cond + ((not singlefile) + (push (cvs-create-fileinfo 'DIRCHANGE dir "." "") fis)) + ((re-search-forward + (concat "^[^/]*/" (regexp-quote singlefile) "/.*") nil t) + (setq all t) + (goto-char (match-beginning 0)) + (narrow-to-region (point) (match-end 0))) + (t + (push (cvs-create-fileinfo 'UNKNOWN dir singlefile "") fis) + (narrow-to-region (point-min) (point-min)))) + (while (looking-at "\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/") + (if (/= (match-beginning 1) (match-end 1)) + (setq fis (append (cvs-fileinfo-from-entries + (concat dir (file-name-as-directory + (match-string 2))) + all) + fis)) + (let ((f (match-string 2)) + (rev (match-string 3)) + (date (match-string 4)) + timestamp + (type 'MODIFIED) + (subtype nil)) + (cond + ((equal (substring rev 0 1) "-") + (setq type 'REMOVED rev (substring rev 1))) + ((not (file-exists-p (concat dir f))) (setq type 'MISSING)) + ((equal rev "0") (setq type 'ADDED rev nil)) + ((equal date "Result of merge") (setq subtype 'MERGED)) + ((let ((mtime (nth 5 (file-attributes (concat dir f)))) + (system-time-locale "C")) + (setq timestamp (format-time-string "%c" mtime 'utc)) + ;; Solaris sometimes uses "Wed Sep 05", not "Wed Sep 5". + ;; See "grep '[^a-z_]ctime' cvs/src/*.c" for reference. + (if (= (aref timestamp 8) ?0) + (setq timestamp (concat (substring timestamp 0 8) + " " (substring timestamp 9)))) + (equal timestamp date)) + (setq type (if all 'UP-TO-DATE))) + ((equal date (concat "Result of merge+" timestamp)) + (setq type 'CONFLICT))) + (when type + (push (cvs-create-fileinfo type dir f "" + :base-rev rev :subtype subtype) + fis)))) + (forward-line 1)))) + fis)) + (provide 'pcvs-info) -;;; pcl-cvs-info.el ends here +;; arch-tag: d85dde07-bdc2-400a-882f-92f398c7b0ba +;;; pcvs-info.el ends here