;;; -*-Scheme-*-
;;;
-;;; $Id: vc.scm,v 1.34 2000/03/23 03:19:25 cph Exp $
+;;; $Id: vc.scm,v 1.35 2000/03/23 22:49:05 cph Exp $
;;;
;;; Copyright (c) 1994-2000 Massachusetts Institute of Technology
;;;
boolean?)
(define-variable vc-keep-workfiles
- "If true, don't delete working files after registering changes."
+ "If true, don't delete working files after registering changes.
+If the back-end is CVS, workfiles are always kept, regardless of the
+value of this flag."
#t
boolean?)
#f
boolean?)
-(define-variable vc-checkin-switches
- "Extra switches passed to the checkin program by \\[vc-checkin]."
- '()
- list-of-strings?)
-
(define-variable diff-switches
"A list of strings specifying switches to be be passed to diff."
'("-c")
"An event distributor that is invoked when entering VC-log mode."
(make-event-distributor))
-(define-variable vc-rcs-status
- "If true, revision and locks on RCS working file displayed in modeline.
+(define-variable vc-display-status
+ "If true, display revision number and lock status in modeline.
Otherwise, not displayed."
#t
boolean?)
;;;; Editor Hooks
(define (vc-find-file-hook buffer)
+ (buffer-remove! buffer 'VC-MASTER)
(let ((master (buffer-vc-master buffer)))
(vc-mode-line master buffer)
(if (and master (not (ref-variable vc-make-backup-files buffer)))
(set-variable! find-file-not-found-hooks
(append! hooks (list vc-file-not-found-hook)))))
-(define (vc-mode-line master buffer)
- (let ((variable (ref-variable-object vc-mode-line-status)))
+(define (vc-after-save buffer)
+ (let ((master (buffer-vc-master buffer)))
(if master
- (set-variable-local-value!
- buffer
- variable
- (string-append " " (vc-mode-line-status master buffer)))
- (undefine-variable-local-value! buffer variable)))
- ;; root shouldn't modify a registered file without locking it first.
- (if (and master
- (= 0 (unix/current-uid))
- (not (let ((locking-user (vc-locking-user master #f)))
- (and locking-user
- (string=? locking-user (current-user-name))))))
- (set-buffer-read-only! buffer)))
+ (vc-mode-line master buffer))))
+\f
+(define (vc-mode-line master buffer)
+ (let ((buffer (or buffer (vc-workfile-buffer master))))
+ (let ((variable (ref-variable-object vc-mode-line-status)))
+ (if master
+ (set-variable-local-value!
+ buffer
+ variable
+ (string-append " "
+ (vc-type-display-name (vc-master-type master))
+ (if (ref-variable vc-display-status buffer)
+ (vc-mode-line-status master)
+ "")))
+ (undefine-variable-local-value! buffer variable)))
+ (buffer-modeline-event! buffer 'VC-MODE-LINE-STATUS)
+ (if (and master
+ (buffer-writeable? buffer)
+ (eq? buffer (vc-workfile-buffer master))
+ ;; If the file is locked by some other user, make the
+ ;; buffer read-only. Like this, even root cannot modify a
+ ;; file that someone else has locked.
+ (or (let ((locking-user (vc-locking-user master #f)))
+ (and locking-user
+ (not (string=? locking-user (current-user-name)))))
+ ;; If the user is root, and the file is not
+ ;; owner-writeable, then pretend that we can't write it
+ ;; even though we can (because root can write
+ ;; anything). This way, even root cannot modify a file
+ ;; that isn't locked.
+ (and (= 0 (unix/current-uid))
+ (fix:= 0
+ (fix:and #o200
+ (file-modes
+ (vc-workfile-pathname master)))))))
+ (set-buffer-read-only! buffer))))
+
+(define (vc-mode-line-status master)
+ (let ((revision
+ (or (vc-workfile-version master)
+ (vc-default-version master #f))))
+ (if revision
+ (let ((locker (vc-locking-user master revision)))
+ (string-append (cond ((not locker) "-")
+ ((string=? locker (current-user-name)) ":")
+ (else (string-append ":" locker ":")))
+ revision))
+ " @@")))
\f
;;;; Primary Commands
(let ((master (file-vc-master workfile)))
(if (not master)
(vc-register workfile revision comment 'LOCK)
- (let ((revision
- (or (vc-get-version revision "Version level to act on")
- (vc-workfile-version master))))
+ (let* ((revision (vc-get-version revision "Version level to act on")))
(let ((owner (vc-locking-user master revision)))
(cond ((not owner)
(vc-checkout master revision))
(not (file-exists? workfile)))
(buffer-modified! buffer)))
(vc-save-workfile-buffer workfile)
- (let ((keep? (or keep? (vc-keep-workfiles? workfile))))
- (vc-start-entry workfile
- "Enter initial comment."
- (or comment
- (if (ref-variable vc-initial-comment
- (vc-workfile-buffer workfile))
- #f
- ""))
+ (vc-start-entry workfile
+ "Enter initial comment."
+ (or comment
+ (if (ref-variable vc-initial-comment
+ (vc-workfile-buffer workfile))
+ #f
+ ""))
+ (let ((keep? (or keep? (vc-keep-workfiles? workfile))))
(lambda (comment)
- (vc-backend-register workfile revision comment)
- (if keep?
- (vc-backend-checkout (file-vc-master workfile #t)
- revision
- (eq? 'LOCK keep?)
- #f))
- (vc-update-workfile-buffer workfile keep?))
- #f))))
+ (vc-backend-register workfile revision comment keep?)
+ (vc-update-workfile-buffer workfile keep?)))
+ #f)))
\f
(define (vc-checkout master revision)
(let ((revision
(string-append "File has unlocked changes, "
"claim lock retaining changes")))))
(guarantee-vc-master-valid master)
- (vc-backend-claim-lock master revision)
+ (vc-backend-steal master revision)
(let ((buffer (vc-workfile-buffer master)))
(if buffer
(vc-mode-line master buffer))))
(editor-error "Checkout aborted."))))))
(define (vc-checkin master revision comment)
- (let ((revision
- (or (vc-get-version revision "New version level")
- (vc-workfile-version master)))
- (keep? (vc-keep-workfiles? master)))
+ (let ((revision (vc-get-version revision "New version level")))
(vc-save-workfile-buffer master)
(vc-start-entry master
"Enter a change comment."
comment
- (lambda (comment)
- (vc-backend-checkin master revision comment)
- (if keep?
- (vc-backend-checkout master revision #f #f))
- (vc-update-workfile-buffer master keep?))
+ (let ((keep? (vc-keep-workfiles? master)))
+ (lambda (comment)
+ (vc-backend-checkin master revision
+ (if (blank-string? comment)
+ "*** empty log message ***"
+ comment)
+ keep?)
+ (vc-update-workfile-buffer master keep?)))
(lambda ()
(event-distributor/invoke!
(ref-variable vc-checkin-hooks
(vc-workfile-buffer master))
master)))))
+
+(define (blank-string? string)
+ (not (string-find-next-char-in-set string char-set:not-whitespace)))
\f
(define (vc-revert master revision)
(let ((revision
(let ((master (current-vc-master #t)))
(let ((revision
(or (vc-normalize-version revision)
- (vc-backend-default-version master))))
+ (vc-default-version master #t))))
(let ((workfile
(string-append (->namestring (vc-master-workfile master))
".~"
(vc-backend-print-log (current-vc-master #t))
(pop-up-vc-command-buffer #f)))
-(define-command vc-list-locked-files
- "List the current directory's locked files in a window.
-Normally lists only those files locked by the user;
-prefix arg says to list all locked files regardless."
- "P"
- (lambda (all-lockers?)
- (vc-backend-list-locked-files (current-vc-master #t) all-lockers?)
- (pop-up-vc-command-buffer #f)))
-
(define-command vc-revert-buffer
"Revert the current buffer's file back to the latest checked-in version.
This asks for confirmation if the buffer contents are not identical
#f))))
\f
(define (%file-vc-master workfile require-master?)
- (let ((master (hash-table/get vc-master-table workfile #f)))
- (if (and master (vc-master-valid? master))
- master
- (begin
- (if master
- (hash-table/remove! vc-master-table workfile))
- (let loop ((templates vc-master-templates))
- (if (null? templates)
- (begin
- (if require-master? (vc-registration-error workfile))
- #f)
- (let ((master
- (make-vc-master (cdar templates)
- ((caar templates) workfile)
- workfile)))
- (if (vc-master-valid? master)
- (begin
- (hash-table/put! vc-master-table workfile master)
- master)
- (loop (cdr templates))))))))))
-
-(define vc-master-table
- ;; EQUAL-HASH-MOD happens to work correctly here, because a pathname
- ;; has the same hash value as its namestring.
- ((weak-hash-table/constructor equal-hash-mod pathname=? #t)))
+ (let ((workfile (->pathname workfile)))
+ (let loop ((templates vc-master-templates))
+ (if (null? templates)
+ (begin
+ (if require-master? (vc-registration-error workfile))
+ #f)
+ (let ((master ((car templates) workfile)))
+ (if (and master (vc-master-valid? master))
+ master
+ (loop (cdr templates))))))))
(define (guarantee-vc-master-valid master)
(if (not (vc-master-valid? master))
(error "VC master file disappeared:" (vc-master-workfile master))))
-(define (vc-master-valid? master)
- ;; FILE-EQ? yields #f if either file doesn't exist.
- (let ((pathname (vc-master-pathname master)))
- (and (file-exists? pathname)
- (not (file-eq? (vc-master-workfile master) pathname)))))
-
(define (vc-registration-error object)
(if (or (buffer? object) (not object))
(editor-error "Buffer "
(pathname #f read-only #t)
(workfile #f read-only #t)
(checkout-time #f)
- (%time #f)
- (%admin #f))
+ (properties (make-1d-table) read-only #t))
+
+(define (vc-master-get master key default)
+ (1d-table/get (vc-master-properties master) key default))
+
+(define (vc-master-put! master key value)
+ (1d-table/put! (vc-master-properties master) key value))
+
+(define (vc-master-remove! master key)
+ (1d-table/remove! (vc-master-properties master) key))
+
+(define (sync-checkout-time! master unchanged?)
+ (set-vc-master-checkout-time!
+ master
+ (and unchanged?
+ (file-modification-time-indirect (vc-workfile-pathname master))))
+ (vc-mode-line master #f))
-(define-structure (vc-type (constructor %make-vc-type (name header-keyword)))
+(define (vc-master-read-cached-value master key read-value)
+ (let ((pathname (vc-master-pathname master)))
+ (let loop ()
+ (let ((time (file-modification-time-indirect pathname)))
+ (or (and (eqv? time (vc-master-get master 'MASTER-TIME #f))
+ (vc-master-get master key #f))
+ (begin
+ (vc-master-put! master 'MASTER-TIME time)
+ (vc-master-put! master key (read-value))
+ (loop)))))))
+
+(define-structure (vc-type (constructor %make-vc-type
+ (name display-name header-keyword)))
(name #f read-only #t)
+ (display-name #f read-only #t)
(header-keyword #f read-only #t)
- (operations '()))
+ (operations '())
+ (properties (make-1d-table) read-only #t))
+
+(define (vc-type-get type key default)
+ (1d-table/get (vc-type-properties type) key default))
-(define (make-vc-type name header-keyword)
- (let ((type (%make-vc-type name header-keyword))
+(define (vc-type-put! type key value)
+ (1d-table/put! (vc-type-properties type) key value))
+
+(define (vc-type-remove! type key)
+ (1d-table/remove! (vc-type-properties type) key))
+
+(define (make-vc-type name display-name header-keyword)
+ (let ((type (%make-vc-type name display-name header-keyword))
(entry (assq name vc-types)))
(if entry
(set-cdr! entry type)
(define vc-types
'())
-(define (define-vc-master-template vc-type pathname-map)
- (set! vc-master-templates
- (cons (cons pathname-map vc-type)
- vc-master-templates))
+(define (define-vc-master-template pathname-map)
+ (set! vc-master-templates (cons pathname-map vc-master-templates))
unspecific)
(define vc-master-templates
'())
+\f
+(define (vc-release? type release)
+ (let ((release* (vc-release type)))
+ (and release*
+ (release<=? release release*))))
+
+(define (vc-release type)
+ (let ((release (vc-type-get type 'RELEASE 'UNKNOWN)))
+ (if (eq? 'UNKNOWN release)
+ (let ((release ((vc-type-operation type 'RELEASE))))
+ (vc-type-put! type 'RELEASE release)
+ release)
+ release)))
+
+(define (release<=? 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 ((t1 (burst-string r1 #\space #t))
+ (t2 (burst-string r2 #\space #t)))
+ (let loop
+ ((ns1 (burst-string (car t1) #\. #f))
+ (ns2 (burst-string (car t2) #\. #f)))
+ (if (pair? ns1)
+ (and (pair? ns2)
+ (let ((n1 (string->number (car ns1)))
+ (n2 (string->number (car ns2))))
+ (or (< n1 n2)
+ (and (= n1 n2)
+ (loop (cdr ns1) (cdr ns2))))))
+ (or (pair? ns2)
+ (not (pair? (cdr t1)))
+ (pair? (cdr t2)))))))
+
+(define (trunk-revision? revision)
+ (re-string-match "\\`[0-9]+\\.[0-9]+\\'" revision))
(define (define-vc-type-operation name type procedure)
(let ((entry (assq name (vc-type-operations type))))
\f
;;;; Back-End Calls
-(define (vc-backend-register workfile revision comment)
+(define (vc-backend-register workfile revision comment keep?)
((vc-type-operation
(if (and (not (null? vc-types))
(null? (cdr vc-types)))
#f
#f))))))
'REGISTER)
- workfile revision comment))
-
-(define (vc-backend-claim-lock master revision)
- (vc-call 'CLAIM-LOCK master revision))
+ workfile revision comment keep?))
(define (vc-backend-checkout master revision lock? workfile)
- (let ((workfile
- (and workfile
- (not (pathname=? workfile (vc-workfile-pathname master)))
- workfile)))
- (vc-call 'CHECKOUT master revision lock? workfile)
- (if (and (not revision) (not workfile))
- (set-vc-master-checkout-time!
- master
- (file-modification-time-indirect (vc-workfile-pathname master))))))
+ (vc-call 'CHECKOUT master revision lock?
+ (and workfile
+ (not (pathname=? workfile (vc-workfile-pathname master)))
+ workfile)))
\f
(define (vc-backend-revert master revision)
(vc-call 'REVERT master revision))
-(define (vc-backend-checkin master revision comment)
- (vc-call 'CHECKIN master revision comment))
+(define (vc-backend-checkin master revision comment keep?)
+ (vc-call 'CHECKIN master revision comment keep?))
(define (vc-backend-steal master revision)
(vc-call 'STEAL master revision))
(vc-call 'LOGENTRY-CHECK master log-buffer))
(define (vc-backend-diff master rev1 rev2 simple?)
- (vc-call 'DIFF master rev1 rev2 simple?))
+ (let ((result (vc-call 'DIFF master rev1 rev2 simple?)))
+ (if (and (or (not rev1) (equal? rev1 (vc-workfile-version master)))
+ (not rev2))
+ (sync-checkout-time! master (= 0 result)))
+ result))
(define (vc-backend-print-log master)
(vc-call 'PRINT-LOG master))
-
-(define (vc-backend-list-locked-files master all-lockers?)
- (vc-call 'LIST-LOCKED-FILES master all-lockers?))
-(define (vc-backend-default-version master)
- (vc-call 'DEFAULT-VERSION master))
+(define (vc-default-version master error?)
+ (vc-call 'DEFAULT-VERSION master error?))
-(define (vc-backend-buffer-version master buffer)
- (vc-call 'BUFFER-VERSION master buffer))
+(define (vc-workfile-version master)
+ (vc-call 'WORKFILE-VERSION master))
(define (vc-locking-user master revision)
(vc-call 'LOCKING-USER master revision))
-(define (vc-mode-line-status master buffer)
- (vc-call 'MODE-LINE-STATUS master buffer))
-
-(define (vc-admin master)
- (let ((pathname (vc-master-pathname master)))
- (let loop ()
- (let ((time (file-modification-time-indirect pathname)))
- (or (and (eqv? (vc-master-%time master) time)
- (vc-master-%admin master))
- (begin
- (set-vc-master-%time! master time)
- (set-vc-master-%admin! master (vc-call 'GET-ADMIN master))
- (loop)))))))
-
(define (vc-backend-check-headers master buffer)
(vc-call 'CHECK-HEADERS master buffer))
+
+(define (vc-master-valid? master)
+ (vc-call 'VALID? master))
\f
;;;; RCS Commands
(define vc-type:rcs
;; Splitting up string constant prevents RCS from expanding this
;; keyword.
- (make-vc-type 'RCS (string-append "$" "Id" "$")))
-
-(define-vc-master-template vc-type:rcs
- (lambda (pathname)
- (merge-pathnames (string-append (file-namestring pathname) ",v")
- (let ((pathname (directory-pathname pathname)))
- (pathname-new-directory
- pathname
- (append (pathname-directory pathname)
- '("RCS")))))))
-
-(define-vc-master-template vc-type:rcs
- (lambda (pathname)
- (merge-pathnames (string-append (file-namestring pathname) ",v")
- (directory-pathname pathname))))
-
-(define-vc-master-template vc-type:rcs
- (lambda (pathname)
- (pathname-new-directory pathname
- (append (pathname-directory pathname)
+ (make-vc-type 'RCS "RCS" (string-append "$" "Id" "$")))
+
+(define (rcs-directory workfile)
+ (let ((directory (directory-pathname workfile)))
+ (pathname-new-directory directory
+ (append (pathname-directory directory)
'("RCS")))))
+(let ((rcs-template
+ (lambda (transform)
+ (define-vc-master-template
+ (lambda (workfile)
+ (make-vc-master vc-type:rcs (transform workfile) workfile)))))
+ (in-rcs-directory
+ (lambda (pathname)
+ (merge-pathnames (file-pathname pathname)
+ (rcs-directory pathname))))
+ (rcs-file
+ (lambda (pathname)
+ (merge-pathnames (string-append (file-namestring pathname) ",v")
+ (directory-pathname pathname)))))
+ (rcs-template (lambda (workfile) (rcs-file (in-rcs-directory workfile))))
+ (rcs-template in-rcs-directory)
+ (rcs-template rcs-file))
+
+(define-vc-type-operation 'VALID? vc-type:rcs
+ (lambda (master)
+ ;; FILE-EQ? yields #f if either file doesn't exist.
+ (let ((pathname (vc-master-pathname master)))
+ (and (file-exists? pathname)
+ (not (file-eq? (vc-master-workfile master) pathname))))))
+
(define-vc-type-operation 'LOCKING-USER vc-type:rcs
(lambda (master revision)
- (let ((admin (vc-admin master)))
+ (let ((admin (get-rcs-admin master)))
(let ((delta (rcs-find-delta admin revision #f)))
(if delta
(let loop ((locks (rcs-admin/locks admin)))
;; Kludge: this causes the next action to be a checkin.
(current-user-name))))))
-(define-vc-type-operation 'MODE-LINE-STATUS vc-type:rcs
- (lambda (master buffer)
- (and (ref-variable vc-rcs-status buffer)
- (string-append
- "RCS"
- (let ((admin (vc-admin master)))
- (let ((locks (rcs-admin/locks admin)))
- (if (not (null? locks))
- (apply string-append
- (let ((user (current-user-name)))
- (map (lambda (lock)
- (string-append
- ":"
- (let ((rev (rcs-delta/number (cdr lock))))
- (if (string=? user (car lock))
- rev
- (string-append (car lock) ":" rev)))))
- locks)))
- (let ((head (rcs-admin/head admin)))
- (if head
- (string-append "-" (rcs-delta/number head))
- " @@")))))))))
-
-(define-vc-type-operation 'GET-ADMIN vc-type:rcs
- (lambda (master)
- (parse-rcs-admin (vc-master-pathname master))))
+(define (get-rcs-admin master)
+ (vc-master-read-cached-value master 'RCS-ADMIN
+ (lambda ()
+ (parse-rcs-admin (vc-master-pathname master)))))
(define-vc-type-operation 'CHECK-HEADERS vc-type:rcs
(lambda (master buffer)
master
- (re-search-forward (string-append "\\$[A-Za-z\300-\326\330-\366\370-\377]+"
- "\\(: [\t -#%-\176\240-\377]*\\)?\\$")
- (buffer-start buffer)
- (buffer-end buffer))))
+ (check-rcs-headers buffer)))
+
+(define (check-rcs-headers buffer)
+ (re-search-forward (string-append "\\$[A-Za-z\300-\326\330-\366\370-\377]+"
+ "\\(: [\t -#%-\176\240-\377]*\\)?\\$")
+ (buffer-start buffer)
+ (buffer-end buffer)))
\f
(define-vc-type-operation 'LIKELY-CONTROL-TYPE? vc-type:rcs
(lambda (workfile)
- (file-directory?
- (let ((directory (directory-pathname workfile)))
- (pathname-new-directory directory
- (append (pathname-directory directory)
- '("RCS")))))))
+ (file-directory? (rcs-directory workfile))))
(define-vc-type-operation 'REGISTER vc-type:rcs
- (lambda (workfile revision comment)
+ (lambda (workfile revision comment keep?)
(with-vc-command-message workfile "Registering"
(lambda ()
- (vc-run-command workfile 0 "ci"
- (rcs-rev-switch "-r" revision)
+ (vc-run-command workfile '() "ci"
+ (and (vc-release? vc-type:rcs "5.6.4") "-i")
+ (rcs-rev-switch (cond ((not keep?) "-r")
+ ((eq? 'LOCK keep?) "-l")
+ (else "-u"))
+ revision)
(string-append "-t-" comment)
(vc-workfile-pathname workfile))))))
-(define-vc-type-operation 'CLAIM-LOCK vc-type:rcs
- (lambda (master revision)
- (vc-run-command master 0 "rcs"
- (rcs-rev-switch "-l" revision)
- (vc-workfile-pathname master))))
+(define-vc-type-operation 'RELEASE vc-type:rcs
+ (lambda ()
+ (and (= 0 (vc-run-command #f '() "rcs" "-V"))
+ (re-search-forward "^RCS version \\([0-9.]+ *.*\\)"
+ (buffer-start (get-vc-command-buffer)))
+ (extract-string (re-match-start 1) (re-match-end 1)))))
(define-vc-type-operation 'CHECKOUT vc-type:rcs
(lambda (master revision lock? workfile)
;; but the working file.
(begin
(delete-file-no-errors workfile)
- (vc-run-shell-command master 0 "co"
+ (vc-run-shell-command master '() "co"
(rcs-rev-switch "-p" revision)
(vc-workfile-pathname master)
">"
workfile)
(set-file-modes! workfile (if lock? #o644 #o444)))
- (vc-run-command master 0 "co"
+ (vc-run-command master '() "co"
(rcs-rev-switch (if lock? "-l" "-r") revision)
(rcs-mtime-switch master)
- (vc-workfile-pathname master)))))))
-
+ (vc-workfile-pathname master)))))
+ (if (and (not revision) (not workfile))
+ (sync-checkout-time! master #t))))
+\f
(define-vc-type-operation 'REVERT vc-type:rcs
(lambda (master revision)
(with-vc-command-message master "Reverting"
(lambda ()
- (vc-run-command master 0 "co"
+ (vc-run-command master '() "co"
"-f"
(rcs-rev-switch "-u" revision)
(rcs-mtime-switch master)
(vc-workfile-pathname master))))))
(define-vc-type-operation 'CHECKIN vc-type:rcs
- (lambda (master revision comment)
+ (lambda (master revision comment keep?)
(with-vc-command-message master "Checking in"
(lambda ()
- (vc-run-command master 0 "ci"
- (rcs-rev-switch "-r" revision)
+ (vc-run-command master '() "ci"
+ ;; If available, use the secure check-in option.
+ (and (vc-release? vc-type:rcs "5.6.4") "-j")
+ (rcs-rev-switch (if keep? "-u" "-r") revision)
(string-append "-m" comment)
(vc-workfile-pathname master))))))
(define-vc-type-operation 'STEAL vc-type:rcs
(lambda (master revision)
+ (if (not (vc-release? vc-type:rcs "5.6.2"))
+ (error "Unable to steal locks with this version of RCS."))
(with-vc-command-message master "Stealing lock on"
(lambda ()
- (vc-run-command master 0 "rcs"
+ (vc-run-command master '() "rcs"
"-M"
(rcs-rev-switch "-u" revision)
(rcs-rev-switch "-l" revision)
(vc-workfile-pathname master))))))
+
+(define (rcs-rev-switch switch revision)
+ (if revision
+ (string-append switch revision)
+ switch))
+
+(define (rcs-mtime-switch master)
+ (and (ref-variable vc-rcs-preserve-mod-times (vc-workfile-buffer master))
+ "-M"))
\f
(define-vc-type-operation 'LOGENTRY-CHECK vc-type:rcs
(lambda (master log-buffer)
(define-vc-type-operation 'DIFF vc-type:rcs
(lambda (master rev1 rev2 simple?)
- (vc-run-command master 1 "rcsdiff"
- "-q"
- (and rev1 (string-append "-r" rev1))
- (and rev2 (string-append "-r" rev2))
- (if simple?
- '()
- (ref-variable diff-switches
- (vc-workfile-buffer master)))
- (vc-workfile-pathname master))))
+ (let ((type (vc-master-type master))
+ (run-diff
+ (lambda (status brief?)
+ (vc-run-command master
+ `((STATUS ,status)
+ ,@(if simple? `((BUFFER " *vc-diff*")) '()))
+ "rcsdiff"
+ (and brief? "--brief")
+ "-q"
+ (and rev1 (string-append "-r" rev1))
+ (and rev2 (string-append "-r" rev2))
+ (if simple?
+ '()
+ (ref-variable diff-switches
+ (vc-workfile-buffer master)))
+ (vc-workfile-pathname master)))))
+ (if (or (not simple?) (vc-type-get type 'RCSDIFF-NO-BRIEF? #f))
+ (run-diff 1 #f)
+ (let ((status (run-diff 2 #t)))
+ (if (= 2 status)
+ (begin
+ (vc-type-put! type 'RCSDIFF-NO-BRIEF? #t)
+ (run-diff 1 #f))
+ status))))))
(define-vc-type-operation 'PRINT-LOG vc-type:rcs
(lambda (master)
- (vc-run-command master 0 "rlog" (vc-workfile-pathname master))))
-
-(define-vc-type-operation 'LIST-LOCKED-FILES vc-type:rcs
- (lambda (master all-lockers?)
- (vc-run-shell-command master 0 "rlog"
- "-L -R"
- (and (not all-lockers?)
- (string-append "-l" (current-user-name)))
- (merge-pathnames
- "*,v"
- (directory-pathname (vc-master-pathname master))))))
+ (vc-run-command master '() "rlog" (vc-workfile-pathname master))))
(define-vc-type-operation 'DEFAULT-VERSION vc-type:rcs
+ (lambda (master error?)
+ (let ((delta (rcs-find-delta (get-rcs-admin master) #f error?)))
+ (and delta
+ (rcs-delta/number delta)))))
+\f
+(define-vc-type-operation 'WORKFILE-VERSION vc-type:rcs
(lambda (master)
- (rcs-delta/number (rcs-find-delta (vc-admin master) #f #t))))
+ (let ((parse-buffer
+ (lambda (buffer)
+ (let ((start (buffer-start buffer))
+ (end (buffer-end buffer)))
+ (let ((find-keyword
+ (lambda (keyword)
+ (let ((mark
+ (search-forward (string-append "$" keyword ":")
+ start end #f)))
+ (and mark
+ (skip-chars-forward " " mark end #f)))))
+ (get-version
+ (lambda (start)
+ (let ((end (skip-chars-forward "0-9." start end)))
+ (and (mark< start end)
+ (let ((revision (extract-string start end)))
+ (let ((length (rcs-number-length revision)))
+ (and (> length 2)
+ (even? length)
+ (rcs-number-head revision
+ (- length 1)
+ #f)))))))))
+ (cond ((or (find-keyword "Id") (find-keyword "Header"))
+ => (lambda (mark)
+ (get-version
+ (skip-chars-forward
+ " "
+ (skip-chars-forward "^ " mark end)
+ end))))
+ ((find-keyword "Revision") => get-version)
+ (else #f)))))))
+ (let ((pathname (vc-workfile-pathname master)))
+ (let ((buffer (pathname->buffer pathname)))
+ (if buffer
+ (parse-buffer buffer)
+ (call-with-temporary-buffer " *VC-temp*"
+ (lambda (buffer)
+ (catch-file-errors (lambda () #f)
+ (lambda ()
+ (read-buffer buffer pathname #f)
+ (parse-buffer buffer)))))))))))
+\f
+;;;; CVS Commands
-(define-vc-type-operation 'BUFFER-VERSION vc-type:rcs
+(define vc-type:cvs
+ (make-vc-type 'CVS "CVS" (string-append "$" "Id" "$")))
+
+(define-vc-master-template
+ (lambda (workfile)
+ (find-cvs-master workfile)))
+
+(define (find-cvs-master workfile)
+ (let* ((entries-file (merge-pathnames "Entries" (cvs-directory workfile)))
+ (master (make-vc-master vc-type:cvs entries-file workfile))
+ (time (file-modification-time-indirect entries-file))
+ (tokens (find-cvs-entry master)))
+ (and tokens
+ (begin
+ (vc-master-put! master 'MASTER-TIME time)
+ (vc-master-put! master 'CVS-WORKFILE-VERSION (cadr tokens))
+ (let ((mtime (file-modification-time-indirect workfile)))
+ (if (string=? (file-time->global-ctime-string mtime)
+ (caddr tokens))
+ (set-vc-master-checkout-time! master mtime)
+ (vc-backend-diff master #f #f #t)))
+ master))))
+
+(define (cvs-directory workfile)
+ (let ((directory (directory-pathname workfile)))
+ (pathname-new-directory directory
+ (append (pathname-directory directory)
+ '("CVS")))))
+
+(define (get-cvs-workfile-version master error?)
+ (vc-master-read-cached-value master 'CVS-WORKFILE-VERSION
+ (lambda ()
+ (let ((tokens (find-cvs-entry master)))
+ (if tokens
+ (cadr tokens)
+ (and error?
+ (error "Workfile has no version:"
+ (vc-master-workfile master))))))))
+
+(define (find-cvs-entry master)
+ (let ((pathname (vc-master-pathname master))
+ (name (file-namestring (vc-master-workfile master))))
+ (and (file-readable? pathname)
+ (call-with-input-file pathname
+ (lambda (port)
+ (let ((prefix (string-append "/" name "/")))
+ (let loop ()
+ (let ((line (read-line port)))
+ (and (not (eof-object? line))
+ (if (string-prefix? prefix line)
+ (let ((tokens (cdr (burst-string line #\/ #f))))
+ (if (fix:= 5 (length tokens))
+ tokens
+ (loop)))
+ (loop)))))))))))
+\f
+(define (get-cvs-status master)
+ (let ((pathname (vc-workfile-pathname master)))
+ (vc-run-command master
+ `((DIRECTORY ,(directory-pathname pathname))
+ (BUFFER " *vc-status*"))
+ "cvs" "status" (file-pathname pathname)))
+ (let ((m (buffer-start (get-vc-command-buffer))))
+ (let ((status
+ (if (re-search-forward "^File: [^ \t]+[ \t]+Status: \\(.*\\)" m)
+ (convert-cvs-status
+ (extract-string (re-match-start 1) (re-match-end 1)))
+ 'UNKNOWN)))
+ (if (eq? 'UP-TO-DATE status)
+ (sync-checkout-time! master #t))
+ (values
+ status
+ (if (re-search-forward
+ "\\(RCS Version\\|RCS Revision\\|Repository revision\\):[ \t]+\\([0-9.]+\\)"
+ m)
+ (extract-string (re-match-start 2) (re-match-end 2))
+ #f)))))
+
+(define (convert-cvs-status status)
+ (cond ((string-ci=? status "Up-to-date")
+ 'UP-TO-DATE)
+ ((string-ci=? status "Locally Modified")
+ 'LOCALLY-MODIFIED)
+ ((string-ci=? status "Needs Merge")
+ 'NEEDS-MERGE)
+ ((or (string-ci=? status "Needs Checkout")
+ (string-ci=? status "Needs Patch"))
+ 'NEEDS-CHECKOUT)
+ ((or (string-ci=? status "Unresolved Conflict")
+ (string-ci=? status "File had conflicts on merge"))
+ 'UNRESOLVED-CONFLICT)
+ ((or (string-ci=? status "Locally Added")
+ (string-ci=? status "New file!"))
+ 'LOCALLY-ADDED)
+ (else
+ 'UNKNOWN)))
+
+(define (cvs-rev-switch revision)
+ (and revision
+ (list "-r" revision)))
+\f
+(define-vc-type-operation 'VALID? vc-type:cvs
+ (lambda (master)
+ (get-cvs-workfile-version master #f)))
+
+(define-vc-type-operation 'RELEASE vc-type:cvs
+ (lambda ()
+ (and (= 0 (vc-run-command #f '() "cvs" "-v"))
+ (re-search-forward "^Concurrent Versions System (CVS) \\([0-9.]+\\)"
+ (buffer-start (get-vc-command-buffer)))
+ (extract-string (re-match-start 1) (re-match-end 1)))))
+
+(define-vc-type-operation 'LOCKING-USER vc-type:cvs
+ (lambda (master revision)
+ revision
+ (let ((workfile (vc-workfile-pathname master)))
+ (let ((mtime (file-modification-time-indirect workfile)))
+ (and mtime
+ (not (eqv? mtime (vc-master-checkout-time master)))
+ (let ((attr (file-attributes workfile)))
+ (and attr
+ (unix/uid->string (file-attributes/uid attr)))))))))
+
+(define-vc-type-operation 'DEFAULT-VERSION vc-type:cvs
+ (lambda (master error?)
+ (or (call-with-values (lambda () (get-cvs-status master))
+ (lambda (status revision)
+ status
+ revision))
+ (and error?
+ (error "Unable to determine default CVS version:"
+ (vc-workfile-pathname master))))))
+
+(define-vc-type-operation 'WORKFILE-VERSION vc-type:cvs
+ (lambda (master)
+ (get-cvs-workfile-version master #f)))
+
+(define-vc-type-operation 'CHECK-HEADERS vc-type:cvs
(lambda (master buffer)
master
- (let ((start (buffer-start buffer))
- (end (buffer-end buffer)))
- (let ((find-keyword
- (lambda (keyword)
- (let ((mark
- (search-forward (string-append "$" keyword ":")
- start
- end
- #f)))
- (and mark
- (skip-chars-forward " " mark end #f)))))
- (get-version
- (lambda (start)
- (let ((end (skip-chars-forward "0-9." start end)))
- (and (mark< start end)
- (let ((revision (extract-string start end)))
- (let ((length (rcs-number-length revision)))
- (and (> length 2)
- (even? length)
- (rcs-number-head revision
- (- length 1)
- #f)))))))))
- (cond ((or (find-keyword "Id") (find-keyword "Header"))
- => (lambda (mark)
- (get-version
- (skip-chars-forward " "
- (skip-chars-forward "^ " mark end)
- end))))
- ((find-keyword "Revision") => get-version)
- (else #f))))))
+ (check-rcs-headers buffer)))
-(define (rcs-rev-switch switch revision)
- (if revision
- (string-append switch revision)
- switch))
+(define-vc-type-operation 'LIKELY-CONTROL-TYPE? vc-type:cvs
+ (lambda (workfile)
+ (file-directory? (cvs-directory workfile))))
-(define (rcs-mtime-switch master)
- (and (ref-variable vc-rcs-preserve-mod-times (vc-workfile-buffer master))
- "-M"))
+(define-vc-type-operation 'REGISTER vc-type:cvs
+ (lambda (workfile revision comment keep?)
+ revision keep? ;always keep file.
+ (with-vc-command-message workfile "Registering"
+ (lambda ()
+ (vc-run-command workfile '() "cvs" "add"
+ "-m" comment
+ (vc-workfile-pathname workfile))))))
+
+(define-vc-type-operation 'CHECKOUT vc-type:cvs
+ (lambda (master revision lock? workfile)
+ lock? ;locking not used with CVS
+ (cond (workfile
+ ;; CVS makes it difficult to check a file out into anything
+ ;; but the working file.
+ (delete-file-no-errors workfile)
+ (vc-run-shell-command master '() "cvs" "update" "-p"
+ (cvs-rev-switch revision)
+ (vc-workfile-pathname master)
+ ">"
+ workfile))
+ (revision
+ ;; Checkout only necessary for given revision.
+ (vc-run-command master '() "cvs" "update"
+ (cvs-rev-switch revision)
+ (vc-workfile-pathname master))
+ (sync-checkout-time! master #t)))))
+\f
+(define-vc-type-operation 'REVERT vc-type:cvs
+ (lambda (master revision)
+ ;; Check out via standard output, so that no sticky tag is set.
+ (vc-backend-checkout master revision #f (vc-workfile-pathname master))))
+
+(define-vc-type-operation 'CHECKIN vc-type:cvs
+ (lambda (master revision comment keep?)
+ keep?
+ (bind-condition-handler (list condition-type:editor-error)
+ (lambda (condition)
+ condition
+ (if (eq? 'NEEDS-MERGE
+ (call-with-values (lambda () (get-cvs-status master))
+ (lambda (status revision)
+ revision
+ status)))
+ (error "Type C-x 0 C-x C-q to merge in changes.")))
+ (lambda ()
+ (if (and revision
+ (not (equal? revision (vc-workfile-version master)))
+ (trunk-revision? revision))
+ (vc-run-command master '() "cvs" "commit"
+ "-m" "#intermediate"
+ (vc-workfile-pathname master)))
+ (vc-run-command master '() "cvs" "commit"
+ (cvs-rev-switch revision)
+ "-m" comment
+ (vc-workfile-pathname master))))
+ ;; If this was an explicit check-in, remove the sticky tag.
+ (vc-run-command master '() "cvs" "update" "-A"
+ (vc-workfile-pathname master))))
+
+(define-vc-type-operation 'STEAL vc-type:cvs
+ (lambda (master revision)
+ master revision
+ (error "You cannot steal a CVS lock; there are no CVS locks to steal.")))
+
+(define-vc-type-operation 'LOGENTRY-CHECK vc-type:cvs
+ (lambda (master log-buffer)
+ master log-buffer
+ unspecific))
+
+(define-vc-type-operation 'DIFF vc-type:cvs
+ (lambda (master rev1 rev2 simple?)
+ (let ((options
+ `((STATUS 1)
+ ,@(if simple? `((BUFFER " *vc-diff*")) '()))))
+ (if (equal? "0" (vc-workfile-version master))
+ ;; This file is added but not yet committed; there is no
+ ;; master file.
+ (begin
+ (if (or rev1 rev2)
+ (error "No revisions exist:" (vc-workfile-pathname master)))
+ (if simple?
+ ;; File is added but not committed; we regard this as
+ ;; "changed".
+ 1
+ ;; Diff against /dev/null.
+ (vc-run-command master options "diff"
+ (ref-variable diff-switches
+ (vc-workfile-buffer master))
+ "/dev/null"
+ (vc-workfile-pathname master))))
+ (vc-run-command master options "cvs" "diff"
+ (and rev1 (string-append "-r" rev1))
+ (and rev2 (string-append "-r" rev2))
+ (if simple?
+ '()
+ (ref-variable diff-switches
+ (vc-workfile-buffer master)))
+ (vc-workfile-pathname master))))))
+
+(define-vc-type-operation 'PRINT-LOG vc-type:cvs
+ (lambda (master)
+ (vc-run-command master '() "cvs" "log" (vc-workfile-pathname master))))
\f
;;;; Command Execution
-(define (vc-run-command master status-limit command . arguments)
+(define (vc-run-command master options command . arguments)
+ (let ((option
+ (lambda (name default)
+ (let ((option (assq name options)))
+ (if option
+ (cadr option)
+ (default))))))
(let ((command-messages?
- (ref-variable vc-command-messages (vc-workfile-buffer master)))
+ (ref-variable vc-command-messages
+ (and master (vc-workfile-buffer master))))
(msg
(string-append "Running " command
- " on " (vc-workfile-string master) "..."))
- (command-buffer (get-vc-command-buffer)))
+ (if master
+ (string-append " on " (vc-workfile-string master))
+ "")
+ "..."))
+ (status-limit (option 'STATUS (lambda () 0)))
+ (directory (option 'DIRECTORY working-directory-pathname))
+ (command-buffer
+ (let ((buffer (option 'BUFFER get-vc-command-buffer)))
+ (cond ((string? buffer) (find-or-create-buffer buffer))
+ ((buffer? buffer) buffer)
+ (else (error "Illegal buffer:" buffer))))))
(if command-messages? (message msg))
(buffer-reset! command-buffer)
(bury-buffer command-buffer)
+ (set-buffer-default-directory! command-buffer directory)
(let ((result
(apply run-synchronous-process
#f
(buffer-end command-buffer)
+ directory
#f
- #f
- (os/find-program command
- (buffer-default-directory command-buffer)
- (ref-variable exec-path))
+ (os/find-program command directory
+ (ref-variable exec-path command-buffer))
(vc-command-arguments arguments))))
(if (and (eq? 'EXITED (car result))
(<= 0 (cdr result) status-limit))
(begin
(pop-up-vc-command-buffer #f)
(editor-error "Running " command "...FAILED "
- (list (car result) (cdr result))))))))
+ (list (car result) (cdr result)))))))))
(define (vc-command-arguments arguments)
(append-map (lambda (argument)
(else (error "Ill-formed command argument:" argument))))
arguments))
-(define (vc-run-shell-command master status-limit command . arguments)
- (vc-run-command master status-limit "/bin/sh" "-c"
+(define (vc-run-shell-command master options command . arguments)
+ (vc-run-command master options "/bin/sh" "-c"
(reduce string-append-separated
""
(vc-command-arguments (cons command arguments)))))
;;;; Workfile Utilities
(define (vc-keep-workfiles? master)
- (ref-variable vc-keep-workfiles (vc-workfile-buffer master)))
+ (or (eq? vc-type:cvs (vc-master-type master))
+ (ref-variable vc-keep-workfiles (vc-workfile-buffer master))))
(define (vc-update-workfile-buffer master keep?)
;; Depending on VC-KEEP-WORKFILES, either revert the workfile
;; buffer to show the updated workfile, or kill the buffer.
(let ((buffer (vc-workfile-buffer master)))
(if buffer
- (if (or keep? (ref-variable vc-keep-workfiles buffer))
+ (if keep?
(vc-revert-buffer buffer #t)
(kill-buffer buffer)))))
(not (string-null? revision))
revision))
-(define (vc-workfile-version master)
- (let ((pathname (vc-workfile-pathname master)))
- (let ((buffer (pathname->buffer pathname)))
- (if buffer
- (vc-backend-buffer-version master buffer)
- (call-with-temporary-buffer " *VC-temp*"
- (lambda (buffer)
- (catch-file-errors (lambda () #f)
- (lambda ()
- (read-buffer buffer pathname #f)
- (vc-backend-buffer-version master buffer)))))))))
-
(define (vc-workfile-buffer master)
(pathname->buffer (vc-workfile-pathname master)))
(file-modification-time-indirect (vc-workfile-pathname master))))
(cond ((not mod-time) #f)
((eqv? (vc-master-checkout-time master) mod-time) #f)
- ((= 0 (vc-backend-diff master #f #f #t))
- (set-vc-master-checkout-time! master mod-time)
- #f)
- (else
- (set-vc-master-checkout-time! master #f)
- #t))))
+ (else (not (= 0 (vc-backend-diff master #f #f #t)))))))
(define (vc-save-workfile-buffer master)
(let ((buffer (vc-workfile-buffer master)))
projects / mit-scheme.git / commitdiff