/
vc.el
2756 lines (2588 loc) · 102 KB
/
vc.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; vc.el --- drive a version-control system from within Emacs
;; Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
;; Modified by:
;; ttn@netcom.com
;; Per Cederqvist <ceder@lysator.liu.edu>
;; Andre Spiegel <spiegel@berlin.informatik.uni-stuttgart.de>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This mode is fully documented in the Emacs user's manual.
;;
;; This was designed and implemented by Eric Raymond <esr@snark.thyrsus.com>.
;; Paul Eggert <eggert@twinsun.com>, Sebastian Kremer <sk@thp.uni-koeln.de>,
;; and Richard Stallman contributed valuable criticism, support, and testing.
;; CVS support was added by Per Cederqvist <ceder@lysator.liu.se>
;; in Jan-Feb 1994.
;;
;; Supported version-control systems presently include SCCS, RCS, and CVS.
;;
;; Some features will not work with old RCS versions. Where
;; appropriate, VC finds out which version you have, and allows or
;; disallows those features (stealing locks, for example, works only
;; from 5.6.2 onwards).
;; Even initial checkins will fail if your RCS version is so old that ci
;; doesn't understand -t-; this has been known to happen to people running
;; NExTSTEP 3.0.
;;
;; You can support the RCS -x option by adding pairs to the
;; vc-master-templates list.
;;
;; Proper function of the SCCS diff commands requires the shellscript vcdiff
;; to be installed somewhere on Emacs's path for executables.
;;
;; If your site uses the ChangeLog convention supported by Emacs, the
;; function vc-comment-to-change-log should prove a useful checkin hook.
;;
;; This code depends on call-process passing back the subprocess exit
;; status. Thus, you need Emacs 18.58 or later to run it. For the
;; vc-directory command to work properly as documented, you need 19.
;; You also need Emacs 19's ring.el.
;;
;; The vc code maintains some internal state in order to reduce expensive
;; version-control operations to a minimum. Some names are only computed
;; once. If you perform version control operations with RCS/SCCS/CVS while
;; vc's back is turned, or move/rename master files while vc is running,
;; vc may get seriously confused. Don't do these things!
;;
;; Developer's notes on some concurrency issues are included at the end of
;; the file.
;;; Code:
(require 'vc-hooks)
(require 'ring)
(eval-when-compile (require 'dired)) ; for dired-map-over-marks macro
(if (not (assoc 'vc-parent-buffer minor-mode-alist))
(setq minor-mode-alist
(cons '(vc-parent-buffer vc-parent-buffer-name)
minor-mode-alist)))
;; To implement support for a new version-control system, add another
;; branch to the vc-backend-dispatch macro and fill it in in each
;; call. The variable vc-master-templates in vc-hooks.el will also
;; have to change.
(defmacro vc-backend-dispatch (f s r c)
"Execute FORM1, FORM2 or FORM3 for SCCS, RCS or CVS respectively.
If FORM3 is `RCS', use FORM2 for CVS as well as RCS.
\(CVS shares some code with RCS)."
(list 'let (list (list 'type (list 'vc-backend f)))
(list 'cond
(list (list 'eq 'type (quote 'SCCS)) s) ;; SCCS
(list (list 'eq 'type (quote 'RCS)) r) ;; RCS
(list (list 'eq 'type (quote 'CVS)) ;; CVS
(if (eq c 'RCS) r c))
)))
;; General customization
(defvar vc-suppress-confirm nil
"*If non-nil, treat user as expert; suppress yes-no prompts on some things.")
(defvar vc-initial-comment nil
"*If non-nil, prompt for initial comment when a file is registered.")
(defvar vc-command-messages nil
"*If non-nil, display run messages from back-end commands.")
(defvar vc-checkin-switches nil
"*A string or list of strings specifying extra switches passed
to the checkin program by \\[vc-checkin].")
(defvar vc-checkout-switches nil
"*A string or list of strings specifying extra switches passed
to the checkout program by \\[vc-checkout].")
(defvar vc-directory-exclusion-list '("SCCS" "RCS" "CVS")
"*A list of directory names ignored by functions that recursively
walk file trees.")
(defconst vc-maximum-comment-ring-size 32
"Maximum number of saved comments in the comment ring.")
;;; This is duplicated in diff.el.
(defvar diff-switches "-c"
"*A string or list of strings specifying switches to be be passed to diff.")
;;;###autoload
(defvar vc-checkin-hook nil
"*List of functions called after a checkin is done. See `run-hooks'.")
(defvar vc-make-buffer-writable-hook nil
"*List of functions called when a buffer is made writable. See `run-hooks.'
This hook is only used when the version control system is CVS. It
might be useful for sites who uses locking with CVS, or who uses link
farms to gold trees.")
;; Header-insertion hair
(defvar vc-header-alist
'((SCCS "\%W\%") (RCS "\$Id\$") (CVS "\$Id\$"))
"*Header keywords to be inserted by `vc-insert-headers'.
Must be a list of two-element lists, the first element of each must
be `RCS', `CVS', or `SCCS'. The second element is the string to
be inserted for this particular backend.")
(defvar vc-static-header-alist
'(("\\.c$" .
"\n#ifndef lint\nstatic char vcid[] = \"\%s\";\n#endif /* lint */\n"))
"*Associate static header string templates with file types. A \%s in the
template is replaced with the first string associated with the file's
version-control type in `vc-header-alist'.")
(defvar vc-comment-alist
'((nroff-mode ".\\\"" ""))
"*Special comment delimiters to be used in generating vc headers only.
Add an entry in this list if you need to override the normal comment-start
and comment-end variables. This will only be necessary if the mode language
is sensitive to blank lines.")
;; Default is to be extra careful for super-user.
(defvar vc-checkout-carefully (= (user-uid) 0)
"*Non-nil means be extra-careful in checkout.
Verify that the file really is not locked
and that its contents match what the master file says.")
(defvar vc-rcs-release nil
"*The release number of your RCS installation, as a string.
If nil, VC itself computes this value when it is first needed.")
(defvar vc-sccs-release nil
"*The release number of your SCCS installation, as a string.
If nil, VC itself computes this value when it is first needed.")
(defvar vc-cvs-release nil
"*The release number of your CVS installation, as a string.
If nil, VC itself computes this value when it is first needed.")
;; Variables the user doesn't need to know about.
(defvar vc-log-entry-mode nil)
(defvar vc-log-operation nil)
(defvar vc-log-after-operation-hook nil)
(defvar vc-checkout-writable-buffer-hook 'vc-checkout-writable-buffer)
;; In a log entry buffer, this is a local variable
;; that points to the buffer for which it was made
;; (either a file, or a VC dired buffer).
(defvar vc-parent-buffer nil)
(defvar vc-parent-buffer-name nil)
(defvar vc-log-file)
(defvar vc-log-version)
(defconst vc-name-assoc-file "VC-names")
(defvar vc-dired-mode nil)
(make-variable-buffer-local 'vc-dired-mode)
(defvar vc-comment-ring nil)
(defvar vc-comment-ring-index nil)
(defvar vc-last-comment-match nil)
;; Back-portability to Emacs 18
(defun file-executable-p-18 (f)
(let ((modes (file-modes f)))
(and modes (not (zerop (logand 292))))))
(defun file-regular-p-18 (f)
(let ((attributes (file-attributes f)))
(and attributes (not (car attributes)))))
; Conditionally rebind some things for Emacs 18 compatibility
(if (not (boundp 'minor-mode-map-alist))
(progn
(setq compilation-old-error-list nil)
(fset 'file-executable-p 'file-executable-p-18)
(fset 'shrink-window-if-larger-than-buffer 'beginning-of-buffer)
))
(if (not (fboundp 'file-regular-p))
(fset 'file-regular-p 'file-regular-p-18))
;;; Find and compare backend releases
(defun vc-backend-release (backend)
;; Returns which backend release is installed on this system.
(cond
((eq backend 'RCS)
(or vc-rcs-release
(and (zerop (vc-do-command nil 2 "rcs" nil nil "-V"))
(save-excursion
(set-buffer (get-buffer "*vc*"))
(setq vc-rcs-release
(car (vc-parse-buffer
'(("^RCS version \\([0-9.]+ *.*\\)" 1)))))))
(setq vc-rcs-release 'unknown)))
((eq backend 'CVS)
(or vc-cvs-release
(and (zerop (vc-do-command nil 1 "cvs" nil nil "-v"))
(save-excursion
(set-buffer (get-buffer "*vc*"))
(setq vc-cvs-release
(car (vc-parse-buffer
'(("^Concurrent Versions System (CVS) \\([0-9.]+\\)"
1)))))))
(setq vc-cvs-release 'unknown)))
((eq backend 'SCCS)
vc-sccs-release)))
(defun vc-release-greater-or-equal (r1 r2)
;; Compare release numbers, represented as strings.
;; Release components are assumed cardinal numbers, not decimal
;; fractions (5.10 is a higher release than 5.9). Omitted fields
;; are considered lower (5.6.7 is earlier than 5.6.7.1).
;; Comparison runs till the end of the string is found, or a
;; non-numeric component shows up (5.6.7 is earlier than "5.6.7 beta",
;; which is probably not what you want in some cases).
;; This code is suitable for existing RCS release numbers.
;; CVS releases are handled reasonably, too (1.3 < 1.4* < 1.5).
(let (v1 v2 i1 i2)
(catch 'done
(or (and (string-match "^\\.?\\([0-9]+\\)" r1)
(setq i1 (match-end 0))
(setq v1 (string-to-number (match-string 1 r1)))
(or (and (string-match "^\\.?\\([0-9]+\\)" r2)
(setq i2 (match-end 0))
(setq v2 (string-to-number (match-string 1 r2)))
(if (> v1 v2) (throw 'done t)
(if (< v1 v2) (throw 'done nil)
(throw 'done
(vc-release-greater-or-equal
(substring r1 i1)
(substring r2 i2)))))))
(throw 'done t)))
(or (and (string-match "^\\.?\\([0-9]+\\)" r2)
(throw 'done nil))
(throw 'done t)))))
(defun vc-backend-release-p (backend release)
;; Return t if we have RELEASE of BACKEND or better
(let (i r (ri 0) (ii 0) is rs (installation (vc-backend-release backend)))
(if (not (eq installation 'unknown))
(cond
((or (eq backend 'RCS) (eq backend 'CVS))
(vc-release-greater-or-equal installation release))))))
;;; functions that operate on RCS revision numbers
(defun vc-trunk-p (rev)
;; return t if REV is a revision on the trunk
(not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev))))
(defun vc-branch-part (rev)
;; return the branch part of a revision number REV
(substring rev 0 (string-match "\\.[0-9]+\\'" rev)))
;; File property caching
(defun vc-clear-context ()
"Clear all cached file properties and the comment ring."
(interactive)
(fillarray vc-file-prop-obarray nil)
;; Note: there is potential for minor lossage here if there is an open
;; log buffer with a nonzero local value of vc-comment-ring-index.
(setq vc-comment-ring nil))
(defun vc-file-clear-masterprops (file)
;; clear all properties of FILE that were retrieved
;; from the master file
(vc-file-setprop file 'vc-latest-version nil)
(vc-file-setprop file 'vc-your-latest-version nil)
(vc-backend-dispatch file
(progn ;; SCCS
(vc-file-setprop file 'vc-master-locks nil))
(progn ;; RCS
(vc-file-setprop file 'vc-default-branch nil)
(vc-file-setprop file 'vc-head-version nil)
(vc-file-setprop file 'vc-master-workfile-version nil)
(vc-file-setprop file 'vc-master-locks nil))
(progn
(vc-file-setprop file 'vc-cvs-status nil))))
(defun vc-head-version (file)
;; Return the RCS head version of FILE
(cond ((vc-file-getprop file 'vc-head-version))
(t (vc-fetch-master-properties file)
(vc-file-getprop file 'vc-head-version))))
;; Random helper functions
(defun vc-latest-on-branch-p (file)
;; return t iff the current workfile version of FILE is
;; the latest on its branch.
(vc-backend-dispatch file
;; SCCS
(string= (vc-workfile-version file) (vc-latest-version file))
;; RCS
(let ((workfile-version (vc-workfile-version file)) tip-version)
(if (vc-trunk-p workfile-version)
(progn
;; Re-fetch the head version number. This is to make
;; sure that no-one has checked in a new version behind
;; our back.
(vc-fetch-master-properties file)
(string= (vc-file-getprop file 'vc-head-version)
workfile-version))
;; If we are not on the trunk, we need to examine the
;; whole current branch. (vc-master-workfile-version
;; is not what we need.)
(save-excursion
(set-buffer (get-buffer-create "*vc-info*"))
(vc-insert-file (vc-name file) "^desc")
(setq tip-version (car (vc-parse-buffer (list (list
(concat "^\\(" (regexp-quote (vc-branch-part workfile-version))
"\\.[0-9]+\\)\ndate[ \t]+\\([0-9.]+\\);") 1 2)))))
(if (get-buffer "*vc-info*")
(kill-buffer (get-buffer "*vc-info*")))
(string= tip-version workfile-version))))
;; CVS
t))
(defun vc-registration-error (file)
(if file
(error "File %s is not under version control" file)
(error "Buffer %s is not associated with a file" (buffer-name))))
(defvar vc-binary-assoc nil)
(defun vc-find-binary (name)
"Look for a command anywhere on the subprocess-command search path."
(or (cdr (assoc name vc-binary-assoc))
(catch 'found
(mapcar
(function
(lambda (s)
(if s
(let ((full (concat s "/" name)))
(if (file-executable-p full)
(progn
(setq vc-binary-assoc
(cons (cons name full) vc-binary-assoc))
(throw 'found full)))))))
exec-path)
nil)))
(defun vc-do-command (buffer okstatus command file last &rest flags)
"Execute a version-control command, notifying user and checking for errors.
Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil.
The command is successful if its exit status does not exceed OKSTATUS.
The last argument of the command is the master name of FILE if LAST is
`MASTER', or the workfile of FILE if LAST is `WORKFILE'; this is appended
to an optional list of FLAGS."
(and file (setq file (expand-file-name file)))
(if (not buffer) (setq buffer "*vc*"))
(if vc-command-messages
(message "Running %s on %s..." command file))
(let ((obuf (current-buffer)) (camefrom (current-buffer))
(squeezed nil)
(vc-file (and file (vc-name file)))
(olddir default-directory)
status)
(set-buffer (get-buffer-create buffer))
(set (make-local-variable 'vc-parent-buffer) camefrom)
(set (make-local-variable 'vc-parent-buffer-name)
(concat " from " (buffer-name camefrom)))
(setq default-directory olddir)
(erase-buffer)
(mapcar
(function (lambda (s) (and s (setq squeezed (append squeezed (list s))))))
flags)
(if (and vc-file (eq last 'MASTER))
(setq squeezed (append squeezed (list vc-file))))
(if (eq last 'WORKFILE)
(progn
(let* ((pwd (expand-file-name default-directory))
(preflen (length pwd)))
(if (string= (substring file 0 preflen) pwd)
(setq file (substring file preflen))))
(setq squeezed (append squeezed (list file)))))
(let ((exec-path (append vc-path exec-path))
;; Add vc-path to PATH for the execution of this command.
(process-environment
(cons (concat "PATH=" (getenv "PATH")
path-separator
(mapconcat 'identity vc-path path-separator))
process-environment)))
(setq status (apply 'call-process command nil t nil squeezed)))
(goto-char (point-max))
(set-buffer-modified-p nil)
(forward-line -1)
(if (or (not (integerp status)) (< okstatus status))
(progn
(pop-to-buffer buffer)
(goto-char (point-min))
(shrink-window-if-larger-than-buffer)
(error "Running %s...FAILED (%s)" command
(if (integerp status)
(format "status %d" status)
status))
)
(if vc-command-messages
(message "Running %s...OK" command))
)
(set-buffer obuf)
status)
)
;;; Save a bit of the text around POSN in the current buffer, to help
;;; us find the corresponding position again later. This works even
;;; if all markers are destroyed or corrupted.
;;; A lot of this was shamelessly lifted from Sebastian Kremer's rcs.el mode.
(defun vc-position-context (posn)
(list posn
(buffer-size)
(buffer-substring posn
(min (point-max) (+ posn 100)))))
;;; Return the position of CONTEXT in the current buffer, or nil if we
;;; couldn't find it.
(defun vc-find-position-by-context (context)
(let ((context-string (nth 2 context)))
(if (equal "" context-string)
(point-max)
(save-excursion
(let ((diff (- (nth 1 context) (buffer-size))))
(if (< diff 0) (setq diff (- diff)))
(goto-char (nth 0 context))
(if (or (search-forward context-string nil t)
;; Can't use search-backward since the match may continue
;; after point.
(progn (goto-char (- (point) diff (length context-string)))
;; goto-char doesn't signal an error at
;; beginning of buffer like backward-char would
(search-forward context-string nil t)))
;; to beginning of OSTRING
(- (point) (length context-string))))))))
(defun vc-buffer-context ()
;; Return a list '(point-context mark-context reparse); from which
;; vc-restore-buffer-context can later restore the context.
(let ((point-context (vc-position-context (point)))
;; Use mark-marker to avoid confusion in transient-mark-mode.
(mark-context (if (eq (marker-buffer (mark-marker)) (current-buffer))
(vc-position-context (mark-marker))))
;; Make the right thing happen in transient-mark-mode.
(mark-active nil)
;; We may want to reparse the compilation buffer after revert
(reparse (and (boundp 'compilation-error-list) ;compile loaded
(let ((curbuf (current-buffer)))
;; Construct a list; each elt is nil or a buffer
;; iff that buffer is a compilation output buffer
;; that contains markers into the current buffer.
(save-excursion
(mapcar (function
(lambda (buffer)
(set-buffer buffer)
(let ((errors (or
compilation-old-error-list
compilation-error-list))
(buffer-error-marked-p nil))
(while (and (consp errors)
(not buffer-error-marked-p))
(and (markerp (cdr (car errors)))
(eq buffer
(marker-buffer
(cdr (car errors))))
(setq buffer-error-marked-p t))
(setq errors (cdr errors)))
(if buffer-error-marked-p buffer))))
(buffer-list)))))))
(list point-context mark-context reparse)))
(defun vc-restore-buffer-context (context)
;; Restore point/mark, and reparse any affected compilation buffers.
;; CONTEXT is that which vc-buffer-context returns.
(let ((point-context (nth 0 context))
(mark-context (nth 1 context))
(reparse (nth 2 context)))
;; Reparse affected compilation buffers.
(while reparse
(if (car reparse)
(save-excursion
(set-buffer (car reparse))
(let ((compilation-last-buffer (current-buffer)) ;select buffer
;; Record the position in the compilation buffer of
;; the last error next-error went to.
(error-pos (marker-position
(car (car-safe compilation-error-list)))))
;; Reparse the error messages as far as they were parsed before.
(compile-reinitialize-errors '(4) compilation-parsing-end)
;; Move the pointer up to find the error we were at before
;; reparsing. Now next-error should properly go to the next one.
(while (and compilation-error-list
(/= error-pos (car (car compilation-error-list))))
(setq compilation-error-list (cdr compilation-error-list))))))
(setq reparse (cdr reparse)))
;; Restore point and mark
(let ((new-point (vc-find-position-by-context point-context)))
(if new-point (goto-char new-point)))
(if mark-context
(let ((new-mark (vc-find-position-by-context mark-context)))
(if new-mark (set-mark new-mark))))))
(defun vc-revert-buffer1 (&optional arg no-confirm)
;; Revert buffer, try to keep point and mark where user expects them in spite
;; of changes because of expanded version-control key words.
;; This is quite important since otherwise typeahead won't work as expected.
(interactive "P")
(widen)
(let ((context (vc-buffer-context)))
;; t means don't call normal-mode; that's to preserve various minor modes.
(revert-buffer arg no-confirm t)
(vc-restore-buffer-context context)))
(defun vc-buffer-sync (&optional not-urgent)
;; Make sure the current buffer and its working file are in sync
;; NOT-URGENT means it is ok to continue if the user says not to save.
(if (buffer-modified-p)
(if (or vc-suppress-confirm
(y-or-n-p (format "Buffer %s modified; save it? " (buffer-name))))
(save-buffer)
(if not-urgent
nil
(error "Aborted")))))
(defun vc-workfile-unchanged-p (file &optional want-differences-if-changed)
;; Has the given workfile changed since last checkout?
(let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
(lastmod (nth 5 (file-attributes file))))
(or (equal checkout-time lastmod)
(and (or (not checkout-time) want-differences-if-changed)
(let ((unchanged (zerop (vc-backend-diff file nil nil
(not want-differences-if-changed)))))
;; 0 stands for an unknown time; it can't match any mod time.
(vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0))
unchanged)))))
(defun vc-next-action-on-file (file verbose &optional comment)
;;; If comment is specified, it will be used as an admin or checkin comment.
(let ((vc-file (vc-name file))
(vc-type (vc-backend file))
owner version buffer)
(cond
;; if there is no master file corresponding, create one
((not vc-file)
(vc-register verbose comment)
(if vc-initial-comment
(setq vc-log-after-operation-hook
'vc-checkout-writable-buffer-hook)
(vc-checkout-writable-buffer file)))
;; CVS: changes to the master file need to be
;; merged back into the working file
((and (eq vc-type 'CVS)
(or (eq (vc-cvs-status file) 'needs-checkout)
(eq (vc-cvs-status file) 'needs-merge)))
(if (or vc-dired-mode
(yes-or-no-p
(format "%s is not up-to-date. Merge in changes now? "
(buffer-name))))
(progn
(if vc-dired-mode
(and (setq buffer (get-file-buffer file))
(buffer-modified-p buffer)
(switch-to-buffer-other-window buffer)
(vc-buffer-sync t))
(setq buffer (current-buffer))
(vc-buffer-sync t))
(if (and buffer (buffer-modified-p buffer)
(not (yes-or-no-p
(format
"Buffer %s modified; merge file on disc anyhow? "
(buffer-name buffer)))))
(error "Merge aborted"))
(if (not (zerop (vc-backend-merge-news file)))
;; Overlaps detected - what now? Should use some
;; fancy RCS conflict resolving package, or maybe
;; emerge, but for now, simply warn the user with a
;; message.
(message "Conflicts detected!"))
(and buffer
(vc-resynch-buffer file t (not (buffer-modified-p buffer)))))
(error "%s needs update" (buffer-name))))
;; if there is no lock on the file, assert one and get it
((not (setq owner (vc-locking-user file)))
(if (and vc-checkout-carefully
(not (vc-workfile-unchanged-p file t)))
(if (save-window-excursion
(pop-to-buffer "*vc-diff*")
(goto-char (point-min))
(insert-string (format "Changes to %s since last lock:\n\n"
file))
(not (beep))
(yes-or-no-p
(concat "File has unlocked changes, "
"claim lock retaining changes? ")))
(progn (vc-backend-steal file)
(vc-mode-line file))
(if (not (yes-or-no-p "Revert to checked-in version, instead? "))
(error "Checkout aborted")
(vc-revert-buffer1 t t)
(vc-checkout-writable-buffer file))
)
(if verbose
(if (not (eq vc-type 'SCCS))
(vc-checkout file nil
(read-string "Branch or version to move to: "))
(error "Sorry, this is not implemented for SCCS"))
(if (vc-latest-on-branch-p file)
(vc-checkout-writable-buffer file)
(if (yes-or-no-p
"This is not the latest version. Really lock it? ")
(vc-checkout-writable-buffer file)
(if (yes-or-no-p "Lock the latest version instead? ")
(vc-checkout-writable-buffer file
(if (vc-trunk-p (vc-workfile-version file))
"" ;; this means check out latest on trunk
(vc-branch-part (vc-workfile-version file)))))))
)))
;; a checked-out version exists, but the user may not own the lock
((and (not (eq vc-type 'CVS))
(not (string-equal owner (user-login-name))))
(if comment
(error "Sorry, you can't steal the lock on %s this way" file))
(and (eq vc-type 'RCS)
(not (vc-backend-release-p 'RCS "5.6.2"))
(error "File is locked by %s" owner))
(vc-steal-lock
file
(if verbose (read-string "Version to steal: ")
(vc-workfile-version file))
owner))
;; OK, user owns the lock on the file
(t
(if vc-dired-mode
(find-file-other-window file)
(find-file file))
;; give luser a chance to save before checking in.
(vc-buffer-sync)
;; Revert if file is unchanged and buffer is too.
;; If buffer is modified, that means the user just said no
;; to saving it; in that case, don't revert,
;; because the user might intend to save
;; after finishing the log entry.
(if (and (vc-workfile-unchanged-p file)
(not (buffer-modified-p)))
;; DO NOT revert the file without asking the user!
(cond
((yes-or-no-p "Revert to master version? ")
(vc-backend-revert file)
(vc-resynch-window file t t)))
;; user may want to set nonstandard parameters
(if verbose
(setq version (read-string "New version level: ")))
;; OK, let's do the checkin
(vc-checkin file version comment)
)))))
(defun vc-next-action-dired (file rev comment)
;; Do a vc-next-action-on-file on all the marked files, possibly
;; passing on the log comment we've just entered.
(let ((configuration (current-window-configuration))
(dired-buffer (current-buffer))
(dired-dir default-directory))
(dired-map-over-marks
(let ((file (dired-get-filename)) p
(default-directory default-directory))
(message "Processing %s..." file)
;; Adjust the default directory so that checkouts
;; go to the right place.
(setq default-directory (file-name-directory file))
(vc-next-action-on-file file nil comment)
(set-buffer dired-buffer)
(setq default-directory dired-dir)
(vc-dired-update-line file)
(set-window-configuration configuration)
(message "Processing %s...done" file))
nil t)))
;; Here's the major entry point.
;;;###autoload
(defun vc-next-action (verbose)
"Do the next logical checkin or checkout operation on the current file.
If you call this from within a VC dired buffer with no files marked,
it will operate on the file in the current line.
If you call this from within a VC dired buffer, and one or more
files are marked, it will accept a log message and then operate on
each one. The log message will be used as a comment for any register
or checkin operations, but ignored when doing checkouts. Attempted
lock steals will raise an error.
A prefix argument lets you specify the version number to use.
For RCS and SCCS files:
If the file is not already registered, this registers it for version
control and then retrieves a writable, locked copy for editing.
If the file is registered and not locked by anyone, this checks out
a writable and locked file ready for editing.
If the file is checked out and locked by the calling user, this
first checks to see if the file has changed since checkout. If not,
it performs a revert.
If the file has been changed, this pops up a buffer for entry
of a log message; when the message has been entered, it checks in the
resulting changes along with the log message as change commentary. If
the variable `vc-keep-workfiles' is non-nil (which is its default), a
read-only copy of the changed file is left in place afterwards.
If the file is registered and locked by someone else, you are given
the option to steal the lock.
For CVS files:
If the file is not already registered, this registers it for version
control. This does a \"cvs add\", but no \"cvs commit\".
If the file is added but not committed, it is committed.
If your working file is changed, but the repository file is
unchanged, this pops up a buffer for entry of a log message; when the
message has been entered, it checks in the resulting changes along
with the logmessage as change commentary. A writable file is retained.
If the repository file is changed, you are asked if you want to
merge in the changes into your working copy."
(interactive "P")
(catch 'nogo
(if vc-dired-mode
(let ((files (dired-get-marked-files)))
(if (string= ""
(mapconcat
(function (lambda (f)
(if (eq (vc-backend f) 'CVS)
(if (or (eq (vc-cvs-status f) 'locally-modified)
(eq (vc-cvs-status f) 'locally-added))
"@" "")
(if (vc-locking-user f) "@" ""))))
files ""))
(vc-next-action-dired nil nil "dummy")
(vc-start-entry nil nil nil
"Enter a change comment for the marked files."
'vc-next-action-dired))
(throw 'nogo nil)))
(while vc-parent-buffer
(pop-to-buffer vc-parent-buffer))
(if buffer-file-name
(vc-next-action-on-file buffer-file-name verbose)
(vc-registration-error nil))))
;;; These functions help the vc-next-action entry point
(defun vc-checkout-writable-buffer (&optional file rev)
"Retrieve a writable copy of the latest version of the current buffer's file."
(vc-checkout (or file (buffer-file-name)) t rev)
)
;;;###autoload
(defun vc-register (&optional override comment)
"Register the current file into your version-control system."
(interactive "P")
(or buffer-file-name
(error "No visited file"))
(let ((master (vc-name buffer-file-name)))
(and master (file-exists-p master)
(error "This file is already registered"))
(and master
(not (y-or-n-p "Previous master file has vanished. Make a new one? "))
(error "This file is already registered")))
;; Watch out for new buffers of size 0: the corresponding file
;; does not exist yet, even though buffer-modified-p is nil.
(if (and (not (buffer-modified-p))
(zerop (buffer-size))
(not (file-exists-p buffer-file-name)))
(set-buffer-modified-p t))
(vc-buffer-sync)
(cond ((not vc-make-backup-files)
;; inhibit backup for this buffer
(make-local-variable 'backup-inhibited)
(setq backup-inhibited t)))
(vc-admin
buffer-file-name
(and override
(read-string
(format "Initial version level for %s: " buffer-file-name))))
)
(defun vc-resynch-window (file &optional keep noquery)
;; If the given file is in the current buffer,
;; either revert on it so we see expanded keywords,
;; or unvisit it (depending on vc-keep-workfiles)
;; NOQUERY if non-nil inhibits confirmation for reverting.
;; NOQUERY should be t *only* if it is known the only difference
;; between the buffer and the file is due to RCS rather than user editing!
(and (string= buffer-file-name file)
(if keep
(progn
;; temporarily remove vc-find-file-hook, so that
;; we don't lose the properties
(remove-hook 'find-file-hooks 'vc-find-file-hook)
(vc-revert-buffer1 t noquery)
(add-hook 'find-file-hooks 'vc-find-file-hook)
(vc-mode-line buffer-file-name))
(kill-buffer (current-buffer)))))
(defun vc-resynch-buffer (file &optional keep noquery)
;; if FILE is currently visited, resynch its buffer
(let ((buffer (get-file-buffer file)))
(if buffer
(save-excursion
(set-buffer buffer)
(vc-resynch-window file keep noquery)))))
(defun vc-start-entry (file rev comment msg action &optional after-hook)
;; Accept a comment for an operation on FILE revision REV. If COMMENT
;; is nil, pop up a VC-log buffer, emit MSG, and set the
;; action on close to ACTION; otherwise, do action immediately.
;; Remember the file's buffer in vc-parent-buffer (current one if no file).
;; AFTER-HOOK specifies the local value for vc-log-operation-hook.
(let ((parent (if file (find-file-noselect file) (current-buffer))))
(if comment
(set-buffer (get-buffer-create "*VC-log*"))
(pop-to-buffer (get-buffer-create "*VC-log*")))
(set (make-local-variable 'vc-parent-buffer) parent)
(set (make-local-variable 'vc-parent-buffer-name)
(concat " from " (buffer-name vc-parent-buffer)))
(if file (vc-mode-line file))
(vc-log-mode)
(make-local-variable 'vc-log-after-operation-hook)
(if after-hook
(setq vc-log-after-operation-hook after-hook))
(setq vc-log-operation action)
(setq vc-log-file file)
(setq vc-log-version rev)
(if comment
(progn
(erase-buffer)
(if (eq comment t)
(vc-finish-logentry t)
(insert comment)
(vc-finish-logentry nil)))
(message "%s Type C-c C-c when done." msg))))
(defun vc-admin (file rev &optional comment)
"Check a file into your version-control system.
FILE is the unmodified name of the file. REV should be the base version
level to check it in under. COMMENT, if specified, is the checkin comment."
(vc-start-entry file rev
(or comment (not vc-initial-comment))
"Enter initial comment." 'vc-backend-admin
nil))
(defun vc-checkout (file &optional writable rev)
"Retrieve a copy of the latest version of the given file."
;; If ftp is on this system and the name matches the ange-ftp format
;; for a remote file, the user is trying something that won't work.
(if (and (string-match "^/[^/:]+:" file) (vc-find-binary "ftp"))
(error "Sorry, you can't check out files over FTP"))
(vc-backend-checkout file writable rev)
(vc-resynch-buffer file t t))
(defun vc-steal-lock (file rev &optional owner)
"Steal the lock on the current workfile."
(let (file-description)
(if (not owner)
(setq owner (vc-locking-user file)))
(if rev
(setq file-description (format "%s:%s" file rev))
(setq file-description file))
(if (not (y-or-n-p (format "Take the lock on %s from %s? "
file-description owner)))
(error "Steal cancelled"))
(pop-to-buffer (get-buffer-create "*VC-mail*"))
(setq default-directory (expand-file-name "~/"))
(auto-save-mode auto-save-default)
(mail-mode)
(erase-buffer)
(mail-setup owner (format "Stolen lock on %s" file-description) nil nil nil
(list (list 'vc-finish-steal file rev)))
(goto-char (point-max))
(insert
(format "I stole the lock on %s, " file-description)
(current-time-string)
".\n")
(message "Please explain why you stole the lock. Type C-c C-c when done.")))
;; This is called when the notification has been sent.
(defun vc-finish-steal (file version)
(vc-backend-steal file version)
(if (get-file-buffer file)
(save-excursion
(set-buffer (get-file-buffer file))
(vc-resynch-window file t t))))
(defun vc-checkin (file &optional rev comment)
"Check in the file specified by FILE.
The optional argument REV may be a string specifying the new version level
\(if nil increment the current level). The file is either retained with write
permissions zeroed, or deleted (according to the value of `vc-keep-workfiles').
If the back-end is CVS, a writable workfile is always kept.
COMMENT is a comment string; if omitted, a buffer is
popped up to accept a comment."
(vc-start-entry file rev comment
"Enter a change comment." 'vc-backend-checkin
'vc-checkin-hook))
;;; Here is a checkin hook that may prove useful to sites using the
;;; ChangeLog facility supported by Emacs.
(defun vc-comment-to-change-log (&optional whoami file-name)
"Enter last VC comment into change log file for current buffer's file.
Optional arg (interactive prefix) non-nil means prompt for user name and site.
Second arg is file name of change log. \
If nil, uses `change-log-default-name'."
(interactive (if current-prefix-arg
(list current-prefix-arg
(prompt-for-change-log-name))))
;; Make sure the defvar for add-log-current-defun-function has been executed
;; before binding it.
(require 'add-log)
(let (;; Extract the comment first so we get any error before doing anything.
(comment (ring-ref vc-comment-ring 0))
;; Don't let add-change-log-entry insert a defun name.
(add-log-current-defun-function 'ignore)
end)
;; Call add-log to do half the work.
(add-change-log-entry whoami file-name t t)
;; Insert the VC comment, leaving point before it.
(setq end (save-excursion (insert comment) (point-marker)))
(if (looking-at "\\s *\\s(")
;; It starts with an open-paren, as in "(foo): Frobbed."
;; So remove the ": " add-log inserted.
(delete-char -2))
;; Canonicalize the white space between the file name and comment.
(just-one-space)
;; Indent rest of the text the same way add-log indented the first line.
(let ((indentation (current-indentation)))
(save-excursion
(while (< (point) end)
(forward-line 1)
(indent-to indentation))
(setq end (point))))
;; Fill the inserted text, preserving open-parens at bol.
(let ((paragraph-separate (concat paragraph-separate "\\|\\s *\\s("))
(paragraph-start (concat paragraph-start "\\|\\s *\\s(")))
(beginning-of-line)
(fill-region (point) end))
;; Canonicalize the white space at the end of the entry so it is
;; separated from the next entry by a single blank line.
(skip-syntax-forward " " end)
(delete-char (- (skip-syntax-backward " ")))
(or (eobp) (looking-at "\n\n")
(insert "\n"))))
(defun vc-finish-logentry (&optional nocomment)
"Complete the operation implied by the current log entry."
(interactive)
;; Check and record the comment, if any.