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

(defglobal .*current-vcs-system*
  ;; The current system.
  (find-version-control-system 'default))

(defun current-version-control-system (optional: (system () systemp))
  ;; Set or get current vcs system.
  (if systemp
      (setf (global .*current-vcs-system*)
	    (find-version-control-system system))
    (global .*current-vcs-system*)))

(define-new-version-control-operation check-in-file (file message)
  ;; Check in a file which is checked in to your name.
  ;; FILE is a pathname; MESSAGE is a string describing the latest
  ;; change.  Returns either FILE if the check-in was successful or ()
  ;; if it wasn't.
  (ignore message)
  (.check-controllable-file 'check-in-file file)
  file)

(define-new-version-control-operation check-out-file (file)
  ;; Check out a file which belongs to nobody.  FILE is a pathname.
  ;; Returns either FILE, if the change was successful, or () if it
  ;; wasn't.
  (.check-controllable-file 'check-out-file file)
  file)

(defun .check-controllable-file (caller file)
  (cond
   ((not (access file))
    (error caller #!errfile file))
   ((file-link-p file)
    (error caller #!.errlink file))
   ((not (eq (file-type file) 'S_ISREG))
    (error caller #!.errnreg file))
   ((not (access (dirname file) 'W_OK))
    (error caller #!.errnwrdir file))))

(define-new-version-control-operation file-checked-out-p (file)
  ;; Determine whether the user has the file checked out or not.
  ;; Returns either FILE or ().  FILE is a pathname.
  file)

(define-new-version-control-operation file-controlled-p (file)
  ;; Is the file under control of the system?  Returns either FILE or
  ;; ().  FILE is a pathname.
  file)

(define-new-version-control-operation log-file (file message)
  ;; check it in and out.
  (when (check-in-file file message)
    (check-out-file file)))

;;; Module level operations, using the basic primitives

(defun .map-module-files (module fn optional: (warnfn #'false))
  ;; Applies FN to each of MODULE's files, including
  ;;  * module description file
  ;;  * source files
  ;;  * test files (when TEST-FILES-P is t)
  ;; The function always receives two arguments:  a pathname and a
  ;; type indicator.  The type indicator is one of:
  ;;  MODULE-DESCRIPTION, SOURCE-FILE, TEST-FILE
  ;; When a file is mentioned in the .td but no corresponding file is
  ;; found, WARNFN is called instead, with the name of the file and
  ;; its type.
  (flet ((act (file full-file type)
	      (funcall (if full-file fn warnfn)
		       (or full-file file)
		       type)))
    (let ((module-file (which module 'td)))
      (when module-file
        (act module module-file 'module-description)
        (when (eq (tdref module 'type:) 'module)
	  (let ((src (walk.module-source-file module module-file)))
	    (act module (if (access src) src ()) 'source-file))
          (let ((test-file-p (tdref module 'test-file-p:)))
            (cond ((null test-file-p) ())
                  (t (act module (which module 'tt) 'test-file)))))
        ()))))

(defun .warn (caller module file type)
  (warn caller #!.missing-file type module file))

(defmessage .missing-file
  english: "in %s %A, missing file %s"
  french: "dans le %s %A, il manque le fichier %s")

(defun check-in-module (module message optional: verbosep)
  (.map-module-files
   module
   (lambda (file type)
     (unless (eq type 'module-description)
       (when verbosep (printf ";;; Checking in %s %s...\n" type file))
       (check-in-file file message)))
   (if verbosep
       (lambda (file type) (.warn 'check-in-module module file type))
     #'false)))

(defun check-out-module (module optional: verbosep)
  (.map-module-files
   module
   (lambda (file type)
     (unless (eq type 'module-description)
       (when verbosep (printf ";;; Checking out %A %s...\n" type file))
       (check-out-file file)))
   (if verbosep
       (lambda (file type) (.warn 'check-out-module module file type))
     #'false)))

(defun log-module (module message optional: verbosep)
  (.map-module-files
   module
   (lambda (file type)
     (unless (eq type 'module-description)
       (when verbosep (printf ";;; Logging %A %s...\n" type file))
       (log-file file message)))
   (if verbosep
       (lambda (file type) (.warn 'log-module module file type))
     #'false)))


(defun checked-out-files (optional: (path (path))
				    (pattern (global .default-extensions)))
  ;; Return a list of pathnames which are checked out.  Files matching
  ;; PATTERN in the path PATH are filtered out.  By default, all files
  ;; in the path.  PATTERN can be a list of patterns.
  (let ((result ()))
    (.map-files
     (lambda (file) (when (file-checked-out-p file) (pushf result file)))
     path pattern 'checked-out-files)
    result))

(defun uncontrolled-files (optional: (path (path))
				     (pattern (global .default-extensions)))
  ;; Return a list of pathnames which are uncontrolled.  Files matching
  ;; PATTERN in the path PATH are filtered out.  By default, all files
  ;; in (path)
  (let ((result ()))
    (.map-files
     (lambda (file) (unless (file-controlled-p file) (pushf result file)))
     path pattern 'uncontrolled-files)
    result))

(defun check-in-files (message optional:
			       (path (path))
			       (pattern (global .default-extensions)))
  ;; Check in all checked out or uncontrolled files in the list of
  ;; directories PATH matching PATTERN.  Return a list of files for
  ;; which the checkin did not work.  Use MESSAGE as the check-in
  ;; message.
  (assert (stringp message) (error 'check-in-files #!errnsa message))
  (let ((result ()))
    (.map-files
     (lambda (file)
       (unless (check-in-file file message) (pushf result file)))
     path pattern 'check-in-files)
    result))

(defun check-out-files (optional: (path (path))
				  (pattern (global .default-extensions)))
  ;; Check out all checked in files in the list of
  ;; directories PATH matching PATTERN.  Return a list of files for
  ;; which the checkout did not work.
  (let ((result ()))
    (.map-files
     (lambda (file)
       (when (and (file-controlled-p file)
		  (not (file-checked-out-p file)))
	 (unless (check-out-file file)
	   (pushf result file))))
     path pattern 'check-out-files)
    result))

(defun log-files (message optional: (path (path))
			  (pattern (global .default-extensions)))
  ;; Check out all checked in files in the list of
  ;; directories PATH matching PATTERN.  Return a list of files for
  ;; which the checkout did not work.
  (assert (stringp message) (error 'log-files #!errnsa message))
  (let ((result ()))
    (.map-files
     (lambda (file) (unless (log-file file message) (pushf result file)))
     path pattern 'log-files)
    result))

;;; Utilities

(defun .map-files (fn path ext caller)
  (.check-path path caller)
  (.check-pattern ext caller)
  (for ((directory in: path))
    (for ((file in-directory: directory))
      (let ((fext (extension file)))
	(when (if (listp ext)
		  (collecting
		   (for ((x in: ext))
		     (collect-or (string= x fext))))
		(string= ext fext))
	  (funcall fn file))))))

(defglobal .default-extensions
  ;; List of interesting extensions
  '(".t"				; source files
    ".td"				; module descriptions
    ".tt"				; test files
    ;; \\ ".c"				; c source files
    ;; \\ ".h"				; c header files
    ".tex"				; documentation
    ;; \\ ".tx"			        ; executables
    ))

(defun .check-pattern (pattern caller)
  (assert (.orp (and (listp pattern)
		     (collecting
		      (for ((pat in: pattern))
			(collect-and (stringp pat)))))
		(stringp pattern))
    (error caller #!.invalid-pattern pattern)))

(defun .check-path (path caller)
  (assert (and (listp path)
	       (collecting
		(for ((pat in: path))
		  (collect-and (stringp pat)))))
    (error caller #!.invalid-path path)))

;;; Messages

(defmessage .invalid-pattern
  english: "invalid file pattern"
  french: "pattern des fichiers invalide")

(defmessage .invalid-path
  english: "invalid path"
  french: "path invalide")

(defmessage .errlink
  english: "file %s is a symbolic link"
  french: "le fichier %s est un lien symbolique")

(defmessage .errnwrdir
  english: "file %s is in a read-only directory"
  french: "le fichier %s est dans un répertoire en lecture seule")

(defmessage .errnreg
  english: "file %s is not a regular file"
  french: "le fichier %s n'est pas un fichier ordinaire")
