From 1a20a700f7c025974151d4e11c5c0b681b4441e7 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 23 Mar 2000 22:49:05 +0000 Subject: [PATCH] Implement CVS support for VC. Bring the RCS support of VC more up to date. --- v7/src/edwin/edwin.pkg | 8 +- v7/src/edwin/fileio.scm | 5 +- v7/src/edwin/vc.scm | 935 +++++++++++++++++++++++++++------------- 3 files changed, 638 insertions(+), 310 deletions(-) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index c438ea48e..32b99658f 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.245 2000/03/23 06:31:16 cph Exp $ +$Id: edwin.pkg,v 1.246 2000/03/23 22:48:47 cph Exp $ Copyright (c) 1989-2000 Massachusetts Institute of Technology @@ -1096,17 +1096,17 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. edwin-mode$vc-log edwin-variable$diff-switches edwin-variable$vc-checkin-hooks - edwin-variable$vc-checkin-switches edwin-variable$vc-checkout-carefully edwin-variable$vc-command-messages + edwin-variable$vc-display-status edwin-variable$vc-initial-comment edwin-variable$vc-keep-workfiles edwin-variable$vc-log-mode-hook edwin-variable$vc-make-backup-files edwin-variable$vc-mode-line-status edwin-variable$vc-rcs-preserve-mod-times - edwin-variable$vc-rcs-status - edwin-variable$vc-suppress-confirm)) + edwin-variable$vc-suppress-confirm + vc-after-save)) (define-package (edwin rcs-parse) (files "rcsparse") diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm index 8a1338938..5e6cab758 100644 --- a/v7/src/edwin/fileio.scm +++ b/v7/src/edwin/fileio.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: fileio.scm,v 1.150 2000/03/23 03:19:11 cph Exp $ +;;; $Id: fileio.scm,v 1.151 2000/03/23 22:48:58 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology ;;; @@ -568,7 +568,8 @@ Otherwise, a message is written both before and after long file writes." (lambda () unspecific) (lambda () (os/restore-modes-to-updated-file! pathname - modes)))))))))) + modes)))) + (vc-after-save buffer))))))) (define (verify-visited-file-modification-time? buffer) (let ((truename (buffer-truename buffer)) diff --git a/v7/src/edwin/vc.scm b/v7/src/edwin/vc.scm index 7de65176f..d16b9f6ae 100644 --- a/v7/src/edwin/vc.scm +++ b/v7/src/edwin/vc.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -48,7 +48,9 @@ Bound to #F if the buffer is not under version control." 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?) @@ -62,11 +64,6 @@ Bound to #F if the buffer is not under version control." #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") @@ -91,8 +88,8 @@ and that its contents match what the master file says." "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?) @@ -106,6 +103,7 @@ Otherwise, the mod time of the file is the checkout time." ;;;; 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))) @@ -133,21 +131,57 @@ Otherwise, the mod time of the file is the checkout time." (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)))) + +(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)) + " @@"))) ;;;; Primary Commands @@ -225,9 +259,7 @@ lock steals will raise an error. (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)) @@ -264,23 +296,18 @@ lock steals will raise an error. (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))) (define (vc-checkout master revision) (let ((revision @@ -313,7 +340,7 @@ lock steals will raise an error. (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)))) @@ -323,24 +350,27 @@ lock steals will raise an error. (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))) (define (vc-revert master revision) (let ((revision @@ -447,7 +477,7 @@ If `F.~REV~' already exists, it is used instead of being re-created." (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)) ".~" @@ -490,15 +520,6 @@ Headers are inserted at the start of the buffer." (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 @@ -773,42 +794,21 @@ the value of vc-log-mode-hook." #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 " @@ -826,16 +826,54 @@ the value of vc-log-mode-hook." (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) @@ -845,14 +883,54 @@ the value of vc-log-mode-hook." (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 '()) + +(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)))) @@ -873,7 +951,7 @@ the value of vc-log-mode-hook." ;;;; 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))) @@ -900,27 +978,19 @@ the value of vc-log-mode-hook." #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))) (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)) @@ -929,70 +999,70 @@ the value of vc-log-mode-hook." (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)) ;;;; 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))) @@ -1003,63 +1073,45 @@ the value of vc-log-mode-hook." ;; 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))) (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) @@ -1070,45 +1122,60 @@ the value of vc-log-mode-hook." ;; 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)))) + (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")) (define-vc-type-operation 'LOGENTRY-CHECK vc-type:rcs (lambda (master log-buffer) @@ -1117,98 +1184,374 @@ the value of vc-log-mode-hook." (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))))) + +(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))))))))))) + +;;;; 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))))))))))) + +(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))) + +(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))))) + +(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)))) ;;;; 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)) @@ -1218,7 +1561,7 @@ the value of vc-log-mode-hook." (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) @@ -1229,8 +1572,8 @@ the value of vc-log-mode-hook." (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))))) @@ -1252,14 +1595,15 @@ the value of vc-log-mode-hook." ;;;; 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))))) @@ -1273,18 +1617,6 @@ the value of vc-log-mode-hook." (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))) @@ -1301,12 +1633,7 @@ the value of vc-log-mode-hook." (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))) -- 2.25.1