/[emacs]/emacs/lisp/vc-cvs.el
ViewVC logotype

Diff of /emacs/lisp/vc-cvs.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.24.4.3 by spiegel, Sun Jan 19 06:51:23 2003 UTC revision 1.77 by ttn, Sat Aug 6 22:13:43 2005 UTC
# Line 1  Line 1 
1  ;;; vc-cvs.el --- non-resident support for CVS version-control  ;;; vc-cvs.el --- non-resident support for CVS version-control
2    
3  ;; Copyright (C) 1995,98,99,2000,2001  Free Software Foundation, Inc.  ;; Copyright (C) 1995, 1998, 1999, 2000, 2001, 2002, 2003,
4    ;;   2004, 2005 Free Software Foundation, Inc.
5    
6  ;; Author:      FSF (see vc.el for full credits)  ;; Author:      FSF (see vc.el for full credits)
7  ;; Maintainer:  Andre Spiegel <spiegel@gnu.org>  ;; Maintainer:  Andre Spiegel <spiegel@gnu.org>
# Line 21  Line 22 
22    
23  ;; You should have received a copy of the GNU General Public License  ;; You should have received a copy of the GNU General Public License
24  ;; along with GNU Emacs; see the file COPYING.  If not, write to the  ;; along with GNU Emacs; see the file COPYING.  If not, write to the
25  ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,  ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26  ;; Boston, MA 02111-1307, USA.  ;; Boston, MA 02110-1301, USA.
27    
28  ;;; Commentary:  ;;; Commentary:
29    
# Line 35  Line 36 
36  ;;; Customization options  ;;; Customization options
37  ;;;  ;;;
38    
39    (defcustom vc-cvs-global-switches nil
40      "*Global switches to pass to any CVS command."
41      :type '(choice (const :tag "None" nil)
42                     (string :tag "Argument String")
43                     (repeat :tag "Argument List"
44                             :value ("")
45                             string))
46      :version "22.1"
47      :group 'vc)
48    
49  (defcustom vc-cvs-register-switches nil  (defcustom vc-cvs-register-switches nil
50    "*Extra switches for registering a file into CVS.    "*Extra switches for registering a file into CVS.
51  A string or list of strings passed to the checkin program by  A string or list of strings passed to the checkin program by
# Line 75  This is only meaningful if you don't use Line 86  This is only meaningful if you don't use
86    "*Non-nil means use local operations when possible for remote repositories.    "*Non-nil means use local operations when possible for remote repositories.
87  This avoids slow queries over the network and instead uses heuristics  This avoids slow queries over the network and instead uses heuristics
88  and past information to determine the current status of a file.  and past information to determine the current status of a file.
89  The value can also be a regular expression to match against the host name  
90  of a repository; then VC only stays local for hosts that match it."  The value can also be a regular expression or list of regular
91    expressions to match against the host name of a repository; then VC
92    only stays local for hosts that match it.  Alternatively, the value
93    can be a list of regular expressions where the first element is the
94    symbol `except'; then VC always stays local except for hosts matched
95    by these regular expressions."
96    :type '(choice (const :tag "Always stay local" t)    :type '(choice (const :tag "Always stay local" t)
97                   (string :tag "Host regexp")                  (const :tag "Don't stay local" nil)
98                   (const :tag "Don't stay local" nil))                   (list :format "\nExamine hostname and %v" :tag "Examine hostname ..."
99                           (set :format "%v" :inline t (const :format "%t" :tag "don't" except))
100                           (regexp :format " stay local,\n%t: %v" :tag "if it matches")
101                           (repeat :format "%v%i\n" :inline t (regexp :tag "or"))))
102    :version "21.1"    :version "21.1"
103    :group 'vc)    :group 'vc)
104    
105    (defcustom vc-cvs-sticky-date-format-string "%c"
106      "*Format string for mode-line display of sticky date.
107    Format is according to `format-time-string'.  Only used if
108    `vc-cvs-sticky-tag-display' is t."
109      :type '(string)
110      :version "22.1"
111      :group 'vc)
112    
113    (defcustom vc-cvs-sticky-tag-display t
114      "*Specify the mode-line display of sticky tags.
115    Value t means default display, nil means no display at all.  If the
116    value is a function or macro, it is called with the sticky tag and
117    its' type as parameters, in that order.  TYPE can have three different
118    values: `symbolic-name' (TAG is a string), `revision-number' (TAG is a
119    string) and `date' (TAG is a date as returned by `encode-time').  The
120    return value of the function or macro will be displayed as a string.
121    
122    Here's an example that will display the formatted date for sticky
123    dates and the word \"Sticky\" for sticky tag names and revisions.
124    
125      (lambda (tag type)
126        (cond ((eq type 'date) (format-time-string
127                                  vc-cvs-sticky-date-format-string tag))
128              ((eq type 'revision-number) \"Sticky\")
129              ((eq type 'symbolic-name) \"Sticky\")))
130    
131    Here's an example that will abbreviate to the first character only,
132    any text before the first occurrence of `-' for sticky symbolic tags.
133    If the sticky tag is a revision number, the word \"Sticky\" is
134    displayed.  Date and time is displayed for sticky dates.
135    
136       (lambda (tag type)
137         (cond ((eq type 'date) (format-time-string \"%Y%m%d %H:%M\" tag))
138               ((eq type 'revision-number) \"Sticky\")
139               ((eq type 'symbolic-name)
140                (condition-case nil
141                    (progn
142                      (string-match \"\\\\([^-]*\\\\)\\\\(.*\\\\)\" tag)
143                      (concat (substring (match-string 1 tag) 0 1) \":\"
144                              (substring (match-string 2 tag) 1 nil)))
145                  (error tag)))))       ; Fall-back to given tag name.
146    
147    See also variable `vc-cvs-sticky-date-format-string'."
148      :type '(choice boolean function)
149      :version "22.1"
150      :group 'vc)
151    
152  ;;;  ;;;
153  ;;; Internal variables  ;;; Internal variables
154  ;;;  ;;;
155    
 (defvar vc-cvs-local-month-numbers  
   '(("Jan" . 1) ("Feb" .  2) ("Mar" .  3) ("Apr" .  4)  
     ("May" . 5) ("Jun" .  6) ("Jul" .  7) ("Aug" .  8)  
     ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))  
   "Local association list of month numbers.")  
   
156    
157  ;;;  ;;;
158  ;;; State-querying functions  ;;; State-querying functions
# Line 102  of a repository; then VC only stays loca Line 161  of a repository; then VC only stays loca
161  ;;;###autoload (defun vc-cvs-registered (f)  ;;;###autoload (defun vc-cvs-registered (f)
162  ;;;###autoload   (when (file-readable-p (expand-file-name  ;;;###autoload   (when (file-readable-p (expand-file-name
163  ;;;###autoload                    "CVS/Entries" (file-name-directory f)))  ;;;###autoload                    "CVS/Entries" (file-name-directory f)))
164  ;;;###autoload       (require 'vc-cvs)  ;;;###autoload       (load "vc-cvs")
165  ;;;###autoload       (vc-cvs-registered f)))  ;;;###autoload       (vc-cvs-registered f)))
166    
167  (defun vc-cvs-registered (file)  (defun vc-cvs-registered (file)
# Line 113  of a repository; then VC only stays loca Line 172  of a repository; then VC only stays loca
172          (case-fold-search nil))          (case-fold-search nil))
173      (if (file-readable-p (expand-file-name "CVS/Entries" dirname))      (if (file-readable-p (expand-file-name "CVS/Entries" dirname))
174          (with-temp-buffer          (with-temp-buffer
175            (vc-insert-file (expand-file-name "CVS/Entries" dirname))            (vc-cvs-get-entries dirname)
176            (goto-char (point-min))            (goto-char (point-min))
177            (cond            (cond
178             ((re-search-forward             ((re-search-forward
179               (concat "^/" (regexp-quote basename) "/") nil t)               ;; CVS-removed files are not taken under VC control.
180                 (concat "^/" (regexp-quote basename) "/[^/-]") nil t)
181              (beginning-of-line)              (beginning-of-line)
182              (vc-cvs-parse-entry file)              (vc-cvs-parse-entry file)
183              t)              t)
# Line 126  of a repository; then VC only stays loca Line 186  of a repository; then VC only stays loca
186    
187  (defun vc-cvs-state (file)  (defun vc-cvs-state (file)
188    "CVS-specific version of `vc-state'."    "CVS-specific version of `vc-state'."
189    (if (vc-cvs-stay-local-p file)    (if (vc-stay-local-p file)
190        (let ((state (vc-file-getprop file 'vc-state)))        (let ((state (vc-file-getprop file 'vc-state)))
191          ;; If we should stay local, use the heuristic but only if          ;; If we should stay local, use the heuristic but only if
192          ;; we don't have a more precise state already available.          ;; we don't have a more precise state already available.
193          (if (memq state '(up-to-date edited))          (if (memq state '(up-to-date edited nil))
194              (vc-cvs-state-heuristic file)              (vc-cvs-state-heuristic file)
195            state))            state))
196      (with-temp-buffer      (with-temp-buffer
197        (cd (file-name-directory file))        (cd (file-name-directory file))
198        (vc-do-command t 0 "cvs" file "status")        (vc-cvs-command t 0 file "status")
199        (vc-cvs-parse-status t))))        (vc-cvs-parse-status t))))
200    
201  (defun vc-cvs-state-heuristic (file)  (defun vc-cvs-state-heuristic (file)
# Line 150  of a repository; then VC only stays loca Line 210  of a repository; then VC only stays loca
210    
211  (defun vc-cvs-dir-state (dir)  (defun vc-cvs-dir-state (dir)
212    "Find the CVS state of all files in DIR."    "Find the CVS state of all files in DIR."
213    (if (vc-cvs-stay-local-p dir)    ;; if DIR is not under CVS control, don't do anything.
214        (vc-cvs-dir-state-heuristic dir)    (when (file-readable-p (expand-file-name "CVS/Entries" dir))
215      (let ((default-directory dir))      (if (vc-stay-local-p dir)
216        ;; Don't specify DIR in this command, the default-directory is          (vc-cvs-dir-state-heuristic dir)
217        ;; enough.  Otherwise it might fail with remote repositories.        (let ((default-directory dir))
218        (with-temp-buffer          ;; Don't specify DIR in this command, the default-directory is
219          (vc-do-command t 0 "cvs" nil "status" "-l")          ;; enough.  Otherwise it might fail with remote repositories.
220          (goto-char (point-min))          (with-temp-buffer
221          (while (re-search-forward "^=+\n\\([^=\n].*\n\\|\n\\)+" nil t)            (vc-cvs-command t 0 nil "status" "-l")
222            (narrow-to-region (match-beginning 0) (match-end 0))            (goto-char (point-min))
223            (vc-cvs-parse-status)            (while (re-search-forward "^=+\n\\([^=\n].*\n\\|\n\\)+" nil t)
224            (goto-char (point-max))              (narrow-to-region (match-beginning 0) (match-end 0))
225            (widen))))))              (vc-cvs-parse-status)
226                (goto-char (point-max))
227                (widen)))))))
228    
229  (defun vc-cvs-workfile-version (file)  (defun vc-cvs-workfile-version (file)
230    "CVS-specific version of `vc-workfile-version'."    "CVS-specific version of `vc-workfile-version'."
# Line 174  of a repository; then VC only stays loca Line 236  of a repository; then VC only stays loca
236    
237  (defun vc-cvs-checkout-model (file)  (defun vc-cvs-checkout-model (file)
238    "CVS-specific version of `vc-checkout-model'."    "CVS-specific version of `vc-checkout-model'."
239    (if (or (getenv "CVSREAD")    (if (getenv "CVSREAD")
           ;; If the file is not writable (despite CVSREAD being  
           ;; undefined), this is probably because the file is being  
           ;; "watched" by other developers.  
           ;; (If vc-mistrust-permissions was t, we actually shouldn't  
           ;; trust this, but there is no other way to learn this from CVS  
           ;; at the moment (version 1.9).)  
           (string-match "r-..-..-." (nth 8 (file-attributes file))))  
240        'announce        'announce
241      'implicit))      (let ((attrib (file-attributes file)))
242          (if (and attrib ;; don't check further if FILE doesn't exist
243                   ;; If the file is not writable (despite CVSREAD being
244                   ;; undefined), this is probably because the file is being
245                   ;; "watched" by other developers.
246                   ;; (If vc-mistrust-permissions was t, we actually shouldn't
247                   ;; trust this, but there is no other way to learn this from CVS
248                   ;; at the moment (version 1.9).)
249                   (string-match "r-..-..-." (nth 8 attrib)))
250              'announce
251            'implicit))))
252    
253  (defun vc-cvs-mode-line-string (file)  (defun vc-cvs-mode-line-string (file)
254    "Return string for placement into the modeline for FILE.    "Return string for placement into the modeline for FILE.
255  Compared to the default implementation, this function handles the  Compared to the default implementation, this function does two things:
256  special case of a CVS file that is added but not yet committed."  Handle the special case of a CVS file that is added but not yet
257    (let ((state   (vc-state file))  committed and support display of sticky tags."
258          (rev     (vc-workfile-version file)))    (let ((sticky-tag (vc-file-getprop file 'vc-cvs-sticky-tag))
259      (cond ((string= rev "0")          (string (if (string= (vc-workfile-version file) "0")
260             ;; A file that is added but not yet committed.                      ;; A file that is added but not yet committed.
261             "CVS @@")                      "CVS @@"
262            ((or (eq state 'up-to-date)                    (vc-default-mode-line-string 'CVS file))))
263                 (eq state 'needs-patch))      (if (zerop (length sticky-tag))
264             (concat "CVS-" rev))          string
265            ((stringp state)        (concat string "[" sticky-tag "]"))))
            (concat "CVS:" state ":" rev))  
           (t  
            ;; Not just for the 'edited state, but also a fallback  
            ;; for all other states.  Think about different symbols  
            ;; for 'needs-patch and 'needs-merge.  
            (concat "CVS:" rev)))))  
266    
267  (defun vc-cvs-dired-state-info (file)  (defun vc-cvs-dired-state-info (file)
268    "CVS-specific version of `vc-dired-state-info'."    "CVS-specific version of `vc-dired-state-info'."
269    (let* ((cvs-state (vc-state file))    (let ((cvs-state (vc-state file)))
270           (state (cond ((eq cvs-state 'edited)   "modified")      (cond ((eq cvs-state 'edited)
271                        ((eq cvs-state 'needs-patch)      "patch")             (if (equal (vc-workfile-version file) "0")
272                        ((eq cvs-state 'needs-merge)      "merge")                 "(added)" "(modified)"))
273                        ;; FIXME: those two states cannot occur right now            ((eq cvs-state 'needs-patch) "(patch)")
274                        ((eq cvs-state 'unlocked-changes) "conflict")            ((eq cvs-state 'needs-merge) "(merge)"))))
                       ((eq cvs-state 'locally-added)    "added")  
                       )))  
     (if state (concat "(" state ")"))))  
275    
276    
277  ;;;  ;;;
# Line 228  COMMENT can be used to provide an initia Line 284  COMMENT can be used to provide an initia
284    
285  `vc-register-switches' and `vc-cvs-register-switches' are passed to  `vc-register-switches' and `vc-cvs-register-switches' are passed to
286  the CVS command (in that order)."  the CVS command (in that order)."
287      (let ((switches (list    (when (and (not (vc-cvs-responsible-p file))
288                       (if (stringp vc-register-switches)               (vc-cvs-could-register file))
289                           (list vc-register-switches)      ;; Register the directory if needed.
290                         vc-register-switches)      (vc-cvs-register (directory-file-name (file-name-directory file))))
291                       (if (stringp vc-cvs-register-switches)    (apply 'vc-cvs-command nil 0 file
292                           (list vc-cvs-register-switches)           "add"
293                         vc-cvs-register-switches))))           (and comment (string-match "[^\t\n ]" comment)
294                  (concat "-m" comment))
295        (apply 'vc-do-command nil 0 "cvs" file           (vc-switches 'CVS 'register)))
              "add"  
              (and comment (string-match "[^\t\n ]" comment)  
                   (concat "-m" comment))  
              switches)))  
296    
297  (defun vc-cvs-responsible-p (file)  (defun vc-cvs-responsible-p (file)
298    "Return non-nil if CVS thinks it is responsible for FILE."    "Return non-nil if CVS thinks it is responsible for FILE."
# Line 251  the CVS command (in that order)." Line 303  the CVS command (in that order)."
303    
304  (defun vc-cvs-could-register (file)  (defun vc-cvs-could-register (file)
305    "Return non-nil if FILE could be registered in CVS.    "Return non-nil if FILE could be registered in CVS.
306  This is only possible if CVS is responsible for FILE's directory."  This is only possible if CVS is managing FILE's directory or one of
307    (vc-cvs-responsible-p file))  its parents."
308      (let ((dir file))
309        (while (and (stringp dir)
310                    (not (equal dir (setq dir (file-name-directory dir))))
311                    dir)
312          (setq dir (if (file-directory-p
313                         (expand-file-name "CVS/Entries" dir))
314                        t (directory-file-name dir))))
315        (eq dir t)))
316    
317  (defun vc-cvs-checkin (file rev comment)  (defun vc-cvs-checkin (file rev comment)
318    "CVS-specific version of `vc-backend-checkin'."    "CVS-specific version of `vc-backend-checkin'."
319    (let ((switches (if (stringp vc-checkin-switches)    (unless (or (not rev) (vc-cvs-valid-version-number-p rev))
320                        (list vc-checkin-switches)      (if (not (vc-cvs-valid-symbolic-tag-name-p rev))
321                      vc-checkin-switches))          (error "%s is not a valid symbolic tag name" rev)
322          status)        ;; If the input revison is a valid symbolic tag name, we create it
323      ;; explicit check-in to the trunk requires a double check-in (first        ;; as a branch, commit and switch to it.
324      ;; unexplicit) (CVS-1.3)        (apply 'vc-cvs-command nil 0 file "tag" "-b" (list rev))
325      (if (and rev (vc-trunk-p rev))        (apply 'vc-cvs-command nil 0 file "update" "-r" (list rev))
326          (apply 'vc-do-command nil 1 "cvs" file        (vc-file-setprop file 'vc-cvs-sticky-tag rev)))
327                 "ci" "-m" "intermediate"    (let ((status (apply 'vc-cvs-command nil 1 file
328                 switches))                         "ci" (if rev (concat "-r" rev))
329      (setq status (apply 'vc-do-command nil 1 "cvs" file                         (concat "-m" comment)
330                          "ci" (if rev (concat "-r" rev))                         (vc-switches 'CVS 'checkin))))
                         (concat "-m" comment)  
                         switches))  
331      (set-buffer "*vc*")      (set-buffer "*vc*")
332      (goto-char (point-min))      (goto-char (point-min))
333      (when (not (zerop status))      (when (not (zerop status))
# Line 294  This is only possible if CVS is responsi Line 352  This is only possible if CVS is responsi
352      ;; tell it from the permissions of the file (see      ;; tell it from the permissions of the file (see
353      ;; vc-cvs-checkout-model).      ;; vc-cvs-checkout-model).
354      (vc-file-setprop file 'vc-checkout-model nil)      (vc-file-setprop file 'vc-checkout-model nil)
355      ;; if this was an explicit check-in, remove the sticky tag  
356      (if rev (vc-do-command nil 0 "cvs" file "update" "-A"))))      ;; if this was an explicit check-in (does not include creation of
357        ;; a branch), remove the sticky tag.
358        (if (and rev (not (vc-cvs-valid-symbolic-tag-name-p rev)))
359            (vc-cvs-command nil 0 file "update" "-A"))))
360    
361    (defun vc-cvs-find-version (file rev buffer)
362      (apply 'vc-cvs-command
363             buffer 0 file
364             "-Q"                           ; suppress diagnostic output
365             "update"
366             (and rev (not (string= rev ""))
367                  (concat "-r" rev))
368             "-p"
369             (vc-switches 'CVS 'checkout)))
370    
371  (defun vc-cvs-checkout (file &optional editable rev workfile)  (defun vc-cvs-checkout (file &optional editable rev workfile)
372    "Retrieve a revision of FILE into a WORKFILE.    "Retrieve a revision of FILE into a WORKFILE.
# Line 308  REV is the revision to check out into WO Line 379  REV is the revision to check out into WO
379      (save-excursion      (save-excursion
380        ;; Change buffers to get local value of vc-checkout-switches.        ;; Change buffers to get local value of vc-checkout-switches.
381        (if file-buffer (set-buffer file-buffer))        (if file-buffer (set-buffer file-buffer))
382        (setq switches (if (stringp vc-checkout-switches)        (setq switches (vc-switches 'CVS 'checkout))
                          (list vc-checkout-switches)  
                        vc-checkout-switches))  
383        ;; Save this buffer's default-directory        ;; Save this buffer's default-directory
384        ;; and use save-excursion to make sure it is restored        ;; and use save-excursion to make sure it is restored
385        ;; in the same buffer it was saved in.        ;; in the same buffer it was saved in.
# Line 334  REV is the revision to check out into WO Line 403  REV is the revision to check out into WO
403                        (let ((coding-system-for-read 'no-conversion)                        (let ((coding-system-for-read 'no-conversion)
404                              (coding-system-for-write 'no-conversion))                              (coding-system-for-write 'no-conversion))
405                          (with-temp-file filename                          (with-temp-file filename
406                            (apply 'vc-do-command                            (apply 'vc-cvs-command
407                                   (current-buffer) 0 "cvs" file                                   (current-buffer) 0 file
408                                   "-Q"   ; suppress diagnostic output                                   "-Q"   ; suppress diagnostic output
409                                   "update"                                   "update"
410                                   (and (stringp rev)                                   (and (stringp rev)
# Line 356  REV is the revision to check out into WO Line 425  REV is the revision to check out into WO
425              (if (and (file-exists-p file) (not rev))              (if (and (file-exists-p file) (not rev))
426                  ;; If no revision was specified, just make the file writable                  ;; If no revision was specified, just make the file writable
427                  ;; if necessary (using `cvs-edit' if requested).                  ;; if necessary (using `cvs-edit' if requested).
428                  (and editable (not (eq (vc-cvs-checkout-model file) 'implicit))                  (and editable (not (eq (vc-cvs-checkout-model file) 'implicit))
429                       (if vc-cvs-use-edit                       (if vc-cvs-use-edit
430                           (vc-do-command nil 0 "cvs" file "edit")                           (vc-cvs-command nil 0 file "edit")
431                         (set-file-modes file (logior (file-modes file) 128))                         (set-file-modes file (logior (file-modes file) 128))
432                         (if file-buffer (toggle-read-only -1))))                         (if file-buffer (toggle-read-only -1))))
433                ;; Check out a particular version (or recreate the file).                ;; Check out a particular version (or recreate the file).
434                (vc-file-setprop file 'vc-workfile-version nil)                (vc-file-setprop file 'vc-workfile-version nil)
435                (apply 'vc-do-command nil 0 "cvs" file                (apply 'vc-cvs-command nil 0 file
436                       (and editable                       (and editable
437                            (or (not (file-exists-p file))                            (or (not (file-exists-p file))
438                                (not (eq (vc-cvs-checkout-model file)                                (not (eq (vc-cvs-checkout-model file)
439                                         'implicit)))                                         'implicit)))
440                            "-w")                            "-w")
441                       "update"                       "update"
442                       ;; default for verbose checkout: clear the sticky tag so                       (when rev
443                       ;; that the actual update will get the head of the trunk                         (unless (eq rev t)
444                       (if (or (not rev) (eq rev t) (string= rev ""))                           ;; default for verbose checkout: clear the
445                           "-A"                           ;; sticky tag so that the actual update will
446                         (concat "-r" rev))                           ;; get the head of the trunk
447                             (if (string= rev "")
448                                 "-A"
449                               (concat "-r" rev))))
450                       switches))))                       switches))))
451          (vc-mode-line file)          (vc-mode-line file)
452          (message "Checking out %s...done" filename)))))          (message "Checking out %s...done" filename)))))
453    
454    (defun vc-cvs-delete-file (file)
455      (vc-cvs-command nil 0 file "remove" "-f"))
456    
457  (defun vc-cvs-revert (file &optional contents-done)  (defun vc-cvs-revert (file &optional contents-done)
458    "Revert FILE to the version it was based on."    "Revert FILE to the version it was based on."
459    (unless contents-done    (unless contents-done
# Line 387  REV is the revision to check out into WO Line 462  REV is the revision to check out into WO
462      (vc-cvs-checkout file nil (vc-workfile-version file) file))      (vc-cvs-checkout file nil (vc-workfile-version file) file))
463    (unless (eq (vc-checkout-model file) 'implicit)    (unless (eq (vc-checkout-model file) 'implicit)
464      (if vc-cvs-use-edit      (if vc-cvs-use-edit
465          (vc-do-command nil 0 "cvs" file "unedit")          (vc-cvs-command nil 0 file "unedit")
466        ;; Make the file read-only by switching off all w-bits        ;; Make the file read-only by switching off all w-bits
467        (set-file-modes file (logand (file-modes file) 3950)))))        (set-file-modes file (logand (file-modes file) 3950)))))
468    
469  (defun vc-cvs-merge (file first-version &optional second-version)  (defun vc-cvs-merge (file first-version &optional second-version)
470    "Merge changes into current working copy of FILE.    "Merge changes into current working copy of FILE.
471  The changes are between FIRST-VERSION and SECOND-VERSION."  The changes are between FIRST-VERSION and SECOND-VERSION."
472    (vc-do-command nil 0 "cvs" file    (vc-cvs-command nil 0 file
473                   "update" "-kk"                   "update" "-kk"
474                   (concat "-j" first-version)                   (concat "-j" first-version)
475                   (concat "-j" second-version))                   (concat "-j" second-version))
476    (vc-file-setprop file 'vc-state 'edited)    (vc-file-setprop file 'vc-state 'edited)
477    (save-excursion    (with-current-buffer (get-buffer "*vc*")
     (set-buffer (get-buffer "*vc*"))  
478      (goto-char (point-min))      (goto-char (point-min))
479      (if (re-search-forward "conflicts during merge" nil t)      (if (re-search-forward "conflicts during merge" nil t)
480          1                               ; signal error          1                               ; signal error
# Line 409  The changes are between FIRST-VERSION an Line 483  The changes are between FIRST-VERSION an
483  (defun vc-cvs-merge-news (file)  (defun vc-cvs-merge-news (file)
484    "Merge in any new changes made to FILE."    "Merge in any new changes made to FILE."
485    (message "Merging changes into %s..." file)    (message "Merging changes into %s..." file)
486    (save-excursion    ;; (vc-file-setprop file 'vc-workfile-version nil)
487      ;; (vc-file-setprop file 'vc-workfile-version nil)    (vc-file-setprop file 'vc-checkout-time 0)
488      (vc-file-setprop file 'vc-checkout-time 0)    (vc-cvs-command nil 0 file "update")
489      (vc-do-command nil 0 "cvs" file "update")    ;; Analyze the merge result reported by CVS, and set
490      ;; Analyze the merge result reported by CVS, and set    ;; file properties accordingly.
491      ;; file properties accordingly.    (with-current-buffer (get-buffer "*vc*")
     (set-buffer (get-buffer "*vc*"))  
492      (goto-char (point-min))      (goto-char (point-min))
493      ;; get new workfile version      ;; get new workfile version
494      (if (re-search-forward (concat "^Merging differences between "      (if (re-search-forward
495                                     "[01234567890.]* and "           "^Merging differences between [0-9.]* and \\([0-9.]*\\) into" nil t)
                                    "\\([01234567890.]*\\) into")  
                            nil t)  
496          (vc-file-setprop file 'vc-workfile-version (match-string 1))          (vc-file-setprop file 'vc-workfile-version (match-string 1))
497        (vc-file-setprop file 'vc-workfile-version nil))        (vc-file-setprop file 'vc-workfile-version nil))
498      ;; get file status      ;; get file status
# Line 460  The changes are between FIRST-VERSION an Line 531  The changes are between FIRST-VERSION an
531  ;;; History functions  ;;; History functions
532  ;;;  ;;;
533    
534  (defun vc-cvs-print-log (file)  (defun vc-cvs-print-log (file &optional buffer)
535    "Get change log associated with FILE."    "Get change log associated with FILE."
536    (vc-do-command    (vc-cvs-command
537     nil     buffer
538     (if (and (vc-cvs-stay-local-p file) (fboundp 'start-process)) 'async 0)     (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
539     "cvs" file "log"))     file "log"))
   
 (defun vc-cvs-show-log-entry (version)  
   (when (re-search-forward  
          ;; also match some context, for safety  
          (concat "----\nrevision " version  
                  "\\(\tlocked by:.*\n\\|\n\\)date: ") nil t)  
     ;; set the display window so that  
     ;; the whole log entry is displayed  
     (let (start end lines)  
       (beginning-of-line) (forward-line -1) (setq start (point))  
       (if (not (re-search-forward "^----*\nrevision" nil t))  
           (setq end (point-max))  
         (beginning-of-line) (forward-line -1) (setq end (point)))  
       (setq lines (count-lines start end))  
       (cond  
        ;; if the global information and this log entry fit  
        ;; into the window, display from the beginning  
        ((< (count-lines (point-min) end) (window-height))  
         (goto-char (point-min))  
         (recenter 0)  
         (goto-char start))  
        ;; if the whole entry fits into the window,  
        ;; display it centered  
        ((< (1+ lines) (window-height))  
         (goto-char start)  
         (recenter (1- (- (/ (window-height) 2) (/ lines 2)))))  
        ;; otherwise (the entry is too large for the window),  
        ;; display from the start  
        (t  
         (goto-char start)  
         (recenter 0))))))  
540    
541  (defun vc-cvs-diff (file &optional oldvers newvers)  (defun vc-cvs-diff (file &optional oldvers newvers buffer)
542    "Get a difference report using CVS between two versions of FILE."    "Get a difference report using CVS between two versions of FILE."
543    (let (options status (diff-switches-list (vc-diff-switches-list cvs)))    (if (string= (vc-workfile-version file) "0")
544      (if (string= (vc-workfile-version file) "0")        ;; This file is added but not yet committed; there is no master file.
545          ;; This file is added but not yet committed; there is no master file.        (if (or oldvers newvers)
546          (if (or oldvers newvers)            (error "No revisions of %s exist" file)
547              (error "No revisions of %s exist" file)          ;; We regard this as "changed".
548            ;; we regard this as "changed".          ;; Diff it against /dev/null.
549            ;; diff it against /dev/null.          ;; Note: this is NOT a "cvs diff".
550            (apply 'vc-do-command "*vc-diff*"          (apply 'vc-do-command (or buffer "*vc-diff*")
551                   1 "diff" file                 1 "diff" file
552                   (append diff-switches-list '("/dev/null"))))                 (append (vc-switches nil 'diff) '("/dev/null")))
553        (setq status          ;; Even if it's empty, it's locally modified.
554              (apply 'vc-do-command "*vc-diff*"          1)
555                     (if (and (vc-cvs-stay-local-p file)      (let* ((async (and (not vc-disable-async-diff)
556                              (fboundp 'start-process))                         (vc-stay-local-p file)
557                         'async                         (fboundp 'start-process)))
558                       1)             (status (apply 'vc-cvs-command (or buffer "*vc-diff*")
559                     "cvs" file "diff"                            (if async 'async 1)
560                     (and oldvers (concat "-r" oldvers))                            file "diff"
561                     (and newvers (concat "-r" newvers))                            (and oldvers (concat "-r" oldvers))
562                     diff-switches-list))                            (and newvers (concat "-r" newvers))
563        (if (vc-cvs-stay-local-p file)                            (vc-switches 'CVS 'diff))))
564            1 ;; async diff, pessimistic assumption        (if async 1 status))))            ; async diff, pessimistic assumption
         status))))  
565    
566  (defun vc-cvs-diff-tree (dir &optional rev1 rev2)  (defun vc-cvs-diff-tree (dir &optional rev1 rev2)
567    "Diff all files at and below DIR."    "Diff all files at and below DIR."
568    (with-current-buffer "*vc-diff*"    (with-current-buffer "*vc-diff*"
569      (setq default-directory dir)      (setq default-directory dir)
570      (if (vc-cvs-stay-local-p dir)      (if (vc-stay-local-p dir)
571          ;; local diff: do it filewise, and only for files that are modified          ;; local diff: do it filewise, and only for files that are modified
572          (vc-file-tree-walk          (vc-file-tree-walk
573           dir           dir
# Line 539  The changes are between FIRST-VERSION an Line 578  The changes are between FIRST-VERSION an
578                 ;; in the tree via vc-cvs-dir-state-heuristic                 ;; in the tree via vc-cvs-dir-state-heuristic
579                 (unless (vc-up-to-date-p ',f)                 (unless (vc-up-to-date-p ',f)
580                   (message "Looking at %s" ',f)                   (message "Looking at %s" ',f)
581                   (vc-diff-internal ',f ',rel1 ',rel2))))))                   (vc-diff-internal ',f ',rev1 ',rev2))))))
582        ;; cvs diff: use a single call for the entire tree        ;; cvs diff: use a single call for the entire tree
583        (let ((coding-system-for-read        (let ((coding-system-for-read
584               (or coding-system-for-read 'undecided)))               (or coding-system-for-read 'undecided)))
585          (apply 'vc-do-command "*vc-diff*" 1 "cvs" nil "diff"          (apply 'vc-cvs-command "*vc-diff*" 1 nil "diff"
586                 (and rel1 (concat "-r" rel1))                 (and rev1 (concat "-r" rev1))
587                 (and rel2 (concat "-r" rel2))                 (and rev2 (concat "-r" rev2))
588                 (vc-diff-switches-list cvs))))))                 (vc-switches 'CVS 'diff))))))
589    
590  (defun vc-cvs-annotate-command (file buffer &optional version)  (defun vc-cvs-annotate-command (file buffer &optional version)
591    "Execute \"cvs annotate\" on FILE, inserting the contents in BUFFER.    "Execute \"cvs annotate\" on FILE, inserting the contents in BUFFER.
592  Optional arg VERSION is a version to annotate from."  Optional arg VERSION is a version to annotate from."
593    (vc-do-command buffer 0 "cvs" file "annotate" (if version    (vc-cvs-command buffer 0 file "annotate" (if version (concat "-r" version)))
594                                                      (concat "-r" version))))    (with-current-buffer buffer
595        (goto-char (point-min))
596        (re-search-forward "^[0-9]")
597        (delete-region (point-min) (1- (point)))))
598    
599  (defun vc-cvs-annotate-difference (point)  (defun vc-cvs-annotate-current-time ()
600    "Return the difference between the time of the line and the current time.    "Return the current time, based at midnight of the current day, and
601  Return values are as defined for `current-time'."  encoded as fractional days."
602    ;; We need a list of months and their corresponding numbers.    (vc-annotate-convert-time
603    (if (looking-at "^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): ")     (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time))))))
604        (progn  
605          (let* ((day (string-to-number (match-string 1)))  (defun vc-cvs-annotate-time ()
606                 (month (cdr (assoc (match-string 2) vc-cvs-local-month-numbers)))    "Return the time of the next annotation (as fraction of days)
607                 (year-tmp (string-to-number (match-string 3)))  systime, or nil if there is none."
608                 ;; Years 0..68 are 2000..2068.    (let* ((bol (point))
609                 ;; Years 69..99 are 1969..1999.           (cache (get-text-property bol 'vc-cvs-annotate-time))
610                 (year (+ (cond ((> 69 year-tmp) 2000)           buffer-read-only)
611                                ((> 100 year-tmp) 1900)      (cond
612                                (t 0))       (cache)
613                          year-tmp)))       ((looking-at
614            (goto-char (match-end 0)) ; Position at end makes for nicer overlay result         "^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): ")
615            (- (car (current-time))        (let ((day (string-to-number (match-string 1)))
616               (car (encode-time 0 0 0 day month year)))))              (month (cdr (assq (intern (match-string 2))
617      ;; If we did not look directly at an annotation, there might be                                '((Jan .  1) (Feb .  2) (Mar .  3)
618      ;; some further down.  This is the case if we are positioned at                                  (Apr .  4) (May .  5) (Jun .  6)
619      ;; the very top of the buffer, for instance.                                  (Jul .  7) (Aug .  8) (Sep .  9)
620      (if (re-search-forward                                  (Oct . 10) (Nov . 11) (Dec . 12)))))
621           "^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): " nil t)              (year (let ((tmp (string-to-number (match-string 3))))
622          (progn                      ;; Years 0..68 are 2000..2068.
623            (beginning-of-line nil)                      ;; Years 69..99 are 1969..1999.
624            (vc-cvs-annotate-difference (point))))))                      (+ (cond ((> 69 tmp) 2000)
625                                 ((> 100 tmp) 1900)
626                                 (t 0))
627                           tmp))))
628            (put-text-property
629             bol (1+ bol) 'vc-cvs-annotate-time
630             (setq cache (cons
631                          ;; Position at end makes for nicer overlay result.
632                          (match-end 0)
633                          (vc-annotate-convert-time
634                           (encode-time 0 0 0 day month year))))))))
635        (when cache
636          (goto-char (car cache))           ; fontify from here to eol
637          (cdr cache))))                    ; days (float)
638    
639    (defun vc-cvs-annotate-extract-revision-at-line ()
640      (save-excursion
641        (beginning-of-line)
642        (if (re-search-forward "^\\([0-9]+\\.[0-9]+\\(\\.[0-9]+\\)*\\) +("
643                               (line-end-position) t)
644            (match-string-no-properties 1)
645          nil)))
646    
647  ;;;  ;;;
648  ;;; Snapshot system  ;;; Snapshot system
# Line 590  Return values are as defined for `curren Line 652  Return values are as defined for `curren
652    "Assign to DIR's current version a given NAME.    "Assign to DIR's current version a given NAME.
653  If BRANCHP is non-nil, the name is created as a branch (and the current  If BRANCHP is non-nil, the name is created as a branch (and the current
654  workspace is immediately moved to that new branch)."  workspace is immediately moved to that new branch)."
655    (vc-do-command nil 0 "cvs" dir "tag" "-c" (if branchp "-b") name)    (vc-cvs-command nil 0 dir "tag" "-c" (if branchp "-b") name)
656    (when branchp (vc-do-command nil 0 "cvs" dir "update" "-r" name)))    (when branchp (vc-cvs-command nil 0 dir "update" "-r" name)))
657    
658  (defun vc-cvs-retrieve-snapshot (dir name update)  (defun vc-cvs-retrieve-snapshot (dir name update)
659    "Retrieve a snapshot at and below DIR.    "Retrieve a snapshot at and below DIR.
660  NAME is the name of the snapshot; if it is empty, do a `cvs update'.  NAME is the name of the snapshot; if it is empty, do a `cvs update'.
661  If UPDATE is non-nil, then update (resynch) any affected buffers."  If UPDATE is non-nil, then update (resynch) any affected buffers."
662    (with-current-buffer (get-buffer-create "*vc*")    (with-current-buffer (get-buffer-create "*vc*")
663      (let ((default-directory dir))      (let ((default-directory dir)
664              (sticky-tag))
665        (erase-buffer)        (erase-buffer)
666        (if (or (not name) (string= name ""))        (if (or (not name) (string= name ""))
667            (vc-do-command t 0 "cvs" nil "update")            (vc-cvs-command t 0 nil "update")
668          (vc-do-command t 0 "cvs" nil "update" "-r" name))          (vc-cvs-command t 0 nil "update" "-r" name)
669            (setq sticky-tag name))
670        (when update        (when update
671          (goto-char (point-min))          (goto-char (point-min))
672          (while (not (eobp))          (while (not (eobp))
# Line 623  If UPDATE is non-nil, then update (resyn Line 687  If UPDATE is non-nil, then update (resyn
687                      (vc-file-setprop file 'vc-state 'edited)                      (vc-file-setprop file 'vc-state 'edited)
688                      (vc-file-setprop file 'vc-workfile-version nil)                      (vc-file-setprop file 'vc-workfile-version nil)
689                      (vc-file-setprop file 'vc-checkout-time 0)))                      (vc-file-setprop file 'vc-checkout-time 0)))
690                      (vc-file-setprop file 'vc-cvs-sticky-tag sticky-tag)
691                    (vc-resynch-buffer file t t))))                    (vc-resynch-buffer file t t))))
692            (forward-line 1))))))            (forward-line 1))))))
693    
# Line 631  If UPDATE is non-nil, then update (resyn Line 696  If UPDATE is non-nil, then update (resyn
696  ;;; Miscellaneous  ;;; Miscellaneous
697  ;;;  ;;;
698    
699  (defun vc-cvs-make-version-backups-p (file)  (defalias 'vc-cvs-make-version-backups-p 'vc-stay-local-p
700    "Return non-nil if version backups should be made for FILE."    "Return non-nil if version backups should be made for FILE.")
   (vc-cvs-stay-local-p file))  
701    
702  (defun vc-cvs-check-headers ()  (defun vc-cvs-check-headers ()
703    "Check if the current file has any headers in it."    "Check if the current file has any headers in it."
# Line 647  If UPDATE is non-nil, then update (resyn Line 711  If UPDATE is non-nil, then update (resyn
711  ;;; Internal functions  ;;; Internal functions
712  ;;;  ;;;
713    
714  (defun vc-cvs-stay-local-p (file)  (defun vc-cvs-command (buffer okstatus file &rest flags)
715    "Return non-nil if VC should stay local when handling FILE."    "A wrapper around `vc-do-command' for use in vc-cvs.el.
716    (if vc-cvs-stay-local  The difference to vc-do-command is that this function always invokes `cvs',
717        (let* ((dirname (if (file-directory-p file)  and that it passes `vc-cvs-global-switches' to it before FLAGS."
718                            (directory-file-name file)    (apply 'vc-do-command buffer okstatus "cvs" file
719                          (file-name-directory file)))           (if (stringp vc-cvs-global-switches)
720               (prop               (cons vc-cvs-global-switches flags)
721                (or (vc-file-getprop dirname 'vc-cvs-stay-local-p)             (append vc-cvs-global-switches
722                    (let ((rootname (expand-file-name "CVS/Root" dirname)))                     flags))))
723                      (vc-file-setprop  
724                       dirname 'vc-cvs-stay-local-p  (defalias 'vc-cvs-stay-local-p 'vc-stay-local-p)  ;Back-compatibility.
725                       (when (file-readable-p rootname)  
726                         (with-temp-buffer  (defun vc-cvs-repository-hostname (dirname)
727                           (vc-insert-file rootname)    "Hostname of the CVS server associated to workarea DIRNAME."
728                           (goto-char (point-min))    (let ((rootname (expand-file-name "CVS/Root" dirname)))
729                           (if (looking-at "\\([^:]*\\):")      (when (file-readable-p rootname)
730                               (if (not (stringp vc-cvs-stay-local))        (with-temp-buffer
731                                   'yes          (let ((coding-system-for-read
732                                 (let ((hostname (match-string 1)))                 (or file-name-coding-system
733                                   (if (string-match vc-cvs-stay-local hostname)                     default-file-name-coding-system)))
734                                       'yes            (vc-insert-file rootname))
735                                     'no)))          (goto-char (point-min))
736                             'no))))))))          (nth 2 (vc-cvs-parse-root
737          (if (eq prop 'yes) t nil))))                  (buffer-substring (point)
738                                      (line-end-position))))))))
739    
740    (defun vc-cvs-parse-root (root)
741      "Split CVS ROOT specification string into a list of fields.
742    A CVS root specification of the form
743      [:METHOD:][[USER@]HOSTNAME:]/path/to/repository
744    is converted to a normalized record with the following structure:
745      \(METHOD USER HOSTNAME CVS-ROOT).
746    The default METHOD for a CVS root of the form
747      /path/to/repository
748    is `local'.
749    The default METHOD for a CVS root of the form
750      [USER@]HOSTNAME:/path/to/repository
751    is `ext'.
752    For an empty string, nil is returned (invalid CVS root)."
753      ;; Split CVS root into colon separated fields (0-4).
754      ;; The `x:' makes sure, that leading colons are not lost;
755      ;; `HOST:/PATH' is then different from `:METHOD:/PATH'.
756      (let* ((root-list (cdr (split-string (concat "x:" root) ":")))
757             (len (length root-list))
758             ;; All syntactic varieties will get a proper METHOD.
759             (root-list
760              (cond
761               ((= len 0)
762                ;; Invalid CVS root
763                nil)
764               ((= len 1)
765                ;; Simple PATH => method `local'
766                (cons "local"
767                      (cons nil root-list)))
768               ((= len 2)
769                ;; [USER@]HOST:PATH => method `ext'
770                (and (not (equal (car root-list) ""))
771                     (cons "ext" root-list)))
772               ((= len 3)
773                ;; :METHOD:PATH
774                (cons (cadr root-list)
775                      (cons nil (cddr root-list))))
776               (t
777                ;; :METHOD:[USER@]HOST:PATH
778                (cdr root-list)))))
779        (if root-list
780            (let ((method (car root-list))
781                  (uhost (or (cadr root-list) ""))
782                  (root (nth 2 root-list))
783                  user host)
784              ;; Split USER@HOST
785              (if (string-match "\\(.*\\)@\\(.*\\)" uhost)
786                  (setq user (match-string 1 uhost)
787                        host (match-string 2 uhost))
788                (setq host uhost))
789              ;; Remove empty HOST
790              (and (equal host "")
791                   (setq host))
792              ;; Fix windows style CVS root `:local:C:\\project\\cvs\\some\\dir'
793              (and host
794                   (equal method "local")
795                   (setq root (concat host ":" root) host))
796              ;; Normalize CVS root record
797              (list method user host root)))))
798    
799  (defun vc-cvs-parse-status (&optional full)  (defun vc-cvs-parse-status (&optional full)
800    "Parse output of \"cvs status\" command in the current buffer.    "Parse output of \"cvs status\" command in the current buffer.
# Line 693  essential information." Line 817  essential information."
817  \[\t ]+\\([0-9.]+\\)"  \[\t ]+\\([0-9.]+\\)"
818                      nil t))                      nil t))
819                (vc-file-setprop file 'vc-latest-version (match-string 2)))                (vc-file-setprop file 'vc-latest-version (match-string 2)))
820            (vc-file-setprop            (vc-file-setprop
821             file 'vc-state             file 'vc-state
822             (cond             (cond
823              ((string-match "Up-to-date" status)              ((string-match "Up-to-date" status)
# Line 708  essential information." Line 832  essential information."
832  (defun vc-cvs-dir-state-heuristic (dir)  (defun vc-cvs-dir-state-heuristic (dir)
833    "Find the CVS state of all files in DIR, using only local information."    "Find the CVS state of all files in DIR, using only local information."
834    (with-temp-buffer    (with-temp-buffer
835      (vc-insert-file (expand-file-name "CVS/Entries" dir))      (vc-cvs-get-entries dir)
836      (goto-char (point-min))      (goto-char (point-min))
837      (while (not (eobp))      (while (not (eobp))
838        (when (looking-at "/\\([^/]*\\)/")        ;; CVS-removed files are not taken under VC control.
839          (when (looking-at "/\\([^/]*\\)/[^/-]")
840          (let ((file (expand-file-name (match-string 1) dir)))          (let ((file (expand-file-name (match-string 1) dir)))
841            (unless (vc-file-getprop file 'vc-state)            (unless (vc-file-getprop file 'vc-state)
842              (vc-cvs-parse-entry file t))))              (vc-cvs-parse-entry file t))))
843        (forward-line 1))))        (forward-line 1))))
844    
845    (defun vc-cvs-get-entries (dir)
846      "Insert the CVS/Entries file from below DIR into the current buffer.
847    This function ensures that the correct coding system is used for that,
848    which may not be the one that is used for the files' contents.
849    CVS/Entries should only be accessed through this function."
850      (let ((coding-system-for-read (or file-name-coding-system
851                                        default-file-name-coding-system)))
852        (vc-insert-file (expand-file-name "CVS/Entries" dir))))
853    
854    (defun vc-cvs-valid-symbolic-tag-name-p (tag)
855      "Return non-nil if TAG is a valid symbolic tag name."
856      ;; According to the CVS manual, a valid symbolic tag must start with
857      ;; an uppercase or lowercase letter and can contain uppercase and
858      ;; lowercase letters, digits, `-', and `_'.
859      (and (string-match "^[a-zA-Z]" tag)
860           (not (string-match "[^a-z0-9A-Z-_]" tag))))
861    
862    (defun vc-cvs-valid-version-number-p (tag)
863      "Return non-nil if TAG is a valid version number."
864      (and (string-match "^[0-9]" tag)
865           (not (string-match "[^0-9.]" tag))))
866    
867    (defun vc-cvs-parse-sticky-tag (match-type match-tag)
868      "Parse and return the sticky tag as a string.
869    `match-data' is protected."
870      (let ((data (match-data))
871            (tag)
872            (type (cond ((string= match-type "D") 'date)
873                        ((string= match-type "T")
874                         (if (vc-cvs-valid-symbolic-tag-name-p match-tag)
875                             'symbolic-name
876                           'revision-number))
877                        (t nil))))
878        (unwind-protect
879            (progn
880              (cond
881               ;; Sticky Date tag.  Convert to a proper date value (`encode-time')
882               ((eq type 'date)
883                (string-match
884                 "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)"
885                 match-tag)
886                (let* ((year-tmp (string-to-number (match-string 1 match-tag)))
887                       (month    (string-to-number (match-string 2 match-tag)))
888                       (day      (string-to-number (match-string 3 match-tag)))
889                       (hour     (string-to-number (match-string 4 match-tag)))
890                       (min      (string-to-number (match-string 5 match-tag)))
891                       (sec      (string-to-number (match-string 6 match-tag)))
892                       ;; Years 0..68 are 2000..2068.
893                       ;; Years 69..99 are 1969..1999.
894                       (year (+ (cond ((> 69 year-tmp) 2000)
895                                      ((> 100 year-tmp) 1900)
896                                      (t 0))
897                                year-tmp)))
898                  (setq tag (encode-time sec min hour day month year))))
899               ;; Sticky Tag name or revision number
900               ((eq type 'symbolic-name) (setq tag match-tag))
901               ((eq type 'revision-number) (setq tag match-tag))
902               ;; Default is no sticky tag at all
903               (t nil))
904              (cond ((eq vc-cvs-sticky-tag-display nil) nil)
905                    ((eq vc-cvs-sticky-tag-display t)
906                     (cond ((eq type 'date) (format-time-string
907                                             vc-cvs-sticky-date-format-string
908                                             tag))
909                           ((eq type 'symbolic-name) tag)
910                           ((eq type 'revision-number) tag)
911                           (t nil)))
912                    ((functionp vc-cvs-sticky-tag-display)
913                     (funcall vc-cvs-sticky-tag-display tag type))
914                    (t nil)))
915    
916          (set-match-data data))))
917    
918  (defun vc-cvs-parse-entry (file &optional set-state)  (defun vc-cvs-parse-entry (file &optional set-state)
919    "Parse a line from CVS/Entries.    "Parse a line from CVS/Entries.
920  Compare modification time to that of the FILE, set file properties  Compare modification time to that of the FILE, set file properties
# Line 733  is non-nil." Line 931  is non-nil."
931       (concat "/[^/]+"       (concat "/[^/]+"
932               ;; revision               ;; revision
933               "/\\([^/]*\\)"               "/\\([^/]*\\)"
934               ;; timestamp               ;; timestamp and optional conflict field
935               "/[A-Z][a-z][a-z]"       ;; week day (irrelevant)               "/\\([^/]*\\)/"
936               " \\([A-Z][a-z][a-z]\\)" ;; month name               ;; options
937               " *\\([0-9]*\\)"         ;; day of month               "\\([^/]*\\)/"
938               " \\([0-9]*\\):\\([0-9]*\\):\\([0-9]*\\)"  ;; hms               ;; sticky tag
939               " \\([0-9]*\\)"          ;; year               "\\(.\\|\\)" ;Sticky tag type (date or tag name, could be empty)
940               ;; optional conflict field               "\\(.*\\)"))               ;Sticky tag
              "\\(+[^/]*\\)?/"))  
     (vc-file-setprop file 'vc-workfile-version (match-string 1))  
     ;; compare checkout time and modification time  
     (let ((second (string-to-number (match-string 6)))  
           (minute (string-to-number (match-string 5)))  
           (hour (string-to-number (match-string 4)))  
           (day (string-to-number (match-string 3)))  
           (year (string-to-number (match-string 7)))  
           (month (/ (string-match  
                      (match-string 2)  
                      "xxxJanFebMarAprMayJunJulAugSepOctNovDec")  
                     3))  
           (mtime (nth 5 (file-attributes file))))  
       (cond ((equal mtime  
                     (encode-time second minute hour day month year 0))  
              (vc-file-setprop file 'vc-checkout-time mtime)  
              (if set-state (vc-file-setprop file 'vc-state 'up-to-date)))  
             (t  
              (vc-file-setprop file 'vc-checkout-time 0)  
              (if set-state (vc-file-setprop file 'vc-state 'edited))))))  
    ;; entry with arbitrary text as timestamp  
    ;; (this means we should consider it modified)  
    ((looking-at  
      (concat "/[^/]+"  
              ;; revision  
              "/\\([^/]*\\)"  
              ;; timestamp (arbitrary text)  
              "/[^/]*"  
              ;; optional conflict field  
              "\\(+[^/]*\\)?/"))  
941      (vc-file-setprop file 'vc-workfile-version (match-string 1))      (vc-file-setprop file 'vc-workfile-version (match-string 1))
942      (vc-file-setprop file 'vc-checkout-time 0)      (vc-file-setprop file 'vc-cvs-sticky-tag
943      (if set-state (vc-file-setprop file 'vc-state 'edited)))))                       (vc-cvs-parse-sticky-tag (match-string 4)
944                                                  (match-string 5)))
945        ;; Compare checkout time and modification time.
946        ;; This is intentionally different from the algorithm that CVS uses
947        ;; (which is based on textual comparison), because there can be problems
948        ;; generating a time string that looks exactly like the one from CVS.
949        (let ((mtime (nth 5 (file-attributes file))))
950          (require 'parse-time)
951          (let ((parsed-time
952                 (parse-time-string (concat (match-string 2) " +0000"))))
953            (cond ((and (not (string-match "\\+" (match-string 2)))
954                        (car parsed-time)
955                        (equal mtime (apply 'encode-time parsed-time)))
956                   (vc-file-setprop file 'vc-checkout-time mtime)
957                   (if set-state (vc-file-setprop file 'vc-state 'up-to-date)))
958                  (t
959                   (vc-file-setprop file 'vc-checkout-time 0)
960                   (if set-state (vc-file-setprop file 'vc-state 'edited)))))))))
961    
962  (provide 'vc-cvs)  (provide 'vc-cvs)
963    
964    ;;; arch-tag: 60e1402a-aa53-4607-927a-cf74f144b432
965  ;;; vc-cvs.el ends here  ;;; vc-cvs.el ends here

Legend:
Removed from v.1.24.4.3  
changed lines
  Added in v.1.77

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26