lisp/pcvs-info.el

   1 ;;; pcvs-info.el --- internal representation of a fileinfo entry
   2
   3 ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4 ;;   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   5 ;;   Free Software Foundation, Inc.
   6
   7 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   8 ;; Keywords: pcl-cvs
   9
  10 ;; This file is part of GNU Emacs.
  11
  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
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; The cvs-fileinfo data structure:
  30 ;;
  31 ;; When the `cvs update' is ready we parse the output.  Every file
  32 ;; that is affected in some way is added to the cookie collection as
  33 ;; a "fileinfo" (as defined below in cvs-create-fileinfo).
  34
  35 ;;; Code:
  36
  37 (eval-when-compile (require 'cl))
  38 (require 'pcvs-util)
  39 ;;(require 'pcvs-defs)
  40
  41 ;;;;
  42 ;;;; config variables
  43 ;;;;
  44
  45 (define-obsolete-variable-alias 'cvs-display-full-path
  46     'cvs-display-full-name "22.1")
  47
  48 (defcustom cvs-display-full-name t
  49   "*Specifies how the filenames should be displayed in the listing.
  50 If non-nil, their full filename name will be displayed, else only the
  51 non-directory part."
  52   :group 'pcl-cvs
  53   :type '(boolean))
  54
  55 (defcustom cvs-allow-dir-commit nil
  56   "*Allow `cvs-mode-commit' on directories.
  57 If you commit without any marked file and with the cursor positioned
  58 on a directory entry, cvs would commit the whole directory.  This seems
  59 to confuse some users sometimes."
  60   :group 'pcl-cvs
  61   :type '(boolean))
  62
  63 ;;;;
  64 ;;;; Faces for fontification
  65 ;;;;
  66
  67 (defface cvs-header
  68   '((((class color) (background dark))
  69      (:foreground "lightyellow" :weight bold))
  70     (((class color) (background light))
  71      (:foreground "blue4" :weight bold))
  72     (t (:weight bold)))
  73   "PCL-CVS face used to highlight directory changes."
  74   :group 'pcl-cvs)
  75 ;; backward-compatibility alias
  76 (put 'cvs-header-face 'face-alias 'cvs-header)
  77
  78 (defface cvs-filename
  79   '((((class color) (background dark))
  80      (:foreground "lightblue"))
  81     (((class color) (background light))
  82      (:foreground "blue4"))
  83     (t ()))
  84   "PCL-CVS face used to highlight file names."
  85   :group 'pcl-cvs)
  86 ;; backward-compatibility alias
  87 (put 'cvs-filename-face 'face-alias 'cvs-filename)
  88
  89 (defface cvs-unknown
  90   '((((class color) (background dark))
  91      (:foreground "red1"))
  92     (((class color) (background light))
  93      (:foreground "red1"))
  94     (t (:slant italic)))
  95   "PCL-CVS face used to highlight unknown file status."
  96   :group 'pcl-cvs)
  97 ;; backward-compatibility alias
  98 (put 'cvs-unknown-face 'face-alias 'cvs-unknown)
  99
 100 (defface cvs-handled
 101   '((((class color) (background dark))
 102      (:foreground "pink"))
 103     (((class color) (background light))
 104      (:foreground "pink"))
 105     (t ()))
 106   "PCL-CVS face used to highlight handled file status."
 107   :group 'pcl-cvs)
 108 ;; backward-compatibility alias
 109 (put 'cvs-handled-face 'face-alias 'cvs-handled)
 110
 111 (defface cvs-need-action
 112   '((((class color) (background dark))
 113      (:foreground "orange"))
 114     (((class color) (background light))
 115      (:foreground "orange"))
 116     (t (:slant italic)))
 117   "PCL-CVS face used to highlight status of files needing action."
 118   :group 'pcl-cvs)
 119 ;; backward-compatibility alias
 120 (put 'cvs-need-action-face 'face-alias 'cvs-need-action)
 121
 122 (defface cvs-marked
 123   '((((min-colors 88) (class color) (background dark))
 124      (:foreground "green1" :weight bold))
 125     (((class color) (background dark))
 126      (:foreground "green" :weight bold))
 127     (((class color) (background light))
 128      (:foreground "green3" :weight bold))
 129     (t (:weight bold)))
 130   "PCL-CVS face used to highlight marked file indicator."
 131   :group 'pcl-cvs)
 132 ;; backward-compatibility alias
 133 (put 'cvs-marked-face 'face-alias 'cvs-marked)
 134
 135 (defface cvs-msg
 136   '((t (:slant italic)))
 137   "PCL-CVS face used to highlight CVS messages."
 138   :group 'pcl-cvs)
 139 ;; backward-compatibility alias
 140 (put 'cvs-msg-face 'face-alias 'cvs-msg)
 141
 142 (defvar cvs-fi-up-to-date-face 'cvs-handled)
 143 (defvar cvs-fi-unknown-face 'cvs-unknown)
 144 (defvar cvs-fi-conflict-face 'font-lock-warning-face)
 145
 146 ;; There is normally no need to alter the following variable, but if
 147 ;; your site has installed CVS in a non-standard way you might have
 148 ;; to change it.
 149
 150 (defvar cvs-bakprefix ".#"
 151   "The prefix that CVS prepends to files when rcsmerge'ing.")
 152
 153 (easy-mmode-defmap cvs-status-map
 154   '(([(mouse-2)] . cvs-mode-toggle-mark))
 155   "Local keymap for text properties of status")
 156
 157 ;; Constructor:
 158
 159 (defstruct (cvs-fileinfo
 160             (:constructor nil)
 161             (:copier nil)
 162             (:constructor -cvs-create-fileinfo (type dir file full-log
 163                                                      &key marked subtype
 164                                                      merge
 165                                                      base-rev
 166                                                      head-rev))
 167             (:conc-name cvs-fileinfo->))
 168   marked        ;; t/nil.
 169   type          ;; See below
 170   subtype       ;; See below
 171   dir           ;; Relative directory the file resides in.
 172                 ;; (concat dir file) should give a valid path.
 173   file          ;; The file name sans the directory.
 174   base-rev      ;; During status: This is the revision that the
 175                 ;; working file is based on.
 176   head-rev      ;; During status: This is the highest revision in
 177                 ;; the repository.
 178   merge         ;; A cons cell containing the (ancestor . head) revisions
 179                 ;; of the merge that resulted in the current file.
 180   ;;removed     ;; t if the file no longer exists.
 181   full-log      ;; The output from cvs, unparsed.
 182   ;;mod-time    ;; Not used.
 183
 184   ;; In addition to the above, the following values can be extracted:
 185
 186   ;; handled    ;; t if this file doesn't require further action.
 187   ;; full-name  ;; The complete relative filename.
 188   ;; pp-name    ;; The printed file name
 189   ;; backup-file;; For MERGED and CONFLICT files after a \"cvs update\",
 190                 ;; this is a full path to the backup file where the
 191                 ;; untouched version resides.
 192
 193   ;; The meaning of the type field:
 194
 195   ;; Value            ---Used by---     Explanation
 196   ;;                  update status
 197   ;; NEED-UPDATE                x       file needs update
 198   ;; MODIFIED           x       x       modified by you, unchanged in repository
 199   ;;   MERGED           x       x       successful merge
 200   ;; ADDED              x       x       added by you, not yet committed
 201   ;; MISSING                    x       rm'd, but not yet `cvs remove'd
 202   ;; REMOVED            x       x       removed by you, not yet committed
 203   ;; NEED-MERGE                 x       need merge
 204   ;; CONFLICT           x               conflict when merging
 205   ;; ;;MOD-CONFLICT     x               removed locally, changed in repository.
 206   ;; DIRCHANGE          x       x       A change of directory.
 207   ;; UNKNOWN            x               An unknown file.
 208   ;; UP-TO-DATE                 x       The file is up-to-date.
 209   ;;   UPDATED          x       x       file copied from repository
 210   ;;   PATCHED          x       x       diff applied from repository
 211   ;;   COMMITTED                x       x       cvs commit'd
 212   ;; DEAD                               An entry that should be removed
 213   ;; MESSAGE            x       x       This is a special fileinfo that is used
 214   ;;                                      to display a text that should be in
 215   ;;                                      full-log."
 216   ;;   TEMP     A temporary message that should be removed
 217   )
 218 (defun cvs-create-fileinfo (type dir file msg &rest keys)
 219   (cvs-check-fileinfo (apply #'-cvs-create-fileinfo type dir file msg keys)))
 220
 221 ;; Fake selectors:
 222
 223 (defun cvs-fileinfo->full-name (fileinfo)
 224   "Return the full path for the file that is described in FILEINFO."
 225   (let ((dir (cvs-fileinfo->dir fileinfo)))
 226     (if (eq (cvs-fileinfo->type fileinfo) 'DIRCHANGE)
 227         (if (string= dir "") "." (directory-file-name dir))
 228       ;; Here, I use `concat' rather than `expand-file-name' because I want
 229       ;; the resulting path to stay relative if `dir' is relative.
 230       (concat dir (cvs-fileinfo->file fileinfo)))))
 231 (define-obsolete-function-alias 'cvs-fileinfo->full-path
 232     'cvs-fileinfo->full-name "22.1")
 233
 234 (defun cvs-fileinfo->pp-name (fi)
 235   "Return the filename of FI as it should be displayed."
 236   (if cvs-display-full-name
 237       (cvs-fileinfo->full-name fi)
 238     (cvs-fileinfo->file fi)))
 239
 240 (defun cvs-fileinfo->backup-file (fileinfo)
 241   "Construct the file name of the backup file for FILEINFO."
 242   (let* ((dir (cvs-fileinfo->dir fileinfo))
 243          (file (cvs-fileinfo->file fileinfo))
 244          (default-directory (file-name-as-directory (expand-file-name dir)))
 245          (files (directory-files "." nil
 246                                  (concat "\\`" (regexp-quote cvs-bakprefix)
 247                                          (regexp-quote file) "\\(\\.[0-9]+\\.[0-9]+\\)+\\'")))
 248          bf)
 249     (dolist (f files)
 250       (when (and (file-readable-p f)
 251                  (or (null bf) (file-newer-than-file-p f bf)))
 252         (setq bf f)))
 253     (concat dir bf)))
 254
 255 ;; (defun cvs-fileinfo->handled (fileinfo)
 256 ;;   "Tell if this requires further action"
 257 ;;   (memq (cvs-fileinfo->type fileinfo) '(UP-TO-DATE DEAD)))
 258
 259 \f
 260 ;; Predicate:
 261
 262 (defun cvs-check-fileinfo (fi)
 263   "Check FI's conformance to some conventions."
 264   (let ((check 'none)
 265         (type (cvs-fileinfo->type fi))
 266         (subtype (cvs-fileinfo->subtype fi))
 267         (marked (cvs-fileinfo->marked fi))
 268         (dir (cvs-fileinfo->dir fi))
 269         (file (cvs-fileinfo->file fi))
 270         (base-rev (cvs-fileinfo->base-rev fi))
 271         (head-rev (cvs-fileinfo->head-rev fi))
 272         (full-log (cvs-fileinfo->full-log fi)))
 273     (if (and (setq check 'marked)       (memq marked '(t nil))
 274              (setq check 'base-rev)     (or (null base-rev) (stringp base-rev))
 275              (setq check 'head-rev)     (or (null head-rev) (stringp head-rev))
 276              (setq check 'full-log)     (stringp full-log)
 277              (setq check 'dir)
 278              (and (stringp dir)
 279                   (not (file-name-absolute-p dir))
 280                   (or (string= dir "")
 281                       (string= dir (file-name-as-directory dir))))
 282              (setq check 'file)
 283              (and (stringp file)
 284                   (string= file (file-name-nondirectory file)))
 285              (setq check 'type)         (symbolp type)
 286              (setq check 'consistency)
 287              (case type
 288                (DIRCHANGE (and (null subtype) (string= "." file)))
 289                ((NEED-UPDATE ADDED MISSING DEAD MODIFIED MESSAGE UP-TO-DATE
 290                              REMOVED NEED-MERGE CONFLICT UNKNOWN MESSAGE)
 291                 t)))
 292         fi
 293       (error "Invalid :%s in cvs-fileinfo %s" check fi))))
 294
 295 \f
 296 ;;;;
 297 ;;;; State table to indicate what you can do when.
 298 ;;;;
 299
 300 (defconst cvs-states
 301   `((NEED-UPDATE        update diff ignore)
 302     (UP-TO-DATE         update nil remove diff safe-rm revert)
 303     (MODIFIED           update commit undo remove diff merge diff-base)
 304     (ADDED              update commit remove)
 305     (MISSING            remove undo update safe-rm revert)
 306     (REMOVED            commit add undo safe-rm)
 307     (NEED-MERGE         update undo diff diff-base)
 308     (CONFLICT           merge remove undo commit diff diff-base)
 309     (DIRCHANGE          remove update diff ,(if cvs-allow-dir-commit 'commit) tag)
 310     (UNKNOWN            ignore add remove)
 311     (DEAD               )
 312     (MESSAGE))
 313   "Fileinfo state descriptions for pcl-cvs.
 314 This is an assoc list.  Each element consists of (STATE . FUNS)
 315 - STATE (described in `cvs-create-fileinfo') is the key
 316 - FUNS is the list of applicable operations.
 317   The first one (if any) should be the \"default\" action.
 318 Most of the actions have the obvious meaning.
 319 `safe-rm' indicates that the file can be removed without losing
 320   any information.")
 321
 322 ;;;;
 323 ;;;; Utility functions
 324 ;;;;
 325
 326 (defun cvs-applicable-p (fi-or-type func)
 327   "Check if FUNC is applicable to FI-OR-TYPE.
 328 If FUNC is nil, always return t.
 329 FI-OR-TYPE can either be a symbol (a fileinfo-type) or a fileinfo."
 330   (let ((type (if (symbolp fi-or-type) fi-or-type
 331                 (cvs-fileinfo->type fi-or-type))))
 332     (and (not (eq type 'MESSAGE))
 333          (eq (car (memq func (cdr (assq type cvs-states)))) func))))
 334
 335 (defun cvs-add-face (str face &optional keymap &rest props)
 336   (when keymap
 337     (when (keymapp keymap)
 338       (setq props (list* 'keymap keymap props)))
 339     (setq props (list* 'mouse-face 'highlight props)))
 340   (add-text-properties 0 (length str) (list* 'font-lock-face face props) str)
 341   str)
 342
 343 (defun cvs-fileinfo-pp (fileinfo)
 344   "Pretty print FILEINFO.  Insert a printed representation in current buffer.
 345 For use by the cookie package."
 346   (cvs-check-fileinfo fileinfo)
 347   (let ((type (cvs-fileinfo->type fileinfo))
 348         (subtype (cvs-fileinfo->subtype fileinfo)))
 349     (insert
 350      (case type
 351        (DIRCHANGE (concat "In directory "
 352                           (cvs-add-face (cvs-fileinfo->full-name fileinfo)
 353                                         'cvs-header t 'cvs-goal-column t)
 354                           ":"))
 355        (MESSAGE
 356         (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo))
 357                       'cvs-msg))
 358        (t
 359         (let* ((status (if (cvs-fileinfo->marked fileinfo)
 360                            (cvs-add-face "*" 'cvs-marked)
 361                          " "))
 362                (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo)
 363                                    'cvs-filename t 'cvs-goal-column t))
 364                (base (or (cvs-fileinfo->base-rev fileinfo) ""))
 365                (head (cvs-fileinfo->head-rev fileinfo))
 366                (type
 367                 (let ((str (case type
 368                              ;;(MOD-CONFLICT "Not Removed")
 369                              (DEAD        "")
 370                              (t (capitalize (symbol-name type)))))
 371                       (face (let ((sym (intern
 372                                         (concat "cvs-fi-"
 373                                                 (downcase (symbol-name type))
 374                                                 "-face"))))
 375                               (or (and (boundp sym) (symbol-value sym))
 376                                   'cvs-need-action))))
 377                   (cvs-add-face str face cvs-status-map)))
 378                (side (or
 379                       ;; maybe a subtype
 380                       (when subtype (downcase (symbol-name subtype)))
 381                       ;; or the head-rev
 382                       (when (and head (not (string= head base))) head)
 383                       ;; or nothing
 384                       "")))
 385            (format "%-11s %s %-11s %-11s %s"
 386                    side status type base file))))
 387      "\n")))
 388
 389
 390 (defun cvs-fileinfo-update (fi fi-new)
 391   "Update FI with the information provided in FI-NEW."
 392   (let ((type (cvs-fileinfo->type fi-new))
 393         (merge (cvs-fileinfo->merge fi-new)))
 394     (setf (cvs-fileinfo->type fi) type)
 395     (setf (cvs-fileinfo->subtype fi) (cvs-fileinfo->subtype fi-new))
 396     (setf (cvs-fileinfo->full-log fi) (cvs-fileinfo->full-log fi-new))
 397     (setf (cvs-fileinfo->base-rev fi) (cvs-fileinfo->base-rev fi-new))
 398     (setf (cvs-fileinfo->head-rev fi) (cvs-fileinfo->head-rev fi-new))
 399     (cond
 400      (merge (setf (cvs-fileinfo->merge fi) merge))
 401      ((memq type '(UP-TO-DATE NEED-UPDATE))
 402       (setf (cvs-fileinfo->merge fi) nil)))))
 403
 404 (defun cvs-fileinfo< (a b)
 405   "Compare fileinfo A with fileinfo B and return t if A is `less'.
 406 The ordering defined by this function is such that directories are
 407 sorted alphabetically, and inside every directory the DIRCHANGE
 408 fileinfo will appear first, followed by all files (alphabetically)."
 409   (let ((subtypea (cvs-fileinfo->subtype a))
 410         (subtypeb (cvs-fileinfo->subtype b)))
 411     (cond
 412      ;; Sort according to directories.
 413      ((string< (cvs-fileinfo->dir a) (cvs-fileinfo->dir b)) t)
 414      ((not (string= (cvs-fileinfo->dir a) (cvs-fileinfo->dir b))) nil)
 415
 416      ;; The DIRCHANGE entry is always first within the directory.
 417      ((eq (cvs-fileinfo->type b) 'DIRCHANGE) nil)
 418      ((eq (cvs-fileinfo->type a) 'DIRCHANGE) t)
 419
 420      ;; All files are sorted by file name.
 421      ((string< (cvs-fileinfo->file a) (cvs-fileinfo->file b))))))
 422
 423 ;;;
 424 ;;; Look at CVS/Entries to quickly find a first approximation of the status
 425 ;;;
 426
 427 (defun cvs-fileinfo-from-entries (dir &optional all)
 428   "List of fileinfos for DIR, extracted from CVS/Entries.
 429 Unless ALL is optional, returns only the files that are not up-to-date.
 430 DIR can also be a file."
 431   (let* ((singlefile
 432           (cond
 433            ((equal dir "") nil)
 434            ((file-directory-p dir) (setq dir (file-name-as-directory dir)) nil)
 435            (t (prog1 (file-name-nondirectory dir)
 436                 (setq dir (or (file-name-directory dir) ""))))))
 437          (file (expand-file-name "CVS/Entries" dir))
 438          (fis nil))
 439     (if (not (file-readable-p file))
 440         (push (cvs-create-fileinfo (if singlefile 'UNKNOWN 'DIRCHANGE)
 441                                    dir (or singlefile ".") "") fis)
 442       (with-temp-buffer
 443         (insert-file-contents file)
 444         (goto-char (point-min))
 445         ;; Select the single file entry in case we're only interested in a file.
 446         (cond
 447          ((not singlefile)
 448           (push (cvs-create-fileinfo 'DIRCHANGE dir "." "") fis))
 449          ((re-search-forward
 450            (concat "^[^/]*/" (regexp-quote singlefile) "/.*") nil t)
 451           (setq all t)
 452           (goto-char (match-beginning 0))
 453           (narrow-to-region (point) (match-end 0)))
 454          (t
 455           (push (cvs-create-fileinfo 'UNKNOWN dir singlefile "") fis)
 456           (narrow-to-region (point-min) (point-min))))
 457         (while (looking-at "\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/\\([^/]*\\)/")
 458           (if (/= (match-beginning 1) (match-end 1))
 459               (setq fis (append (cvs-fileinfo-from-entries
 460                                  (concat dir (file-name-as-directory
 461                                               (match-string 2)))
 462                                  all)
 463                                 fis))
 464             (let ((f (match-string 2))
 465                   (rev (match-string 3))
 466                   (date (match-string 4))
 467                   timestamp
 468                   (type 'MODIFIED)
 469                   (subtype nil))
 470               (cond
 471                ((equal (substring rev 0 1) "-")
 472                 (setq type 'REMOVED rev (substring rev 1)))
 473                ((not (file-exists-p (concat dir f))) (setq type 'MISSING))
 474                ((equal rev "0") (setq type 'ADDED rev nil))
 475                ((equal date "Result of merge") (setq subtype 'MERGED))
 476                ((let ((mtime (nth 5 (file-attributes (concat dir f))))
 477                       (system-time-locale "C"))
 478                   (setq timestamp (format-time-string "%c" mtime 'utc))
 479                   ;; Solaris sometimes uses "Wed Sep 05", not "Wed Sep  5".
 480                   ;; See "grep '[^a-z_]ctime' cvs/src/*.c" for reference.
 481                   (if (= (aref timestamp 8) ?0)
 482                       (setq timestamp (concat (substring timestamp 0 8)
 483                                               " " (substring timestamp 9))))
 484                   (equal timestamp date))
 485                 (setq type (if all 'UP-TO-DATE)))
 486                ((equal date (concat "Result of merge+" timestamp))
 487                 (setq type 'CONFLICT)))
 488               (when type
 489                 (push (cvs-create-fileinfo type dir f ""
 490                                            :base-rev rev :subtype subtype)
 491                       fis))))
 492           (forward-line 1))))
 493     fis))
 494
 495 (provide 'pcvs-info)
 496
 497 ;; arch-tag: d85dde07-bdc2-400a-882f-92f398c7b0ba
 498 ;;; pcvs-info.el ends here