mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-24 07:20:37 +00:00
475 lines
16 KiB
EmacsLisp
475 lines
16 KiB
EmacsLisp
;;; pcvs-info.el --- internal representation of a fileinfo entry
|
||
|
||
;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
|
||
|
||
;; Author: Stefan Monnier <monnier@cs.yale.edu>
|
||
;; Keywords: pcl-cvs
|
||
;; Revision: $Id: pcvs-info.el,v 1.14 2003/01/14 21:53:39 monnier Exp $
|
||
|
||
;; This file is part of GNU Emacs.
|
||
|
||
;; 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.
|
||
|
||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; 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.
|
||
|
||
;;; Commentary:
|
||
|
||
;; The cvs-fileinfo data structure:
|
||
;;
|
||
;; When the `cvs update' is ready we parse the output. Every file
|
||
;; that is affected in some way is added to the cookie collection as
|
||
;; a "fileinfo" (as defined below in cvs-create-fileinfo).
|
||
|
||
;;; Code:
|
||
|
||
(eval-when-compile (require 'cl))
|
||
(require 'pcvs-util)
|
||
;;(require 'pcvs-defs)
|
||
|
||
;;;;
|
||
;;;; 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))
|
||
|
||
(defcustom cvs-allow-dir-commit nil
|
||
"*Allow `cvs-mode-commit' on directories.
|
||
If you commit without any marked file and with the cursor positioned
|
||
on a directory entry, cvs would commit the whole directory. This seems
|
||
to confuse some users sometimes."
|
||
:group 'pcl-cvs
|
||
:type '(boolean))
|
||
|
||
;;;;
|
||
;;;; Faces for fontification
|
||
;;;;
|
||
|
||
(defface cvs-header-face
|
||
'((((class color) (background dark))
|
||
(:foreground "lightyellow" :weight bold))
|
||
(((class color) (background light))
|
||
(:foreground "blue4" :weight bold))
|
||
(t (:weight bold)))
|
||
"PCL-CVS face used to highlight directory changes."
|
||
:group 'pcl-cvs)
|
||
|
||
(defface cvs-filename-face
|
||
'((((class color) (background dark))
|
||
(:foreground "lightblue"))
|
||
(((class color) (background light))
|
||
(:foreground "blue4"))
|
||
(t ()))
|
||
"PCL-CVS face used to highlight file names."
|
||
:group 'pcl-cvs)
|
||
|
||
(defface cvs-unknown-face
|
||
'((((class color) (background dark))
|
||
(:foreground "red"))
|
||
(((class color) (background light))
|
||
(:foreground "red"))
|
||
(t (:slant italic)))
|
||
"PCL-CVS face used to highlight unknown file status."
|
||
:group 'pcl-cvs)
|
||
|
||
(defface cvs-handled-face
|
||
'((((class color) (background dark))
|
||
(:foreground "pink"))
|
||
(((class color) (background light))
|
||
(:foreground "pink"))
|
||
(t ()))
|
||
"PCL-CVS face used to highlight handled file status."
|
||
:group 'pcl-cvs)
|
||
|
||
(defface cvs-need-action-face
|
||
'((((class color) (background dark))
|
||
(:foreground "orange"))
|
||
(((class color) (background light))
|
||
(:foreground "orange"))
|
||
(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" :weight bold))
|
||
(((class color) (background light))
|
||
(:foreground "green3" :weight bold))
|
||
(t (:weight bold)))
|
||
"PCL-CVS face used to highlight marked file indicator."
|
||
:group 'pcl-cvs)
|
||
|
||
(defface cvs-msg-face
|
||
'((t (:slant italic)))
|
||
"PCL-CVS face used to highlight CVS messages."
|
||
:group 'pcl-cvs)
|
||
|
||
(defvar cvs-fi-up-to-date-face 'cvs-handled-face)
|
||
(defvar cvs-fi-unknown-face 'cvs-unknown-face)
|
||
(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
|
||
;; to change it.
|
||
|
||
(defvar cvs-bakprefix ".#"
|
||
"The prefix that CVS prepends to files when rcsmerge'ing.")
|
||
|
||
(easy-mmode-defmap cvs-status-map
|
||
'(([(mouse-2)] . cvs-mouse-toggle-mark))
|
||
"Local keymap for text properties of status")
|
||
|
||
;; Constructor:
|
||
|
||
(defstruct (cvs-fileinfo
|
||
(:constructor nil)
|
||
(:copier nil)
|
||
(:constructor -cvs-create-fileinfo (type dir file full-log
|
||
&key marked subtype
|
||
merge
|
||
base-rev
|
||
head-rev))
|
||
(:conc-name cvs-fileinfo->))
|
||
marked ;; t/nil.
|
||
type ;; See below
|
||
subtype ;; See below
|
||
dir ;; Relative directory the file resides in.
|
||
;; (concat dir file) should give a valid path.
|
||
file ;; The file name sans the directory.
|
||
base-rev ;; During status: This is the revision that the
|
||
;; working file is based on.
|
||
head-rev ;; During status: This is the highest revision in
|
||
;; the repository.
|
||
merge ;; A cons cell containing the (ancestor . head) revisions
|
||
;; of the merge that resulted in the current file.
|
||
;;removed ;; t if the file no longer exists.
|
||
full-log ;; The output from cvs, unparsed.
|
||
;;mod-time ;; Not used.
|
||
|
||
;; 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.
|
||
;; 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
|
||
;; MODIFIED x x modified by you, unchanged in repository
|
||
;; MERGED x x successful merge
|
||
;; ADDED x x added by you, not yet committed
|
||
;; MISSING x rm'd, but not yet `cvs remove'd
|
||
;; REMOVED x x removed by you, not yet committed
|
||
;; NEED-MERGE x need merge
|
||
;; CONFLICT x conflict when merging
|
||
;; ;;MOD-CONFLICT x removed locally, changed in repository.
|
||
;; DIRCHANGE x x A change of directory.
|
||
;; UNKNOWN x An unknown file.
|
||
;; UP-TO-DATE x The file is up-to-date.
|
||
;; UPDATED x x file copied from repository
|
||
;; PATCHED x x diff applied from repository
|
||
;; COMMITTED x x cvs commit'd
|
||
;; DEAD An entry that should be removed
|
||
;; MESSAGE x x This is a special fileinfo that is used
|
||
;; to display a text that should be in
|
||
;; full-log."
|
||
;; TEMP A temporary message that should be removed
|
||
)
|
||
(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)
|
||
"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.
|
||
(concat dir (cvs-fileinfo->file fileinfo)))))
|
||
|
||
(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)
|
||
(cvs-fileinfo->file fi)))
|
||
|
||
(defun cvs-fileinfo->backup-file (fileinfo)
|
||
"Construct the file name of the backup file for FILEINFO."
|
||
(let* ((dir (cvs-fileinfo->dir fileinfo))
|
||
(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) "\\.")))
|
||
bf)
|
||
(dolist (f files bf)
|
||
(when (and (file-readable-p f)
|
||
(or (null bf) (file-newer-than-file-p f bf)))
|
||
(setq bf (concat dir f))))))
|
||
|
||
;; (defun cvs-fileinfo->handled (fileinfo)
|
||
;; "Tell if this requires further action"
|
||
;; (memq (cvs-fileinfo->type fileinfo) '(UP-TO-DATE DEAD)))
|
||
|
||
|
||
;; Predicate:
|
||
|
||
(defun cvs-check-fileinfo (fi)
|
||
"Check FI's conformance to some conventions."
|
||
(let ((check 'none)
|
||
(type (cvs-fileinfo->type fi))
|
||
(subtype (cvs-fileinfo->subtype fi))
|
||
(marked (cvs-fileinfo->marked fi))
|
||
(dir (cvs-fileinfo->dir fi))
|
||
(file (cvs-fileinfo->file fi))
|
||
(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) (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)
|
||
(setq check 'dir)
|
||
(and (stringp dir)
|
||
(not (file-name-absolute-p dir))
|
||
(or (string= dir "")
|
||
(string= dir (file-name-as-directory dir))))
|
||
(setq check 'file)
|
||
(and (stringp file)
|
||
(string= file (file-name-nondirectory file)))
|
||
(setq check 'type) (symbolp type)
|
||
(setq check 'consistency)
|
||
(case type
|
||
(DIRCHANGE (and (null subtype) (string= "." file)))
|
||
((NEED-UPDATE ADDED MISSING DEAD MODIFIED MESSAGE UP-TO-DATE
|
||
REMOVED NEED-MERGE CONFLICT UNKNOWN MESSAGE)
|
||
t)))
|
||
fi
|
||
(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)
|
||
(UP-TO-DATE update nil remove diff safe-rm revert)
|
||
(MODIFIED update commit undo remove diff merge diff-base)
|
||
(ADDED update commit remove)
|
||
(MISSING remove undo update safe-rm revert)
|
||
(REMOVED commit add undo safe-rm)
|
||
(NEED-MERGE update undo diff diff-base)
|
||
(CONFLICT merge remove undo commit diff diff-base)
|
||
(DIRCHANGE remove update diff ,(if cvs-allow-dir-commit 'commit) tag)
|
||
(UNKNOWN ignore add remove)
|
||
(DEAD )
|
||
(MESSAGE))
|
||
"Fileinfo state descriptions for pcl-cvs.
|
||
This is an assoc list. Each element consists of (STATE . FUNS)
|
||
- STATE (described in `cvs-create-fileinfo') is the key
|
||
- FUNS is the list of applicable operations.
|
||
The first one (if any) should be the \"default\" action.
|
||
Most of the actions have the obvious meaning.
|
||
`safe-rm' indicates that the file can be removed without losing
|
||
any information.")
|
||
|
||
;;;;
|
||
;;;; 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.
|
||
FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo."
|
||
(let ((type (if (symbolp fi-or-type) fi-or-type
|
||
(cvs-fileinfo->type fi-or-type))))
|
||
(and (not (eq type 'MESSAGE))
|
||
(eq (car (memq func (cdr (assq type cvs-states)))) func))))
|
||
|
||
(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."
|
||
(cvs-check-fileinfo fileinfo)
|
||
(let ((type (cvs-fileinfo->type fileinfo))
|
||
(subtype (cvs-fileinfo->subtype fileinfo)))
|
||
(insert
|
||
(case type
|
||
(DIRCHANGE (concat "In directory "
|
||
(cvs-add-face (cvs-fileinfo->full-path fileinfo)
|
||
'cvs-header-face t
|
||
'cvs-goal-column t)
|
||
":"))
|
||
(MESSAGE
|
||
(cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo))
|
||
'cvs-msg-face))
|
||
(t
|
||
(let* ((status (if (cvs-fileinfo->marked fileinfo)
|
||
(cvs-add-face "*" 'cvs-marked-face)
|
||
" "))
|
||
(file (cvs-add-face (cvs-fileinfo->pp-name fileinfo)
|
||
'cvs-filename-face t
|
||
'cvs-goal-column t))
|
||
(base (or (cvs-fileinfo->base-rev fileinfo) ""))
|
||
(head (cvs-fileinfo->head-rev fileinfo))
|
||
(type
|
||
(let ((str (case type
|
||
;;(MOD-CONFLICT "Not Removed")
|
||
(DEAD "")
|
||
(t (capitalize (symbol-name type)))))
|
||
(face (let ((sym (intern
|
||
(concat "cvs-fi-"
|
||
(downcase (symbol-name type))
|
||
"-face"))))
|
||
(or (and (boundp sym) (symbol-value sym))
|
||
'cvs-need-action-face))))
|
||
(cvs-add-face str face cvs-status-map)))
|
||
(side (or
|
||
;; maybe a subtype
|
||
(when subtype (downcase (symbol-name subtype)))
|
||
;; or the head-rev
|
||
(when (and head (not (string= head base))) head)
|
||
;; or nothing
|
||
"")))
|
||
(format "%-11s %s %-11s %-11s %s"
|
||
side status type base file)))))))
|
||
|
||
|
||
(defun cvs-fileinfo-update (fi fi-new)
|
||
"Update FI with the information provided in FI-NEW."
|
||
(let ((type (cvs-fileinfo->type fi-new))
|
||
(merge (cvs-fileinfo->merge fi-new)))
|
||
(setf (cvs-fileinfo->type fi) type)
|
||
(setf (cvs-fileinfo->subtype fi) (cvs-fileinfo->subtype fi-new))
|
||
(setf (cvs-fileinfo->full-log fi) (cvs-fileinfo->full-log fi-new))
|
||
(setf (cvs-fileinfo->base-rev fi) (cvs-fileinfo->base-rev fi-new))
|
||
(setf (cvs-fileinfo->head-rev fi) (cvs-fileinfo->head-rev fi-new))
|
||
(cond
|
||
(merge (setf (cvs-fileinfo->merge fi) merge))
|
||
((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
|
||
sorted alphabetically, and inside every directory the DIRCHANGE
|
||
fileinfo will appear first, followed by all files (alphabetically)."
|
||
(let ((subtypea (cvs-fileinfo->subtype a))
|
||
(subtypeb (cvs-fileinfo->subtype b)))
|
||
(cond
|
||
;; 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)
|
||
|
||
;; The DIRCHANGE entry is always first within the directory.
|
||
((eq (cvs-fileinfo->type b) 'DIRCHANGE) nil)
|
||
((eq (cvs-fileinfo->type a) 'DIRCHANGE) t)
|
||
|
||
;; 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)
|
||
|
||
;;; pcvs-info.el ends here
|