comparison lisp/pcvs-info.el @ 88155:d7ddb3e565de

sync with trunk

88154:8ce476d3ba36

;;; 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 <[e-mail]>
;; 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

;; 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:
;;

;;;;
;;;; 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

;;;;
;;;; 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

  ;;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.

(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)))

;;;;
;;;; 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)

  (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")

		      (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

	  (forward-line 1))))
    fis))

(provide 'pcvs-info)

;;; pcvs-info.el ends here

88155:d7ddb3e565de

;;; pcvs-info.el --- internal representation of a fileinfo entry

;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
;;   2000, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.

;; Author: Stefan Monnier <[e-mail]>
;; Keywords: pcl-cvs

;; 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

;; 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; The cvs-fileinfo data structure:
;;

;;;;
;;;; config variables
;;;;

(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.
If you commit without any marked file and with the cursor positioned
on a directory entry, cvs would commit the whole directory.  This seems

;;;;
;;;; Faces for fontification
;;;;

(defface cvs-header
  '((((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)
;; backward-compatibility alias
(put 'cvs-header-face 'face-alias 'cvs-header)

(defface cvs-filename
  '((((class color) (background dark))
     (:foreground "lightblue"))
    (((class color) (background light))
     (:foreground "blue4"))
    (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
  '((((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)
;; backward-compatibility alias
(put 'cvs-unknown-face 'face-alias 'cvs-unknown)

(defface cvs-handled
  '((((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)
;; backward-compatibility alias
(put 'cvs-handled-face 'face-alias 'cvs-handled)

(defface cvs-need-action
  '((((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)
;; 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" :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
  '((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
;; 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-mode-toggle-mark))
  "Local keymap for text properties of status")

;; Constructor:

(defstruct (cvs-fileinfo

  ;;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-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.

(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-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.
      (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-name
      (cvs-fileinfo->full-name 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) "\\(\\.[0-9]+\\.[0-9]+\\)+\\'")))
	 bf)
    (dolist (f files)
      (when (and (file-readable-p f)
		 (or (null bf) (file-newer-than-file-p f bf)))
	(setq bf f)))
    (concat dir bf)))

;; (defun cvs-fileinfo->handled (fileinfo)
;;   "Tell if this requires further action"
;;   (memq (cvs-fileinfo->type fileinfo) '(UP-TO-DATE DEAD)))

;;;;
;;;; State table to indicate what you can do when.
;;;;

(defconst cvs-states
  `((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)
    (MISSING     	remove undo update safe-rm revert)
    (REMOVED     	commit add undo safe-rm)

  (let ((type (cvs-fileinfo->type fileinfo))
	(subtype (cvs-fileinfo->subtype fileinfo)))
    (insert
     (case type
       (DIRCHANGE (concat "In directory "
			  (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))
       (t
	(let* ((status (if (cvs-fileinfo->marked fileinfo)
			   (cvs-add-face "*" 'cvs-marked)
			 " "))
	       (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo)
				   'cvs-filename 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")

		      (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
		      (when subtype (downcase (symbol-name subtype)))
		      ;; or the head-rev

	  (forward-line 1))))
    fis))

(provide 'pcvs-info)

;; arch-tag: d85dde07-bdc2-400a-882f-92f398c7b0ba
;;; pcvs-info.el ends here