X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/cb3430a1f76f18e76cd3436e02346222895bd657..f67b40b3d890918f1e856a5052f86c3c724f0658:/lisp/pcvs-info.el diff --git a/lisp/pcvs-info.el b/lisp/pcvs-info.el index 0adb7b680e..983e451a40 100644 --- a/lisp/pcvs-info.el +++ b/lisp/pcvs-info.el @@ -1,18 +1,18 @@ -;;; 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, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 +;; Free Software Foundation, Inc. -;; Author: Stefan Monnier +;; Author: Stefan Monnier ;; Keywords: pcl-cvs -;; Version: $Name: $ -;; Revision: $Id: pcvs-info.el,v 1.1 2000/03/11 03:42:29 monnier Exp $ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -20,9 +20,7 @@ ;; GNU General Public License for more details. ;; 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. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -42,18 +40,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)) +(define-obsolete-variable-alias 'cvs-display-full-path + 'cvs-display-full-name "22.1") -(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)) @@ -65,21 +58,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 +81,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")) + (:foreground "red1")) (((class color) (background light)) - (:foreground "red")) - (t (:italic t))) + (:foreground "red1")) + (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 +103,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 +148,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 +182,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 @@ -218,20 +218,21 @@ to confuse some users sometimes." ;; 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 "22.1") (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) @@ -240,13 +241,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" @@ -255,7 +257,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) @@ -267,7 +268,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) @@ -290,12 +291,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) @@ -320,7 +321,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. @@ -330,23 +330,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." @@ -356,18 +347,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 (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo)) - 'cvs-msg-face)) + '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 @@ -375,10 +366,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 @@ -387,8 +380,9 @@ For use by the cookie package." (when (and head (not (string= head base))) head) ;; or nothing ""))) - (format "%-11s %s %-11s %-11s %s" - side status type base file))))))) + (format "%-11s %s %-11s %-11s %s" + side status type base file)))) + "\n"))) (defun cvs-fileinfo-update (fi fi-new) @@ -405,7 +399,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 @@ -425,6 +418,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