Mercurial > emacs
comparison lisp/pcvs-info.el @ 28088:b442dfc3cef0
*** empty log message ***
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Sat, 11 Mar 2000 03:51:31 +0000 |
parents | |
children | 06cfa273543d |
comparison
equal
deleted
inserted
replaced
28087:9ca294cf76c7 | 28088:b442dfc3cef0 |
---|---|
1 ;;; pcvs-info.el --- Internal representation of a fileinfo entry | |
2 | |
3 ;; Copyright (C) 1991-2000 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Stefan Monnier <monnier@cs.yale.edu> | |
6 ;; Keywords: pcl-cvs | |
7 ;; Version: $Name: $ | |
8 ;; Revision: $Id: pcl-cvs-info.el,v 1.28 2000/03/05 21:32:21 monnier Exp $ | |
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 2, 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., 59 Temple Place - Suite 330, | |
25 ;; Boston, MA 02111-1307, 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 (defcustom cvs-display-full-path t | |
46 "*Specifies how the filenames should look like in the listing. | |
47 If t, their full path name will be displayed, else only the filename." | |
48 :group 'pcl-cvs | |
49 :type '(boolean)) | |
50 | |
51 (defvar global-font-lock-mode) | |
52 (defvar font-lock-auto-fontify) | |
53 (defcustom cvs-highlight | |
54 (or (and (boundp 'font-lock-auto-fontify) font-lock-auto-fontify) | |
55 (and (boundp 'global-font-lock-mode) global-font-lock-mode)) | |
56 "*Whether to use text highlighting (à la font-lock) or not." | |
57 :group 'pcl-cvs | |
58 :type '(boolean)) | |
59 | |
60 (defcustom cvs-allow-dir-commit nil | |
61 "*Allow `cvs-mode-commit' on directories. | |
62 If you commit without any marked file and with the cursor positioned | |
63 on a directory entry, cvs would commit the whole directory. This seems | |
64 to confuse some users sometimes." | |
65 :group 'pcl-cvs | |
66 :type '(boolean)) | |
67 | |
68 | |
69 ;;;; | |
70 ;;;; Faces for fontification | |
71 ;;;; | |
72 | |
73 (defface cvs-header-face | |
74 '((((class color) (background dark)) | |
75 (:foreground "lightyellow" :bold t)) | |
76 (((class color) (background light)) | |
77 (:foreground "blue4" :bold t)) | |
78 (t (:bold t))) | |
79 "PCL-CVS face used to highlight directory changes." | |
80 :group 'pcl-cvs) | |
81 | |
82 (defface cvs-filename-face | |
83 '((((class color) (background dark)) | |
84 (:foreground "lightblue")) | |
85 (((class color) (background light)) | |
86 (:foreground "blue4")) | |
87 (t ())) | |
88 "PCL-CVS face used to highlight file names." | |
89 :group 'pcl-cvs) | |
90 | |
91 (defface cvs-unknown-face | |
92 '((((class color) (background dark)) | |
93 (:foreground "red")) | |
94 (((class color) (background light)) | |
95 (:foreground "red")) | |
96 (t (:italic t))) | |
97 "PCL-CVS face used to highlight unknown file status." | |
98 :group 'pcl-cvs) | |
99 | |
100 (defface cvs-handled-face | |
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 | |
109 (defface cvs-need-action-face | |
110 '((((class color) (background dark)) | |
111 (:foreground "orange")) | |
112 (((class color) (background light)) | |
113 (:foreground "orange")) | |
114 (t (:italic t))) | |
115 "PCL-CVS face used to highlight status of files needing action." | |
116 :group 'pcl-cvs) | |
117 | |
118 (defface cvs-marked-face | |
119 '((((class color) (background dark)) | |
120 (:foreground "green" :bold t)) | |
121 (((class color) (background light)) | |
122 (:foreground "green3" :bold t)) | |
123 (t (:bold t))) | |
124 "PCL-CVS face used to highlight marked file indicator." | |
125 :group 'pcl-cvs) | |
126 | |
127 (defface cvs-msg-face | |
128 '((t (:italic t))) | |
129 "PCL-CVS face used to highlight CVS messages." | |
130 :group 'pcl-cvs) | |
131 | |
132 | |
133 ;; There is normally no need to alter the following variable, but if | |
134 ;; your site has installed CVS in a non-standard way you might have | |
135 ;; to change it. | |
136 | |
137 (defvar cvs-bakprefix ".#" | |
138 "The prefix that CVS prepends to files when rcsmerge'ing.") | |
139 | |
140 (easy-mmode-defmap cvs-filename-map | |
141 '(([(mouse-2)] . cvs-mode-find-file)) | |
142 "Local keymap for text properties of file names" | |
143 :inherit 'cvs-mode-map) | |
144 | |
145 (easy-mmode-defmap cvs-status-map | |
146 '(([(mouse-2)] . cvs-mouse-toggle-mark)) | |
147 "Local keymap for text properties of status" | |
148 :inherit 'cvs-mode-map) | |
149 | |
150 (easy-mmode-defmap cvs-dirname-map | |
151 '(([(mouse-2)] . cvs-mode-find-file)) | |
152 "Local keymap for text properties of directory names" | |
153 :inherit 'cvs-mode-map) | |
154 | |
155 ;; Constructor: | |
156 | |
157 (defstruct (cvs-fileinfo | |
158 (:constructor nil) | |
159 (:copier nil) | |
160 (:constructor -cvs-create-fileinfo (type dir file full-log | |
161 &key marked subtype | |
162 merge | |
163 base-rev | |
164 head-rev)) | |
165 (:conc-name cvs-fileinfo->)) | |
166 marked ;; t/nil. | |
167 type ;; See below | |
168 subtype ;; See below | |
169 dir ;; Relative directory the file resides in. | |
170 ;; (concat dir file) should give a valid path. | |
171 file ;; The file name sans the directory. | |
172 base-rev ;; During status: This is the revision that the | |
173 ;; working file is based on. | |
174 head-rev ;; During status: This is the highest revision in | |
175 ;; the repository. | |
176 merge ;; A cons cell containing the (ancestor . head) revisions | |
177 ;; of the merge that resulted in the current file. | |
178 ;;removed ;; t if the file no longer exists. | |
179 full-log ;; The output from cvs, unparsed. | |
180 ;;mod-time ;; Not used. | |
181 | |
182 ;; In addition to the above, the following values can be extracted: | |
183 | |
184 ;; handled ;; t if this file doesn't require further action. | |
185 ;; full-path ;; The complete relative filename. | |
186 ;; pp-name ;; The printed file name | |
187 ;; backup-file;; For MERGED and CONFLICT files after a \"cvs update\", | |
188 ;; this is a full path to the backup file where the | |
189 ;; untouched version resides. | |
190 | |
191 ;; The meaning of the type field: | |
192 | |
193 ;; Value ---Used by--- Explanation | |
194 ;; update status | |
195 ;; NEED-UPDATE x file needs update | |
196 ;; MODIFIED x x modified by you, unchanged in repository | |
197 ;; MERGED x x successful merge | |
198 ;; ADDED x x added by you, not yet committed | |
199 ;; MISSING x rm'd, but not yet `cvs remove'd | |
200 ;; REMOVED x x removed by you, not yet committed | |
201 ;; NEED-MERGE x need merge | |
202 ;; CONFLICT x conflict when merging | |
203 ;; ;;MOD-CONFLICT x removed locally, changed in repository. | |
204 ;; DIRCHANGE x x A change of directory. | |
205 ;; UNKNOWN x An unknown file. | |
206 ;; UP-TO-DATE x The file is up-to-date. | |
207 ;; UPDATED x x file copied from repository | |
208 ;; PATCHED x x diff applied from repository | |
209 ;; COMMITTED x x cvs commit'd | |
210 ;; DEAD An entry that should be removed | |
211 ;; MESSAGE x x This is a special fileinfo that is used | |
212 ;; to display a text that should be in | |
213 ;; full-log." | |
214 ;; TEMP A temporary message that should be removed | |
215 ;; HEADER A message that should stick at the top of the display | |
216 ;; FOOTER A message that should stick at the bottom of the display | |
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-path (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 ;; I could also use `expand-file-name' with `default-directory = ""' | |
231 (concat dir (cvs-fileinfo->file fileinfo))))) | |
232 | |
233 (defun cvs-fileinfo->pp-name (fi) | |
234 "Return the filename of FI as it should be displayed." | |
235 (if cvs-display-full-path | |
236 (cvs-fileinfo->full-path fi) | |
237 (cvs-fileinfo->file fi))) | |
238 | |
239 (defun cvs-fileinfo->backup-file (fileinfo) | |
240 "Construct the file name of the backup file for FILEINFO." | |
241 (let* ((dir (cvs-fileinfo->dir fileinfo)) | |
242 (file (cvs-fileinfo->file fileinfo)) | |
243 (default-directory (file-name-as-directory (expand-file-name dir))) | |
244 (files (directory-files "." nil | |
245 (concat "^" (regexp-quote cvs-bakprefix) | |
246 (regexp-quote file) "\\."))) | |
247 bf) | |
248 (dolist (f files bf) | |
249 (when (and (file-readable-p f) | |
250 (or (null bf) (file-newer-than-file-p f bf))) | |
251 (setq bf (concat dir f)))))) | |
252 | |
253 ;; (defun cvs-fileinfo->handled (fileinfo) | |
254 ;; "Tell if this requires further action" | |
255 ;; (memq (cvs-fileinfo->type fileinfo) '(UP-TO-DATE DEAD))) | |
256 | |
257 | |
258 ;; Predicate: | |
259 | |
260 (defun boolp (x) (or (eq t x) (null x))) | |
261 (defun cvs-check-fileinfo (fi) | |
262 "Check FI's conformance to some conventions." | |
263 (let ((check 'none) | |
264 (type (cvs-fileinfo->type fi)) | |
265 (subtype (cvs-fileinfo->subtype fi)) | |
266 (marked (cvs-fileinfo->marked fi)) | |
267 (dir (cvs-fileinfo->dir fi)) | |
268 (file (cvs-fileinfo->file fi)) | |
269 (base-rev (cvs-fileinfo->base-rev fi)) | |
270 (head-rev (cvs-fileinfo->head-rev fi)) | |
271 (full-log (cvs-fileinfo->full-log fi))) | |
272 (if (and (setq check 'marked) (boolp marked) | |
273 (setq check 'base-rev) (or (null base-rev) (stringp base-rev)) | |
274 (setq check 'head-rev) (or (null head-rev) (stringp head-rev)) | |
275 (setq check 'full-log) (stringp full-log) | |
276 (setq check 'dir) | |
277 (and (stringp dir) | |
278 (not (file-name-absolute-p dir)) | |
279 (or (string= dir "") | |
280 (string= dir (file-name-as-directory dir)))) | |
281 (setq check 'file) | |
282 (and (stringp file) | |
283 (string= file (file-name-nondirectory file))) | |
284 (setq check 'type) (symbolp type) | |
285 (setq check 'consistency) | |
286 (case type | |
287 (DIRCHANGE (and (null subtype) (string= "." file))) | |
288 ((NEED-UPDATE ADDED MISSING DEAD MODIFIED MESSAGE UP-TO-DATE | |
289 REMOVED NEED-MERGE CONFLICT UNKNOWN MESSAGE) | |
290 t))) | |
291 fi | |
292 (error "Invalid :%s in cvs-fileinfo %s" check fi)))) | |
293 | |
294 | |
295 ;;;; | |
296 ;;;; State table to indicate what you can do when. | |
297 ;;;; | |
298 | |
299 (defconst cvs-states | |
300 `((NEED-UPDATE update diff) | |
301 (UP-TO-DATE update nil remove diff safe-rm revert) | |
302 (MODIFIED update commit undo remove diff merge diff-base) | |
303 (ADDED update commit remove) | |
304 (MISSING remove undo update safe-rm revert) | |
305 (REMOVED commit add undo safe-rm) | |
306 (NEED-MERGE update undo diff diff-base) | |
307 (CONFLICT merge remove undo commit diff diff-base) | |
308 (DIRCHANGE remove update diff ,(if cvs-allow-dir-commit 'commit) tag) | |
309 (UNKNOWN ignore add remove) | |
310 (DEAD ) | |
311 (MESSAGE)) | |
312 "Fileinfo state descriptions for pcl-cvs. | |
313 This is an assoc list. Each element consists of (STATE . FUNS) | |
314 - STATE (described in `cvs-create-fileinfo') is the key | |
315 - FUNS is the list of applicable operations. | |
316 The first one (if any) should be the \"default\" action. | |
317 Most of the actions have the obvious meaning. | |
318 `safe-rm' indicates that the file can be removed without losing | |
319 any information.") | |
320 | |
321 ;;;; | |
322 ;;;; Utility functions | |
323 ;;;; | |
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-default-action (fileinfo) | |
336 ;; "Return some kind of \"default\" action to be performed." | |
337 ;; (second (assq (cvs-fileinfo->type fileinfo) cvs-states))) | |
338 | |
339 ;; fileinfo pretty-printers: | |
340 | |
341 (defun cvs-add-face (str face &optional keymap) | |
342 (when cvs-highlight | |
343 (add-text-properties 0 (length str) | |
344 (list* 'face face | |
345 (when keymap | |
346 (list 'mouse-face 'highlight | |
347 'local-map keymap))) | |
348 str)) | |
349 str) | |
350 | |
351 ;;---------- | |
352 (defun cvs-fileinfo-pp (fileinfo) | |
353 "Pretty print FILEINFO. Insert a printed representation in current buffer. | |
354 For use by the cookie package." | |
355 (cvs-check-fileinfo fileinfo) | |
356 (let ((type (cvs-fileinfo->type fileinfo)) | |
357 (subtype (cvs-fileinfo->subtype fileinfo))) | |
358 (insert | |
359 (case type | |
360 (DIRCHANGE (concat "In directory " | |
361 (cvs-add-face (cvs-fileinfo->full-path fileinfo) | |
362 'cvs-header-face cvs-dirname-map) | |
363 ":")) | |
364 (MESSAGE | |
365 (if (memq (cvs-fileinfo->subtype fileinfo) '(FOOTER HEADER)) | |
366 (cvs-fileinfo->full-log fileinfo) | |
367 (cvs-add-face (format "Message: %s" (cvs-fileinfo->full-log fileinfo)) | |
368 'cvs-msg-face))) | |
369 (t | |
370 (let* ((status (if (cvs-fileinfo->marked fileinfo) | |
371 (cvs-add-face "*" 'cvs-marked-face) | |
372 " ")) | |
373 (file (cvs-add-face (cvs-fileinfo->pp-name fileinfo) | |
374 'cvs-filename-face cvs-filename-map)) | |
375 (base (or (cvs-fileinfo->base-rev fileinfo) "")) | |
376 (head (cvs-fileinfo->head-rev fileinfo)) | |
377 (type | |
378 (let ((str (case type | |
379 ;;(MOD-CONFLICT "Not Removed") | |
380 (DEAD "") | |
381 (t (capitalize (symbol-name type))))) | |
382 (face (case type | |
383 (UP-TO-DATE 'cvs-handled-face) | |
384 (UNKNOWN 'cvs-unknown-face) | |
385 (t 'cvs-need-action-face)))) | |
386 (cvs-add-face str face cvs-status-map))) | |
387 (side (or | |
388 ;; maybe a subtype | |
389 (when subtype (downcase (symbol-name subtype))) | |
390 ;; or the head-rev | |
391 (when (and head (not (string= head base))) head) | |
392 ;; or nothing | |
393 "")) | |
394 ;; (action (cvs-add-face (case (cvs-default-action fileinfo) | |
395 ;; (commit "com") | |
396 ;; (update "upd") | |
397 ;; (undo "udo") | |
398 ;; (t " ")) | |
399 ;; 'cvs-action-face | |
400 ;; cvs-action-map)) | |
401 ) | |
402 (concat (cvs-string-fill side 11) " " | |
403 status " " | |
404 (cvs-string-fill type 11) " " | |
405 ;; action " " | |
406 (cvs-string-fill base 11) " " | |
407 file))))))) | |
408 ;; it seems that `format' removes text-properties. Too bad! | |
409 ;; (format "%-11s %s %-11s %-11s %s" | |
410 ;; side status type base file))))))) | |
411 | |
412 | |
413 (defun cvs-fileinfo-update (fi fi-new) | |
414 "Update FI with the information provided in FI-NEW." | |
415 (let ((type (cvs-fileinfo->type fi-new)) | |
416 (merge (cvs-fileinfo->merge fi-new))) | |
417 (setf (cvs-fileinfo->type fi) type) | |
418 (setf (cvs-fileinfo->subtype fi) (cvs-fileinfo->subtype fi-new)) | |
419 (setf (cvs-fileinfo->full-log fi) (cvs-fileinfo->full-log fi-new)) | |
420 (setf (cvs-fileinfo->base-rev fi) (cvs-fileinfo->base-rev fi-new)) | |
421 (setf (cvs-fileinfo->head-rev fi) (cvs-fileinfo->head-rev fi-new)) | |
422 (cond | |
423 (merge (setf (cvs-fileinfo->merge fi) merge)) | |
424 ((memq type '(UP-TO-DATE NEED-UPDATE)) | |
425 (setf (cvs-fileinfo->merge fi) nil))))) | |
426 | |
427 ;;---------- | |
428 (defun cvs-fileinfo< (a b) | |
429 "Compare fileinfo A with fileinfo B and return t if A is `less'. | |
430 The ordering defined by this function is such that directories are | |
431 sorted alphabetically, and inside every directory the DIRCHANGE | |
432 fileinfo will appear first, followed by all files (alphabetically)." | |
433 (let ((subtypea (cvs-fileinfo->subtype a)) | |
434 (subtypeb (cvs-fileinfo->subtype b))) | |
435 (cond | |
436 ;; keep header and footer where they belong. Note: the order is important | |
437 ((eq subtypeb 'HEADER) nil) | |
438 ((eq subtypea 'HEADER) t) | |
439 ((eq subtypea 'FOOTER) nil) | |
440 ((eq subtypeb 'FOOTER) t) | |
441 | |
442 ;; Sort according to directories. | |
443 ((string< (cvs-fileinfo->dir a) (cvs-fileinfo->dir b)) t) | |
444 ((not (string= (cvs-fileinfo->dir a) (cvs-fileinfo->dir b))) nil) | |
445 | |
446 ;; The DIRCHANGE entry is always first within the directory. | |
447 ((eq (cvs-fileinfo->type b) 'DIRCHANGE) nil) | |
448 ((eq (cvs-fileinfo->type a) 'DIRCHANGE) t) | |
449 | |
450 ;; All files are sorted by file name. | |
451 ((string< (cvs-fileinfo->file a) (cvs-fileinfo->file b)))))) | |
452 | |
453 (provide 'pcvs-info) | |
454 | |
455 ;;; pcl-cvs-info.el ends here |