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