;;;
;;; ILTVERRCS:  RCS implementation of version control
;;;
;;; ----------------------------------------------------------------------
;;;
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1993-1996 by ILOG
;;; $Header: /nfs/talk/work/talk/contrib/src/RCS/iltverrcs.t,v 3.21 1996/01/13 12:03:54 v16admin Exp $
;;; ----------------------------------------------------------------------
;;;

(define-version-control-system rcs)

(define-version-control-operation check-in-file rcs (file message)
  ;; Use CI.  Must distinguish the first check-in from further ones
  ;; because RCS wants it that way.
  (call-next-method)
  (cond ((not (file-controlled-p file))
	 (.rcs-control-file file message #'.check-in-command))
	((.rcs-file-checked-out-p file)
	 (.rcs-check-in-file file message () #'.check-in-command))
	(t ())))

(define-version-control-operation log-file rcs (file message)
  (cond ((not (file-controlled-p file))
	 (.rcs-control-file file message #'.log-command))
	((.rcs-file-checked-out-p file)
	 (.rcs-check-in-file file message () #'.log-command))
	(t ())))

(defun .rcs-control-file (file message command-fn)
  ;; Because RCS is completely weird, we have to put the
  ;; message in a temporary file and then pass the name of the
  ;; file to ci.
  (let* ((temp-file (tmpnam))
	 (ostream (fopen temp-file 'w)))
    (fprintf ostream "%s\n" message)
    (fclose ostream)
    (prog1 (.rcs-check-in-file file temp-file t command-fn)
      (unlink temp-file))))

(defun .rcs-check-in-file (file message first-time-p command-fn)
  (destructuring-let (((directory file-name)
		       (.directory-name file 'check-in-file)))
    (withf (((getcwd) directory))
      (when (system (funcall command-fn file-name message first-time-p)
		    ())
	file))))

(define-version-control-operation check-out-file rcs (file)
  ;; Use CO
  (call-next-method)
  (unless (file-checked-out-p file)
    (destructuring-let (((directory file-name)
			 (.directory-name file 'check-out-file)))
      (withf (((getcwd) directory))
	(when (system (.check-out-command file-name) ())
	  file)))))

(define-version-control-operation file-checked-out-p rcs (file)
  ;; Do I have the file?  To have it, it must be controlled and be
  ;; writable.
  (when (file-controlled-p file)
    (.rcs-file-checked-out-p file)))

(defun .rcs-file-checked-out-p (file)
  ;; assume it's controlled.
  (destructuring-let (((directory file-name)
		       (.directory-name file 'file-checked-out-p)))
    (withf (((getcwd) directory))
      (access file-name 'W_OK))))

(define-version-control-operation file-controlled-p rcs (file)
  ;; look in RCS subdirectory for file,v, or file,v in current
  ;; directory.
  (destructuring-let (((directory file-name)
		       (.directory-name file 'file-controlled-p)))
    (withf (((getcwd) directory))
      (when (.orp (access (merge-filenames (make-filename "RCS/")
					   file-name ",v"))
		  (access (merge-filenames (make-filename "")
					   file-name ",v")))
	file))))

(current-version-control-system 'rcs)

;;; Utilities

(defglobal .*quietp* "-q")

(defun .ci-command (mode file message)
  (sprintf () "ci %s -f %s -m\"%s\" %s"
	   mode (global .*quietp*)
	   (if (string= message "") #!.no-message message)
	   file))

(defun .enter-command (mode message file)
  (sprintf () "ci %s -f %s -t%s %s"
	   mode (global .*quietp*) message file))

(defun .check-in-command (file message first-time-p)
  (.rcs-enter-command "-u" file message first-time-p))

(defun .log-command (file message first-time-p)
  (.rcs-enter-command "-l" file message first-time-p))

(defun .rcs-enter-command (mode file message first-time-p)
  (if first-time-p
      (.enter-command mode message file)
    (.ci-command mode file message)))

(defun .check-out-command (file)
  (sprintf () "co %s -f -l %s" (global .*quietp*) file))

(defun .directory-name (path caller)
  (assert (filenamep path) (error caller #!.errnfila path))
  (list (dirname path) (basename path)))

(defmessage .no-message
  english: "no message"
  french: "pas de message")
