299 lines
9.4 KiB
Scheme
299 lines
9.4 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Version Control: RCS
|
||
|
||
|
||
|
||
(define vc-type:rcs
|
||
;; Splitting up string constant prevents RCS from expanding this
|
||
;; keyword.
|
||
(make-vc-type 'RCS "RCS" "\$Id\$"))
|
||
|
||
(define (rcs-master? master)
|
||
(eq? vc-type:rcs (vc-master-type master)))
|
||
|
||
(define (rcs-directory workfile)
|
||
(subdirectory-pathname workfile "RCS"))
|
||
|
||
(define (get-rcs-admin master)
|
||
(let ((pathname (vc-master-pathname master)))
|
||
(read-cached-value-1 master 'RCS-ADMIN pathname
|
||
(lambda (time) time (parse-rcs-admin pathname)))))
|
||
|
||
(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 (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
|
||
(pathname->buffer (->workfile master)))
|
||
"-M"))
|
||
|
||
(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 'FIND-MASTER vc-type:rcs
|
||
(lambda (workfile control-dir)
|
||
(let ((try
|
||
(lambda (transform)
|
||
(let ((master-file (transform workfile)))
|
||
(and (file-exists? master-file)
|
||
(make-vc-master vc-type:rcs master-file workfile)))))
|
||
(in-control-dir
|
||
(lambda (pathname)
|
||
(merge-pathnames (file-pathname pathname) control-dir)))
|
||
(rcs-file
|
||
(lambda (pathname)
|
||
(merge-pathnames (string-append (file-namestring pathname) ",v")
|
||
(directory-pathname pathname)))))
|
||
(or (try (lambda (workfile) (rcs-file (in-control-dir workfile))))
|
||
(try in-control-dir)
|
||
(try rcs-file)))))
|
||
|
||
(define-vc-type-operation 'VALID? vc-type:rcs
|
||
(lambda (master)
|
||
(file-exists? (vc-master-pathname master))))
|
||
|
||
(define-vc-type-operation 'DEFAULT-REVISION vc-type:rcs
|
||
(lambda (master)
|
||
(let ((delta (rcs-find-delta (get-rcs-admin master) #f #f)))
|
||
(and delta
|
||
(rcs-delta/number delta)))))
|
||
|
||
(define-vc-type-operation 'WORKFILE-REVISION vc-type:rcs
|
||
(lambda (master)
|
||
(let ((workfile (vc-master-workfile master)))
|
||
(read-cached-value-1 master 'RCS-WORKFILE-REVISION workfile
|
||
(lambda (time)
|
||
time
|
||
(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-revision
|
||
(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-revision
|
||
(skip-chars-forward
|
||
" "
|
||
(skip-chars-forward "^ " mark end)
|
||
end))))
|
||
((find-keyword "Revision") => get-revision)
|
||
(else #f)))))))
|
||
(let ((buffer (pathname->buffer workfile)))
|
||
(if buffer
|
||
(parse-buffer buffer)
|
||
(call-with-temporary-buffer " *VC-temp*"
|
||
(lambda (buffer)
|
||
(catch-file-errors (lambda (condition) condition #f)
|
||
(lambda ()
|
||
(read-buffer buffer workfile #f)
|
||
(parse-buffer buffer)))))))))))))
|
||
|
||
(define-vc-type-operation 'WORKFILE-MODIFIED? vc-type:rcs
|
||
(lambda (master)
|
||
(read-cached-value-2 master 'MODIFIED?
|
||
(vc-master-pathname master)
|
||
(vc-master-workfile master)
|
||
(lambda (tm tw)
|
||
tm tw
|
||
(vc-backend-diff master #f #f #t)))))
|
||
|
||
(define-vc-type-operation 'NEXT-ACTION vc-type:rcs
|
||
(lambda (master)
|
||
(let ((owner (vc-backend-locking-user master #f)))
|
||
(cond ((not owner) 'CHECKOUT)
|
||
((string=? owner (current-user-name)) 'CHECKIN)
|
||
(else 'STEAL-LOCK)))))
|
||
|
||
(define-vc-type-operation 'KEEP-WORKFILES? vc-type:rcs
|
||
(lambda (master)
|
||
(ref-variable vc-keep-workfiles (vc-workfile-buffer master #f))))
|
||
|
||
(define-vc-type-operation 'WORKFILE-STATUS-STRING vc-type:rcs
|
||
(lambda (master)
|
||
(vc-backend-locking-user master #f)))
|
||
|
||
(define-vc-type-operation 'LOCKING-USER vc-type:rcs
|
||
(lambda (master revision)
|
||
(let ((admin (get-rcs-admin master)))
|
||
(let ((delta
|
||
(rcs-find-delta admin
|
||
(or revision
|
||
(vc-backend-workfile-revision master))
|
||
#f)))
|
||
(and delta
|
||
(let loop ((locks (rcs-admin/locks admin)))
|
||
(and (not (null? locks))
|
||
(if (eq? delta (cdar locks))
|
||
(caar locks)
|
||
(loop (cdr locks))))))))))
|
||
|
||
(define-vc-type-operation 'CONTROL-DIRECTORY vc-type:rcs
|
||
(lambda (directory)
|
||
(let ((cd (rcs-directory directory)))
|
||
(and (file-directory? cd)
|
||
(any (lambda (pathname)
|
||
(string-suffix? ",v" (file-namestring pathname)))
|
||
(directory-read cd))
|
||
cd))))
|
||
|
||
(define-vc-type-operation 'REGISTER vc-type:rcs
|
||
(lambda (workfile revision comment keep?)
|
||
(with-vc-command-message workfile "Registering"
|
||
(lambda ()
|
||
(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)
|
||
(rcs-mtime-switch workfile)
|
||
(string-append "-t-" comment)
|
||
workfile)))))
|
||
|
||
(define-vc-type-operation 'CHECKOUT vc-type:rcs
|
||
(lambda (master revision lock? workfile)
|
||
(let ((revision (or revision (vc-backend-workfile-revision master))))
|
||
(with-vc-command-message master "Checking out"
|
||
(lambda ()
|
||
(if workfile
|
||
;; RCS makes it difficult to check a file out into anything
|
||
;; but the working file.
|
||
(begin
|
||
(delete-file-no-errors workfile)
|
||
(vc-run-shell-command master '() "co"
|
||
(rcs-rev-switch "-p" revision)
|
||
(vc-master-workfile master)
|
||
">"
|
||
workfile)
|
||
(set-file-modes! workfile (if lock? #o644 #o444)))
|
||
(vc-run-command master '() "co"
|
||
(rcs-rev-switch (if lock? "-l" "-r") revision)
|
||
(rcs-mtime-switch master)
|
||
(vc-master-workfile master))))))))
|
||
|
||
(define-vc-type-operation 'CHECKIN vc-type:rcs
|
||
(lambda (master revision comment keep?)
|
||
(with-vc-command-message master "Checking in"
|
||
(lambda ()
|
||
(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)
|
||
(rcs-mtime-switch master)
|
||
(string-append "-m" comment)
|
||
(vc-master-workfile master))))))
|
||
|
||
(define-vc-type-operation 'REVERT vc-type:rcs
|
||
(lambda (master)
|
||
(with-vc-command-message master "Reverting"
|
||
(lambda ()
|
||
(vc-run-command master '() "co"
|
||
"-f" "-u"
|
||
(rcs-mtime-switch master)
|
||
(vc-master-workfile 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."))
|
||
(let ((revision (or revision (vc-backend-workfile-revision master))))
|
||
(with-vc-command-message master "Stealing lock on"
|
||
(lambda ()
|
||
(vc-run-command master '() "rcs"
|
||
"-M"
|
||
(rcs-rev-switch "-u" revision)
|
||
(rcs-rev-switch "-l" revision)
|
||
(vc-master-workfile master)))))))
|
||
|
||
(define-vc-type-operation 'DIFF vc-type:rcs
|
||
(lambda (master rev1 rev2 simple?)
|
||
(= 1
|
||
(vc-run-command master
|
||
(get-vc-diff-options simple?)
|
||
"rcsdiff"
|
||
"-q"
|
||
(if (and rev1 rev2)
|
||
(list (string-append "-r" rev1)
|
||
(string-append "-r" rev2))
|
||
(let ((rev
|
||
(or rev1 rev2
|
||
(vc-backend-workfile-revision master))))
|
||
(and rev
|
||
(string-append "-r" rev))))
|
||
(if simple?
|
||
(and (diff-brief-available?) "--brief")
|
||
(gc-vc-diff-switches master))
|
||
(vc-master-workfile master)))))
|
||
|
||
(define-vc-type-operation 'PRINT-LOG vc-type:rcs
|
||
(lambda (master)
|
||
(vc-run-command master '() "rlog" (vc-master-workfile master))))
|
||
|
||
(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:rcs
|
||
(lambda (master log-buffer)
|
||
master log-buffer
|
||
unspecific))
|
||
|
||
(define-vc-type-operation 'CHECK-HEADERS vc-type:rcs
|
||
(lambda (master buffer)
|
||
master
|
||
(check-rcs-headers buffer)))
|