3
;;; $Id: vc.scm,v 1.79 2001/06/07 17:48:19 cph Exp $
5
;;; Copyright (c) 1994-2001 Massachusetts Institute of Technology
7
;;; This program is free software; you can redistribute it and/or
8
;;; modify it under the terms of the GNU General Public License as
9
;;; published by the Free Software Foundation; either version 2 of the
10
;;; License, or (at your option) any later version.
12
;;; This program is distributed in the hope that it will be useful,
13
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15
;;; General Public License for more details.
17
;;; You should have received a copy of the GNU General Public License
18
;;; along with this program; if not, write to the Free Software
19
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
24
;;; Adapted from "vc.el" in Emacs 19.22.
25
;;; Updated March 2000 from "vc.el" in Emacs 20.6.
27
(declare (usual-integrations))
31
(define-variable vc-make-backup-files
32
"If true, backups of registered files are made as with other files.
33
If false (the default), files covered by version control don't get backups."
37
(define-variable-per-buffer vc-mode-line-status
38
"A mode line string showing the version control status of the buffer.
39
Bound to #F if the buffer is not under version control."
42
(let ((variable (ref-variable-object vc-mode-line-status)))
43
;;(variable-permanent-local! variable)
44
(set-variable! minor-mode-alist
45
(cons (list variable variable)
46
(ref-variable minor-mode-alist))))
48
(define-variable vc-suppress-confirm
49
"If true, treat user as expert; suppress yes-no prompts on some things."
53
(define-variable vc-keep-workfiles
54
"If true, don't delete working files after registering changes.
55
If the back-end is CVS, workfiles are always kept, regardless of the
60
(define-variable vc-delete-logbuf-window
61
"If true, delete the *VC-log* buffer and window after each logical action.
62
If false, bury that buffer instead.
63
This is most useful if you have multiple windows on a frame and would like to
64
preserve the setting."
68
(define-variable vc-initial-comment
69
"Prompt for initial comment when a file is registered."
73
(define-variable vc-default-init-version
74
"A string used as the default version number when a new file is registered.
75
This can be overriden by giving a prefix argument to \\[vc-register]."
79
(define-variable vc-command-messages
80
"If true, display run messages from back-end commands."
84
(define-variable diff-switches
85
"A list of strings specifying switches to be be passed to diff."
89
(define-variable vc-checkin-hooks
90
"An event distributor that is invoked after a checkin is done."
91
(make-event-distributor))
93
(define-variable vc-checkout-carefully
94
"True means be extra-careful in checkout.
95
Verify that the file really is not locked
96
and that its contents match what the master file says."
97
;; Default is to be extra careful for super-user.
98
(lambda () (= (unix/current-uid) 0))
100
(or (boolean? object)
101
(and (procedure? object)
102
(procedure-arity-valid? object 0)))))
104
(define-variable vc-log-mode-hook
105
"An event distributor that is invoked when entering VC-log mode."
106
(make-event-distributor))
108
(define-variable vc-follow-symlinks
109
"Indicates what to do if you visit a symbolic link to a file
110
that is under version control. Editing such a file through the
111
link bypasses the version control system, which is dangerous and
112
probably not what you want.
113
If this variable is #t, VC follows the link and visits the real file,
114
telling you about it in the echo area. If it is `ask', VC asks for
115
confirmation whether it should follow the link. If #f, the link is
116
visited and a warning displayed."
118
(lambda (object) (or (boolean? object) (eq? 'ASK object))))
120
(define-variable vc-display-status
121
"If true, display revision number and lock status in modeline.
122
Otherwise, not displayed."
126
(define-variable vc-rcs-preserve-mod-times
127
"If true, files checked out from RCS use checkin time for mod time.
128
Otherwise, the mod time of the file is the checkout time."
132
;;;; VC-TYPE datatype
134
(define-structure (vc-type (constructor %make-vc-type
135
(name display-name header-keyword))
137
(name #f read-only #t) ;a symbol
138
(display-name #f read-only #t) ;a string
139
(header-keyword #f read-only #t) ;a string
140
(operations (make-1d-table) read-only #t)
141
(properties (make-1d-table) read-only #t))
143
(define (vc-type-get type key default)
144
(1d-table/get (vc-type-properties type) key default))
146
(define (vc-type-put! type key value)
147
(1d-table/put! (vc-type-properties type) key value))
149
(define (vc-type-remove! type key)
150
(1d-table/remove! (vc-type-properties type) key))
152
(define (make-vc-type name display-name header-keyword)
153
(let ((type (%make-vc-type name display-name header-keyword)))
154
(let loop ((types vc-types))
156
(if (eq? name (vc-type-name (car types)))
157
(set-car! types type)
159
(set! vc-types (cons type vc-types))))
162
(define vc-types '())
164
(define (define-vc-type-operation name type procedure)
165
(1d-table/put! (vc-type-operations type) name procedure))
167
(define (vc-type-operation type name)
168
(or (1d-table/get (vc-type-operations type) name #f)
169
(error:bad-range-argument name 'VC-TYPE-OPERATION)))
171
(define (vc-call name master . arguments)
172
(apply (vc-type-operation (vc-master-type master) name) master arguments))
174
;;;; VC-MASTER datatype
176
(define-structure (vc-master (constructor make-vc-master
177
(type pathname workfile))
179
(type #f read-only #t) ;a VC-TYPE object
180
(pathname #f read-only #t) ;a PATHNAME object
181
(workfile #f read-only #t) ;a PATHNAME object
182
(properties (make-1d-table) read-only #t))
184
(define (vc-master-get master key default)
185
(1d-table/get (vc-master-properties master) key default))
187
(define (vc-master-put! master key value)
188
(1d-table/put! (vc-master-properties master) key value))
190
(define (vc-master-remove! master key)
191
(1d-table/remove! (vc-master-properties master) key))
193
(define (read-cached-value-1 master key pathname read-value)
195
(let ((v.t (vc-master-get master key #f))
196
(time (file-modification-time pathname)))
197
(if (and v.t (eqv? time (cdr v.t)))
200
(vc-master-put! master key (cons (read-value time) time))
203
(define (cache-value-1! master key pathname read-value)
204
(let ((time (file-modification-time pathname)))
205
(let ((value (read-value)))
206
(vc-master-put! master key (cons value time))
209
(define (read-cached-value-2 master key p1 p2 read-value)
211
(let ((vtt (vc-master-get master key #f))
212
(t1 (file-modification-time p1))
213
(t2 (file-modification-time p2)))
215
(eqv? t1 (vector-ref vtt 1))
216
(eqv? t2 (vector-ref vtt 2)))
219
(vc-master-put! master key (vector (read-value t1 t2) t1 t2))
222
(define (cache-value-2! master key p1 p2 read-value)
223
(let ((t1 (file-modification-time p1))
224
(t2 (file-modification-time p2)))
225
(let ((value (read-value t1 t2)))
226
(vc-master-put! master key (vector value t1 t2))
231
(set-variable! find-file-hooks
232
(append! (ref-variable find-file-hooks)
233
(list (lambda (buffer) (vc-hook:find-file buffer)))))
235
(define (vc-hook:find-file buffer)
236
(cond ((buffer-vc-master buffer #f)
238
(vc-mode-line master buffer)
239
(if (not (ref-variable vc-make-backup-files buffer))
240
(local-set-variable! make-backup-files #f buffer))
242
((let ((pathname (buffer-pathname buffer)))
243
(and (file-symbolic-link? pathname)
244
(file-vc-master (file-chase-links pathname) #f)))
246
(let ((workfile (vc-master-workfile master))
247
(type (vc-type-display-name (vc-master-type master))))
252
(or (pathname->buffer workfile)
253
(find-file-noselect workfile #f))))
254
(message "Followed link to "
255
(->namestring workfile))
257
(case (ref-variable vc-follow-symlinks buffer)
259
(message "Warning: symbolic link to "
261
"-controlled source file"))
263
(if (or (pathname->buffer workfile)
264
(prompt-for-yes-or-no?
268
"-controlled source file; follow link")))
272
"Warning: editing through the link bypasses version control.")
278
find-file-not-found-hooks
279
(append! (ref-variable find-file-not-found-hooks)
280
(list (lambda (buffer) (vc-hook:find-file-not-found buffer)))))
282
(define (vc-hook:find-file-not-found buffer)
283
(let ((master (buffer-vc-master buffer #f)))
285
(call-with-current-continuation
287
(bind-condition-handler (list condition-type:error)
288
(lambda (condition) condition (k #f))
290
(vc-checkout master #f)
293
(add-event-receiver! event:after-buffer-save
294
(lambda (buffer) (vc-hook:after-buffer-save buffer)))
296
(define (vc-hook:after-buffer-save buffer)
297
(let ((master (buffer-vc-master buffer #f)))
299
(vc-mode-line master buffer))))
301
(add-event-receiver! event:set-buffer-pathname
302
(lambda (buffer) (vc-hook:set-buffer-pathname buffer)))
304
(define (vc-hook:set-buffer-pathname buffer)
305
(buffer-remove! buffer 'VC-MASTER))
307
(add-event-receiver! event:set-buffer-major-mode
308
(lambda (buffer) (vc-hook:set-buffer-major-mode buffer)))
310
(define (vc-hook:set-buffer-major-mode buffer)
311
(let ((master (buffer-vc-master buffer #f)))
314
(vc-mode-line master buffer)
315
(if (not (ref-variable vc-make-backup-files buffer))
316
(local-set-variable! make-backup-files #f buffer))))))
320
(define (vc-mode-line master buffer)
321
(let ((workfile-buffer (vc-workfile-buffer master #f)))
322
(let ((buffer (or buffer workfile-buffer))
324
(or (vc-backend-workfile-revision master)
325
(vc-backend-default-revision master #f))))
326
(let ((locker (vc-backend-locking-user master revision))
327
(user-name (current-user-name)))
332
(vc-type-display-name (vc-master-type master))
333
(if (ref-variable vc-display-status buffer)
337
(cond ((not locker) "-")
338
((string=? locker user-name) ":")
339
(else (string-append ":" locker ":")))
344
(buffer-modeline-event! buffer 'VC-MODE-LINE-STATUS)
345
(if (and (buffer-writeable? buffer)
346
(eq? buffer workfile-buffer)
347
;; If the file is locked by some other user, make the
348
;; buffer read-only. Like this, even root cannot modify a
349
;; file that someone else has locked.
350
(or (and locker (not (string=? locker user-name)))
351
;; If the user is root, and the file is not
352
;; owner-writeable, then pretend that we can't write it
353
;; even though we can (because root can write
354
;; anything). This way, even root cannot modify a file
355
;; that isn't locked.
356
(and (= 0 (unix/current-uid))
360
(vc-master-workfile master)))))))
361
(set-buffer-read-only! buffer))))))
363
;;;; VC-MASTER association
365
(define (current-vc-master error?)
366
(buffer-vc-master (selected-buffer) error?))
368
(define (buffer-vc-master buffer error?)
369
(let ((buffer (chase-parent-buffer buffer)))
370
(let ((master (buffer-get buffer 'VC-MASTER #f)))
371
(if (and master (vc-backend-master-valid? master))
374
(buffer-remove! buffer 'VC-MASTER)
375
(if (vc-dired-buffer? buffer)
376
(let ((workfile (dired-this-file buffer error?)))
378
(file-vc-master workfile error?)))
379
(let ((workfile (buffer-pathname buffer)))
381
(let ((master (%file-vc-master workfile error?)))
382
(if master (buffer-put! buffer 'VC-MASTER master))
384
(and error? (vc-registration-error buffer))))))))))
386
(define (chase-parent-buffer buffer)
387
(let loop ((buffer buffer))
388
(let ((buffer* (buffer-get buffer 'VC-PARENT-BUFFER #f)))
393
(define (file-vc-master workfile error?)
394
(let ((workfile (->pathname workfile)))
395
(let ((buffer (pathname->buffer workfile)))
397
(buffer-vc-master buffer error?)
398
(%file-vc-master workfile error?)))))
400
(define (%file-vc-master workfile error?)
401
(let ((workfile (->pathname workfile)))
402
(or (vc-backend-find-master workfile)
403
(and error? (vc-registration-error workfile)))))
405
(define (guarantee-vc-master-valid master)
406
(if (not (vc-backend-master-valid? master))
407
(error "VC master file disappeared:" (vc-master-pathname master))))
409
(define (vc-registration-error object)
411
(editor-error "Buffer " (buffer-name object)
412
" is not associated with a file.")
413
(editor-error "File " (->namestring object)
414
" is not under version control.")))
416
;;;; Primary Commands
418
(define-command vc-toggle-read-only
419
"Change read-only status of current buffer, perhaps via version control.
420
If the buffer is visiting a file registered with version control,
421
then check the file in or out. Otherwise, just change the read-only flag
425
(if (current-vc-master #f)
426
((ref-command vc-next-action) #f)
427
((ref-command toggle-read-only)))))
429
(define-command vc-next-action
430
"Do the next logical checkin or checkout operation on the current file.
431
If you call this from within a VC dired buffer with no files marked,
432
it will operate on the file in the current line.
433
If you call this from within a VC dired buffer, and one or more
434
files are marked, it will accept a log message and then operate on
435
each one. The log message will be used as a comment for any register
436
or checkin operations, but ignored when doing checkouts. Attempted
437
lock steals will raise an error.
438
A prefix argument lets you specify the version number to use.
441
If the file is not already registered, this registers it for version
443
If the file is registered and not locked by anyone, this checks out
444
a writable and locked file ready for editing.
445
If the file is checked out and locked by the calling user, this
446
first checks to see if the file has changed since checkout. If not,
447
it performs a revert.
448
If the file has been changed, this pops up a buffer for entry
449
of a log message; when the message has been entered, it checks in the
450
resulting changes along with the log message as change commentary. If
451
the variable `vc-keep-workfiles' is true (which is its default), a
452
read-only copy of the changed file is left in place afterwards.
453
If the file is registered and locked by someone else, you are given
454
the option to steal the lock.
457
If the file is not already registered, this registers it for version
458
control. This does a \"cvs add\", but no \"cvs commit\".
459
If the file is added but not committed, it is committed.
460
If your working file is changed, but the repository file is
461
unchanged, this pops up a buffer for entry of a log message; when the
462
message has been entered, it checks in the resulting changes along
463
with the logmessage as change commentary. A writable file is retained.
464
If the repository file is changed, you are asked if you want to
465
merge in the changes into your working copy."
468
(let ((buffer (selected-buffer)))
469
(if (vc-dired-buffer? buffer)
470
(vc-next-action-dired buffer)
471
(vc-next-action-on-file (or (buffer-pathname buffer)
472
(vc-registration-error buffer))
475
(define-command vc-register
476
"Register the current file into your version-control system."
480
(let ((buffer (selected-buffer)))
481
(or (if (vc-dired-buffer? buffer)
482
(dired-this-file buffer #t)
483
(buffer-pathname buffer))
484
(vc-registration-error buffer)))))
485
(if (file-vc-master workfile #f)
486
(editor-error "This file is already registered."))
487
(vc-register workfile revision? #f #f))))
489
(define (vc-next-action-on-file workfile from-dired? revision? comment)
490
(let ((master (file-vc-master workfile #f)))
495
(let ((buffer (pathname->buffer workfile)))
497
(find-file-revert buffer))))
504
(pop-up-buffer buffer #f
505
'(NOT-CURRENT-WINDOW))
506
(select-buffer buffer))
507
(set! shown? #t))))))
508
;; If the file on disk is newer, then the user just
509
;; said no to rereading it. So the user probably
510
;; wishes to overwrite the file with the buffer's
511
;; contents, and check that in.
512
(cond ((not buffer) unspecific)
513
((verify-visited-file-modification-time? buffer)
514
(vc-save-buffer buffer #t))
517
(prompt-for-yes-or-no?
518
"Replace file on disk with buffer contents"))
519
(save-buffer buffer #f))
520
(else (editor-error "Aborted")))
521
;; Revert if file is unchanged and buffer is too.
522
;; If buffer is modified, that means the user just
523
;; said no to saving it; in that case, don't
524
;; revert, because the user might intend to save
525
;; after finishing the log entry.
526
(cond ((or (and buffer (buffer-modified? buffer))
527
(vc-workfile-modified? master))
528
(vc-checkin master revision? comment))
529
;; DO NOT revert the file without asking the
531
((prompt-for-yes-or-no?
533
(begin (show) "Revert to master version")
534
(string-append "Revert "
535
(file-namestring workfile)
536
" to master version")))
537
(vc-backend-revert master)
538
(if buffer (vc-revert-buffer buffer #t)))))))
541
(vc-save-workfile-buffer workfile)
542
(vc-checkout master revision?))))
543
(if (cvs-master? master)
544
(case (cvs-status master)
546
(let ((buffer (vc-workfile-buffer master #f)))
547
(cond ((or (and buffer (buffer-modified? buffer))
548
(cvs-file-edited? master))
550
((or revision? (cvs-workfile-protected? workfile))
553
(message (buffer-name buffer) " is up to date.")))))
554
((NEEDS-CHECKOUT NEEDS-MERGE)
555
(vc-next-action-merge master from-dired?))
556
((LOCALLY-MODIFIED LOCALLY-ADDED LOCALLY-REMOVED)
558
((UNRESOLVED-CONFLICT)
559
(message (->namestring workfile)
560
" has an unresolved conflict."))
562
(error "Unable to determine CVS status of file:" workfile)))
563
(let ((owner (vc-backend-locking-user master #f)))
564
(cond ((not owner) (do-checkout))
565
((string=? owner (current-user-name)) (do-checkin))
566
(else (vc-steal-lock master revision? comment owner))))))
567
(vc-register workfile revision? comment 'LOCK))))
569
(define (vc-next-action-dired buffer)
571
(let ((files (dired-marked-files buffer)))
574
(dired-next-files 1 buffer)))))
576
(if (pair? (cdr files))
579
"Enter a change comment for the marked files."
580
(if (there-exists? files
582
(let ((master (file-vc-master (car file) #f)))
584
(if (cvs-master? master)
585
(memq (cvs-status master)
589
(vc-backend-locking-user master #f))))))
593
(for-each-dired-mark buffer
596
(string-append "Processing "
600
(vc-next-action-on-file file #t #f comment)
601
(message msg "done")))))
603
(vc-next-action-on-file (caar files) #t #f #f)))))
605
(define (vc-register workfile revision? comment keep?)
606
(let ((buffer (pathname->buffer workfile)))
608
(or (vc-get-revision revision?
609
(string-append "Initial version level for "
610
(->namestring workfile)))
611
(ref-variable vc-default-init-version buffer))))
612
;; Watch out for new buffers of size 0: the corresponding file
613
;; does not exist yet, even though buffer-modified? is false.
615
(not (buffer-modified? buffer))
616
(= 0 (buffer-length buffer))
617
(not (file-exists? workfile)))
618
(buffer-modified! buffer))
619
(vc-save-workfile-buffer workfile)
620
(vc-start-entry workfile "Enter initial comment."
622
(if (ref-variable vc-initial-comment buffer) #f ""))
625
(ref-variable vc-keep-workfiles buffer))))
627
(vc-backend-register workfile revision comment keep?)
628
(vc-resync-workfile-buffer workfile keep?)))
631
(define (vc-checkout master revision?)
632
(let ((revision (vc-get-revision revision? "Branch or version to move to")))
635
(vc-backend-checkout master revision #t #f)
636
(vc-revert-workfile-buffer master #t))))
637
(cond ((not (and (let ((value (ref-variable vc-checkout-carefully)))
638
(if (boolean? value) value (value)))
639
(vc-workfile-modified? master)))
641
((cleanup-pop-up-buffers
643
(run-diff master #f #f)
645
(string-append "Changes to "
646
(vc-workfile-string master)
647
" since last lock:\n\n")
648
(buffer-start (get-vc-diff-buffer #f)))
649
(pop-up-vc-diff-buffer #f)
651
(prompt-for-yes-or-no?
652
"File has unlocked changes, claim lock retaining changes")))
653
(guarantee-vc-master-valid master)
654
(vc-backend-steal master revision)
655
(let ((buffer (vc-workfile-buffer master #f)))
657
(vc-mode-line master buffer))))
658
((prompt-for-yes-or-no? "Revert to checked-in version, instead")
661
(editor-error "Checkout aborted."))))))
663
(define (vc-checkin master revision? comment)
664
(let ((revision (vc-get-revision revision? "New version level")))
665
(vc-save-workfile-buffer (vc-master-workfile master))
666
(vc-start-entry master "Enter a change comment." comment
668
(or (cvs-master? master)
669
(ref-variable vc-keep-workfiles
670
(vc-workfile-buffer master #f)))))
672
(vc-backend-checkin master revision
673
(if (blank-string? comment)
674
"*** empty log message ***"
677
(vc-resync-workfile-buffer (vc-master-workfile master)
680
(event-distributor/invoke!
681
(ref-variable vc-checkin-hooks
682
(vc-workfile-buffer master #f))
685
(define (vc-steal-lock master revision? comment owner)
686
(if (and (rcs-master? master)
687
(not (vc-release? vc-type:rcs "5.6.2")))
688
;; Can't steal locks with old RCS versions.
689
(editor-error "File is locked by " owner "."))
690
(let ((filename (vc-workfile-string master)))
692
(editor-error "Sorry, you can't steal the lock on "
695
(let ((revision (vc-get-revision revision? "Version level to steal")))
698
(string-append filename ":" revision)
700
(if (not (prompt-for-confirmation?
701
(string-append "Take the lock on " file:rev " from " owner)))
702
(editor-error "Steal cancelled."))
703
(make-mail-buffer `(("To" ,owner) ("Subject" ,file:rev))
705
select-buffer-other-window
706
'DISCARD-PREVIOUS-MAIL)
707
(let ((mail-buffer (selected-buffer)))
709
(string-append "I stole the lock on " file:rev ", "
710
(universal-time->string (get-universal-time))
712
(buffer-end mail-buffer))
713
(set-buffer-point! mail-buffer (buffer-end mail-buffer))
714
(let ((variable (ref-variable-object send-mail-procedure)))
715
(define-variable-local-value! mail-buffer variable
717
(guarantee-vc-master-valid master)
718
(vc-backend-steal master revision)
719
(vc-revert-workfile-buffer master #t)
720
;; Send the mail after the steal has completed
722
((variable-default-value variable)))))))))
723
(message "Please explain why you are stealing the lock."
724
" Type C-c C-c when done."))
726
(define (vc-next-action-merge master from-dired?)
727
(let ((buffer (vc-workfile-buffer master #f)))
728
;; (NOT FROM-DIRED?) implies (NOT (NOT BUFFER)).
730
(prompt-for-yes-or-no?
733
" is not up-to-date. Merge in changes now")))
735
(if (and buffer (buffer-modified? buffer))
738
(select-buffer-other-window buffer)
739
(select-buffer buffer))
740
(vc-save-buffer buffer #f)))
742
(buffer-modified? buffer)
744
(prompt-for-yes-or-no?
748
" modified; merge file on disc anyhow"))))
749
(editor-error "Merge aborted"))
750
(let ((conflicts? (cvs-backend-merge-news master)))
752
(vc-revert-buffer buffer #t))
754
(prompt-for-confirmation?
755
"Conflicts detected. Resolve them now"))
756
(find-file (vc-master-workfile master)))))
757
(editor-error (buffer-name buffer) " needs update."))))
759
;;;; Auxiliary Commands
761
(define-command vc-diff
762
"Display diffs between file versions.
763
Normally this compares the current file and buffer with the most recent
764
checked in version of that file. This uses no arguments.
765
With a prefix argument, it reads the file name to use
766
and two version designators specifying which versions to compare."
770
(dispatch-on-command (ref-command-object vc-version-diff))
771
(vc-diff (current-vc-master #t) #f #f))))
773
(define-command vc-version-diff
774
"Report diffs between two stored versions REV1 and REV2 of a file."
777
(prompt-for-existing-file
779
(let ((pathname (buffer-pathname (selected-buffer))))
782
(master (file-vc-master workfile #t))
783
(revision (vc-backend-workfile-revision master)))
787
(and (not (vc-workfile-modified? master))
788
(previous-revision revision))))
790
(values previous revision)
791
(values revision #f))))
792
(lambda (default1 default2)
793
(let* ((rev1 (prompt-for-string "Older version" default1))
795
(prompt-for-string "Newer version" default2
796
'DEFAULT-TYPE 'NULL-DEFAULT)))
797
(list workfile rev1 rev2))))))
798
(lambda (workfile rev1 rev2)
799
(if (file-directory? workfile)
800
(editor-error "Directory diffs not yet supported.")
801
(vc-diff (file-vc-master workfile #t) rev1 rev2))))
803
(define (vc-diff master rev1 rev2)
804
(vc-save-workfile-buffer (vc-master-workfile master))
805
(let ((rev1 (vc-normalize-revision rev1))
806
(rev2 (vc-normalize-revision rev2)))
807
(if (and (or rev1 rev2 (vc-workfile-modified? master))
808
(run-diff master rev1 rev2))
810
(pop-up-vc-diff-buffer #t)
813
(message "No changes to "
814
(vc-workfile-string master)
816
(string-append " between " rev1 " and " rev2)
817
(string-append " since "
818
(or rev1 rev2 "latest version")))
822
(define (run-diff master rev1 rev2)
823
(if (and (not rev1) (not rev2))
824
(cache-value-2! master 'MODIFIED?
825
(vc-master-pathname master)
826
(vc-master-workfile master)
828
(let ((modified? (vc-backend-diff master rev1 rev2 #f)))
829
(set-vc-cvs-workfile-mtime-string! master tm tw modified?)
831
(vc-backend-diff master rev1 rev2 #f)))
833
(define-command vc-version-other-window
834
"Visit version REV of the current buffer in another window.
835
If the current buffer is named `F', the version is named `F.~REV~'.
836
If `F.~REV~' already exists, it is used instead of being re-created."
837
"sVersion to visit (default is latest version)"
839
(let* ((master (current-vc-master #t))
841
(or (vc-normalize-revision revision)
842
(vc-backend-workfile-revision master)
843
(vc-backend-default-revision master #f)))
845
(string-append (vc-workfile-string master) ".~" revision "~")))
846
(if (not (file-exists? workfile))
847
(vc-backend-checkout master revision #f workfile))
848
(find-file-other-window workfile))))
850
(define-command vc-insert-headers
851
"Insert headers in a file for use with your version-control system.
852
Headers are inserted at the start of the buffer."
855
(let* ((master (current-vc-master #t))
856
(buffer (vc-workfile-buffer master #t)))
857
(without-group-clipped! (buffer-group buffer)
859
(if (or (not (vc-backend-check-headers master buffer))
860
(prompt-for-confirmation?
861
"Version headers already exist. Insert another set"))
864
(or (ref-variable comment-start buffer) "#")
866
(vc-type-header-keyword (vc-master-type master))
867
(let ((end (or (ref-variable comment-end buffer) "")))
868
(if (string-null? end)
870
(string-append "\t" end)))
872
(buffer-start buffer))))))))
874
(define-command vc-print-log
875
"List the change log of the current buffer in a window."
878
(vc-backend-print-log (current-vc-master #t))
879
(pop-up-vc-command-buffer #f)))
881
(define-command vc-revert-buffer
882
"Revert the current buffer's file back to the latest checked-in version.
883
This asks for confirmation if the buffer contents are not identical
887
(let* ((master (current-vc-master #t))
888
(buffer (vc-workfile-buffer master #t)))
889
(if (or (and (vc-workfile-modified? master)
890
(or (ref-variable vc-suppress-confirm)
891
(cleanup-pop-up-buffers
893
(run-diff master #f #f)
894
(pop-up-vc-diff-buffer #f)
895
(prompt-for-yes-or-no? "Discard changes")))))
896
(and (cvs-master? master)
897
(cvs-file-edited? master)))
899
(vc-backend-revert master)
900
(vc-revert-buffer buffer #t))
901
(editor-error "Revert cancelled.")))))
905
(define-command vc-directory
906
"Show version-control status of files under a directory.
907
Normally shows only locked files; prefix arg says to show all files."
908
"DDired under VC (directory)\nP"
909
(lambda (directory all-files?)
910
(let ((buffer (vc-dired directory all-files?)))
911
(if (group-end? (line-start (buffer-start buffer) 1 'LIMIT))
913
(if (not (buffer-visible? buffer))
914
(kill-buffer buffer))
915
(message "No files are currently "
916
(if all-files? "registered" "locked")
918
(->namestring directory)))
919
(pop-up-buffer buffer #t)))))
921
(define-command vc-dired
922
"Show version-control status of files under a directory.
923
Normally shows only locked files; prefix arg says to show all files."
924
"DVC-Dired (directory)\nP"
925
(lambda (directory all-files?)
926
(select-buffer (vc-dired directory all-files?))))
928
(define (vc-dired directory all-files?)
929
(let ((buffer (get-vc-dired-buffer directory)))
930
(fill-vc-dired-buffer! buffer directory all-files?)
933
(define (get-vc-dired-buffer directory)
934
(or (list-search-positive (buffer-list)
936
(let ((spec (buffer-get buffer 'VC-DIRECTORY-SPEC #f)))
938
(pathname=? (car spec) directory)))))
939
(new-buffer (pathname->buffer-name directory))))
941
(define (fill-vc-dired-buffer! buffer directory all-files?)
943
(string-append "Reading directory " (->namestring directory) "...")))
944
(buffer-reset! buffer)
945
(set-buffer-major-mode! buffer (ref-mode-object vc-dired))
946
(set-buffer-default-directory! buffer (directory-pathname directory))
947
(buffer-put! buffer 'VC-DIRECTORY-SPEC (cons directory all-files?))
948
(buffer-put! buffer 'REVERT-BUFFER-METHOD revert-vc-dired-buffer)
950
(let ((mark (mark-left-inserting-copy (buffer-start buffer))))
951
(insert-string (string-append " Files currently "
952
(if all-files? "registered" "locked")
954
(->namestring directory)
957
(generate-vc-dired-lines directory all-files? mark)
958
(mark-temporary! mark))
959
(message msg "done"))
960
(set-buffer-point! buffer (buffer-start buffer))
961
(buffer-not-modified! buffer)
962
(set-buffer-read-only! buffer))
964
(define (revert-vc-dired-buffer buffer dont-use-auto-save? dont-confirm?)
965
(let ((spec (buffer-get buffer 'VC-DIRECTORY-SPEC #f)))
968
(fill-vc-dired-buffer! buffer (car spec) (cdr spec))
970
(revert-buffer-default buffer dont-use-auto-save? dont-confirm?))))
972
(define (generate-vc-dired-lines directory all-files? mark)
975
(let ((attr (file-attributes-direct file)))
976
(if (and attr (not (file-attributes/type attr)))
978
(let ((master (file-vc-master file #f)))
981
((cvs-master? master)
982
(and (vc-workfile-modified? master)
983
(case (cvs-status master)
984
((LOCALLY-MODIFIED) "modified")
985
((LOCALLY-ADDED) "added")
986
((NEEDS-CHECKOUT) "patch")
987
((NEEDS-MERGE) "merge")
988
((UNRESOLVED-CONFLICT) "conflict")
991
(vc-backend-locking-user master #f))))))
992
(if (or status all-files?)
993
(generate-vc-dired-line file attr status mark))))))
994
(directory-read directory)))
996
(define (generate-vc-dired-line file attr status mark)
1000
(file-attributes/mode-string attr)
1002
(pad-on-right-to (if status (string-append "(" status ")") "") 10)
1004
(file-time->ls-string (file-attributes/modification-time attr))
1006
(file-namestring file)
1010
(define-major-mode vc-dired dired "VC-Dired"
1011
"The major mode used in VC directory buffers. It works like Dired,
1012
but lists only files under version control, with the current VC state of
1013
each file being indicated in the place of the file's link count, owner,
1014
group and size. Subdirectories are also listed, and you may insert them
1015
into the buffer as desired, as in Dired.
1016
All Dired commands operate normally, with the exception of `v', which
1017
is redefined as the version control prefix, so that you can type
1018
`vl', `v=' etc. to invoke `vc-print-log', `vc-diff', and the like on
1019
the file named in the current Dired buffer line. `vv' invokes
1020
`vc-next-action' on this file, or on all files currently marked.
1021
There is a special command, `*l', to mark all files currently locked.
1028
(define (vc-dired-buffer? buffer)
1029
(eq? (ref-mode-object vc-dired) (buffer-major-mode buffer)))
1031
(define-key 'vc-dired '(#\v #\h) 'vc-insert-headers)
1032
(define-key 'vc-dired '(#\v #\i) 'vc-register)
1033
(define-key 'vc-dired '(#\v #\l) 'vc-print-log)
1034
;;(define-key 'vc-dired '(#\v #\m) 'vc-merge)
1035
;;(define-key 'vc-dired '(#\v #\r) 'vc-retrieve-snapshot)
1036
;;(define-key 'vc-dired '(#\v #\s) 'vc-create-snapshot)
1037
(define-key 'vc-dired '(#\v #\u) 'vc-revert-buffer)
1038
(define-key 'vc-dired '(#\v #\v) 'vc-next-action)
1039
(define-key 'vc-dired '(#\v #\=) 'vc-diff)
1040
(define-key 'vc-dired '(#\v #\~) 'vc-version-other-window)
1041
(define-key 'vc-dired '(#\* #\l) 'vc-dired-mark-locked)
1043
(define-command vc-dired-mark-locked
1044
"Mark all files currently locked."
1047
(dired-mark-files! (selected-buffer)
1049
(let ((master (file-vc-master file #f)))
1051
(vc-backend-locking-user master #f)))))))
1055
(define (vc-start-entry reference msg comment finish-entry after)
1058
(finish-entry comment)
1060
(let ((log-buffer (new-buffer "*VC-log*")))
1061
(set-buffer-major-mode! log-buffer (ref-mode-object vc-log))
1062
(if (vc-master? reference)
1063
(vc-mode-line reference log-buffer))
1066
(if (buffer? reference)
1068
(pathname->buffer (->workfile reference))))))
1070
(buffer-put! log-buffer 'VC-PARENT-BUFFER buffer)
1071
(buffer-remove! log-buffer 'VC-PARENT-BUFFER)))
1072
(let ((window (selected-window))
1073
(buffer (selected-buffer)))
1074
(let ((log-window (pop-up-buffer log-buffer #t)))
1075
(buffer-put! log-buffer
1076
'VC-LOG-FINISH-ENTRY
1077
(vc-finish-entry reference
1080
(weak-cons log-window #f)
1081
(weak-cons window #f)
1082
(weak-cons buffer #f)))))
1083
(message msg " Type C-c C-c when done."))))
1085
(define (vc-finish-entry reference finish-entry after log-window window buffer)
1086
(lambda (log-buffer)
1087
(if (vc-master? reference)
1089
(guarantee-vc-master-valid reference)
1090
(vc-backend-check-log-entry reference log-buffer)))
1091
(guarantee-newline (buffer-end log-buffer))
1092
(let ((comment (buffer-string log-buffer))
1093
(parent-buffer (chase-parent-buffer log-buffer)))
1094
(comint-record-input vc-comment-ring comment)
1095
;; Save any changes the user might have made while editing the
1097
(if (and (not (eq? parent-buffer log-buffer))
1098
(buffer-alive? parent-buffer)
1099
(not (vc-dired-buffer? parent-buffer)))
1100
(vc-save-buffer parent-buffer #t))
1101
;; If a new window was created to hold the log buffer, and the log
1102
;; buffer is still selected in that window, delete it.
1103
(let ((log-window (weak-car log-window)))
1105
(window-live? log-window)
1106
(eq? log-buffer (window-buffer log-window))
1107
(not (window-has-no-neighbors? log-window)))
1108
(window-delete! log-window)))
1109
;; Either kill or bury the log buffer.
1110
(if (buffer-alive? log-buffer)
1111
(if (ref-variable vc-delete-logbuf-window log-buffer)
1112
(kill-buffer log-buffer)
1114
(make-buffer-invisible log-buffer)
1115
(bury-buffer log-buffer))))
1116
(let ((window (weak-car window))
1117
(buffer (weak-car buffer)))
1118
(if (and window (window-live? window))
1119
(select-window window))
1120
(if (and buffer (buffer-alive? buffer))
1121
(if (and window (window-live? window))
1122
(select-buffer-no-record buffer window)
1123
(select-buffer buffer))))
1124
;; Do the log operation.
1125
(finish-entry comment))
1126
(if after (after))))
1128
(define vc-comment-ring
1131
(define-major-mode vc-log text "VC-Log"
1132
"Major mode for entering a version-control change log message.
1133
In this mode, the following additional bindings will be in effect.
1135
\\[vc-finish-logentry] proceed with check in, ending log message entry
1137
Whenever you do a checkin, your log comment is added to a ring of
1138
saved comments. These can be recalled as follows:
1140
\\[comint-previous-input] replace region with previous message in comment ring
1141
\\[comint-next-input] replace region with next message in comment ring
1142
\\[comint-history-search-reverse] search backward for regexp in the comment ring
1143
\\[comint-history-search-forward] search forward for regexp in the comment ring
1145
Entry to the vc-log submode calls the value of text-mode-hook, then
1146
the value of vc-log-mode-hook."
1148
(local-set-variable! comint-input-ring vc-comment-ring buffer)
1149
(local-set-variable! comint-last-input-match #f buffer)
1150
(event-distributor/invoke! (ref-variable vc-log-mode-hook buffer) buffer)))
1152
(define-key 'vc-log '(#\C-c #\C-c) 'vc-finish-logentry)
1153
(define-key 'vc-log #\M-p 'comint-previous-input)
1154
(define-key 'vc-log #\M-n 'comint-next-input)
1155
(define-key 'vc-log #\M-r 'comint-history-search-backward)
1156
(define-key 'vc-log #\M-s 'comint-history-search-forward)
1158
(define-command vc-finish-logentry
1159
"Complete the operation implied by the current log entry."
1162
(let ((buffer (selected-buffer)))
1163
(let ((finish-entry (buffer-get buffer 'VC-LOG-FINISH-ENTRY #f)))
1164
(if (not finish-entry)
1165
(error "No log operation is pending."))
1166
(finish-entry buffer)))))
1170
;;; In what follows, a "revision string" has the following definition:
1171
;;; A revision string of #F usually refers to the head of the
1172
;;; branch on which the workfile resides, but in some cases it has a
1173
;;; different meaning.
1174
;;; A revision string with an odd number of elements specifies a branch,
1175
;;; and the string refers to the head of the specified branch.
1176
;;; A revision string with an even number of elements specifies a
1177
;;; particular revision. When checking in, this revision must not
1178
;;; exist, and must be greater than any existing revision on the
1179
;;; associated trunk or branch. When checking out, this revision
1181
;;; A revision string may be symbolic, in which case it is treated as
1182
;;; the numeric string that it is bound to.
1184
(define (vc-backend-release type)
1185
;; TYPE is a VC-TYPE object.
1186
;; The return value is either a release string or #F.
1187
;; A release string matches "[0-9.]+ *.*".
1188
(let ((release (vc-type-get type 'RELEASE 'UNKNOWN)))
1189
(if (eq? 'UNKNOWN release)
1190
(let ((release ((vc-type-operation type 'RELEASE))))
1191
(vc-type-put! type 'RELEASE release)
1195
(define (vc-backend-find-master workfile)
1196
(let loop ((types vc-types))
1198
(or ((vc-type-operation (car types) 'FIND-MASTER) workfile)
1199
(loop (cdr types))))))
1201
(define (vc-backend-master-valid? master)
1202
;; MASTER is a VC-MASTER object.
1203
;; The return value is a boolean indicating that MASTER is valid.
1204
(vc-call 'VALID? master))
1206
(define (vc-backend-default-revision master error?)
1207
;; MASTER is a valid VC-MASTER object.
1208
;; ERROR? is a boolean.
1209
;; The default revision (usually the head of the trunk) is returned.
1210
;; If there is no such revision, then if ERROR? is true, an error is
1211
;; signalled. Otherwise #F is returned.
1212
(vc-call 'DEFAULT-REVISION master error?))
1214
(define (vc-backend-workfile-revision master)
1215
;; MASTER is a valid VC-MASTER object.
1216
;; The last checked-in revision of the file is returned.
1217
;; If this can't be determined, #F is returned.
1218
(vc-call 'WORKFILE-REVISION master))
1220
(define (vc-backend-locking-user master revision)
1221
;; MASTER is a valid VC-MASTER object.
1222
;; REVISION is a revision string or #F.
1223
;; A REVISION of #F refers to the last checked-in revision of the
1225
;; The user holding the lock on that revision is returned. If there
1226
;; is no lock, or if the lock cannot be determined, #F is returned.
1227
(vc-call 'LOCKING-USER master revision))
1229
(define (vc-backend-register workfile revision comment keep?)
1230
;; WORKFILE is an absolute pathname to an existing file.
1231
;; REVISION is either a revision string or #F.
1232
;; COMMENT is a comment string.
1233
;; KEEP? is either #F, #T, or LOCK.
1234
;; #F means don't keep a copy of WORKFILE after registration.
1235
;; #T means keep an unlocked copy.
1236
;; LOCK means keep a locked copy.
1237
;; On return, WORKFILE must be registered.
1239
(if (and (pair? vc-types)
1240
(null? (cdr vc-types)))
1243
(list-transform-positive vc-types
1245
((vc-type-operation type 'LIKELY-CONTROL-TYPE?)
1247
(if (and (pair? likely-types)
1248
(null? (cdr likely-types)))
1250
(cleanup-pop-up-buffers
1252
(call-with-output-to-temporary-buffer " *VC-types*"
1257
(write-string (vc-type-display-name type) port)
1260
(prompt-for-alist-value
1261
"Version control type"
1263
(cons (vc-type-display-name type)
1269
workfile revision comment keep?))
1271
(define (vc-backend-checkout master revision lock? workfile)
1272
;; MASTER is a valid VC-MASTER object.
1273
;; REVISION is either a revision string or #F.
1274
;; LOCK? is a boolean saying whether to lock the specified revision.
1275
;; This has effect only with backends that do locking.
1276
;; WORKFILE is either an absolute pathname or #F.
1277
;; If #F, the file is checked out into the workfile pathname of MASTER.
1278
;; Otherwise, the file is checked out into WORKFILE.
1279
(vc-call 'CHECKOUT master revision lock?
1281
(not (pathname=? workfile (vc-master-workfile master)))
1284
(define (vc-backend-checkin master revision comment keep?)
1285
;; MASTER is a valid VC-MASTER object.
1286
;; REVISION is either a revision string or #F.
1287
;; COMMENT is a comment string.
1288
;; KEEP? is a boolean specifying that the workfile should be kept
1289
;; after checking in. If #F, the workfile is deleted.
1290
;; The workfile is checked in.
1291
(vc-call 'CHECKIN master revision comment keep?))
1293
(define (vc-backend-revert master)
1294
;; MASTER is a valid VC-MASTER object.
1295
;; The workfile is checked out, discarding the existing workfile.
1296
(vc-call 'REVERT master))
1298
(define (vc-backend-steal master revision)
1299
;; MASTER is a valid VC-MASTER object.
1300
;; REVISION is either a revision string or #F.
1301
;; The lock is stolen from the owner without notification.
1302
(vc-call 'STEAL master revision))
1304
(define (vc-backend-diff master rev1 rev2 simple?)
1305
;; MASTER is a valid VC-MASTER object.
1306
;; REV1 is either a revision string or #F.
1307
;; REV2 is either a revision string or #F.
1308
;; If REV1 and REV2 are both #F, the workfile is compared to its
1309
;; most recent checked-in revision.
1310
;; If REV1 nor REV2 is #F, the specified revisions are compared.
1311
;; Otherwise, the workfile is compared to the specified revision.
1312
;; SIMPLE? is a boolean specifying how the comparison is performed.
1313
;; If #T, only the result of the comparison is interesting.
1314
;; If #F, the differences are to be shown to the user.
1315
(vc-call 'DIFF master rev1 rev2 simple?))
1317
(define (vc-backend-print-log master)
1318
;; MASTER is a valid VC-MASTER object.
1319
;; The log associated with that file is popped up in another buffer.
1320
(vc-call 'PRINT-LOG master))
1322
(define (vc-backend-check-log-entry master log-buffer)
1323
;; MASTER is a valid VC-MASTER object.
1324
;; LOG-BUFFER is a buffer containing a log message.
1325
;; The buffer's contents is checked for compatibility with the
1326
;; backend, and an error is signalled if it is incompatible.
1327
(vc-call 'CHECK-LOG-ENTRY master log-buffer))
1329
(define (vc-backend-check-headers master buffer)
1330
;; MASTER is a valid VC-MASTER object.
1331
;; BUFFER is the workfile buffer.
1332
;; Examines the buffer contents to determine if they contain
1333
;; appropriate revision-control header strings. Returns #t iff the
1334
;; header strings are present.
1335
(vc-call 'CHECK-HEADERS master buffer))
1340
;; Splitting up string constant prevents RCS from expanding this
1342
(make-vc-type 'RCS "RCS" "\$Id\$"))
1344
(define (rcs-master? master)
1345
(eq? vc-type:rcs (vc-master-type master)))
1347
(define (rcs-directory workfile)
1348
(subdirectory-pathname workfile "RCS"))
1350
(define (get-rcs-admin master)
1351
(let ((pathname (vc-master-pathname master)))
1352
(read-cached-value-1 master 'RCS-ADMIN pathname
1353
(lambda (time) time (parse-rcs-admin pathname)))))
1355
(define (check-rcs-headers buffer)
1356
(re-search-forward (string-append "\\$[A-Za-z\300-\326\330-\366\370-\377]+"
1357
"\\(: [\t -#%-\176\240-\377]*\\)?\\$")
1358
(buffer-start buffer)
1359
(buffer-end buffer)))
1361
(define (rcs-rev-switch switch revision)
1363
(string-append switch revision)
1366
(define (rcs-mtime-switch master)
1367
(and (ref-variable vc-rcs-preserve-mod-times
1368
(pathname->buffer (->workfile master)))
1371
(define-vc-type-operation 'RELEASE vc-type:rcs
1373
(and (= 0 (vc-run-command #f '() "rcs" "-V"))
1374
(re-search-forward "^RCS version \\([0-9.]+ *.*\\)"
1375
(buffer-start (get-vc-command-buffer)))
1376
(extract-string (re-match-start 1) (re-match-end 1)))))
1378
(define-vc-type-operation 'FIND-MASTER vc-type:rcs
1382
(let ((master-file (transform workfile)))
1383
(and (file-exists? master-file)
1384
(make-vc-master vc-type:rcs master-file workfile)))))
1387
(merge-pathnames (file-pathname pathname)
1388
(rcs-directory pathname))))
1391
(merge-pathnames (string-append (file-namestring pathname) ",v")
1392
(directory-pathname pathname)))))
1393
(or (try (lambda (workfile) (rcs-file (in-rcs-directory workfile))))
1394
(try in-rcs-directory)
1397
(define-vc-type-operation 'VALID? vc-type:rcs
1399
(file-exists? (vc-master-pathname master))))
1401
(define-vc-type-operation 'DEFAULT-REVISION vc-type:rcs
1402
(lambda (master error?)
1403
(let ((delta (rcs-find-delta (get-rcs-admin master) #f error?)))
1405
(rcs-delta/number delta)))))
1407
(define-vc-type-operation 'WORKFILE-REVISION vc-type:rcs
1409
(let ((workfile (vc-master-workfile master)))
1410
(read-cached-value-1 master 'RCS-WORKFILE-REVISION workfile
1415
(let ((start (buffer-start buffer))
1416
(end (buffer-end buffer)))
1421
(string-append "$" keyword ":")
1424
(skip-chars-forward " " mark end #f)))))
1428
(skip-chars-forward "0-9." start end)))
1429
(and (mark< start end)
1431
(extract-string start end)))
1433
(rcs-number-length revision)))
1436
(rcs-number-head revision
1439
(cond ((or (find-keyword "Id") (find-keyword "Header"))
1444
(skip-chars-forward "^ " mark end)
1446
((find-keyword "Revision") => get-revision)
1448
(let ((buffer (pathname->buffer workfile)))
1450
(parse-buffer buffer)
1451
(call-with-temporary-buffer " *VC-temp*"
1453
(catch-file-errors (lambda (condition) condition #f)
1455
(read-buffer buffer workfile #f)
1456
(parse-buffer buffer)))))))))))))
1458
(define-vc-type-operation 'LOCKING-USER vc-type:rcs
1459
(lambda (master revision)
1460
(let ((admin (get-rcs-admin master)))
1462
(rcs-find-delta admin
1464
(vc-backend-workfile-revision master))
1467
(let loop ((locks (rcs-admin/locks admin)))
1468
(and (not (null? locks))
1469
(if (eq? delta (cdar locks))
1471
(loop (cdr locks))))))))))
1473
(define-vc-type-operation 'LIKELY-CONTROL-TYPE? vc-type:rcs
1475
(file-directory? (rcs-directory workfile))))
1477
(define-vc-type-operation 'REGISTER vc-type:rcs
1478
(lambda (workfile revision comment keep?)
1479
(with-vc-command-message workfile "Registering"
1481
(vc-run-command workfile '() "ci"
1482
(and (vc-release? vc-type:rcs "5.6.4") "-i")
1483
(rcs-rev-switch (cond ((not keep?) "-r")
1484
((eq? 'LOCK keep?) "-l")
1487
(rcs-mtime-switch workfile)
1488
(string-append "-t-" comment)
1491
(define-vc-type-operation 'CHECKOUT vc-type:rcs
1492
(lambda (master revision lock? workfile)
1493
(let ((revision (or revision (vc-backend-workfile-revision master))))
1494
(with-vc-command-message master "Checking out"
1497
;; RCS makes it difficult to check a file out into anything
1498
;; but the working file.
1500
(delete-file-no-errors workfile)
1501
(vc-run-shell-command master '() "co"
1502
(rcs-rev-switch "-p" revision)
1503
(vc-master-workfile master)
1506
(set-file-modes! workfile (if lock? #o644 #o444)))
1507
(vc-run-command master '() "co"
1508
(rcs-rev-switch (if lock? "-l" "-r") revision)
1509
(rcs-mtime-switch master)
1510
(vc-master-workfile master))))))))
1512
(define-vc-type-operation 'CHECKIN vc-type:rcs
1513
(lambda (master revision comment keep?)
1514
(with-vc-command-message master "Checking in"
1516
(vc-run-command master '() "ci"
1517
;; If available, use the secure check-in option.
1518
(and (vc-release? vc-type:rcs "5.6.4") "-j")
1519
(rcs-rev-switch (if keep? "-u" "-r") revision)
1520
(rcs-mtime-switch master)
1521
(string-append "-m" comment)
1522
(vc-master-workfile master))))))
1524
(define-vc-type-operation 'REVERT vc-type:rcs
1526
(with-vc-command-message master "Reverting"
1528
(vc-run-command master '() "co"
1530
(rcs-mtime-switch master)
1531
(vc-master-workfile master))))))
1533
(define-vc-type-operation 'STEAL vc-type:rcs
1534
(lambda (master revision)
1535
(if (not (vc-release? vc-type:rcs "5.6.2"))
1536
(error "Unable to steal locks with this version of RCS."))
1537
(let ((revision (or revision (vc-backend-workfile-revision master))))
1538
(with-vc-command-message master "Stealing lock on"
1540
(vc-run-command master '() "rcs"
1542
(rcs-rev-switch "-u" revision)
1543
(rcs-rev-switch "-l" revision)
1544
(vc-master-workfile master)))))))
1546
(define-vc-type-operation 'DIFF vc-type:rcs
1547
(lambda (master rev1 rev2 simple?)
1549
(vc-run-command master
1551
(BUFFER ,(get-vc-diff-buffer simple?)))
1555
(list (string-append "-r" rev1)
1556
(string-append "-r" rev2))
1559
(vc-backend-workfile-revision master))))
1561
(string-append "-r" rev))))
1563
(and (diff-brief-available?) "--brief")
1564
(ref-variable diff-switches
1565
(vc-workfile-buffer master #f)))
1566
(vc-master-workfile master)))))
1568
(define-vc-type-operation 'PRINT-LOG vc-type:rcs
1570
(vc-run-command master '() "rlog" (vc-master-workfile master))))
1572
(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:rcs
1573
(lambda (master log-buffer)
1577
(define-vc-type-operation 'CHECK-HEADERS vc-type:rcs
1578
(lambda (master buffer)
1580
(check-rcs-headers buffer)))
1585
(make-vc-type 'CVS "CVS" "\$Id\$"))
1587
(define (cvs-master? master)
1588
(eq? vc-type:cvs (vc-master-type master)))
1590
(define (find-cvs-master workfile)
1591
(let ((entries-file (merge-pathnames "Entries" (cvs-directory workfile))))
1592
(and (%find-cvs-entry entries-file workfile)
1593
(make-vc-master vc-type:cvs entries-file workfile))))
1595
(define (cvs-directory workfile)
1596
(subdirectory-pathname workfile "CVS"))
1598
(define (get-cvs-workfile-revision master error?)
1599
(let ((tokens (find-cvs-entry master)))
1603
(error "Workfile has no version:" (vc-master-workfile master))))))
1605
(define (find-cvs-entry master)
1606
(let ((pathname (vc-master-pathname master)))
1607
(read-cached-value-1 master 'CVS-ENTRY pathname
1610
(%find-cvs-entry pathname (vc-master-workfile master))))))
1612
(define (%find-cvs-entry pathname workfile)
1614
(find-cvs-line pathname
1615
(string-append "/" (file-namestring workfile) "/"))))
1617
(let ((tokens (cdr (burst-string line #\/ #f))))
1618
(and (fix:= 5 (length tokens))
1621
(define (cvs-workfile-protected? workfile)
1622
(string-prefix? "-r-"
1623
(file-attributes/mode-string (file-attributes workfile))))
1625
(define (cvs-file-edited? master)
1627
(merge-pathnames "Baserev"
1628
(directory-pathname (vc-master-pathname master)))))
1629
(read-cached-value-1 master 'CVS-FILE-EDITED? pathname
1632
(find-cvs-line pathname
1635
(file-namestring (vc-master-workfile master))
1638
(define (find-cvs-line pathname prefix)
1639
(and (file-readable? pathname)
1640
(call-with-input-file pathname
1643
(let ((line (read-line port)))
1644
(and (not (eof-object? line))
1645
(if (string-prefix? prefix line)
1649
(define (cvs-status master)
1650
(get-cvs-status master
1652
(if (re-search-forward "^File: [^ \t]+[ \t]+Status: \\(.*\\)" m)
1654
(extract-string (re-match-start 1) (re-match-end 1)))
1657
(define (cvs-default-revision master)
1658
(get-cvs-status master
1660
(and (re-search-forward
1661
"\\(RCS Version\\|RCS Revision\\|Repository revision\\):[ \t]+\\([0-9.]+\\)"
1663
(extract-string (re-match-start 2) (re-match-end 2))))))
1665
(define (get-cvs-status master parse-output)
1666
(vc-run-command master
1667
`((BUFFER " *vc-status*"))
1669
(file-pathname (vc-master-workfile master)))
1670
(parse-output (buffer-start (find-or-create-buffer " *vc-status*"))))
1672
(define (convert-cvs-status status)
1673
(cond ((string-ci=? status "Up-to-date")
1675
((string-ci=? status "Locally Modified")
1677
((or (string-ci=? status "Locally Added")
1678
(string-ci=? status "New file!"))
1680
((string-ci=? status "Locally Removed")
1682
((or (string-ci=? status "Needs Checkout")
1683
(string-ci=? status "Needs Patch"))
1685
((string-ci=? status "Needs Merge")
1687
((or (string-ci=? status "File had conflicts on merge")
1688
(string-ci=? status "Unresolved Conflict"))
1689
'UNRESOLVED-CONFLICT)
1693
(define (cvs-rev-switch revision)
1695
(list "-r" revision)))
1697
(define-vc-type-operation 'RELEASE vc-type:cvs
1699
(and (= 0 (vc-run-command #f '() "cvs" "-v"))
1700
(re-search-forward "^Concurrent Versions System (CVS) \\([0-9.]+\\)"
1701
(buffer-start (get-vc-command-buffer)))
1702
(extract-string (re-match-start 1) (re-match-end 1)))))
1704
(define-vc-type-operation 'FIND-MASTER vc-type:cvs
1706
(find-cvs-master workfile)))
1708
(define-vc-type-operation 'VALID? vc-type:cvs
1710
(get-cvs-workfile-revision master #f)))
1712
(define-vc-type-operation 'DEFAULT-REVISION vc-type:cvs
1713
(lambda (master error?)
1714
(or (cvs-default-revision master)
1716
(error "Unable to determine default CVS version:"
1717
(vc-master-workfile master))))))
1719
(define-vc-type-operation 'WORKFILE-REVISION vc-type:cvs
1721
(get-cvs-workfile-revision master #t)))
1723
(define-vc-type-operation 'LOCKING-USER vc-type:cvs
1724
(lambda (master revision)
1725
;; The workfile is "locked" if it is modified.
1726
;; We consider the workfile's owner to be the locker.
1727
(and (or (not revision)
1728
(equal? revision (vc-backend-workfile-revision master)))
1730
(let ((t1 (file-modification-time (vc-master-workfile master)))
1731
(t2 (vc-cvs-workfile-mtime-string master)))
1733
(string=? (file-time->global-ctime-string t1) t2))))
1734
(cvs-file-edited? master))
1736
(file-attributes/uid
1737
(file-attributes (vc-master-workfile master)))))))
1739
(define-vc-type-operation 'LIKELY-CONTROL-TYPE? vc-type:cvs
1741
(file-directory? (cvs-directory workfile))))
1743
(define-vc-type-operation 'REGISTER vc-type:cvs
1744
(lambda (workfile revision comment keep?)
1745
revision keep? ;always keep file.
1746
(with-vc-command-message workfile "Registering"
1748
(vc-run-command workfile '() "cvs" "add"
1750
(file-pathname workfile))))))
1752
(define-vc-type-operation 'CHECKOUT vc-type:cvs
1753
(lambda (master revision lock? workfile)
1754
(let ((workfile* (file-pathname (vc-master-workfile master))))
1755
(with-vc-command-message master "Checking out"
1758
;; CVS makes it difficult to check a file out into
1759
;; anything but the working file.
1760
(delete-file-no-errors workfile)
1761
(vc-run-shell-command master '() "cvs" "update" "-p"
1762
(cvs-rev-switch revision)
1767
(vc-run-command master '() "cvs" (and lock? "-w") "update"
1768
(cvs-rev-switch revision)
1771
(vc-run-command master '() "cvs" "edit" workfile*))))))))
1773
(define-vc-type-operation 'CHECKIN vc-type:cvs
1774
(lambda (master revision comment keep?)
1776
(with-vc-command-message master "Checking in"
1778
(bind-condition-handler (list condition-type:editor-error)
1781
(if (eq? 'NEEDS-MERGE (cvs-status master))
1782
;; The CVS output will be on top of this message.
1783
(error "Type C-x 0 C-x C-q to merge in changes.")))
1785
;; Explicit check-in to the trunk requires a double check-in
1786
;; (first unexplicit) (CVS-1.3). [This is copied from Emacs
1787
;; 20.6, but I don't understand it. -- CPH]
1789
(not (equal? revision
1790
(vc-backend-workfile-revision master)))
1791
(trunk-revision? revision))
1792
(vc-run-command master '() "cvs" "commit"
1793
"-m" "#intermediate"
1794
(file-pathname (vc-master-workfile master))))
1795
(vc-run-command master '() "cvs" "commit"
1796
(cvs-rev-switch revision)
1798
(file-pathname (vc-master-workfile master)))))
1799
;; If this was an explicit check-in, remove the sticky tag.
1801
(vc-run-command master '() "cvs" "update" "-A"
1802
(file-pathname (vc-master-workfile master))))))))
1804
(define-vc-type-operation 'REVERT vc-type:cvs
1806
(with-vc-command-message master "Reverting"
1808
(let ((workfile (vc-master-workfile master)))
1809
(if (cvs-file-edited? master)
1810
(vc-run-command master '() "cvs" "unedit"
1811
(file-pathname workfile))
1813
(delete-file-no-errors workfile)
1814
(vc-run-command master '() "cvs" "update"
1815
(file-pathname workfile)))))))))
1817
(define-vc-type-operation 'STEAL vc-type:cvs
1818
(lambda (master revision)
1820
(error "You cannot steal a CVS lock; there are no CVS locks to steal.")))
1822
(define-vc-type-operation 'DIFF vc-type:cvs
1823
(lambda (master rev1 rev2 simple?)
1826
(BUFFER ,(get-vc-diff-buffer simple?)))))
1827
(if (equal? "0" (vc-backend-workfile-revision master))
1828
;; This file is added but not yet committed; there is no
1832
(error "No revisions exist:" (vc-master-workfile master)))
1834
;; File is added but not committed; we regard this as
1837
;; Diff against /dev/null.
1839
(vc-run-command master options "diff"
1840
(ref-variable diff-switches
1841
(vc-workfile-buffer master
1845
(vc-master-workfile master))))))
1847
(vc-run-command master options "cvs" "diff"
1849
(and (diff-brief-available?) "--brief")
1850
(ref-variable diff-switches
1851
(vc-workfile-buffer master #f)))
1852
(and rev1 (string-append "-r" rev1))
1853
(and rev2 (string-append "-r" rev2))
1854
(file-pathname (vc-master-workfile master))))))))
1856
(define-vc-type-operation 'PRINT-LOG vc-type:cvs
1858
(vc-run-command master '() "cvs" "log"
1859
(file-pathname (vc-master-workfile master)))))
1861
(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:cvs
1862
(lambda (master log-buffer)
1866
(define-vc-type-operation 'CHECK-HEADERS vc-type:cvs
1867
(lambda (master buffer)
1869
(check-rcs-headers buffer)))
1871
(define (cvs-backend-merge-news master)
1872
(with-vc-command-message master "Merging changes into"
1874
(let ((workfile (vc-master-workfile master)))
1875
(vc-run-command master '() "cvs" "update" (file-pathname workfile))
1876
(let ((buffer (get-vc-command-buffer))
1877
(fn (re-quote-string (file-namestring workfile))))
1878
(cond ((re-search-forward
1879
(string-append "^\\([CMUP]\\) " fn)
1880
(buffer-start buffer))
1881
(char=? #\C (extract-right-char (re-match-start 0))))
1884
" already contains the differences between ")
1885
(buffer-start buffer))
1886
;; Special case: file contents in sync with repository
1890
(pop-up-buffer buffer #f)
1891
(error "Couldn't analyze cvs update result."))))))))
1893
;;;; Command Execution
1895
(define (vc-run-command master options command . arguments)
1896
(let ((workfile (and master (->workfile master)))
1898
(lambda (name default)
1899
(let ((option (assq name options)))
1903
(let ((command-messages?
1904
(ref-variable vc-command-messages
1905
(and workfile (pathname->buffer workfile))))
1907
(string-append "Running " command
1909
(string-append " on " (->namestring workfile))
1912
(status-limit (option 'STATUS (lambda () 0)))
1916
(lambda () (directory-pathname workfile))
1917
working-directory-pathname)))
1919
(let ((buffer (option 'BUFFER get-vc-command-buffer)))
1920
(cond ((buffer? buffer) buffer)
1921
((string? buffer) (find-or-create-buffer buffer))
1922
(else (error "Illegal buffer:" buffer))))))
1923
(if command-messages? (message msg))
1924
(buffer-reset! command-buffer)
1925
(bury-buffer command-buffer)
1926
(set-buffer-default-directory! command-buffer directory)
1928
(apply run-synchronous-process
1930
(buffer-end command-buffer)
1933
(os/find-program command directory
1934
(ref-variable exec-path command-buffer))
1935
(vc-command-arguments arguments))))
1936
(if (and (eq? 'EXITED (car result))
1937
(<= 0 (cdr result) status-limit))
1939
(if command-messages? (message msg "done"))
1942
(pop-up-vc-command-buffer #f)
1943
(editor-error msg "...FAILED "
1944
(list (car result) (cdr result)))))))))
1946
(define (vc-command-arguments arguments)
1947
(append-map (lambda (argument)
1948
(cond ((not argument) '())
1949
((string? argument) (list argument))
1950
((pathname? argument) (list (->namestring argument)))
1951
((list? argument) (vc-command-arguments argument))
1952
(else (error "Ill-formed command argument:" argument))))
1955
(define (vc-run-shell-command master options command . arguments)
1956
(vc-run-command master options "/bin/sh" "-c"
1957
(reduce string-append-separated
1959
(vc-command-arguments (cons command arguments)))))
1961
(define (pop-up-vc-command-buffer select?)
1962
(let ((buffer (get-vc-command-buffer)))
1963
(set-buffer-point! buffer (buffer-start buffer))
1964
(pop-up-buffer buffer select?)))
1966
(define (get-vc-command-buffer)
1967
(find-or-create-buffer "*vc*"))
1969
(define (pop-up-vc-diff-buffer select?)
1970
(let ((buffer (get-vc-diff-buffer #f)))
1971
(set-buffer-point! buffer (buffer-start buffer))
1972
(pop-up-buffer buffer select?)))
1974
(define (get-vc-diff-buffer simple?)
1975
(find-or-create-buffer (if simple? " *vc-diff*" "*vc-diff*")))
1977
(define (with-vc-command-message master operation thunk)
1979
(string-append operation " " (->namestring (->workfile master))
1983
(message msg "done")))
1985
;;;; Release/Revision numbers
1987
(define (vc-release? type release)
1988
(let ((release* (vc-backend-release type)))
1990
(release<=? release release*))))
1992
(define (release<=? r1 r2)
1993
;; Compare release numbers, represented as strings.
1994
;; Release components are assumed cardinal numbers, not decimal
1995
;; fractions (5.10 is a higher release than 5.9). Omitted fields
1996
;; are considered lower (5.6.7 is earlier than 5.6.7.1).
1997
;; Comparison runs till the end of the string is found, or a
1998
;; non-numeric component shows up (5.6.7 is earlier than "5.6.7 beta",
1999
;; which is probably not what you want in some cases).
2000
;; This code is suitable for existing RCS release numbers.
2001
;; CVS releases are handled reasonably, too (1.3 < 1.4* < 1.5).
2002
(let ((t1 (burst-string r1 #\space #t))
2003
(t2 (burst-string r2 #\space #t)))
2005
((ns1 (burst-string (car t1) #\. #f))
2006
(ns2 (burst-string (car t2) #\. #f)))
2009
(let ((n1 (string->number (car ns1)))
2010
(n2 (string->number (car ns2))))
2013
(loop (cdr ns1) (cdr ns2))))))
2015
(not (pair? (cdr t1)))
2016
(pair? (cdr t2)))))))
2018
(define (trunk-revision? revision)
2019
(re-string-match "\\`[0-9]+\\.[0-9]+\\'" revision))
2021
(define (branch-revision? revision)
2022
(re-string-match "\\`[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*\\'" revision))
2024
(define (revision-branch-part revision)
2025
(let ((regs (re-string-search-forward "\\.[0-9]+\\'" revision)))
2027
(error:bad-range-argument revision 'BRANCH-PART))
2028
(string-head revision (re-match-start-index 0 regs))))
2030
(define (revision-minor-part revision)
2031
(let ((regs (re-string-search-forward "[0-9]+\\'" revision)))
2033
(error:bad-range-argument revision 'BRANCH-PART))
2035
(re-match-start-index 0 regs)
2036
(re-match-end-index 0 regs))))
2038
(define (previous-revision revision)
2039
(let ((branch (revision-branch-part revision))
2040
(minor (string->number (revision-minor-part revision))))
2042
(string-append branch "." (number->string (- minor 1)))
2043
;; At the first minor number. If on trunk, no obvious answer.
2044
(and (branch-revision? revision)
2045
(revision-branch-part branch)))))
2047
(define (vc-get-revision revision? prompt)
2049
(vc-normalize-revision (prompt-for-string prompt #f))))
2051
(define (vc-normalize-revision revision)
2053
(not (string-null? revision))
2058
(define (blank-string? string)
2059
(not (string-find-next-char-in-set string char-set:not-whitespace)))
2061
(define (subdirectory-pathname pathname name)
2062
(let ((directory (directory-pathname pathname)))
2063
(pathname-new-directory directory
2064
(append (pathname-directory directory)
2067
(define (->workfile object)
2068
(cond ((vc-master? object) (vc-master-workfile object))
2069
((pathname? object) object)
2070
(else (error:wrong-type-argument object "workfile" '->WORKFILE))))
2072
(define (vc-workfile-buffer master find?)
2073
(let ((pathname (vc-master-workfile master)))
2075
(find-file-noselect pathname #f)
2076
(pathname->buffer pathname))))
2078
(define (vc-workfile-string master)
2079
(->namestring (vc-master-workfile master)))
2081
(define (vc-save-workfile-buffer workfile)
2082
(let ((buffer (pathname->buffer workfile)))
2084
(vc-save-buffer buffer #t))))
2086
(define (vc-save-buffer buffer error?)
2087
(if (buffer-modified? buffer)
2088
(if (or (ref-variable vc-suppress-confirm buffer)
2089
(prompt-for-confirmation?
2090
(string-append "Buffer " (buffer-name buffer)
2091
" modified; save it")))
2092
(save-buffer buffer #f)
2093
(if error? (editor-error "Aborted")))))
2095
(define (vc-resync-workfile-buffer workfile keep?)
2096
(let ((buffer (pathname->buffer workfile)))
2099
(vc-revert-buffer buffer #t)
2100
(kill-buffer buffer)))))
2102
(define diff-brief-available?
2103
(let ((result 'UNKNOWN))
2105
(if (eq? result 'UNKNOWN)
2108
(run-synchronous-subprocess
2109
"diff" '("--brief" "/dev/null" "/dev/null")
2113
(define (vc-workfile-modified? master)
2114
(read-cached-value-2 master 'MODIFIED?
2115
(vc-master-pathname master)
2116
(vc-master-workfile master)
2118
(if (eq? vc-type:cvs (vc-master-type master))
2120
(let ((ts (vc-cvs-workfile-mtime-string master)))
2122
(string=? ts (file-time->global-ctime-string tw)))))
2124
(let ((modified? (vc-backend-diff master #f #f #t)))
2125
(set-vc-cvs-workfile-mtime-string! master tm tw modified?)
2127
(vc-backend-diff master #f #f #t)))))
2129
(define (vc-cvs-workfile-mtime-string master)
2130
(read-cached-value-2 master 'CVS-MTIME-STRING
2131
(vc-master-pathname master)
2132
(vc-master-workfile master)
2135
(let ((entry (find-cvs-entry master)))
2139
(define (set-vc-cvs-workfile-mtime-string! master tm tw modified?)
2140
(if (and (not modified?) tm tw (eq? vc-type:cvs (vc-master-type master)))
2142
;; This breaks the READ-CACHED-VALUE-2 abstraction:
2143
(vc-master-put! master 'CVS-MTIME-STRING
2144
(vector (file-time->global-ctime-string tw) tm tw))
2145
(let ((buffer (pathname->buffer (vc-master-workfile master))))
2147
(vc-mode-line master buffer))))))
2149
(define (vc-revert-workfile-buffer master dont-confirm?)
2150
(let ((buffer (vc-workfile-buffer master #f)))
2152
(vc-revert-buffer buffer dont-confirm?))))
2154
(define (vc-revert-buffer buffer dont-confirm?)
2155
;; Revert BUFFER, try to keep point and mark where user expects them
2156
;; in spite of changes due to expanded version-control keywords.
2157
(let ((point-contexts
2158
(map (lambda (window)
2160
(vc-mark-context (window-point window))
2161
(vc-mark-context (window-start-mark window))))
2162
(buffer-windows buffer)))
2163
(point-context (vc-mark-context (buffer-point buffer)))
2164
(mark-context (vc-mark-context (buffer-mark buffer))))
2165
(let ((buffer (revert-buffer buffer #t dont-confirm?)))
2166
(update-screens! '(IGNORE-INPUT NO-SCREEN-OUTPUT))
2167
(if (null? point-contexts)
2168
(let ((m (vc-find-context buffer point-context)))
2170
(set-buffer-point! buffer m)))
2171
(for-each (lambda (entry)
2172
(let ((window (car entry)))
2173
(if (and (window-live? window)
2174
(eq? buffer (window-buffer window)))
2176
(let ((m (vc-find-context buffer (caddr entry))))
2178
(set-window-start-mark! window m #t)))
2179
(let ((m (vc-find-context buffer (cadr entry))))
2181
(set-window-point! window m)))))))
2183
(let ((m (vc-find-context buffer mark-context)))
2185
(set-buffer-mark! buffer m)))
2188
(define (vc-mark-context mark)
2189
(let ((group (mark-group mark))
2190
(index (mark-index mark)))
2191
(let ((length (group-length group)))
2194
(group-extract-string group index (min length (+ index 100)))))))
2196
(define (vc-find-context buffer context)
2197
(let ((group (buffer-group buffer))
2198
(index (vector-ref context 0))
2199
(string (vector-ref context 2)))
2200
(let ((length (group-length group)))
2201
(if (string-null? string)
2202
(group-end-mark group)
2203
(and (or (and (< index length)
2204
(search-forward string
2205
(make-mark group index)
2206
(make-mark group length)))
2209
(abs (- (vector-ref context 1) length))
2210
(string-length string))))
2211
(and (<= 0 index length)
2212
(search-forward string
2213
(make-mark group index)
2214
(make-mark group length)))))
2215
(let ((mark (re-match-start 0)))
2216
(cond ((mark< mark (group-start-mark group))
2217
(group-start-mark group))
2218
((mark> mark (group-end-mark group))
2219
(group-end-mark group))
b'\\ No newline at end of file'
added
removed
src/edwin/vc.scm
