From 9a69ee7a7828e17befdd4b8cf4925ad1f096e6e3 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 9 Mar 1994 21:33:05 +0000 Subject: [PATCH] * Attach VC-PARENT-BUFFER property to vc-log buffers. Use that property to make some of the VC commands work from the log buffer. In particular, the VC-DIFF command now works from the log buffer. * Generalize the log-buffer mechanism to allow multiple log buffers to be open simultaneously. --- v7/src/edwin/vc.scm | 297 +++++++++++++++++++++++--------------------- 1 file changed, 153 insertions(+), 144 deletions(-) diff --git a/v7/src/edwin/vc.scm b/v7/src/edwin/vc.scm index c8c4d51a0..008577fb7 100644 --- a/v7/src/edwin/vc.scm +++ b/v7/src/edwin/vc.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: vc.scm,v 1.8 1994/03/08 22:06:19 cph Exp $ +;;; $Id: vc.scm,v 1.9 1994/03/09 21:33:05 cph Exp $ ;;; ;;; Copyright (c) 1994 Massachusetts Institute of Technology ;;; @@ -223,9 +223,9 @@ lock steals will raise an error. #| (cond ((not (eq? (current-major-mode) (ref-mode-object vc-dired-mode))) (let ((workfile (buffer-pathname (current-buffer)))) - (if workfile - (vc-next-action-on-file workfile revision? #f) - (vc-registration-error #f)))) + (if (not workfile) + (vc-registration-error #f)) + (vc-next-action-on-file workfile revision? #f))) ((= (length (dired-get-marked-files)) 1) (let ((workfile (dired-current-pathname))) (find-file-other-window workfile) @@ -421,7 +421,7 @@ and two version designators specifying which versions to compare." (lambda (revisions?) (if revisions? (dispatch-on-command (ref-command-object vc-version-diff)) - (vc-diff (buffer-vc-master (current-buffer) #t) #f #f)))) + (vc-diff (current-vc-master #t) #f #f)))) (define-command vc-version-diff "For FILE, report diffs between two stored versions REV1 and REV2 of it. @@ -461,7 +461,7 @@ If the current buffer is named `F', the version is named `F.~REV~'. If `F.~REV~' already exists, it is used instead of being re-created." "sVersion to visit (default is latest version)" (lambda (revision) - (let ((master (buffer-vc-master (current-buffer)))) + (let ((master (current-vc-master))) (let ((revision (or (vc-normalize-version revision) (vc-backend-default-version master)))) @@ -485,7 +485,7 @@ Headers are inserted at the start of the buffer." "List the change log of the current buffer in a window." () (lambda () - (vc-backend-print-log (buffer-vc-master (current-buffer))) + (vc-backend-print-log (current-vc-master)) (pop-up-vc-command-buffer #f))) (define-command vc-list-locked-files @@ -494,8 +494,7 @@ 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 (buffer-vc-master (current-buffer)) - all-lockers?) + (vc-backend-list-locked-files (current-vc-master) all-lockers?) (pop-up-vc-command-buffer #f))) (define-command vc-revert-buffer @@ -531,13 +530,11 @@ A prefix argument means do not revert the buffer afterwards." (begin (finish-entry comment) (if after (after))) - (let ((log-buffer (find-or-create-buffer "*VC-log*"))) - (buffer-reset! log-buffer) + (let ((log-buffer (new-buffer "*VC-log*"))) (set-buffer-major-mode! log-buffer (ref-mode-object vc-log)) - (buffer-not-modified! log-buffer) - (set-buffer-pathname! log-buffer #f) (if (vc-master? master) (vc-mode-line master log-buffer)) + (buffer-put! log-buffer 'VC-PARENT-BUFFER (vc-workfile-buffer master)) (let ((window (current-window))) (let ((log-window (pop-up-buffer log-buffer #t))) (buffer-put! log-buffer @@ -622,7 +619,146 @@ the value of vc-log-mode-hook." (error "No log operation is pending.")) (finish-entry buffer))))) -;;;; Back End +;;;; VC-Master Association + +(define (file-vc-master workfile #!optional require-master?) + (let ((require-master? + (if (default-object? require-master?) + #f + require-master?)) + (buffer (pathname->buffer workfile))) + (if buffer + (buffer-vc-master buffer require-master?) + (%file-vc-master workfile require-master?)))) + +(define (current-vc-master #!optional require-master?) + (buffer-vc-master (let ((buffer (current-buffer))) + (or (buffer-get buffer 'VC-PARENT-BUFFER) + buffer)) + (if (default-object? require-master?) + #f + require-master?))) + +(define (buffer-vc-master buffer #!optional require-master?) + (let ((require-master? + (if (default-object? require-master?) + #f + require-master?)) + (workfile (buffer-pathname buffer))) + (if workfile + (let ((master (buffer-get buffer 'VC-MASTER))) + (if (and master + (pathname=? workfile (vc-master-workfile master)) + (vc-master-valid? master)) + master + (let ((master (%file-vc-master workfile require-master?))) + (buffer-put! buffer 'VC-MASTER master) + master))) + (begin + (buffer-put! buffer 'VC-MASTER #f) + (if require-master? (vc-registration-error buffer)) + #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))) + +(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 " + (buffer-name (or object (current-buffer))) + " is not associated with a file.") + (editor-error "File " + (vc-workfile-string object) + " is not under version control."))) + +;;;; VC-Master Datatype + +(define-structure (vc-master + (constructor make-vc-master (type pathname workfile))) + (type #f read-only #t) + (pathname #f read-only #t) + (workfile #f read-only #t) + (checkout-time #f) + (%time #f) + (%admin #f)) + +(define-structure (vc-type (constructor %make-vc-type (name header-keyword))) + (name #f read-only #t) + (header-keyword #f read-only #t) + (operations '())) + +(define (make-vc-type name header-keyword) + (let ((type (%make-vc-type name header-keyword)) + (entry (assq name vc-types))) + (if entry + (set-cdr! entry type) + (set! vc-types (cons (cons name type) vc-types))) + 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)) + unspecific) + +(define vc-master-templates + '()) + +(define (define-vc-type-operation name type procedure) + (let ((entry (assq name (vc-type-operations type)))) + (if entry + (set-cdr! entry procedure) + (set-vc-type-operations! type + (cons (cons name procedure) + (vc-type-operations type)))))) + +(define (vc-type-operation type name) + (let ((entry (assq name (vc-type-operations type)))) + (if (not entry) + (error:bad-range-argument name 'VC-TYPE-OPERATION)) + (cdr entry))) + +(define (vc-call name master . arguments) + (apply (vc-type-operation (vc-master-type master) name) master arguments)) + +;;;; Back-End Calls (define (vc-backend-register workfile revision comment) ((vc-type-operation @@ -665,7 +801,7 @@ the value of vc-log-mode-hook." (set-vc-master-checkout-time! master (file-modification-time-indirect (vc-workfile-pathname master)))))) - + (define (vc-backend-revert master revision) (vc-call 'REVERT master revision)) @@ -692,7 +828,7 @@ the value of vc-log-mode-hook." (define (vc-backend-buffer-version master buffer) (vc-call 'BUFFER-VERSION master buffer)) - + (define (vc-locking-user master revision) (vc-call 'LOCKING-USER master revision)) @@ -709,138 +845,11 @@ the value of vc-log-mode-hook." (set-vc-master-%time! master time) (set-vc-master-%admin! master (vc-call 'GET-ADMIN master)) (loop))))))) - -(define-structure (vc-master - (constructor make-vc-master (type pathname workfile))) - (type #f read-only #t) - (pathname #f read-only #t) - (workfile #f read-only #t) - (checkout-time #f) - (%time #f) - (%admin #f)) - -(define-structure (vc-type (constructor %make-vc-type (name header-keyword))) - (name #f read-only #t) - (header-keyword #f read-only #t) - (operations '())) - -(define (make-vc-type name header-keyword) - (let ((type (%make-vc-type name header-keyword)) - (entry (assq name vc-types))) - (if entry - (set-cdr! entry type) - (set! vc-types (cons (cons name type) vc-types))) - 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)) - unspecific) - -(define vc-master-templates - '()) - -(define (define-vc-type-operation name type procedure) - (let ((entry (assq name (vc-type-operations type)))) - (if entry - (set-cdr! entry procedure) - (set-vc-type-operations! type - (cons (cons name procedure) - (vc-type-operations type)))))) - -(define (vc-type-operation type name) - (let ((entry (assq name (vc-type-operations type)))) - (if (not entry) - (error:bad-range-argument name 'VC-TYPE-OPERATION)) - (cdr entry))) - -(define (vc-call name master . arguments) - (apply (vc-type-operation (vc-master-type master) name) master arguments)) - -(define (file-vc-master workfile #!optional require-master?) - (let ((require-master? - (if (default-object? require-master?) - #f - require-master?)) - (buffer (pathname->buffer workfile))) - (if buffer - (buffer-vc-master buffer require-master?) - (%file-vc-master workfile require-master?)))) - -(define (buffer-vc-master buffer #!optional require-master?) - (let ((require-master? - (if (default-object? require-master?) - #f - require-master?)) - (workfile (buffer-pathname buffer))) - (if workfile - (let ((master (buffer-get buffer 'VC-MASTER))) - (if (and master - (pathname=? workfile (vc-master-workfile master)) - (vc-master-valid? master)) - master - (let ((master (%file-vc-master workfile require-master?))) - (buffer-put! buffer 'VC-MASTER master) - master))) - (begin - (buffer-put! buffer 'VC-MASTER #f) - (if require-master? (vc-registration-error buffer)) - #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))) - -(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 " - (buffer-name (or object (current-buffer))) - " is not associated with a file.") - (editor-error "File " - (vc-workfile-string object) - " is not under version control."))) ;;;; RCS Commands (define vc-type:rcs - (make-vc-type 'RCS "$Id: vc.scm,v 1.8 1994/03/08 22:06:19 cph Exp $")) + (make-vc-type 'RCS "$Id: vc.scm,v 1.9 1994/03/09 21:33:05 cph Exp $")) (define-vc-master-template vc-type:rcs (lambda (pathname) -- 2.25.1